symdef.pas 298 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603660466056606660766086609661066116612661366146615661666176618661966206621662266236624662566266627662866296630663166326633663466356636663766386639664066416642664366446645664666476648664966506651665266536654665566566657665866596660666166626663666466656666666766686669667066716672667366746675667666776678667966806681668266836684668566866687668866896690669166926693669466956696669766986699670067016702670367046705670667076708670967106711671267136714671567166717671867196720672167226723672467256726672767286729673067316732673367346735673667376738673967406741674267436744674567466747674867496750675167526753675467556756675767586759676067616762676367646765676667676768676967706771677267736774677567766777677867796780678167826783678467856786678767886789679067916792679367946795679667976798679968006801680268036804680568066807680868096810681168126813681468156816681768186819682068216822682368246825682668276828682968306831683268336834683568366837683868396840684168426843684468456846684768486849685068516852685368546855685668576858685968606861686268636864686568666867686868696870687168726873687468756876687768786879688068816882688368846885688668876888688968906891689268936894689568966897689868996900690169026903690469056906690769086909691069116912691369146915691669176918691969206921692269236924692569266927692869296930693169326933693469356936693769386939694069416942694369446945694669476948694969506951695269536954695569566957695869596960696169626963696469656966696769686969697069716972697369746975697669776978697969806981698269836984698569866987698869896990699169926993699469956996699769986999700070017002700370047005700670077008700970107011701270137014701570167017701870197020702170227023702470257026702770287029703070317032703370347035703670377038703970407041704270437044704570467047704870497050705170527053705470557056705770587059706070617062706370647065706670677068706970707071707270737074707570767077707870797080708170827083708470857086708770887089709070917092709370947095709670977098709971007101710271037104710571067107710871097110711171127113711471157116711771187119712071217122712371247125712671277128712971307131713271337134713571367137713871397140714171427143714471457146714771487149715071517152715371547155715671577158715971607161716271637164716571667167716871697170717171727173717471757176717771787179718071817182718371847185718671877188718971907191719271937194719571967197719871997200720172027203720472057206720772087209721072117212721372147215721672177218721972207221722272237224722572267227722872297230723172327233723472357236723772387239724072417242724372447245724672477248724972507251725272537254725572567257725872597260726172627263726472657266726772687269727072717272727372747275727672777278727972807281728272837284728572867287728872897290729172927293729472957296729772987299730073017302730373047305730673077308730973107311731273137314731573167317731873197320732173227323732473257326732773287329733073317332733373347335733673377338733973407341734273437344734573467347734873497350735173527353735473557356735773587359736073617362736373647365736673677368736973707371737273737374737573767377737873797380738173827383738473857386738773887389739073917392739373947395739673977398739974007401740274037404740574067407740874097410741174127413741474157416741774187419742074217422742374247425742674277428742974307431743274337434743574367437743874397440744174427443744474457446744774487449745074517452745374547455745674577458745974607461746274637464746574667467746874697470747174727473747474757476747774787479748074817482748374847485748674877488748974907491749274937494749574967497749874997500750175027503750475057506750775087509751075117512751375147515751675177518751975207521752275237524752575267527752875297530753175327533753475357536753775387539754075417542754375447545754675477548754975507551755275537554755575567557755875597560756175627563756475657566756775687569757075717572757375747575757675777578757975807581758275837584758575867587758875897590759175927593759475957596759775987599760076017602760376047605760676077608760976107611761276137614761576167617761876197620762176227623762476257626762776287629763076317632763376347635763676377638763976407641764276437644764576467647764876497650765176527653765476557656765776587659766076617662766376647665766676677668766976707671767276737674767576767677767876797680768176827683768476857686768776887689769076917692769376947695769676977698769977007701770277037704770577067707770877097710771177127713771477157716771777187719772077217722772377247725772677277728772977307731773277337734773577367737773877397740774177427743774477457746774777487749775077517752775377547755775677577758775977607761776277637764776577667767776877697770777177727773777477757776777777787779778077817782778377847785778677877788778977907791779277937794779577967797779877997800780178027803780478057806780778087809781078117812781378147815781678177818781978207821782278237824782578267827782878297830783178327833783478357836783778387839784078417842784378447845784678477848784978507851785278537854785578567857785878597860786178627863786478657866786778687869787078717872787378747875787678777878787978807881788278837884788578867887788878897890789178927893789478957896789778987899790079017902790379047905790679077908790979107911791279137914791579167917791879197920792179227923792479257926792779287929793079317932793379347935793679377938793979407941794279437944794579467947794879497950795179527953795479557956795779587959796079617962796379647965796679677968796979707971797279737974797579767977797879797980798179827983798479857986798779887989799079917992799379947995799679977998799980008001800280038004800580068007800880098010801180128013801480158016801780188019802080218022802380248025802680278028802980308031803280338034803580368037803880398040804180428043804480458046804780488049805080518052805380548055805680578058805980608061806280638064806580668067806880698070807180728073807480758076807780788079808080818082808380848085808680878088808980908091809280938094809580968097809880998100810181028103810481058106810781088109811081118112811381148115811681178118811981208121812281238124812581268127812881298130813181328133813481358136813781388139814081418142814381448145814681478148814981508151815281538154815581568157815881598160816181628163816481658166816781688169817081718172817381748175817681778178817981808181818281838184818581868187818881898190819181928193819481958196819781988199820082018202820382048205820682078208820982108211821282138214821582168217821882198220822182228223822482258226822782288229823082318232823382348235823682378238823982408241824282438244824582468247824882498250825182528253825482558256825782588259826082618262826382648265826682678268826982708271827282738274827582768277827882798280828182828283828482858286828782888289829082918292829382948295829682978298829983008301830283038304830583068307830883098310831183128313831483158316831783188319832083218322832383248325832683278328832983308331833283338334833583368337833883398340834183428343834483458346834783488349835083518352835383548355835683578358835983608361836283638364836583668367836883698370837183728373837483758376837783788379838083818382838383848385838683878388838983908391839283938394839583968397839883998400840184028403840484058406840784088409841084118412841384148415841684178418841984208421842284238424842584268427842884298430843184328433843484358436843784388439844084418442844384448445844684478448844984508451845284538454845584568457845884598460846184628463846484658466846784688469847084718472847384748475847684778478847984808481848284838484848584868487848884898490849184928493849484958496849784988499850085018502850385048505850685078508850985108511851285138514851585168517851885198520852185228523852485258526852785288529853085318532853385348535853685378538853985408541854285438544854585468547854885498550855185528553855485558556855785588559856085618562856385648565856685678568856985708571857285738574857585768577857885798580858185828583858485858586858785888589859085918592859385948595859685978598859986008601860286038604860586068607860886098610861186128613861486158616861786188619862086218622862386248625862686278628862986308631863286338634863586368637863886398640864186428643864486458646864786488649865086518652865386548655865686578658865986608661866286638664866586668667866886698670867186728673867486758676867786788679868086818682868386848685868686878688868986908691869286938694869586968697869886998700870187028703870487058706870787088709871087118712871387148715871687178718871987208721872287238724872587268727872887298730873187328733873487358736873787388739874087418742874387448745874687478748874987508751875287538754875587568757875887598760876187628763876487658766876787688769877087718772877387748775877687778778877987808781878287838784878587868787878887898790879187928793879487958796879787988799880088018802880388048805880688078808880988108811881288138814881588168817881888198820882188228823882488258826882788288829883088318832883388348835883688378838883988408841884288438844884588468847884888498850885188528853885488558856885788588859886088618862886388648865886688678868886988708871887288738874887588768877887888798880888188828883888488858886888788888889889088918892889388948895889688978898889989008901890289038904890589068907890889098910
  1. {
  2. Symbol table implementation for the definitions
  3. Copyright (c) 1998-2005 by Florian Klaempfl, Pierre Muller
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit symdef;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cclasses,widestr,
  23. { global }
  24. globtype,globals,tokens,constexp,
  25. { symtable }
  26. symconst,symbase,symtype,
  27. { node }
  28. node,
  29. { aasm }
  30. aasmtai,
  31. cpuinfo,
  32. cgbase,
  33. parabase
  34. ;
  35. type
  36. {************************************************
  37. TDef
  38. ************************************************}
  39. tgenericconstraintdata=class
  40. interfaces : tfpobjectlist;
  41. interfacesderef : tfplist;
  42. flags : tgenericconstraintflags;
  43. { only required while parsing }
  44. fileinfo : tfileposinfo;
  45. constructor create;
  46. destructor destroy;override;
  47. procedure ppuload(ppufile:tcompilerppufile);
  48. procedure ppuwrite(ppufile:tcompilerppufile);
  49. procedure buildderef;
  50. procedure deref;
  51. end;
  52. { trtti_attribute_list }
  53. trtti_attribute = class
  54. typesym : tsym;
  55. typesymderef : tderef;
  56. typeconstr : tdef;
  57. typeconstrderef : tderef;
  58. { these two are not stored in PPU }
  59. constructorcall : tnode;
  60. constructorpd : tdef;
  61. paras : array of tnode;
  62. constructor ppuload(ppufile:tcompilerppufile);
  63. procedure ppuwrite(ppufile:tcompilerppufile);
  64. procedure ppuload_subentries(ppufile:tcompilerppufile);
  65. procedure ppuwrite_subentries(ppufile:tcompilerppufile);
  66. destructor destroy;override;
  67. procedure buildderef;
  68. procedure deref;
  69. end;
  70. trtti_attribute_list = class
  71. rtti_attributes : TFPObjectList;
  72. { if the attribute list is bound to a def or symbol }
  73. is_bound : Boolean;
  74. class procedure bind(var dangling,owned:trtti_attribute_list);
  75. procedure addattribute(atypesym:tsym;typeconstr:tdef;constructorcall:tnode;constref paras:array of tnode);
  76. procedure addattribute(attr:trtti_attribute);
  77. destructor destroy; override;
  78. function get_attribute_count:longint;
  79. procedure buildderef;
  80. procedure deref;
  81. class function ppuload(ppufile:tcompilerppufile):trtti_attribute_list;
  82. class procedure ppuwrite(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  83. class procedure ppuload_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  84. class procedure ppuwrite_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  85. end;
  86. { tstoreddef }
  87. tstoreddef = class(tdef)
  88. private
  89. {$ifdef symansistr}
  90. _fullownerhierarchyname : ansistring;
  91. {$else symansistr}
  92. _fullownerhierarchyname : pshortstring;
  93. {$endif symansistr}
  94. procedure writeentry(ppufile: tcompilerppufile; ibnr: byte);
  95. protected
  96. typesymderef : tderef;
  97. procedure ppuwrite_platform(ppufile:tcompilerppufile);virtual;
  98. procedure ppuload_platform(ppufile:tcompilerppufile);virtual;
  99. { a (possibly) reusable def is always created on the basis of another
  100. def, and contains a reference to this other def. If this other
  101. def is in a non-persistent symboltable, the new def cannot actually
  102. be safely reused everywhere in the current module. This routine
  103. abtracts that checking, and also restores the symtable stack
  104. (which had to be reset before creating the new def, so that the new
  105. def did not automatically get added to its top) }
  106. class procedure setup_reusable_def(origdef, newdef: tdef; res: PHashSetItem; oldsymtablestack: tsymtablestack);
  107. public
  108. {$ifdef EXTDEBUG}
  109. fileinfo : tfileposinfo;
  110. {$endif}
  111. { generic support }
  112. genericdef : tstoreddef;
  113. genericdefderef : tderef;
  114. generictokenbuf : tdynamicarray;
  115. { this list contains references to the symbols that make up the
  116. generic parameters; the symbols are not owned by this list
  117. Note: this list is allocated on demand! }
  118. genericparas : tfphashobjectlist;
  119. genericparaderefs : tfplist;
  120. { contains additional data if this def is a generic constraint
  121. Note: this class is allocated on demand! }
  122. genconstraintdata : tgenericconstraintdata;
  123. { this is Nil if the def has no RTTI attributes }
  124. rtti_attribute_list : trtti_attribute_list;
  125. constructor create(dt:tdeftyp;doregister:boolean);
  126. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  127. destructor destroy;override;
  128. function getcopy : tstoreddef;virtual;
  129. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  130. { this is called directly after ppuload }
  131. procedure ppuload_subentries(ppufile:tcompilerppufile);virtual;
  132. { this is called directly after ppuwrite }
  133. procedure ppuwrite_subentries(ppufile:tcompilerppufile);virtual;
  134. procedure buildderef;override;
  135. procedure buildderefimpl;override;
  136. procedure deref;override;
  137. procedure derefimpl;override;
  138. function size:asizeint;override;
  139. function getvardef:longint;override;
  140. function alignment:shortint;override;
  141. function is_publishable : boolean;override;
  142. function needs_inittable : boolean;override;
  143. function has_non_trivial_init_child(check_parent:boolean):boolean;override;
  144. function rtti_mangledname(rt:trttitype):TSymStr;override;
  145. function OwnerHierarchyName: string; override;
  146. function fullownerhierarchyname(skipprocparams:boolean):TSymStr;override;
  147. function needs_separate_initrtti:boolean;override;
  148. function in_currentunit: boolean;
  149. { regvars }
  150. function is_intregable : boolean;
  151. function is_fpuregable : boolean;
  152. { def can be put into a register if it is const/immutable }
  153. function is_const_intregable : boolean;
  154. { generics }
  155. procedure initgeneric;
  156. { this function can be used to determine whether a def is really a
  157. generic declaration or just a normal type declared inside another
  158. generic }
  159. function is_generic:boolean;
  160. { same as above for specializations }
  161. function is_specialization:boolean;
  162. { generic utilities }
  163. function is_generic_param_const(index:integer):boolean;inline;
  164. function get_generic_param_def(index:integer):tdef;inline;
  165. { registers this def in the unit's deflist; no-op if already registered }
  166. procedure register_def; override;
  167. { add the def to the top of the symtable stack if it's not yet owned
  168. by another symtable }
  169. procedure maybe_put_in_symtable_stack;
  170. private
  171. savesize : asizeuint;
  172. end;
  173. tfiletyp = (ft_text,ft_typed,ft_untyped);
  174. tfiledef = class(tstoreddef)
  175. filetyp : tfiletyp;
  176. typedfiledef : tdef;
  177. typedfiledefderef : tderef;
  178. constructor createtext;virtual;
  179. constructor createuntyped;virtual;
  180. constructor createtyped(def : tdef);virtual;
  181. constructor ppuload(ppufile:tcompilerppufile);
  182. function getcopy : tstoreddef;override;
  183. { do not override this routine in platform-specific subclasses,
  184. override ppuwrite_platform instead }
  185. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  186. procedure buildderef;override;
  187. procedure deref;override;
  188. function GetTypeName:string;override;
  189. function getmangledparaname:TSymStr;override;
  190. function size:asizeint;override;
  191. procedure setsize;
  192. function alignment: shortint; override;
  193. end;
  194. tfiledefclass = class of tfiledef;
  195. tvariantdef = class(tstoreddef)
  196. varianttype : tvarianttype;
  197. constructor create(v : tvarianttype);virtual;
  198. constructor ppuload(ppufile:tcompilerppufile);
  199. function getcopy : tstoreddef;override;
  200. function GetTypeName:string;override;
  201. { do not override this routine in platform-specific subclasses,
  202. override ppuwrite_platform instead }
  203. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  204. function getvardef:longint;override;
  205. procedure setsize;
  206. function is_publishable : boolean;override;
  207. function needs_inittable : boolean;override;
  208. end;
  209. tvariantdefclass = class of tvariantdef;
  210. tformaldef = class(tstoreddef)
  211. typed:boolean;
  212. constructor create(Atyped:boolean);virtual;
  213. constructor ppuload(ppufile:tcompilerppufile);
  214. { do not override this routine in platform-specific subclasses,
  215. override ppuwrite_platform instead }
  216. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  217. function GetTypeName:string;override;
  218. end;
  219. tformaldefclass = class of tformaldef;
  220. tforwarddef = class(tstoreddef)
  221. tosymname : pshortstring;
  222. forwardpos : tfileposinfo;
  223. constructor create(const s:string;const pos:tfileposinfo);virtual;
  224. destructor destroy;override;
  225. function getcopy:tstoreddef;override;
  226. function GetTypeName:string;override;
  227. end;
  228. tforwarddefclass = class of tforwarddef;
  229. tundefineddef = class(tstoreddef)
  230. constructor create(doregister:boolean);virtual;
  231. constructor ppuload(ppufile:tcompilerppufile);
  232. { do not override this routine in platform-specific subclasses,
  233. override ppuwrite_platform instead }
  234. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  235. function GetTypeName:string;override;
  236. end;
  237. tundefineddefclass = class of tundefineddef;
  238. terrordef = class(tstoreddef)
  239. constructor create;virtual;
  240. { do not override this routine in platform-specific subclasses,
  241. override ppuwrite_platform instead }
  242. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  243. function GetTypeName:string;override;
  244. function getmangledparaname : TSymStr;override;
  245. end;
  246. terrordefclass = class of terrordef;
  247. tabstractpointerdef = class(tstoreddef)
  248. pointeddef : tdef;
  249. pointeddefderef : tderef;
  250. constructor create(dt:tdeftyp;def:tdef);
  251. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  252. procedure ppuwrite(ppufile:tcompilerppufile);override;
  253. procedure buildderef;override;
  254. procedure deref;override;
  255. function size:asizeint;override;
  256. function alignment:shortint;override;
  257. end;
  258. tpointerdef = class(tabstractpointerdef)
  259. has_pointer_math : boolean;
  260. constructor create(def:tdef);virtual;
  261. { returns a pointerdef for def, reusing an existing one in case it
  262. exists in the current module }
  263. class function getreusable(def: tdef): tpointerdef; virtual;
  264. { same as above, but in case the def must never be freed after the
  265. current module has been compiled -- even if the def was not written
  266. to the ppu file (for defs in para locations, as we don't reset them
  267. so we don't have to recalculate them all the time) }
  268. class function getreusable_no_free(def: tdef): tpointerdef;
  269. function size:asizeint;override;
  270. function getcopy:tstoreddef;override;
  271. constructor ppuload(ppufile:tcompilerppufile);
  272. { do not override this routine in platform-specific subclasses,
  273. override ppuwrite_platform instead }
  274. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  275. function GetTypeName:string;override;
  276. {# returns the appropriate int type for pointer arithmetic with the given pointer type.
  277. When adding or subtracting a number to/from a pointer, this function returns the
  278. int type to which that number has to be converted, before the operation can be performed.
  279. Normally, this is sinttype, except on i8086, where it takes into account the
  280. special i8086 pointer types (near, far, huge). }
  281. function pointer_arithmetic_int_type:tdef;virtual;
  282. {# the unsigned version of pointer_arithmetic_int_type. Used with inc/dec. }
  283. function pointer_arithmetic_uint_type:tdef;virtual;
  284. {# returns the int type produced when subtracting two pointers of the given type.
  285. Normally, this is sinttype, except on i8086, where it takes into account the
  286. special i8086 pointer types (near, far, huge). }
  287. function pointer_subtraction_result_type:tdef;virtual;
  288. function compatible_with_pointerdef_size(ptr: tpointerdef): boolean; virtual;
  289. {# the integer index type used to convert the pointer to array (i.e. denotes int_type in: ptr[int_type]) }
  290. function converted_pointer_to_array_range_type:tdef;virtual;
  291. end;
  292. tpointerdefclass = class of tpointerdef;
  293. tprocdef = class;
  294. tabstractrecorddef= class(tstoreddef)
  295. private
  296. rttistring : string;
  297. public
  298. objname,
  299. objrealname : PShortString;
  300. { for C++ classes: name of the library this class is imported from }
  301. { for Java classes/records: package name }
  302. import_lib : PShortString;
  303. symtable : TSymtable;
  304. cloneddef : tabstractrecorddef;
  305. cloneddefderef : tderef;
  306. objectoptions : tobjectoptions;
  307. { for targets that initialise typed constants via explicit assignments
  308. instead of by generating an initialised data sectino }
  309. tcinitcode : tnode;
  310. constructor create(const n:string; dt:tdeftyp;doregister:boolean);
  311. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  312. procedure ppuwrite(ppufile:tcompilerppufile);override;
  313. destructor destroy; override;
  314. procedure buildderefimpl;override;
  315. procedure derefimpl;override;
  316. procedure check_forwards; virtual;
  317. function find_procdef_bytype(pt:tproctypeoption): tprocdef;
  318. function GetSymtable(t:tGetSymtable):TSymtable;override;
  319. function is_packed:boolean;
  320. function RttiName: string;
  321. { enumerator support }
  322. function search_enumerator_get: tprocdef; virtual;
  323. function search_enumerator_move: tprocdef; virtual;
  324. function search_enumerator_current: tsym; virtual;
  325. { JVM }
  326. function jvm_full_typename(with_package_name: boolean): string;
  327. { check if the symtable contains a float field }
  328. function contains_float_field : boolean;
  329. { check if the symtable contains a field that spans an aword boundary }
  330. function contains_cross_aword_field: boolean;
  331. end;
  332. pvariantrecdesc = ^tvariantrecdesc;
  333. tvariantrecbranch = record
  334. { we store only single values here and no ranges because tvariantrecdesc is only needed in iso mode
  335. which does not support range expressions in variant record definitions }
  336. values : array of Tconstexprint;
  337. nestedvariant : pvariantrecdesc;
  338. end;
  339. ppvariantrecdesc = ^pvariantrecdesc;
  340. tvariantrecdesc = record
  341. variantselector : tsym;
  342. variantselectorderef : tderef;
  343. branches : array of tvariantrecbranch;
  344. end;
  345. trecorddef = class(tabstractrecorddef)
  346. public
  347. variantrecdesc : pvariantrecdesc;
  348. isunion : boolean;
  349. constructor create(const n:string; p:TSymtable);virtual;
  350. constructor create_global_internal(const n: string; packrecords, recordalignmin: shortint); virtual;
  351. function add_field_by_def(const optionalname: TIDString; def: tdef): tsym;
  352. procedure add_fields_from_deflist(fieldtypes: tfplist);
  353. constructor ppuload(ppufile:tcompilerppufile);
  354. destructor destroy;override;
  355. function getcopy : tstoreddef;override;
  356. { do not override this routine in platform-specific subclasses,
  357. override ppuwrite_platform instead }
  358. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  359. procedure buildderef;override;
  360. procedure deref;override;
  361. function size:asizeint;override;
  362. function alignment : shortint;override;
  363. function padalignment: shortint;
  364. function GetTypeName:string;override;
  365. { debug }
  366. function needs_inittable : boolean;override;
  367. function needs_separate_initrtti:boolean;override;
  368. function has_non_trivial_init_child(check_parent:boolean):boolean;override;
  369. end;
  370. trecorddefclass = class of trecorddef;
  371. tobjectdef = class;
  372. { TImplementedInterface }
  373. TImplementedInterface = class
  374. private
  375. fIOffset : longint;
  376. function GetIOffset: longint;
  377. public
  378. IntfDef : tobjectdef;
  379. IntfDefDeref : tderef;
  380. IType : tinterfaceentrytype;
  381. VtblImplIntf : TImplementedInterface;
  382. NameMappings : TFPHashList;
  383. ProcDefs : TFPObjectList;
  384. ImplementsGetter : tsym;
  385. ImplementsGetterDeref : tderef;
  386. ImplementsField : tsym;
  387. constructor create(aintf: tobjectdef);virtual;
  388. constructor create_deref(intfd,getterd:tderef);virtual;
  389. destructor destroy; override;
  390. function getcopy:TImplementedInterface;
  391. procedure buildderef;
  392. procedure deref;
  393. procedure AddMapping(const origname, newname: string);
  394. function GetMapping(const origname: string):string;
  395. procedure AddImplProc(pd:tprocdef);
  396. function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  397. property IOffset: longint read GetIOffset write fIOffset;
  398. end;
  399. timplementedinterfaceclass = class of timplementedinterface;
  400. { tvmtentry }
  401. tvmtentry = record
  402. procdef : tprocdef;
  403. procdefderef : tderef;
  404. visibility : tvisibility;
  405. end;
  406. pvmtentry = ^tvmtentry;
  407. { tobjectdef }
  408. tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
  409. pmvcallstaticinfo = ^tmvcallstaticinfo;
  410. tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
  411. tobjectdef = class(tabstractrecorddef)
  412. private
  413. fcurrent_dispid: longint;
  414. public
  415. childof : tobjectdef;
  416. childofderef : tderef;
  417. { for Object Pascal helpers }
  418. extendeddef : tdef;
  419. extendeddefderef: tderef;
  420. helpertype : thelpertype;
  421. { for Objective-C: protocols and classes can have the same name there }
  422. objextname : pshortstring;
  423. { to be able to have a variable vmt position }
  424. { and no vmt field for objects without virtuals }
  425. vmtentries : TFPList;
  426. vmcallstaticinfo : pmvcallstaticinfo;
  427. vmt_field : tsym;
  428. vmt_fieldderef : tderef;
  429. iidguid : pguid;
  430. iidstr : pshortstring;
  431. { store implemented interfaces defs and name mappings }
  432. ImplementedInterfaces : TFPObjectList;
  433. { number of abstract methods (used by JVM target to determine whether
  434. or not the class should be marked as abstract: must be done if 1 or
  435. more abstract methods) }
  436. abstractcnt : longint;
  437. writing_class_record_dbginfo,
  438. { a class of this type has been created in this module }
  439. created_in_current_module,
  440. { a loadvmtnode for this class has been created in this
  441. module, so if a classrefdef variable of this or a parent
  442. class is used somewhere to instantiate a class, then this
  443. class may be instantiated
  444. }
  445. maybe_created_in_current_module,
  446. { a "class of" this particular class has been created in
  447. this module
  448. }
  449. classref_created_in_current_module : boolean;
  450. objecttype : tobjecttyp;
  451. constructor create(ot:tobjecttyp;const n:string;c:tobjectdef;doregister:boolean);virtual;
  452. constructor ppuload(ppufile:tcompilerppufile);
  453. destructor destroy;override;
  454. function getcopy : tstoreddef;override;
  455. { do not override this routine in platform-specific subclasses,
  456. override ppuwrite_platform instead }
  457. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  458. function GetTypeName:string;override;
  459. procedure buildderef;override;
  460. procedure deref;override;
  461. procedure derefimpl;override;
  462. procedure copyvmtentries(objdef:tobjectdef);
  463. function getparentdef:tdef;override;
  464. function size : asizeint;override;
  465. function alignment:shortint;override;
  466. function vmtmethodoffset(index:longint):longint;
  467. function members_need_inittable : boolean;
  468. { this should be called when this class implements an interface }
  469. procedure prepareguid;
  470. function is_publishable : boolean;override;
  471. function needs_inittable : boolean;override;
  472. function needs_separate_initrtti : boolean;override;
  473. function has_non_trivial_init_child(check_parent:boolean):boolean;override;
  474. function rtti_mangledname(rt:trttitype):TSymStr;override;
  475. function is_unique_objpasdef: boolean;
  476. function vmt_mangledname : TSymStr;
  477. function vmt_def: trecorddef;
  478. procedure check_forwards; override;
  479. procedure insertvmt;
  480. function vmt_offset: asizeint;
  481. procedure set_parent(c : tobjectdef);
  482. function find_destructor: tprocdef;
  483. function implements_any_interfaces: boolean;
  484. { dispinterface support }
  485. function get_next_dispid: longint;
  486. { enumerator support }
  487. function search_enumerator_get: tprocdef; override;
  488. function search_enumerator_move: tprocdef; override;
  489. function search_enumerator_current: tsym; override;
  490. { WPO }
  491. procedure register_created_object_type;override;
  492. procedure register_maybe_created_object_type;
  493. procedure register_created_classref_type;
  494. procedure register_vmt_call(index:longint);
  495. { ObjC }
  496. procedure finish_objc_data;
  497. function check_objc_types: boolean;
  498. { C++ }
  499. procedure finish_cpp_data;
  500. end;
  501. tobjectdefclass = class of tobjectdef;
  502. tclassrefdef = class(tabstractpointerdef)
  503. constructor create(def:tdef);virtual;
  504. constructor ppuload(ppufile:tcompilerppufile);
  505. { do not override this routine in platform-specific subclasses,
  506. override ppuwrite_platform instead }
  507. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  508. function getcopy:tstoreddef;override;
  509. function GetTypeName:string;override;
  510. function is_publishable : boolean;override;
  511. function rtti_mangledname(rt:trttitype):TSymStr;override;
  512. procedure register_created_object_type;override;
  513. end;
  514. tclassrefdefclass = class of tclassrefdef;
  515. tarraydef = class(tstoreddef)
  516. lowrange,
  517. highrange : asizeint;
  518. rangedef : tdef;
  519. rangedefderef : tderef;
  520. arrayoptions : tarraydefoptions;
  521. symtable : TSymtable;
  522. protected
  523. _elementdef : tdef;
  524. _elementdefderef : tderef;
  525. procedure setelementdef(def:tdef);
  526. class function getreusable_intern(def: tdef; elems: asizeint; const options: tarraydefoptions): tarraydef;
  527. public
  528. function elesize : asizeint;
  529. function elepackedbitsize : asizeint;
  530. function elecount : asizeuint;
  531. constructor create_from_pointer(def: tpointerdef);virtual;
  532. constructor create(l, h: asizeint; def: tdef);virtual;
  533. constructor create_vector(l,h:asizeint; def:tdef);
  534. constructor create_openarray;virtual;
  535. class function getreusable(def: tdef; elems: asizeint): tarraydef;
  536. class function getreusable_vector(def: tdef; elems: asizeint): tarraydef;
  537. { same as above, but in case the def must never be freed after the
  538. current module has been compiled -- even if the def was not written
  539. to the ppu file (for defs in para locations, as we don't reset them
  540. so we don't have to recalculate them all the time) }
  541. class function getreusable_no_free(def: tdef; elems: asizeint): tarraydef;
  542. class function getreusable_no_free_vector(def: tdef; elems: asizeint): tarraydef;
  543. constructor ppuload(ppufile:tcompilerppufile);
  544. destructor destroy; override;
  545. function getcopy : tstoreddef;override;
  546. { do not override this routine in platform-specific subclasses,
  547. override ppuwrite_platform instead }
  548. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  549. function GetTypeName:string;override;
  550. function getmangledparaname : TSymStr;override;
  551. procedure buildderef;override;
  552. procedure deref;override;
  553. function size : asizeint;override;
  554. function alignment : shortint;override;
  555. { returns the label of the range check string }
  556. function needs_inittable : boolean;override;
  557. function needs_separate_initrtti : boolean;override;
  558. property elementdef : tdef read _elementdef write setelementdef;
  559. function is_publishable : boolean;override;
  560. function is_hwvector: boolean;
  561. end;
  562. tarraydefclass = class of tarraydef;
  563. torddef = class(tstoreddef)
  564. low,high : TConstExprInt;
  565. ordtype : tordtype;
  566. constructor create(t : tordtype;v,b : TConstExprInt; doregister: boolean);virtual;
  567. constructor ppuload(ppufile:tcompilerppufile);
  568. function getcopy : tstoreddef;override;
  569. { do not override this routine in platform-specific subclasses,
  570. override ppuwrite_platform instead }
  571. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  572. function is_publishable : boolean;override;
  573. function GetTypeName:string;override;
  574. function alignment:shortint;override;
  575. procedure setsize;
  576. function packedbitsize: asizeint; override;
  577. function getvardef : longint;override;
  578. end;
  579. torddefclass = class of torddef;
  580. tfloatdef = class(tstoreddef)
  581. floattype : tfloattype;
  582. constructor create(t: tfloattype; doregister: boolean);virtual;
  583. constructor ppuload(ppufile:tcompilerppufile);
  584. function getcopy : tstoreddef;override;
  585. { do not override this routine in platform-specific subclasses,
  586. override ppuwrite_platform instead }
  587. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  588. function GetTypeName:string;override;
  589. function is_publishable : boolean;override;
  590. function alignment:shortint;override;
  591. function structalignment: shortint;override;
  592. procedure setsize;
  593. function getvardef:longint;override;
  594. end;
  595. tfloatdefclass = class of tfloatdef;
  596. { tabstractprocdef }
  597. tprocnameoption = (pno_showhidden, pno_proctypeoption, pno_paranames,
  598. pno_ownername, pno_noclassmarker, pno_noleadingdollar,
  599. pno_mangledname, pno_noparams);
  600. tprocnameoptions = set of tprocnameoption;
  601. tproccopytyp = (pc_normal,
  602. {$ifdef i8086}
  603. { the address in a far format }
  604. pc_far_address,
  605. { the offset part of the far address }
  606. pc_offset,
  607. {$endif i8086}
  608. { creates a procvardef describing only the code pointer
  609. of a method/netsted function/... }
  610. pc_address_only,
  611. { everything except for hidden parameters }
  612. pc_normal_no_hidden,
  613. { always creates a top-level function, removes all
  614. special parameters (self, vmt, parentfp, ...) }
  615. pc_bareproc
  616. );
  617. tcacheableproccopytyp = pc_normal..pc_address_only;
  618. tabstractprocdef = class(tstoreddef)
  619. { saves a definition to the return type }
  620. returndef : tdef;
  621. returndefderef : tderef;
  622. parast : TSymtable;
  623. paras : tparalist;
  624. proctypeoption : tproctypeoption;
  625. proccalloption : tproccalloption;
  626. procoptions : tprocoptions;
  627. callerargareasize,
  628. calleeargareasize: pint;
  629. {$ifdef m68k}
  630. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  631. {$endif}
  632. funcretloc : array[callerside..calleeside] of TCGPara;
  633. has_paraloc_info : tcallercallee; { paraloc info is available }
  634. { number of user visible parameters }
  635. maxparacount,
  636. minparacount : byte;
  637. constructor create(dt:tdeftyp;level:byte;doregister:boolean);
  638. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  639. destructor destroy;override;
  640. procedure ppuwrite(ppufile:tcompilerppufile);override;
  641. procedure buildderef;override;
  642. procedure deref;override;
  643. procedure calcparas;
  644. function mangledprocparanames(oldlen : longint) : string;
  645. function typename_paras(pno: tprocnameoptions): ansistring;
  646. function is_methodpointer:boolean;virtual;
  647. function is_addressonly:boolean;virtual;
  648. function no_self_node:boolean;
  649. { get either a copy as a procdef or procvardef }
  650. function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef; virtual;
  651. function compatible_with_pointerdef_size(ptr: tpointerdef): boolean; virtual;
  652. procedure check_mark_as_nested;
  653. procedure init_paraloc_info(side: tcallercallee);
  654. procedure done_paraloc_info(side: tcallercallee);
  655. function stack_tainting_parameter(side: tcallercallee): boolean;
  656. function is_pushleftright: boolean;virtual;
  657. function address_type:tdef;virtual;
  658. { address type, generated for ofs() }
  659. function ofs_address_type:tdef;virtual;
  660. procedure declared_far;virtual;
  661. procedure declared_near;virtual;
  662. function generate_safecall_wrapper: boolean; virtual;
  663. private
  664. procedure count_para(p:TObject;arg:pointer);
  665. procedure insert_para(p:TObject;arg:pointer);
  666. end;
  667. tprocvardef = class(tabstractprocdef)
  668. constructor create(level:byte);virtual;
  669. { returns a procvardef that represents the address of a proc(var)def }
  670. class function getreusableprocaddr(def: tabstractprocdef; copytyp: tcacheableproccopytyp): tprocvardef; virtual;
  671. { same as above, but in case the def must never be freed after the
  672. current module has been compiled -- even if the def was not written
  673. to the ppu file (for defs in para locations, as we don't reset them
  674. so we don't have to recalculate them all the time) }
  675. class function getreusableprocaddr_no_free(def: tabstractprocdef): tprocvardef;
  676. constructor ppuload(ppufile:tcompilerppufile);
  677. function getcopy : tstoreddef;override;
  678. { do not override this routine in platform-specific subclasses,
  679. override ppuwrite_platform instead }
  680. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  681. function GetSymtable(t:tGetSymtable):TSymtable;override;
  682. function size : asizeint;override;
  683. function GetTypeName:string;override;
  684. function is_publishable : boolean;override;
  685. function is_methodpointer:boolean;override;
  686. function is_addressonly:boolean;override;
  687. function getmangledparaname:TSymStr;override;
  688. function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
  689. end;
  690. tprocvardefclass = class of tprocvardef;
  691. tmessageinf = record
  692. case integer of
  693. 0 : (str : pshortstring);
  694. 1 : (i : longint);
  695. end;
  696. tinlininginfo = record
  697. { node tree }
  698. code : tnode;
  699. flags : tprocinfoflags;
  700. end;
  701. pinlininginfo = ^tinlininginfo;
  702. {$ifdef oldregvars}
  703. { register variables }
  704. pregvarinfo = ^tregvarinfo;
  705. tregvarinfo = record
  706. regvars : array[1..maxvarregs] of tsym;
  707. regvars_para : array[1..maxvarregs] of boolean;
  708. regvars_refs : array[1..maxvarregs] of longint;
  709. fpuregvars : array[1..maxfpuvarregs] of tsym;
  710. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  711. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  712. end;
  713. {$endif oldregvars}
  714. timplprocdefinfo = record
  715. resultname : pshortstring;
  716. parentfpstruct: tsym;
  717. parentfpstructptrtype: tdef;
  718. parentfpinitblock: tnode;
  719. procstarttai,
  720. procendtai : tai;
  721. skpara: pointer;
  722. personality: tprocdef;
  723. forwarddef,
  724. interfacedef : boolean;
  725. hasforward : boolean;
  726. is_implemented : boolean;
  727. end;
  728. pimplprocdefinfo = ^timplprocdefinfo;
  729. { tprocdef }
  730. tprocdef = class(tabstractprocdef)
  731. protected
  732. {$ifdef symansistr}
  733. _mangledname : ansistring;
  734. {$else symansistr}
  735. _mangledname : pshortstring;
  736. {$endif}
  737. _parentfpsym : tsym;
  738. { information that is only required until the implementation of the
  739. procdef has been handled }
  740. implprocdefinfo : pimplprocdefinfo;
  741. function store_localst:boolean;
  742. function GetResultName: PShortString;
  743. procedure SetResultName(AValue: PShortString);
  744. function GetParentFPStruct: tsym;
  745. procedure SetParentFPStruct(AValue: tsym);
  746. function GetParentFPStructPtrType: tdef;
  747. procedure SetParentFPStructPtrType(AValue: tdef);
  748. function GetParentFPInitBlock: tnode;
  749. procedure SetParentFPInitBlock(AValue: tnode);
  750. function Getprocstarttai: tai;
  751. procedure Setprocstarttai(AValue: tai);
  752. function Getprocendtai: tai;
  753. procedure Setprocendtai(AValue: tai);
  754. function Getskpara: pointer;
  755. procedure Setskpara(AValue: pointer);
  756. function Getpersonality: tprocdef;
  757. procedure Setpersonality(AValue: tprocdef);
  758. function Getforwarddef: boolean;
  759. procedure Setforwarddef(AValue: boolean);
  760. function Getinterfacedef: boolean;
  761. procedure Setinterfacedef(AValue: boolean);virtual;
  762. function Gethasforward: boolean;
  763. procedure Sethasforward(AValue: boolean);
  764. function GetIsEmpty: boolean;
  765. procedure SetIsEmpty(AValue: boolean);
  766. function GetHasInliningInfo: boolean;
  767. procedure SetHasInliningInfo(AValue: boolean);
  768. function Getis_implemented: boolean;
  769. procedure Setis_implemented(AValue: boolean);
  770. function getparentfpsym: tsym;
  771. public
  772. messageinf : tmessageinf;
  773. dispid : longint;
  774. {$ifndef EXTDEBUG}
  775. { where is this function defined and what were the symbol
  776. flags, needed here because there
  777. is only one symbol for all overloaded functions
  778. EXTDEBUG has fileinfo in tdef (PFV) }
  779. fileinfo : tfileposinfo;
  780. {$endif}
  781. symoptions : tsymoptions;
  782. deprecatedmsg : pshortstring;
  783. { generic support }
  784. genericdecltokenbuf : tdynamicarray;
  785. { symbol owning this definition }
  786. procsym : tsym;
  787. procsymderef : tderef;
  788. { alias names }
  789. aliasnames : TCmdStrList;
  790. { symtables }
  791. localst : TSymtable;
  792. funcretsym : tsym;
  793. funcretsymderef : tderef;
  794. struct : tabstractrecorddef;
  795. structderef : tderef;
  796. implprocoptions: timplprocoptions;
  797. { import info }
  798. import_dll,
  799. import_name : pshortstring;
  800. { info for inlining the subroutine, if this pointer is nil,
  801. the procedure can't be inlined }
  802. inlininginfo : pinlininginfo;
  803. {$ifdef oldregvars}
  804. regvarinfo: pregvarinfo;
  805. {$endif oldregvars}
  806. import_nr : word;
  807. extnumber : word;
  808. { set to a value different from tsk_none in case this procdef is for
  809. a routine that has to be internally generated by the compiler }
  810. synthetickind: tsynthetickind;
  811. visibility : tvisibility;
  812. {$ifndef DISABLE_FAST_OVERLOAD_PATCH}
  813. seenmarker : pointer; // used for filtering in tcandidate
  814. {$endif}
  815. constructor create(level:byte;doregister:boolean);virtual;
  816. constructor ppuload(ppufile:tcompilerppufile);
  817. destructor destroy;override;
  818. procedure freeimplprocdefinfo;
  819. { do not override this routine in platform-specific subclasses,
  820. override ppuwrite_platform instead }
  821. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  822. procedure buildderef;override;
  823. procedure buildderefimpl;override;
  824. procedure deref;override;
  825. procedure derefimpl;override;
  826. function GetSymtable(t:tGetSymtable):TSymtable;override;
  827. { warnings:
  828. * the symtablestack top has to be the symtable to which the copy
  829. should be added
  830. * getcopy does not create a finished/ready-to-use procdef; it
  831. needs to be finalised afterwards by calling
  832. symcreat.finish_copied_procdef() afterwards
  833. }
  834. function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef; override;
  835. function getcopy: tstoreddef; override;
  836. function GetTypeName : string;override;
  837. function mangledname : TSymStr; virtual;
  838. procedure setmangledname(const s : TSymStr);
  839. function needsglobalasmsym: boolean;
  840. procedure setcompilerprocname;
  841. function fullprocname(showhidden:boolean):string;
  842. function customprocname(pno: tprocnameoptions):ansistring;
  843. function defaultmangledname: TSymStr;
  844. function cplusplusmangledname : TSymStr;
  845. function objcmangledname : TSymStr;
  846. function is_methodpointer:boolean;override;
  847. function is_addressonly:boolean;override;
  848. procedure make_external;
  849. procedure init_genericdecl;
  850. function get_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean; virtual;
  851. function get_safecall_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean; virtual;
  852. { returns whether the mangled name or any of its aliases is equal to
  853. s }
  854. function has_alias_name(const s: TSymStr):boolean;
  855. { aliases to fields only required when a function is implemented in
  856. the current unit }
  857. property resultname: PShortString read GetResultName write SetResultName;
  858. { temporary reference to structure containing copies of all local
  859. variables and parameters accessed by nested routines; reference to
  860. this structure is passed as "parent frame pointer" on targets that
  861. lack this concept (at least JVM and LLVM); no need to save to/
  862. restore from ppu, since nested routines are always in the same
  863. unit }
  864. property parentfpstruct: tsym read GetParentFPStruct write SetParentFPStruct;
  865. { pointer to parentfpstruct's type (not yet valid during parsing, so
  866. cannot be used for $parentfp parameter) (no need to save to ppu) }
  867. property parentfpstructptrtype: tdef read GetParentFPStructPtrType write SetParentFPStructPtrType;
  868. { code to copy the parameters accessed from nested routines into the
  869. parentfpstruct (no need to save to ppu) }
  870. property parentfpinitblock: tnode read GetParentFPInitBlock write SetParentFPInitBlock;
  871. { First/last assembler symbol/instruction in aasmoutput list.
  872. Note: initialised after compiling the code for the procdef, but
  873. not saved to/restored from ppu. Used when inserting debug info }
  874. property procstarttai: tai read Getprocstarttai write Setprocstarttai;
  875. property procendtai: tai read Getprocendtai write Setprocendtai;
  876. { optional parameter for the synthetic routine generation logic }
  877. property skpara: pointer read Getskpara write Setskpara;
  878. { ABI-conformant exception handling personality function }
  879. property personality: tprocdef read Getpersonality write Setpersonality;
  880. { true, if the procedure is only declared
  881. (forward procedure) }
  882. property forwarddef: boolean read Getforwarddef write Setforwarddef;
  883. { true if the procedure is declared in the interface }
  884. property interfacedef: boolean read Getinterfacedef write Setinterfacedef;
  885. { true if the procedure has a forward declaration }
  886. property hasforward: boolean read Gethasforward write Sethasforward;
  887. { true if the routine's body is empty }
  888. property isempty: boolean read GetIsEmpty write SetIsEmpty;
  889. { true if all information required to inline this routine is available }
  890. property has_inlininginfo: boolean read GetHasInliningInfo write SetHasInliningInfo;
  891. { returns the $parentfp parameter for nested routines }
  892. property parentfpsym: tsym read getparentfpsym;
  893. { true if the implementation part for this procdef has been handled }
  894. property is_implemented: boolean read Getis_implemented write Setis_implemented;
  895. end;
  896. tprocdefclass = class of tprocdef;
  897. { single linked list of overloaded procs }
  898. pprocdeflist = ^tprocdeflist;
  899. tprocdeflist = record
  900. def : tprocdef;
  901. defderef : tderef;
  902. next : pprocdeflist;
  903. end;
  904. tstringdef = class(tstoreddef)
  905. encoding : tstringencoding;
  906. stringtype : tstringtype;
  907. len : asizeint;
  908. constructor createshort(l: byte; doregister: boolean);virtual;
  909. constructor loadshort(ppufile:tcompilerppufile);
  910. constructor createlong(l: asizeint; doregister: boolean);virtual;
  911. constructor loadlong(ppufile:tcompilerppufile);
  912. constructor createansi(aencoding: tstringencoding; doregister: boolean);virtual;
  913. constructor loadansi(ppufile:tcompilerppufile);
  914. constructor createwide(doregister: boolean);virtual;
  915. constructor loadwide(ppufile:tcompilerppufile);
  916. constructor createunicode(doregister: boolean);virtual;
  917. constructor loadunicode(ppufile:tcompilerppufile);virtual;
  918. function getcopy : tstoreddef;override;
  919. function stringtypname:string;
  920. { do not override this routine in platform-specific subclasses,
  921. override ppuwrite_platform instead }
  922. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  923. function GetTypeName:string;override;
  924. function getmangledparaname:TSymStr;override;
  925. function is_publishable : boolean;override;
  926. function size:asizeint;override;
  927. function alignment : shortint;override;
  928. function needs_inittable : boolean;override;
  929. function getvardef:longint;override;
  930. end;
  931. tstringdefclass = class of tstringdef;
  932. { tenumdef }
  933. tenumdef = class(tstoreddef)
  934. minval,
  935. maxval : asizeint;
  936. basedef : tenumdef;
  937. basedefderef : tderef;
  938. symtable : TSymtable;
  939. has_jumps : boolean;
  940. constructor create;virtual;
  941. constructor create_subrange(_basedef:tenumdef;_min,_max:asizeint);virtual;
  942. constructor ppuload(ppufile:tcompilerppufile);
  943. destructor destroy;override;
  944. function getcopy : tstoreddef;override;
  945. { do not override this routine in platform-specific subclasses,
  946. override ppuwrite_platform instead }
  947. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  948. procedure buildderef;override;
  949. procedure deref;override;
  950. function GetTypeName:string;override;
  951. function is_publishable : boolean;override;
  952. procedure calcsavesize(packenum: shortint);
  953. function packedbitsize: asizeint; override;
  954. procedure setmax(_max:asizeint);
  955. procedure setmin(_min:asizeint);
  956. function min:asizeint;
  957. function max:asizeint;
  958. function getfirstsym:tsym;
  959. function int2enumsym(l: asizeint): tsym;
  960. { returns basedef if assigned, otherwise self }
  961. function getbasedef: tenumdef;
  962. end;
  963. tenumdefclass = class of tenumdef;
  964. tsetdef = class(tstoreddef)
  965. elementdef : tdef;
  966. elementdefderef : tderef;
  967. setbase,
  968. setmax : asizeint;
  969. constructor create(def: tdef; low, high: asizeint; doregister: boolean);virtual;
  970. constructor ppuload(ppufile:tcompilerppufile);
  971. function getcopy : tstoreddef;override;
  972. { do not override this routine in platform-specific subclasses,
  973. override ppuwrite_platform instead }
  974. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  975. procedure buildderef;override;
  976. procedure deref;override;
  977. function GetTypeName:string;override;
  978. function is_publishable : boolean;override;
  979. function alignment: shortint; override;
  980. end;
  981. tsetdefclass = class of tsetdef;
  982. tgenericdummyentry = class
  983. dummysym : tsym;
  984. resolvedsym : tsym;
  985. end;
  986. tdefawaresymtablestack = class(TSymtablestack)
  987. private
  988. procedure add_helpers_and_generics(st:tsymtable;addgenerics:boolean);
  989. procedure remove_helpers_and_generics(st:tsymtable);inline;
  990. procedure remove_helpers(st:tsymtable);
  991. procedure remove_generics(st:tsymtable);
  992. procedure pushcommon(st:tsymtable);inline;
  993. public
  994. procedure push(st: TSymtable); override;
  995. procedure pushafter(st,afterst:TSymtable); override;
  996. procedure pop(st: TSymtable); override;
  997. end;
  998. var
  999. current_structdef: tabstractrecorddef; { used for private functions check !! }
  1000. current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class }
  1001. current_specializedef: tstoreddef; { used to implement usage of generic class in itself }
  1002. cfiledef: tfiledefclass;
  1003. cvariantdef: tvariantdefclass;
  1004. cformaldef: tformaldefclass;
  1005. cforwarddef: tforwarddefclass;
  1006. cundefineddef: tundefineddefclass;
  1007. cerrordef: terrordefclass;
  1008. cpointerdef: tpointerdefclass;
  1009. crecorddef: trecorddefclass;
  1010. cimplementedinterface: timplementedinterfaceclass;
  1011. cobjectdef: tobjectdefclass;
  1012. cclassrefdef: tclassrefdefclass;
  1013. carraydef: tarraydefclass;
  1014. corddef: torddefclass;
  1015. cfloatdef: tfloatdefclass;
  1016. cprocvardef: tprocvardefclass;
  1017. cprocdef: tprocdefclass;
  1018. cstringdef: tstringdefclass;
  1019. cenumdef: tenumdefclass;
  1020. csetdef: tsetdefclass;
  1021. { default types }
  1022. generrordef, { error in definition }
  1023. voidpointertype, { pointer for Void-pointeddef }
  1024. charpointertype, { pointer for Char-pointeddef }
  1025. widecharpointertype, { pointer for WideChar-pointeddef }
  1026. voidcodepointertype, { pointer to code; corresponds to System.CodePointer }
  1027. voidstackpointertype, { the pointer type used for accessing parameters and local vars on the stack }
  1028. parentfpvoidpointertype, { void pointer with the size of the hidden parentfp parameter, passed to nested functions }
  1029. {$ifdef x86}
  1030. voidnearpointertype,
  1031. voidnearcspointertype,
  1032. voidneardspointertype,
  1033. voidnearsspointertype,
  1034. voidnearespointertype,
  1035. voidnearfspointertype,
  1036. voidneargspointertype,
  1037. {$ifdef i8086}
  1038. voidfarpointertype,
  1039. voidhugepointertype,
  1040. charnearpointertype,
  1041. charfarpointertype,
  1042. charhugepointertype,
  1043. bytefarpointertype, { used for Mem[] }
  1044. wordfarpointertype, { used for MemW[] }
  1045. longintfarpointertype, { used for MemL[] }
  1046. {$endif i8086}
  1047. {$endif x86}
  1048. cundefinedtype,
  1049. cformaltype, { unique formal definition }
  1050. ctypedformaltype, { unique typed formal definition }
  1051. voidtype, { Void (procedure) }
  1052. cansichartype, { Char }
  1053. cwidechartype, { WideChar }
  1054. pasbool1type, { boolean type }
  1055. pasbool8type,
  1056. pasbool16type,
  1057. pasbool32type,
  1058. pasbool64type,
  1059. bool8type,
  1060. bool16type,
  1061. bool32type,
  1062. bool64type, { implement me }
  1063. {$ifdef llvm}
  1064. llvmbool1type, { LLVM i1 type }
  1065. {$endif llvm}
  1066. u8inttype, { 8-Bit unsigned integer }
  1067. s8inttype, { 8-Bit signed integer }
  1068. u16inttype, { 16-Bit unsigned integer }
  1069. s16inttype, { 16-Bit signed integer }
  1070. u24inttype, { 24-Bit unsigned integer }
  1071. s24inttype, { 24-Bit signed integer }
  1072. u32inttype, { 32-Bit unsigned integer }
  1073. s32inttype, { 32-Bit signed integer }
  1074. u40inttype, { 40-Bit unsigned integer }
  1075. s40inttype, { 40-Bit signed integer }
  1076. u48inttype, { 48-Bit unsigned integer }
  1077. s48inttype, { 48-Bit signed integer }
  1078. u56inttype, { 56-Bit unsigned integer }
  1079. s56inttype, { 56-Bit signed integer }
  1080. u64inttype, { 64-bit unsigned integer }
  1081. s64inttype, { 64-bit signed integer }
  1082. u128inttype, { 128-bit unsigned integer }
  1083. s128inttype, { 128-bit signed integer }
  1084. s32floattype, { 32 bit floating point number }
  1085. s64floattype, { 64 bit floating point number }
  1086. s80floattype, { 80 bit floating point number }
  1087. sc80floattype, { 80 bit floating point number but stored like in C }
  1088. s64currencytype, { pointer to a currency type }
  1089. cshortstringtype, { pointer to type of short string const }
  1090. clongstringtype, { pointer to type of long string const }
  1091. cansistringtype, { pointer to type of ansi string const }
  1092. cwidestringtype, { pointer to type of wide string const }
  1093. cunicodestringtype,
  1094. openshortstringtype, { pointer to type of an open shortstring,
  1095. needed for readln() }
  1096. openchararraytype, { pointer to type of an open array of char,
  1097. needed for readln() }
  1098. cfiletype, { get the same definition for all file }
  1099. { used for stabs }
  1100. methodpointertype, { typecasting of methodpointers to extract self }
  1101. nestedprocpointertype, { typecasting of nestedprocpointers to extract parentfp }
  1102. hresultdef,
  1103. typekindtype, { def of TTypeKind for correct handling of GetTypeKind parameters }
  1104. { we use only one variant def for every variant class }
  1105. cvarianttype,
  1106. colevarianttype,
  1107. { default integer type, normally s32inttype on 32 bit systems and s64bittype on 64 bit systems }
  1108. sinttype,
  1109. uinttype,
  1110. { integer types corresponding to OS_SINT/OS_INT }
  1111. ossinttype,
  1112. osuinttype,
  1113. { integer types corresponding to the ALU size, sizeof(aint) and the ALUSInt/ALUUInt types in the system unit }
  1114. alusinttype,
  1115. aluuinttype,
  1116. { integer types corresponding to SizeInt and SizeUInt for the target platform }
  1117. sizeuinttype,
  1118. sizesinttype,
  1119. { unsigned and signed ord type with the same size as a pointer }
  1120. ptruinttype,
  1121. ptrsinttype,
  1122. { unsigned and signed ord type with the same size as a codepointer }
  1123. codeptruinttype,
  1124. codeptrsinttype,
  1125. { several types to simulate more or less C++ objects for GDB }
  1126. vmttype,
  1127. vmtarraytype,
  1128. pvmttype : tdef; { type of classrefs, used for stabs }
  1129. { pointer to the anchestor of all classes }
  1130. class_tobject : tobjectdef;
  1131. { pointer to the base type for custom attributes }
  1132. class_tcustomattribute : tobjectdef;
  1133. { pointer to the ancestor of all COM interfaces }
  1134. interface_iunknown : tobjectdef;
  1135. { pointer to the ancestor of all dispinterfaces }
  1136. interface_idispatch : tobjectdef;
  1137. { pointer to the TGUID type
  1138. of all interfaces }
  1139. rec_tguid : trecorddef;
  1140. { jump buffer type, used by setjmp }
  1141. rec_jmp_buf : trecorddef;
  1142. { system.texceptaddr type, used by fpc_pushexceptaddr }
  1143. rec_exceptaddr: trecorddef;
  1144. { Objective-C base types }
  1145. objc_metaclasstype,
  1146. objc_superclasstype,
  1147. objc_idtype,
  1148. objc_seltype : tpointerdef;
  1149. objc_objecttype : trecorddef;
  1150. { base type of @protocol(protocolname) Objective-C statements }
  1151. objc_protocoltype : tobjectdef;
  1152. { helper types for for-in "fast enumeration" support in Objective-C 2.0 }
  1153. objc_fastenumeration : tobjectdef;
  1154. objc_fastenumerationstate : trecorddef;
  1155. {$ifdef llvm}
  1156. { llvm types }
  1157. { a unique def to identify any kind of metadata }
  1158. llvm_metadatatype : tdef;
  1159. {$endif llvm}
  1160. { Java base types }
  1161. { java.lang.Object }
  1162. java_jlobject : tobjectdef;
  1163. { java.lang.Throwable }
  1164. java_jlthrowable : tobjectdef;
  1165. { FPC base type for records }
  1166. java_fpcbaserecordtype : tobjectdef;
  1167. { java.lang.String }
  1168. java_jlstring : tobjectdef;
  1169. { java.lang.Enum }
  1170. java_jlenum : tobjectdef;
  1171. { java.util.EnumSet }
  1172. java_juenumset : tobjectdef;
  1173. { java.util.BitSet }
  1174. java_jubitset : tobjectdef;
  1175. { FPC java implementation of ansistrings }
  1176. java_ansistring : tobjectdef;
  1177. { FPC java implementation of shortstrings }
  1178. java_shortstring : tobjectdef;
  1179. { FPC java procvar base class }
  1180. java_procvarbase : tobjectdef;
  1181. { x86 vector types }
  1182. x86_m64type,
  1183. x86_m128type,
  1184. x86_m128dtype,
  1185. x86_m128itype,
  1186. x86_m256type,
  1187. x86_m256dtype,
  1188. x86_m256itype : tdef;
  1189. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  1190. function make_dllmangledname(const dllname,importname:TSymStr;
  1191. import_nr : word; pco : tproccalloption):TSymStr;
  1192. { should be in the types unit, but the types unit uses the node stuff :( }
  1193. function is_interfacecom(def: tdef): boolean;
  1194. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  1195. function is_any_interface_kind(def: tdef): boolean;
  1196. function is_interfacecorba(def: tdef): boolean;
  1197. function is_interface(def: tdef): boolean;
  1198. function is_dispinterface(def: tdef): boolean;
  1199. function is_object(def: tdef): boolean;
  1200. function is_class(def: tdef): boolean;
  1201. function is_cppclass(def: tdef): boolean;
  1202. function is_objectpascal_helper(def: tdef): boolean;
  1203. function is_objcclass(def: tdef): boolean;
  1204. function is_objcclassref(def: tdef): boolean;
  1205. function is_objcprotocol(def: tdef): boolean;
  1206. function is_objccategory(def: tdef): boolean;
  1207. function is_objc_class_or_protocol(def: tdef): boolean;
  1208. function is_objc_protocol_or_category(def: tdef): boolean;
  1209. function is_classhelper(def: tdef): boolean;
  1210. function is_class_or_interface(def: tdef): boolean;
  1211. function is_class_or_interface_or_objc(def: tdef): boolean;
  1212. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  1213. function is_class_or_interface_or_dispinterface_or_objc_or_java(def: tdef): boolean;
  1214. function is_class_or_interface_or_object(def: tdef): boolean;
  1215. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  1216. function is_implicit_pointer_object_type(def: tdef): boolean;
  1217. { returns true, if def is a type which is an implicit pointer to an array (dyn. array or dyn. string) }
  1218. function is_implicit_array_pointer(def: tdef): boolean;
  1219. function is_class_or_object(def: tdef): boolean;
  1220. function is_record(def: tdef): boolean;
  1221. function is_javaclass(def: tdef): boolean;
  1222. function is_javaclassref(def: tdef): boolean;
  1223. function is_javainterface(def: tdef): boolean;
  1224. function is_java_class_or_interface(def: tdef): boolean;
  1225. procedure loadobjctypes;
  1226. procedure maybeloadcocoatypes;
  1227. function use_vectorfpu(def : tdef) : boolean;
  1228. function getansistringcodepage:tstringencoding; inline;
  1229. function getansistringdef:tstringdef;
  1230. function getparaencoding(def:tdef):tstringencoding; inline;
  1231. function get_threadvar_record(def: tdef; out index_field, non_mt_data_field: tsym): trecorddef;
  1232. function get_recorddef(prefix:tinternaltypeprefix;const fields:array of tdef; packrecords:shortint): trecorddef;
  1233. { get a table def of the form
  1234. record
  1235. count: countdef;
  1236. elements: array[0..count-1] of elementdef
  1237. end;
  1238. Returns both the outer record and the inner arraydef
  1239. }
  1240. procedure get_tabledef(prefix:tinternaltypeprefix;countdef,elementdef:tdef;count:longint;packrecords:shortint;out recdef:trecorddef;out arrdef:tarraydef);
  1241. implementation
  1242. uses
  1243. SysUtils,
  1244. cutils,
  1245. { global }
  1246. verbose,
  1247. { target }
  1248. systems,paramgr,
  1249. { symtable }
  1250. symsym,symtable,defutil,objcdef,
  1251. { parser }
  1252. pgenutil,
  1253. { module }
  1254. fmodule,ppu,
  1255. { other }
  1256. aasmbase,
  1257. gendef,
  1258. fpccrc,
  1259. entfile
  1260. ;
  1261. {****************************************************************************
  1262. Helpers
  1263. ****************************************************************************}
  1264. function getansistringcodepage:tstringencoding; inline;
  1265. begin
  1266. if ([cs_explicit_codepage,cs_system_codepage]*current_settings.moduleswitches)<>[] then
  1267. result:=current_settings.sourcecodepage
  1268. else
  1269. result:=0;
  1270. end;
  1271. function getansistringdef:tstringdef;
  1272. var
  1273. symtable:tsymtable;
  1274. oldstack : tsymtablestack;
  1275. begin
  1276. { if a codepage is explicitly defined in this mudule we need to return
  1277. a replacement for ansistring def }
  1278. if ([cs_explicit_codepage,cs_system_codepage]*current_settings.moduleswitches)<>[] then
  1279. begin
  1280. if not assigned(current_module) then
  1281. internalerror(2011101301);
  1282. { codepage can be redeclared only once per unit so we don't need a list of
  1283. redefined ansistring but only one pointer }
  1284. if not assigned(current_module.ansistrdef) then
  1285. begin
  1286. { if we did not create it yet we need to do this now }
  1287. if current_module.in_interface then
  1288. symtable:=current_module.globalsymtable
  1289. else
  1290. symtable:=current_module.localsymtable;
  1291. { create a temporary stack as it's not good (TM) to mess around
  1292. with the order if the unit contains generics or helpers; don't
  1293. use a def aware symtablestack though }
  1294. oldstack:=symtablestack;
  1295. symtablestack:=tsymtablestack.create;
  1296. symtablestack.push(symtable);
  1297. current_module.ansistrdef:=cstringdef.createansi(current_settings.sourcecodepage,true);
  1298. symtablestack.pop(symtable);
  1299. symtablestack.free;
  1300. symtablestack:=oldstack;
  1301. end;
  1302. result:=tstringdef(current_module.ansistrdef);
  1303. end
  1304. else
  1305. result:=tstringdef(cansistringtype);
  1306. end;
  1307. function getparaencoding(def:tdef):tstringencoding; inline;
  1308. begin
  1309. { don't pass CP_NONE encoding to internal functions
  1310. they expect 0 encoding instead
  1311. exception: result of string concatenation, because if you pass the
  1312. result of a string concatenation to a rawbytestring, the result of
  1313. that concatenation shouldn't be converted to defaultsystemcodepage
  1314. if all strings have the same type }
  1315. result:=tstringdef(def).encoding;
  1316. if result=globals.CP_NONE then
  1317. result:=0
  1318. end;
  1319. function get_threadvar_record(def: tdef; out index_field, non_mt_data_field: tsym): trecorddef;
  1320. var
  1321. typ: ttypesym;
  1322. name: string;
  1323. begin
  1324. name:=internaltypeprefixName[itp_threadvar_record]+def.unique_id_str;
  1325. typ:=try_search_current_module_type(name);
  1326. if assigned(typ) then
  1327. begin
  1328. result:=trecorddef(ttypesym(typ).typedef);
  1329. index_field:=tsym(result.symtable.symlist[0]);
  1330. non_mt_data_field:=tsym(result.symtable.symlist[1]);
  1331. exit;
  1332. end;
  1333. { set recordalinmin to sizeof(pint), so the second field gets put at
  1334. offset = sizeof(pint) as expected }
  1335. result:=crecorddef.create_global_internal(
  1336. name,sizeof(pint),sizeof(pint));
  1337. {$ifdef cpu16bitaddr}
  1338. index_field:=result.add_field_by_def('',u16inttype);
  1339. {$else cpu16bitaddr}
  1340. index_field:=result.add_field_by_def('',u32inttype);
  1341. {$endif cpu16bitaddr}
  1342. non_mt_data_field:=result.add_field_by_def('',def);
  1343. { no need to add alignment padding, we won't create arrays of these }
  1344. end;
  1345. function get_recorddef(prefix:tinternaltypeprefix; const fields:array of tdef; packrecords:shortint): trecorddef;
  1346. var
  1347. fieldlist: tfplist;
  1348. srsym: tsym;
  1349. srsymtable: tsymtable;
  1350. i: longint;
  1351. name : TIDString;
  1352. begin
  1353. name:=copy(internaltypeprefixName[prefix],2,length(internaltypeprefixName[prefix]));
  1354. if searchsym_type(name,srsym,srsymtable) then
  1355. begin
  1356. result:=trecorddef(ttypesym(srsym).typedef);
  1357. exit
  1358. end;
  1359. { also always search in the current module (symtables are popped for
  1360. RTTI related code already) }
  1361. if searchsym_in_module(pointer(current_module),name,srsym,srsymtable) then
  1362. begin
  1363. result:=trecorddef(ttypesym(srsym).typedef);
  1364. exit;
  1365. end;
  1366. fieldlist:=tfplist.create;
  1367. for i:=low(fields) to high(fields) do
  1368. fieldlist.add(fields[i]);
  1369. result:=crecorddef.create_global_internal(internaltypeprefixName[prefix],packrecords,
  1370. targetinfos[target_info.system]^.alignment.recordalignmin);
  1371. result.add_fields_from_deflist(fieldlist);
  1372. fieldlist.free;
  1373. end;
  1374. procedure get_tabledef(prefix:tinternaltypeprefix;countdef,elementdef:tdef;count:longint;packrecords:shortint;out recdef:trecorddef;out arrdef:tarraydef);
  1375. var
  1376. fields: tfplist;
  1377. name: TIDString;
  1378. srsym: tsym;
  1379. srsymtable: tsymtable;
  1380. begin
  1381. { already created a message string table with this number of elements
  1382. in this unit -> reuse the def }
  1383. name:=internaltypeprefixName[prefix]+tostr(count);
  1384. if searchsym_type(copy(name,2,length(name)),srsym,srsymtable) then
  1385. begin
  1386. recdef:=trecorddef(ttypesym(srsym).typedef);
  1387. arrdef:=tarraydef(trecordsymtable(recdef.symtable).findfieldbyoffset(countdef.size).vardef);
  1388. exit
  1389. end;
  1390. { also always search in the current module (symtables are popped for
  1391. RTTI related code already) }
  1392. if searchsym_in_module(pointer(current_module),copy(name,2,length(name)),srsym,srsymtable) then
  1393. begin
  1394. recdef:=trecorddef(ttypesym(srsym).typedef);
  1395. arrdef:=tarraydef(trecordsymtable(recdef.symtable).findfieldbyoffset(countdef.size).vardef);
  1396. exit;
  1397. end;
  1398. recdef:=crecorddef.create_global_internal(name,packrecords,
  1399. targetinfos[target_info.system]^.alignment.recordalignmin);
  1400. fields:=tfplist.create;
  1401. fields.add(countdef);
  1402. if count>0 then
  1403. begin
  1404. arrdef:=carraydef.create(0,count-1,sizeuinttype);
  1405. arrdef.elementdef:=elementdef;
  1406. fields.add(arrdef);
  1407. end
  1408. else
  1409. arrdef:=nil;
  1410. recdef.add_fields_from_deflist(fields);
  1411. fields.free;
  1412. end;
  1413. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  1414. var
  1415. s,
  1416. prefix : TSymStr;
  1417. crc : dword;
  1418. begin
  1419. prefix:='';
  1420. if not assigned(st) then
  1421. internalerror(200204212);
  1422. { sub procedures }
  1423. while (st.symtabletype in [localsymtable,parasymtable]) do
  1424. begin
  1425. if st.defowner.typ<>procdef then
  1426. internalerror(200204173);
  1427. { Add the full mangledname of procedure to prevent
  1428. conflicts with 2 overloads having both a nested procedure
  1429. with the same name, see tb0314 (PFV) }
  1430. s:=tprocdef(st.defowner).procsym.name;
  1431. s:=s+tprocdef(st.defowner).mangledprocparanames(Length(s));
  1432. if prefix<>'' then
  1433. prefix:=s+'_'+prefix
  1434. else
  1435. prefix:=s;
  1436. if length(prefix)>100 then
  1437. begin
  1438. crc:=0;
  1439. crc:=UpdateCrc32(crc,prefix[1],length(prefix));
  1440. prefix:='$CRC'+hexstr(crc,8);
  1441. end;
  1442. st:=st.defowner.owner;
  1443. end;
  1444. { object/classes symtable, nested type definitions in classes require the while loop }
  1445. while st.symtabletype in [ObjectSymtable,recordsymtable] do
  1446. begin
  1447. if not (st.defowner.typ in [objectdef,recorddef]) then
  1448. internalerror(200204174);
  1449. prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
  1450. st:=st.defowner.owner;
  1451. end;
  1452. { symtable must now be static or global }
  1453. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  1454. internalerror(200204175);
  1455. { The mangled name is made out of at most 4 parts:
  1456. 1) Optional typeprefix given as first parameter
  1457. with '_$' appended if not empty
  1458. 2) Unit name or 'P$'+program name (never empty)
  1459. 3) optional prefix variable that contains a unique
  1460. name for the local symbol table (prepended with '$_$'
  1461. if not empty)
  1462. 4) suffix as given as third parameter,
  1463. also optional (i.e. can be empty)
  1464. prepended by '_$$_' if not empty }
  1465. result:='';
  1466. if typeprefix<>'' then
  1467. result:=result+typeprefix+'_$';
  1468. { Add P$ for program, which can have the same name as
  1469. a unit }
  1470. if (TSymtable(main_module.localsymtable)=st) and
  1471. (not main_module.is_unit) then
  1472. result:=result+'P$'+st.name^
  1473. else
  1474. result:=result+st.name^;
  1475. if prefix<>'' then
  1476. result:=result+'$_$'+prefix;
  1477. if suffix<>'' then
  1478. result:=result+'_$$_'+suffix;
  1479. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  1480. { Further, the Mac OS X 10.5 linker does not consider symbols which do not }
  1481. { start with '_' as regular symbols (it does not generate N_GSYM entries }
  1482. { those in the debug map, leading to troubles with dsymutil). So always }
  1483. { add an underscore on darwin. }
  1484. if (target_info.system in systems_darwin) then
  1485. result := '_' + result;
  1486. end;
  1487. function make_dllmangledname(const dllname,importname:TSymStr;import_nr : word; pco : tproccalloption):TSymStr;
  1488. var
  1489. crc : cardinal;
  1490. i : longint;
  1491. use_crc : boolean;
  1492. dllprefix : TSymStr;
  1493. begin
  1494. if (target_info.system in (systems_all_windows + systems_nativent +
  1495. [system_i386_emx, system_i386_os2]))
  1496. and (dllname <> '') then
  1497. begin
  1498. dllprefix:=lower(ExtractFileName(dllname));
  1499. { Remove .dll suffix if present }
  1500. if copy(dllprefix,length(dllprefix)-3,length(dllprefix))='.dll' then
  1501. dllprefix:=copy(dllprefix,1,length(dllprefix)-4);
  1502. use_crc:=false;
  1503. for i:=1 to length(dllprefix) do
  1504. if not (dllprefix[i] in ['a'..'z','A'..'Z','_','0'..'9']) then
  1505. begin
  1506. use_crc:=true;
  1507. break;
  1508. end;
  1509. if use_crc then
  1510. begin
  1511. crc:=0;
  1512. crc:=UpdateCrc32(crc,dllprefix[1],length(dllprefix));
  1513. dllprefix:='_$dll$crc$'+hexstr(crc,8)+'$';
  1514. end
  1515. else
  1516. dllprefix:='_$dll$'+dllprefix+'$';
  1517. if importname<>'' then
  1518. result:=dllprefix+importname
  1519. else
  1520. result:=dllprefix+'_index_'+tostr(import_nr);
  1521. { Replace ? and @ in import name, since GNU AS does not allow these characters in symbol names. }
  1522. { This allows to import VC++ mangled names from DLLs. }
  1523. { Do not perform replacement, if external symbol is not imported from DLL. }
  1524. if (dllname<>'') then
  1525. begin
  1526. Replace(result,'?','__q$$');
  1527. {$ifdef arm}
  1528. { @ symbol is not allowed in ARM assembler only }
  1529. Replace(result,'@','__a$$');
  1530. {$endif arm}
  1531. end;
  1532. end
  1533. else
  1534. begin
  1535. if importname<>'' then
  1536. begin
  1537. if not(pco in [pocall_cdecl,pocall_cppdecl]) then
  1538. result:=importname
  1539. else
  1540. result:=target_info.Cprefix+importname;
  1541. end
  1542. else
  1543. result:='_index_'+tostr(import_nr);
  1544. end;
  1545. end;
  1546. {****************************************************************************
  1547. TDEFAWARESYMTABLESTACK
  1548. (symtablestack descendant that does some special actions on
  1549. the pushed/popped symtables)
  1550. ****************************************************************************}
  1551. procedure tdefawaresymtablestack.add_helpers_and_generics(st:tsymtable;addgenerics:boolean);
  1552. var
  1553. i: integer;
  1554. s: string;
  1555. list: TFPObjectList;
  1556. def: tdef;
  1557. sym : tsym;
  1558. begin
  1559. { search the symtable from first to last; the helper to use will be the
  1560. last one in the list }
  1561. for i:=0 to st.symlist.count-1 do
  1562. begin
  1563. sym:=tsym(st.symlist[i]);
  1564. if not (sym.typ in [typesym,procsym]) then
  1565. continue;
  1566. if sym.typ=typesym then
  1567. def:=ttypesym(st.SymList[i]).typedef
  1568. else
  1569. def:=nil;
  1570. if is_objectpascal_helper(def) then
  1571. begin
  1572. s:=generate_objectpascal_helper_key(tobjectdef(def).extendeddef);
  1573. Message1(sym_d_adding_helper_for,s);
  1574. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  1575. if not assigned(list) then
  1576. begin
  1577. list:=TFPObjectList.Create(false);
  1578. current_module.extendeddefs.Add(s,list);
  1579. end;
  1580. list.Add(def);
  1581. end
  1582. else
  1583. begin
  1584. if addgenerics then
  1585. add_generic_dummysym(sym);
  1586. { add nested helpers as well }
  1587. if assigned(def) and
  1588. (def.typ in [recorddef,objectdef]) and
  1589. (sto_has_helper in tabstractrecorddef(def).symtable.tableoptions) then
  1590. add_helpers_and_generics(tabstractrecorddef(def).symtable,false);
  1591. end;
  1592. end;
  1593. end;
  1594. procedure tdefawaresymtablestack.remove_helpers_and_generics(st:tsymtable);
  1595. begin
  1596. if sto_has_helper in st.tableoptions then
  1597. remove_helpers(st);
  1598. if sto_has_generic in st.tableoptions then
  1599. remove_generics(st);
  1600. end;
  1601. procedure tdefawaresymtablestack.remove_helpers(st:TSymtable);
  1602. var
  1603. i, j: integer;
  1604. tmpst: TSymtable;
  1605. list: TFPObjectList;
  1606. begin
  1607. for i:=current_module.extendeddefs.count-1 downto 0 do
  1608. begin
  1609. list:=TFPObjectList(current_module.extendeddefs[i]);
  1610. for j:=list.count-1 downto 0 do
  1611. begin
  1612. if not (list[j] is tobjectdef) then
  1613. Internalerror(2011031501);
  1614. tmpst:=tobjectdef(list[j]).owner;
  1615. repeat
  1616. if tmpst=st then
  1617. begin
  1618. list.delete(j);
  1619. break;
  1620. end
  1621. else
  1622. begin
  1623. if assigned(tmpst.defowner) then
  1624. tmpst:=tmpst.defowner.owner
  1625. else
  1626. tmpst:=nil;
  1627. end;
  1628. until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]);
  1629. end;
  1630. if list.count=0 then
  1631. current_module.extendeddefs.delete(i);
  1632. end;
  1633. end;
  1634. procedure tdefawaresymtablestack.remove_generics(st:tsymtable);
  1635. var
  1636. i,j : longint;
  1637. entry : tgenericdummyentry;
  1638. list : tfpobjectlist;
  1639. begin
  1640. for i:=current_module.genericdummysyms.count-1 downto 0 do
  1641. begin
  1642. list:=tfpobjectlist(current_module.genericdummysyms[i]);
  1643. if not assigned(list) then
  1644. continue;
  1645. for j:=list.count-1 downto 0 do
  1646. begin
  1647. entry:=tgenericdummyentry(list[j]);
  1648. if entry.dummysym.owner=st then
  1649. list.delete(j);
  1650. end;
  1651. if list.count=0 then
  1652. current_module.genericdummysyms.delete(i);
  1653. end;
  1654. end;
  1655. procedure tdefawaresymtablestack.pushcommon(st:tsymtable);
  1656. begin
  1657. if (sto_has_generic in st.tableoptions) or
  1658. (
  1659. (st.symtabletype in [globalsymtable,staticsymtable]) and
  1660. (sto_has_helper in st.tableoptions)
  1661. ) then
  1662. { nested helpers will be added as well }
  1663. add_helpers_and_generics(st,true);
  1664. end;
  1665. procedure tdefawaresymtablestack.push(st: TSymtable);
  1666. begin
  1667. pushcommon(st);
  1668. inherited push(st);
  1669. end;
  1670. procedure tdefawaresymtablestack.pushafter(st,afterst:TSymtable);
  1671. begin
  1672. pushcommon(st);
  1673. inherited pushafter(st,afterst);
  1674. end;
  1675. procedure tdefawaresymtablestack.pop(st: TSymtable);
  1676. begin
  1677. inherited pop(st);
  1678. if (sto_has_generic in st.tableoptions) or
  1679. (
  1680. (st.symtabletype in [globalsymtable,staticsymtable]) and
  1681. (sto_has_helper in st.tableoptions)
  1682. ) then
  1683. { nested helpers will be removed as well }
  1684. remove_helpers_and_generics(st);
  1685. end;
  1686. {****************************************************************************
  1687. TDEF (base class for definitions)
  1688. ****************************************************************************}
  1689. constructor tgenericconstraintdata.create;
  1690. begin
  1691. interfaces:=tfpobjectlist.create(false);
  1692. interfacesderef:=tfplist.create;
  1693. end;
  1694. destructor tgenericconstraintdata.destroy;
  1695. var
  1696. i : longint;
  1697. begin
  1698. for i:=0 to interfacesderef.count-1 do
  1699. dispose(pderef(interfacesderef[i]));
  1700. interfacesderef.free;
  1701. interfaces.free;
  1702. inherited destroy;
  1703. end;
  1704. procedure tgenericconstraintdata.ppuload(ppufile: tcompilerppufile);
  1705. var
  1706. cnt,i : longint;
  1707. intfderef : pderef;
  1708. begin
  1709. ppufile.getset(tppuset1(flags));
  1710. cnt:=ppufile.getlongint;
  1711. for i:=0 to cnt-1 do
  1712. begin
  1713. new(intfderef);
  1714. ppufile.getderef(intfderef^);
  1715. interfacesderef.add(intfderef);
  1716. end;
  1717. end;
  1718. procedure tgenericconstraintdata.ppuwrite(ppufile: tcompilerppufile);
  1719. var
  1720. i : longint;
  1721. begin
  1722. ppufile.putset(tppuset1(flags));
  1723. ppufile.putlongint(interfacesderef.count);
  1724. for i:=0 to interfacesderef.count-1 do
  1725. ppufile.putderef(pderef(interfacesderef[i])^);
  1726. end;
  1727. procedure tgenericconstraintdata.buildderef;
  1728. var
  1729. intfderef : pderef;
  1730. i : longint;
  1731. begin
  1732. for i:=0 to interfaces.count-1 do
  1733. begin
  1734. new(intfderef);
  1735. intfderef^.build(tobjectdef(interfaces[i]));
  1736. interfacesderef.add(intfderef);
  1737. end;
  1738. end;
  1739. procedure tgenericconstraintdata.deref;
  1740. var
  1741. i : longint;
  1742. begin
  1743. for i:=0 to interfacesderef.count-1 do
  1744. interfaces.add(pderef(interfacesderef[i])^.resolve);
  1745. end;
  1746. procedure tstoreddef.writeentry(ppufile: tcompilerppufile; ibnr: byte);
  1747. begin
  1748. ppuwrite_platform(ppufile);
  1749. ppufile.writeentry(ibnr);
  1750. end;
  1751. procedure tstoreddef.ppuwrite_platform(ppufile: tcompilerppufile);
  1752. begin
  1753. { by default: do nothing }
  1754. end;
  1755. procedure tstoreddef.ppuload_platform(ppufile: tcompilerppufile);
  1756. begin
  1757. { by default: do nothing }
  1758. end;
  1759. class procedure tstoreddef.setup_reusable_def(origdef, newdef: tdef; res: PHashSetItem; oldsymtablestack: tsymtablestack);
  1760. var
  1761. reusablesymtab: tsymtable;
  1762. begin
  1763. { must not yet belong to a symtable }
  1764. if assigned(newdef.owner) then
  1765. internalerror(2015111503);
  1766. reusablesymtab:=origdef.getreusablesymtab;
  1767. res^.Data:=newdef;
  1768. reusablesymtab.insertdef(newdef);
  1769. symtablestack:=oldsymtablestack;
  1770. end;
  1771. constructor tstoreddef.create(dt:tdeftyp;doregister:boolean);
  1772. begin
  1773. inherited create(dt);
  1774. savesize := 0;
  1775. {$ifdef EXTDEBUG}
  1776. fileinfo := current_filepos;
  1777. {$endif}
  1778. generictokenbuf:=nil;
  1779. genericdef:=nil;
  1780. typesymderef.reset;
  1781. genericdefderef.reset;
  1782. { Don't register forwarddefs, they are disposed at the
  1783. end of an type block }
  1784. if (dt=forwarddef) then
  1785. exit;
  1786. { Register in symtable stack }
  1787. if doregister then
  1788. begin
  1789. { immediately register interface defs, as they will always be
  1790. written to the ppu, their defid inlfuences the interface crc and
  1791. if we wait, depending on e.g. compiler defines they may get a
  1792. different defid (e.g. when a function is called, its procdef is
  1793. registered, so depending on whether or not, or when, an interface
  1794. procedure is called in the implementation, that may change its
  1795. defid otherwise) }
  1796. if assigned(current_module) and
  1797. current_module.in_interface then
  1798. register_def
  1799. else
  1800. maybe_put_in_symtable_stack;
  1801. end;
  1802. end;
  1803. destructor tstoreddef.destroy;
  1804. var
  1805. i : longint;
  1806. begin
  1807. { Direct calls are not allowed, use symtable.deletedef() }
  1808. if assigned(owner) then
  1809. internalerror(200612311);
  1810. if assigned(generictokenbuf) then
  1811. begin
  1812. generictokenbuf.free;
  1813. generictokenbuf:=nil;
  1814. end;
  1815. rtti_attribute_list.free;
  1816. genericparas.free;
  1817. if assigned(genericparaderefs) then
  1818. for i:=0 to genericparaderefs.count-1 do
  1819. dispose(pderef(genericparaderefs[i]));
  1820. genericparaderefs.free;
  1821. genconstraintdata.free;
  1822. {$ifndef symansistr}
  1823. stringdispose(_fullownerhierarchyname);
  1824. {$endif not symansistr}
  1825. inherited destroy;
  1826. end;
  1827. constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1828. var
  1829. sizeleft,i,cnt : longint;
  1830. buf : array[0..255] of byte;
  1831. symderef : pderef;
  1832. begin
  1833. inherited create(dt);
  1834. DefId:=ppufile.getlongint;
  1835. current_module.deflist[DefId]:=self;
  1836. {$ifdef EXTDEBUG}
  1837. fillchar(fileinfo,sizeof(fileinfo),0);
  1838. {$endif}
  1839. { load }
  1840. ppufile.getderef(typesymderef);
  1841. ppufile.getset(tppuset2(defoptions));
  1842. ppufile.getset(tppuset1(defstates));
  1843. if df_genconstraint in defoptions then
  1844. begin
  1845. genconstraintdata:=tgenericconstraintdata.create;
  1846. genconstraintdata.ppuload(ppufile);
  1847. end;
  1848. if [df_generic,df_specialization]*defoptions<>[] then
  1849. begin
  1850. cnt:=ppufile.getlongint;
  1851. if cnt>0 then
  1852. begin
  1853. genericparas:=tfphashobjectlist.create(false);
  1854. genericparaderefs:=tfplist.create;
  1855. for i:=0 to cnt-1 do
  1856. begin
  1857. genericparas.add(ppufile.getstring,nil);
  1858. New(symderef);
  1859. ppufile.getderef(symderef^);
  1860. genericparaderefs.add(symderef);
  1861. end;
  1862. end;
  1863. end;
  1864. if df_generic in defoptions then
  1865. begin
  1866. sizeleft:=ppufile.getlongint;
  1867. initgeneric;
  1868. while sizeleft>0 do
  1869. begin
  1870. if sizeleft>sizeof(buf) then
  1871. i:=sizeof(buf)
  1872. else
  1873. i:=sizeleft;
  1874. ppufile.getdata(buf,i);
  1875. generictokenbuf.write(buf,i);
  1876. dec(sizeleft,i);
  1877. end;
  1878. end;
  1879. if df_specialization in defoptions then
  1880. ppufile.getderef(genericdefderef);
  1881. rtti_attribute_list:=trtti_attribute_list.ppuload(ppufile);
  1882. end;
  1883. function tstoreddef.needs_separate_initrtti:boolean;
  1884. begin
  1885. result:=false;
  1886. end;
  1887. function tstoreddef.rtti_mangledname(rt : trttitype) : TSymStr;
  1888. var
  1889. prefix : string[4];
  1890. begin
  1891. if (rt=fullrtti) or (not needs_separate_initrtti) then
  1892. begin
  1893. prefix:='RTTI';
  1894. include(defstates,ds_rtti_table_used);
  1895. end
  1896. else
  1897. begin
  1898. prefix:='INIT';
  1899. include(defstates,ds_init_table_used);
  1900. end;
  1901. if assigned(typesym) and
  1902. (owner.symtabletype in [staticsymtable,globalsymtable]) then
  1903. result:=make_mangledname(prefix,typesym.owner,typesym.name)
  1904. else
  1905. result:=make_mangledname(prefix,findunitsymtable(owner),'def'+unique_id_str)
  1906. end;
  1907. function tstoreddef.OwnerHierarchyName: string;
  1908. var
  1909. tmp: tdef;
  1910. begin
  1911. tmp:=self;
  1912. result:='';
  1913. repeat
  1914. { can be not assigned in case of a forwarddef }
  1915. if assigned(tmp.owner) and
  1916. (tmp.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  1917. tmp:=tdef(tmp.owner.defowner)
  1918. else
  1919. break;
  1920. result:=tabstractrecorddef(tmp).objrealname^+'.'+result;
  1921. until tmp=nil;
  1922. end;
  1923. function tstoreddef.fullownerhierarchyname(skipprocparams:boolean): TSymStr;
  1924. var
  1925. lastowner: tsymtable;
  1926. tmp: tdef;
  1927. pno: tprocnameoptions;
  1928. begin
  1929. {$ifdef symansistr}
  1930. if not skipprocparams and (_fullownerhierarchyname<>'') then
  1931. exit(_fullownerhierarchyname);
  1932. {$else symansistr}
  1933. if not skipprocparams and assigned(_fullownerhierarchyname) then
  1934. exit(_fullownerhierarchyname^);
  1935. {$endif symansistr}
  1936. { the def can only reside inside structured types or
  1937. procedures/functions/methods }
  1938. tmp:=self;
  1939. result:='';
  1940. repeat
  1941. lastowner:=tmp.owner;
  1942. { can be not assigned in case of a forwarddef }
  1943. if not assigned(lastowner) then
  1944. break
  1945. else
  1946. tmp:=tdef(lastowner.defowner);
  1947. if not assigned(tmp) then
  1948. break;
  1949. if tmp.typ in [recorddef,objectdef] then
  1950. result:=tabstractrecorddef(tmp).objrealname^+'.'+result
  1951. else
  1952. if tmp.typ=procdef then
  1953. begin
  1954. pno:=[pno_paranames,pno_proctypeoption];
  1955. if skipprocparams then
  1956. include(pno,pno_noparams);
  1957. result:=tprocdef(tmp).customprocname(pno)+'.'+result;
  1958. end;
  1959. until tmp=nil;
  1960. { add the unit name }
  1961. if assigned(lastowner) and
  1962. assigned(lastowner.realname) then
  1963. result:=lastowner.realname^+'.'+result;
  1964. if not skipprocparams then
  1965. { don't store the name in this case }
  1966. {$ifdef symansistr}
  1967. _fullownerhierarchyname:=result;
  1968. {$else symansistr}
  1969. _fullownerhierarchyname:=stringdup(result);
  1970. {$endif symansistr}
  1971. end;
  1972. function tstoreddef.in_currentunit: boolean;
  1973. var
  1974. st: tsymtable;
  1975. begin
  1976. st:=owner;
  1977. while not(st.symtabletype in [globalsymtable,staticsymtable]) do
  1978. st:=st.defowner.owner;
  1979. result:=st.iscurrentunit;
  1980. end;
  1981. function tstoreddef.getcopy : tstoreddef;
  1982. begin
  1983. Message(sym_e_cant_create_unique_type);
  1984. getcopy:=cerrordef.create;
  1985. end;
  1986. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  1987. var
  1988. sizeleft,i : longint;
  1989. buf : array[0..255] of byte;
  1990. oldintfcrc : boolean;
  1991. begin
  1992. if defid<0 then
  1993. internalerror(2015101401);
  1994. ppufile.putlongint(DefId);
  1995. ppufile.putderef(typesymderef);
  1996. ppufile.putset(tppuset2(defoptions));
  1997. oldintfcrc:=ppufile.do_crc;
  1998. ppufile.do_crc:=false;
  1999. ppufile.putset(tppuset1(defstates));
  2000. if df_genconstraint in defoptions then
  2001. genconstraintdata.ppuwrite(ppufile);
  2002. if [df_generic,df_specialization]*defoptions<>[] then
  2003. begin
  2004. if not assigned(genericparas) then
  2005. ppufile.putlongint(0)
  2006. else
  2007. begin
  2008. if not assigned(genericparaderefs) then
  2009. internalerror(2014052305);
  2010. ppufile.putlongint(genericparas.count);
  2011. for i:=0 to genericparas.count-1 do
  2012. begin
  2013. ppufile.putstring(genericparas.nameofindex(i));
  2014. ppufile.putderef(pderef(genericparaderefs[i])^);
  2015. end;
  2016. end;
  2017. end;
  2018. if df_generic in defoptions then
  2019. begin
  2020. if assigned(generictokenbuf) then
  2021. begin
  2022. sizeleft:=generictokenbuf.size;
  2023. generictokenbuf.seek(0);
  2024. end
  2025. else
  2026. sizeleft:=0;
  2027. ppufile.putlongint(sizeleft);
  2028. while sizeleft>0 do
  2029. begin
  2030. if sizeleft>sizeof(buf) then
  2031. i:=sizeof(buf)
  2032. else
  2033. i:=sizeleft;
  2034. generictokenbuf.read(buf,i);
  2035. ppufile.putdata(buf,i);
  2036. dec(sizeleft,i);
  2037. end;
  2038. end;
  2039. ppufile.do_crc:=oldintfcrc;
  2040. if df_specialization in defoptions then
  2041. ppufile.putderef(genericdefderef);
  2042. trtti_attribute_list.ppuwrite(rtti_attribute_list,ppufile);
  2043. end;
  2044. procedure tstoreddef.ppuload_subentries(ppufile: tcompilerppufile);
  2045. begin
  2046. trtti_attribute_list.ppuload_subentries(rtti_attribute_list,ppufile);
  2047. end;
  2048. procedure tstoreddef.ppuwrite_subentries(ppufile: tcompilerppufile);
  2049. begin
  2050. trtti_attribute_list.ppuwrite_subentries(rtti_attribute_list,ppufile);
  2051. end;
  2052. procedure tstoreddef.buildderef;
  2053. var
  2054. i : longint;
  2055. sym : tsym;
  2056. symderef : pderef;
  2057. begin
  2058. if not registered then
  2059. register_def;
  2060. typesymderef.build(typesym);
  2061. genericdefderef.build(genericdef);
  2062. if assigned(rtti_attribute_list) then
  2063. rtti_attribute_list.buildderef;
  2064. if assigned(genconstraintdata) then
  2065. genconstraintdata.buildderef;
  2066. if assigned(genericparas) then
  2067. begin
  2068. if not assigned(genericparaderefs) then
  2069. genericparaderefs:=tfplist.create;
  2070. for i:=0 to genericparas.count-1 do
  2071. begin
  2072. sym:=tsym(genericparas.items[i]);
  2073. new(symderef);
  2074. symderef^.build(sym);
  2075. genericparaderefs.add(symderef);
  2076. end;
  2077. end;
  2078. end;
  2079. procedure tstoreddef.buildderefimpl;
  2080. begin
  2081. end;
  2082. procedure tstoreddef.deref;
  2083. var
  2084. symderef : pderef;
  2085. i : longint;
  2086. begin
  2087. typesym:=ttypesym(typesymderef.resolve);
  2088. if df_specialization in defoptions then
  2089. genericdef:=tstoreddef(genericdefderef.resolve);
  2090. if assigned(rtti_attribute_list) then
  2091. rtti_attribute_list.deref;
  2092. if assigned(genconstraintdata) then
  2093. genconstraintdata.deref;
  2094. if assigned(genericparas) then
  2095. begin
  2096. if not assigned(genericparaderefs) then
  2097. internalerror(2014052302);
  2098. if genericparas.count<>genericparaderefs.count then
  2099. internalerror(2014052303);
  2100. for i:=0 to genericparaderefs.count-1 do
  2101. begin
  2102. symderef:=pderef(genericparaderefs[i]);
  2103. genericparas.items[i]:=symderef^.resolve;
  2104. end;
  2105. end;
  2106. end;
  2107. procedure tstoreddef.derefimpl;
  2108. begin
  2109. end;
  2110. function tstoreddef.size : asizeint;
  2111. begin
  2112. size:=savesize;
  2113. end;
  2114. function tstoreddef.getvardef:longint;
  2115. begin
  2116. result:=varUndefined;
  2117. end;
  2118. function tstoreddef.alignment : shortint;
  2119. begin
  2120. { natural alignment by default }
  2121. alignment:=size_2_align(savesize);
  2122. { can happen if savesize = 0, e.g. for voiddef or
  2123. an empty record
  2124. }
  2125. if (alignment=0) then
  2126. alignment:=1;
  2127. end;
  2128. { returns true, if the definition can be published }
  2129. function tstoreddef.is_publishable : boolean;
  2130. begin
  2131. is_publishable:=false;
  2132. end;
  2133. { needs an init table }
  2134. function tstoreddef.needs_inittable : boolean;
  2135. begin
  2136. needs_inittable:=false;
  2137. end;
  2138. function tstoreddef.has_non_trivial_init_child(check_parent:boolean):boolean;
  2139. begin
  2140. result:=false;
  2141. end;
  2142. function tstoreddef.is_intregable : boolean;
  2143. var
  2144. recsize,temp: longint;
  2145. begin
  2146. case typ of
  2147. orddef,
  2148. pointerdef,
  2149. enumdef,
  2150. classrefdef:
  2151. is_intregable:=true;
  2152. procvardef :
  2153. is_intregable:=tprocvardef(self).is_addressonly or (po_methodpointer in tprocvardef(self).procoptions);
  2154. objectdef:
  2155. is_intregable:=(is_implicit_pointer_object_type(self)) and not needs_inittable;
  2156. setdef:
  2157. is_intregable:=is_smallset(self);
  2158. arraydef:
  2159. {$ifdef cpuhighleveltarget}
  2160. is_intregable:=false
  2161. {$else cpuhighleveltarget}
  2162. is_intregable:=not(is_special_array(self)) and
  2163. (tarraydef(self).size<=8) and (tarraydef(self).size in [1,2,4,8]) and
  2164. tstoreddef(tarraydef(self).elementdef).is_intregable
  2165. {$ifdef SUPPORT_MMX}
  2166. and not((cs_mmx in current_settings.localswitches) and
  2167. is_mmx_able_array(self))
  2168. {$endif SUPPORT_MMX}
  2169. {$endif cpuhighleveltarget}
  2170. ;
  2171. recorddef:
  2172. begin
  2173. {$ifdef cpuhighleveltarget}
  2174. is_intregable:=false;
  2175. {$else cpuhighleveltarget}
  2176. recsize:=size;
  2177. is_intregable:=
  2178. ispowerof2(recsize,temp) and
  2179. ((recsize<=sizeof(aint)*2) and
  2180. not trecorddef(self).contains_cross_aword_field and
  2181. { records cannot go into registers on 16 bit targets for now }
  2182. (sizeof(aint)>2) and
  2183. not trecorddef(self).contains_float_field
  2184. ) and
  2185. not needs_inittable;
  2186. {$endif cpuhighleveltarget}
  2187. end;
  2188. else
  2189. is_intregable:=false;
  2190. end;
  2191. end;
  2192. function tstoreddef.is_fpuregable : boolean;
  2193. begin
  2194. {$ifdef x86}
  2195. result:=use_vectorfpu(self);
  2196. {$else x86}
  2197. result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches)
  2198. {$ifdef xtensa}
  2199. and (FPUXTENSA_SINGLE in fpu_capabilities[init_settings.fputype]) and (tfloatdef(self).floattype=s32real)
  2200. {$endif xtensa}
  2201. {$ifdef arm}
  2202. and (((FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[init_settings.fputype]) and (tfloatdef(self).floattype=s32real)) or
  2203. (FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[init_settings.fputype]))
  2204. {$endif arm}
  2205. ;
  2206. {$endif x86}
  2207. end;
  2208. function tstoreddef.is_const_intregable : boolean;
  2209. begin
  2210. case typ of
  2211. stringdef:
  2212. result:=tstringdef(self).stringtype in [st_ansistring,st_unicodestring,st_widestring];
  2213. arraydef:
  2214. result:=is_dynamic_array(self);
  2215. objectdef:
  2216. result:=is_interface(self);
  2217. else
  2218. result:=false;
  2219. end;
  2220. end;
  2221. procedure tstoreddef.initgeneric;
  2222. begin
  2223. if assigned(generictokenbuf) then
  2224. internalerror(200512131);
  2225. generictokenbuf:=tdynamicarray.create(256);
  2226. end;
  2227. function tstoreddef.is_generic: boolean;
  2228. var
  2229. sym: tsym;
  2230. i: longint;
  2231. begin
  2232. result:=assigned(genericparas) and
  2233. (genericparas.count>0) and
  2234. (df_generic in defoptions);
  2235. if result then
  2236. { if any of the type parameters does *not* belong to as (meaning it was passed
  2237. in from outside) then we aren't a generic, but a specialization }
  2238. for i:=0 to genericparas.count-1 do
  2239. begin
  2240. sym:=tsym(genericparas[i]);
  2241. { sym must be either a type or const }
  2242. if not (sym.typ in [symconst.typesym,symconst.constsym]) then
  2243. internalerror(2014050903);
  2244. if sym.owner.defowner<>self then
  2245. exit(false);
  2246. if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then
  2247. exit(false);
  2248. end;
  2249. end;
  2250. function tstoreddef.is_generic_param_const(index:integer):boolean;
  2251. begin
  2252. result:=tsym(genericparas[index]).typ=constsym;
  2253. end;
  2254. function tstoreddef.get_generic_param_def(index:integer):tdef;
  2255. begin
  2256. if tsym(genericparas[index]).typ=constsym then
  2257. result:=tconstsym(genericparas[index]).constdef
  2258. else
  2259. result:=ttypesym(genericparas[index]).typedef;
  2260. end;
  2261. function tstoreddef.is_specialization: boolean;
  2262. var
  2263. i : longint;
  2264. sym : tsym;
  2265. begin
  2266. result:=assigned(genericparas) and
  2267. (genericparas.count>0) and
  2268. (df_specialization in defoptions);
  2269. if result then
  2270. begin
  2271. { if at least one of the generic parameters is not owned by us (meaning it was
  2272. passed in from outside) then we have a specialization, otherwise we have a generic }
  2273. for i:=0 to genericparas.count-1 do
  2274. begin
  2275. sym:=tsym(genericparas[i]);
  2276. { sym must be either a type or const }
  2277. if not (sym.typ in [symconst.typesym,symconst.constsym]) then
  2278. internalerror(2014050904);
  2279. if sym.owner.defowner<>self then
  2280. exit(true);
  2281. if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then
  2282. exit(true);
  2283. end;
  2284. result:=false;
  2285. end;
  2286. end;
  2287. procedure tstoreddef.register_def;
  2288. var
  2289. gst : tgetsymtable;
  2290. st : tsymtable;
  2291. begin
  2292. if registered then
  2293. exit;
  2294. { Register in current_module }
  2295. if assigned(current_module) then
  2296. begin
  2297. exclude(defoptions,df_not_registered_no_free);
  2298. for gst:=low(tgetsymtable) to high(tgetsymtable) do
  2299. begin
  2300. st:=getsymtable(gst);
  2301. if assigned(st) then
  2302. tstoredsymtable(st).register_children;
  2303. end;
  2304. if defid<defid_not_registered then
  2305. defid:=deflist_index
  2306. else
  2307. begin
  2308. current_module.deflist.Add(self);
  2309. defid:=current_module.deflist.Count-1;
  2310. end;
  2311. maybe_put_in_symtable_stack;
  2312. end
  2313. else
  2314. DefId:=defid_registered_nost;
  2315. end;
  2316. procedure tstoreddef.maybe_put_in_symtable_stack;
  2317. var
  2318. insertstack: psymtablestackitem;
  2319. begin
  2320. if assigned(symtablestack) and
  2321. not assigned(self.owner) then
  2322. begin
  2323. insertstack:=symtablestack.stack;
  2324. { don't insert defs in exception symtables, as they are freed before
  2325. the module is compiled, so we can get crashes on high level targets
  2326. if they still need it while e.g. writing assembler code }
  2327. while assigned(insertstack) and
  2328. (insertstack^.symtable.symtabletype in [stt_exceptsymtable,withsymtable]) do
  2329. insertstack:=insertstack^.next;
  2330. if not assigned(insertstack) then
  2331. internalerror(200602044);
  2332. if insertstack^.symtable.sealed then
  2333. internalerror(2015022301);
  2334. insertstack^.symtable.insertdef(self);
  2335. end;
  2336. end;
  2337. {****************************************************************************
  2338. Tstringdef
  2339. ****************************************************************************}
  2340. constructor tstringdef.createshort(l: byte; doregister: boolean);
  2341. begin
  2342. inherited create(stringdef,doregister);
  2343. stringtype:=st_shortstring;
  2344. encoding:=0;
  2345. len:=l;
  2346. end;
  2347. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  2348. begin
  2349. inherited ppuload(stringdef,ppufile);
  2350. stringtype:=st_shortstring;
  2351. encoding:=0;
  2352. len:=ppufile.getbyte;
  2353. ppuload_platform(ppufile);
  2354. end;
  2355. constructor tstringdef.createlong(l: asizeint; doregister: boolean);
  2356. begin
  2357. inherited create(stringdef,doregister);
  2358. stringtype:=st_longstring;
  2359. encoding:=0;
  2360. len:=l;
  2361. end;
  2362. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  2363. begin
  2364. inherited ppuload(stringdef,ppufile);
  2365. stringtype:=st_longstring;
  2366. encoding:=0;
  2367. len:=ppufile.getasizeint;
  2368. ppuload_platform(ppufile);
  2369. end;
  2370. constructor tstringdef.createansi(aencoding: tstringencoding; doregister: boolean);
  2371. begin
  2372. inherited create(stringdef,doregister);
  2373. stringtype:=st_ansistring;
  2374. encoding:=aencoding;
  2375. len:=-1;
  2376. end;
  2377. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  2378. begin
  2379. inherited ppuload(stringdef,ppufile);
  2380. stringtype:=st_ansistring;
  2381. len:=ppufile.getasizeint;
  2382. encoding:=ppufile.getword;
  2383. ppuload_platform(ppufile);
  2384. end;
  2385. constructor tstringdef.createwide(doregister: boolean);
  2386. begin
  2387. inherited create(stringdef,doregister);
  2388. stringtype:=st_widestring;
  2389. if target_info.endian=endian_little then
  2390. encoding:=CP_UTF16LE
  2391. else
  2392. encoding:=CP_UTF16BE;
  2393. len:=-1;
  2394. end;
  2395. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  2396. begin
  2397. inherited ppuload(stringdef,ppufile);
  2398. stringtype:=st_widestring;
  2399. if target_info.endian=endian_little then
  2400. encoding:=CP_UTF16LE
  2401. else
  2402. encoding:=CP_UTF16BE;
  2403. len:=ppufile.getasizeint;
  2404. ppuload_platform(ppufile);
  2405. end;
  2406. constructor tstringdef.createunicode(doregister: boolean);
  2407. begin
  2408. inherited create(stringdef,doregister);
  2409. stringtype:=st_unicodestring;
  2410. if target_info.endian=endian_little then
  2411. encoding:=CP_UTF16LE
  2412. else
  2413. encoding:=CP_UTF16BE;
  2414. len:=-1;
  2415. end;
  2416. constructor tstringdef.loadunicode(ppufile:tcompilerppufile);
  2417. begin
  2418. inherited ppuload(stringdef,ppufile);
  2419. stringtype:=st_unicodestring;
  2420. len:=ppufile.getasizeint;
  2421. encoding:=ppufile.getword;
  2422. ppuload_platform(ppufile);
  2423. end;
  2424. function tstringdef.getcopy : tstoreddef;
  2425. begin
  2426. result:=cstringdef.create(typ,true);
  2427. result.typ:=stringdef;
  2428. tstringdef(result).stringtype:=stringtype;
  2429. tstringdef(result).encoding:=encoding;
  2430. tstringdef(result).len:=len;
  2431. end;
  2432. function tstringdef.stringtypname:string;
  2433. const
  2434. typname:array[tstringtype] of string[10]=(
  2435. 'shortstr','longstr','ansistr','widestr','unicodestr'
  2436. );
  2437. begin
  2438. stringtypname:=typname[stringtype];
  2439. end;
  2440. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  2441. begin
  2442. inherited ppuwrite(ppufile);
  2443. if stringtype=st_shortstring then
  2444. begin
  2445. {$ifdef extdebug}
  2446. if len > 255 then internalerror(12122002);
  2447. {$endif}
  2448. ppufile.putbyte(byte(len))
  2449. end
  2450. else
  2451. ppufile.putasizeint(len);
  2452. if stringtype in [st_ansistring,st_unicodestring] then
  2453. ppufile.putword(encoding);
  2454. case stringtype of
  2455. st_shortstring : writeentry(ppufile,ibshortstringdef);
  2456. st_longstring : writeentry(ppufile,iblongstringdef);
  2457. st_ansistring : writeentry(ppufile,ibansistringdef);
  2458. st_widestring : writeentry(ppufile,ibwidestringdef);
  2459. st_unicodestring : writeentry(ppufile,ibunicodestringdef);
  2460. end;
  2461. end;
  2462. function tstringdef.needs_inittable : boolean;
  2463. begin
  2464. needs_inittable:=stringtype in [st_ansistring,st_widestring,st_unicodestring];
  2465. end;
  2466. function tstringdef.GetTypeName : string;
  2467. const
  2468. names : array[tstringtype] of string[15] = (
  2469. 'ShortString','LongString','AnsiString','WideString','UnicodeString');
  2470. begin
  2471. GetTypeName:=names[stringtype];
  2472. case stringtype of
  2473. st_ansistring,st_unicodestring:
  2474. GetTypeName:=GetTypeName+'('+tostr(encoding)+')';
  2475. st_shortstring:
  2476. GetTypeName:=GetTypeName+'['+tostr(len)+']';
  2477. else
  2478. ;
  2479. end;
  2480. end;
  2481. function tstringdef.getvardef : longint;
  2482. const
  2483. vardef : array[tstringtype] of longint = (
  2484. varUndefined,varUndefined,varString,varOleStr,varUString);
  2485. begin
  2486. result:=vardef[stringtype];
  2487. end;
  2488. function tstringdef.alignment : shortint;
  2489. begin
  2490. case stringtype of
  2491. st_unicodestring,
  2492. st_widestring,
  2493. st_ansistring:
  2494. alignment:=voidpointertype.alignment;
  2495. st_longstring,
  2496. st_shortstring:
  2497. { char to string accesses byte 0 and 1 with one word access }
  2498. if (tf_requires_proper_alignment in target_info.flags) or
  2499. { macpas needs an alignment of 2 (MetroWerks compatible) }
  2500. (m_mac in current_settings.modeswitches) then
  2501. alignment:=size_2_align(2)
  2502. else
  2503. alignment:=size_2_align(1);
  2504. end;
  2505. end;
  2506. function tstringdef.getmangledparaname : TSymStr;
  2507. begin
  2508. getmangledparaname:='STRING';
  2509. end;
  2510. function tstringdef.is_publishable : boolean;
  2511. begin
  2512. is_publishable:=true;
  2513. end;
  2514. function tstringdef.size: asizeint;
  2515. begin
  2516. case stringtype of
  2517. st_shortstring:
  2518. Result:=len+1;
  2519. st_longstring,
  2520. st_ansistring,
  2521. st_widestring,
  2522. st_unicodestring:
  2523. Result:=voidpointertype.size;
  2524. end;
  2525. end;
  2526. {****************************************************************************
  2527. TENUMDEF
  2528. ****************************************************************************}
  2529. constructor tenumdef.create;
  2530. begin
  2531. inherited create(enumdef,true);
  2532. minval:=0;
  2533. maxval:=0;
  2534. calcsavesize(current_settings.packenum);
  2535. has_jumps:=false;
  2536. basedef:=nil;
  2537. basedefderef.reset;
  2538. symtable:=tenumsymtable.create(self);
  2539. end;
  2540. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  2541. begin
  2542. inherited create(enumdef,true);
  2543. minval:=_min;
  2544. maxval:=_max;
  2545. basedef:=_basedef;
  2546. calcsavesize(current_settings.packenum);
  2547. has_jumps:=false;
  2548. symtable:=basedef.symtable.getcopy;
  2549. include(defoptions, df_copied_def);
  2550. end;
  2551. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  2552. begin
  2553. inherited ppuload(enumdef,ppufile);
  2554. minval:=ppufile.getaint;
  2555. maxval:=ppufile.getaint;
  2556. savesize:=ppufile.getaint;
  2557. has_jumps:=false;
  2558. if df_copied_def in defoptions then
  2559. begin
  2560. symtable:=nil;
  2561. ppufile.getderef(basedefderef);
  2562. ppuload_platform(ppufile);
  2563. end
  2564. else
  2565. begin
  2566. ppuload_platform(ppufile);
  2567. // create with nil defowner first to prevent values changes on insert
  2568. symtable:=tenumsymtable.create(nil);
  2569. tenumsymtable(symtable).ppuload(ppufile);
  2570. symtable.defowner:=self;
  2571. end;
  2572. end;
  2573. destructor tenumdef.destroy;
  2574. begin
  2575. symtable.free;
  2576. symtable:=nil;
  2577. inherited destroy;
  2578. end;
  2579. function tenumdef.getcopy : tstoreddef;
  2580. begin
  2581. if assigned(basedef) then
  2582. result:=cenumdef.create_subrange(basedef,minval,maxval)
  2583. else
  2584. begin
  2585. result:=cenumdef.create;
  2586. tenumdef(result).minval:=minval;
  2587. tenumdef(result).maxval:=maxval;
  2588. tenumdef(result).symtable.free;
  2589. tenumdef(result).symtable:=symtable.getcopy;
  2590. tenumdef(result).basedef:=self;
  2591. end;
  2592. tenumdef(result).has_jumps:=has_jumps;
  2593. tenumdef(result).basedefderef:=basedefderef;
  2594. include(tenumdef(result).defoptions,df_copied_def);
  2595. end;
  2596. procedure tenumdef.calcsavesize(packenum: shortint);
  2597. begin
  2598. {$IFNDEF cpu64bitaddr} {$push}{$warnings off} {$ENDIF} //comparison always false warning
  2599. if (packenum=8) or (int64(min)<low(longint)) or (int64(max)>high(cardinal)) then
  2600. savesize:=8
  2601. {$IFNDEF cpu64bitaddr} {$pop} {$ENDIF}
  2602. else
  2603. {$IFDEF cpu16bitaddr} {$push}{$warnings off} {$ENDIF} //comparison always false warning
  2604. if (packenum=4) or (min<low(smallint)) or (max>high(word)) then
  2605. savesize:=4
  2606. {$IFDEF cpu16bitaddr} {$pop} {$ENDIF}
  2607. else
  2608. if (packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  2609. savesize:=2
  2610. else
  2611. savesize:=1;
  2612. end;
  2613. function tenumdef.packedbitsize: asizeint;
  2614. var
  2615. sizeval: tconstexprint;
  2616. power: longint;
  2617. begin
  2618. result := 0;
  2619. if (minval >= 0) and
  2620. (maxval <= 1) then
  2621. result := 1
  2622. else
  2623. begin
  2624. if (minval>=0) then
  2625. sizeval:=maxval
  2626. else
  2627. { don't count 0 twice, but take into account that range goes from -n-1..n }
  2628. sizeval:=(cutils.max(-minval,maxval+1)*2)-1;
  2629. { 256 must become 512 etc. }
  2630. nextpowerof2(sizeval+1,power);
  2631. result := power;
  2632. end;
  2633. end;
  2634. procedure tenumdef.setmax(_max:asizeint);
  2635. begin
  2636. maxval:=_max;
  2637. calcsavesize(current_settings.packenum);
  2638. end;
  2639. procedure tenumdef.setmin(_min:asizeint);
  2640. begin
  2641. minval:=_min;
  2642. calcsavesize(current_settings.packenum);
  2643. end;
  2644. function tenumdef.min:asizeint;
  2645. begin
  2646. min:=minval;
  2647. end;
  2648. function tenumdef.max:asizeint;
  2649. begin
  2650. max:=maxval;
  2651. end;
  2652. function tenumdef.getfirstsym: tsym;
  2653. var
  2654. i:integer;
  2655. begin
  2656. for i := 0 to symtable.SymList.Count - 1 do
  2657. begin
  2658. result:=tsym(symtable.SymList[i]);
  2659. if tenumsym(result).value=minval then
  2660. exit;
  2661. end;
  2662. result:=nil;
  2663. end;
  2664. function tenumdef.int2enumsym(l: asizeint): tsym;
  2665. var
  2666. i: longint;
  2667. sym: tsym;
  2668. bdef: tenumdef;
  2669. begin
  2670. result:=nil;
  2671. if (l<minval) or
  2672. (l>maxval) then
  2673. exit;
  2674. bdef:=getbasedef;
  2675. for i:=0 to bdef.symtable.symlist.count-1 do
  2676. begin
  2677. sym:=tsym(bdef.symtable.symlist[i]);
  2678. if (sym.typ=enumsym) and
  2679. (tenumsym(sym).value=l) then
  2680. begin
  2681. result:=sym;
  2682. exit;
  2683. end;
  2684. end;
  2685. end;
  2686. function tenumdef.getbasedef: tenumdef;
  2687. begin
  2688. if not assigned(basedef) then
  2689. result:=self
  2690. else
  2691. result:=basedef;
  2692. end;
  2693. procedure tenumdef.buildderef;
  2694. begin
  2695. inherited buildderef;
  2696. if df_copied_def in defoptions then
  2697. basedefderef.build(basedef)
  2698. else
  2699. tenumsymtable(symtable).buildderef;
  2700. end;
  2701. procedure tenumdef.deref;
  2702. begin
  2703. inherited deref;
  2704. if df_copied_def in defoptions then
  2705. begin
  2706. basedef:=tenumdef(basedefderef.resolve);
  2707. symtable:=basedef.symtable.getcopy;
  2708. end
  2709. else
  2710. tenumsymtable(symtable).deref(false);
  2711. end;
  2712. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  2713. begin
  2714. inherited ppuwrite(ppufile);
  2715. ppufile.putaint(min);
  2716. ppufile.putaint(max);
  2717. ppufile.putaint(savesize);
  2718. if df_copied_def in defoptions then
  2719. ppufile.putderef(basedefderef);
  2720. writeentry(ppufile,ibenumdef);
  2721. if not (df_copied_def in defoptions) then
  2722. tenumsymtable(symtable).ppuwrite(ppufile);
  2723. end;
  2724. function tenumdef.is_publishable : boolean;
  2725. begin
  2726. is_publishable:=true;
  2727. end;
  2728. function tenumdef.GetTypeName : string;
  2729. begin
  2730. GetTypeName:='<enumeration type>';
  2731. end;
  2732. {****************************************************************************
  2733. TRTTI_ATTRIBUTE_LIST
  2734. ****************************************************************************}
  2735. constructor trtti_attribute.ppuload(ppufile: tcompilerppufile);
  2736. begin
  2737. ppufile.getderef(typesymderef);
  2738. ppufile.getderef(typeconstrderef);
  2739. setlength(paras,ppufile.getlongint);
  2740. end;
  2741. procedure trtti_attribute.ppuwrite(ppufile: tcompilerppufile);
  2742. begin
  2743. ppufile.putderef(typesymderef);
  2744. ppufile.putderef(typeconstrderef);
  2745. ppufile.putlongint(length(paras));
  2746. end;
  2747. procedure trtti_attribute.ppuload_subentries(ppufile: tcompilerppufile);
  2748. var
  2749. i : sizeint;
  2750. begin
  2751. for i:=0 to high(paras) do
  2752. paras[i]:=ppuloadnodetree(ppufile);
  2753. end;
  2754. procedure trtti_attribute.ppuwrite_subentries(ppufile: tcompilerppufile);
  2755. var
  2756. i : sizeint;
  2757. begin
  2758. for i:=0 to high(paras) do
  2759. ppuwritenodetree(ppufile,paras[i]);
  2760. end;
  2761. destructor trtti_attribute.destroy;
  2762. var
  2763. n : tnode;
  2764. begin
  2765. constructorcall.free;
  2766. for n in paras do
  2767. n.free;
  2768. inherited destroy;
  2769. end;
  2770. procedure trtti_attribute.buildderef;
  2771. var
  2772. i : sizeint;
  2773. begin
  2774. typesymderef.build(typesym);
  2775. typeconstrderef.build(typeconstr);
  2776. for i:=0 to high(paras) do
  2777. paras[i].buildderefimpl;
  2778. end;
  2779. procedure trtti_attribute.deref;
  2780. var
  2781. i : sizeint;
  2782. begin
  2783. typesym:=tsym(typesymderef.resolve);
  2784. typeconstr:=tdef(typeconstrderef.resolve);
  2785. for i:=0 to high(paras) do
  2786. paras[i].derefimpl;
  2787. end;
  2788. class procedure trtti_attribute_list.bind(var dangling,owned:trtti_attribute_list);
  2789. begin
  2790. if assigned(owned) then
  2791. internalerror(2019071001);
  2792. if not assigned(dangling) then
  2793. exit;
  2794. if dangling.is_bound then
  2795. internalerror(2019071002);
  2796. current_module.used_rtti_attrs.concatlistcopy(dangling.rtti_attributes);
  2797. dangling.is_bound:=true;
  2798. owned:=dangling;
  2799. dangling:=nil;
  2800. end;
  2801. procedure trtti_attribute_list.addattribute(atypesym:tsym;typeconstr:tdef;constructorcall:tnode;constref paras:array of tnode);
  2802. var
  2803. newattribute : trtti_attribute;
  2804. i : sizeint;
  2805. begin
  2806. if not assigned(rtti_attributes) then
  2807. rtti_attributes:=TFPObjectList.Create(true);
  2808. newattribute:=trtti_attribute.Create;
  2809. newattribute.typesym:=atypesym;
  2810. newattribute.typeconstr:=typeconstr;
  2811. newattribute.constructorcall:=constructorcall;
  2812. setlength(newattribute.paras,length(paras));
  2813. for i:=0 to high(paras) do
  2814. newattribute.paras[i]:=paras[i];
  2815. rtti_attributes.Add(newattribute);
  2816. end;
  2817. procedure trtti_attribute_list.addattribute(attr:trtti_attribute);
  2818. begin
  2819. if not assigned(rtti_attributes) then
  2820. rtti_attributes:=TFPObjectList.Create(true);
  2821. rtti_attributes.add(attr);
  2822. end;
  2823. destructor trtti_attribute_list.destroy;
  2824. begin
  2825. rtti_attributes.Free;
  2826. inherited destroy;
  2827. end;
  2828. function trtti_attribute_list.get_attribute_count:longint;
  2829. begin
  2830. if assigned(rtti_attributes) then
  2831. result:=rtti_attributes.Count
  2832. else
  2833. result:=0;
  2834. end;
  2835. procedure trtti_attribute_list.buildderef;
  2836. var
  2837. i : sizeint;
  2838. begin
  2839. if not assigned(rtti_attributes) then
  2840. exit;
  2841. for i:=0 to rtti_attributes.count-1 do
  2842. trtti_attribute(rtti_attributes[i]).buildderef;
  2843. end;
  2844. procedure trtti_attribute_list.deref;
  2845. var
  2846. i : sizeint;
  2847. begin
  2848. if not assigned(rtti_attributes) then
  2849. exit;
  2850. for i:=0 to rtti_attributes.count-1 do
  2851. trtti_attribute(rtti_attributes[i]).deref;
  2852. end;
  2853. class procedure trtti_attribute_list.ppuload_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  2854. var
  2855. i : sizeint;
  2856. begin
  2857. if assigned(attrlist) then
  2858. begin
  2859. if not assigned(attrlist.rtti_attributes) then
  2860. internalerror(2019071101);
  2861. for i:=0 to attrlist.rtti_attributes.count-1 do
  2862. trtti_attribute(attrlist.rtti_attributes[i]).ppuload_subentries(ppufile);
  2863. end;
  2864. end;
  2865. class procedure trtti_attribute_list.ppuwrite_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  2866. var
  2867. i : sizeint;
  2868. begin
  2869. if assigned(attrlist) and assigned(attrlist.rtti_attributes) then
  2870. begin
  2871. for i:=0 to attrlist.rtti_attributes.count-1 do
  2872. trtti_attribute(attrlist.rtti_attributes[i]).ppuwrite_subentries(ppufile);
  2873. end;
  2874. end;
  2875. class function trtti_attribute_list.ppuload(ppufile:tcompilerppufile):trtti_attribute_list;
  2876. var
  2877. cnt,i : longint;
  2878. begin
  2879. cnt:=ppufile.getlongint;
  2880. if cnt>0 then
  2881. begin
  2882. result:=trtti_attribute_list.create;
  2883. for i:=0 to cnt-1 do
  2884. result.addattribute(trtti_attribute.ppuload(ppufile));
  2885. end
  2886. else
  2887. result:=nil;
  2888. end;
  2889. class procedure trtti_attribute_list.ppuwrite(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  2890. var
  2891. i : longint;
  2892. begin
  2893. if assigned(attrlist) and assigned(attrlist.rtti_attributes) then
  2894. begin
  2895. ppufile.putlongint(attrlist.rtti_attributes.count);
  2896. for i:=0 to attrlist.rtti_attributes.count-1 do
  2897. trtti_attribute(attrlist.rtti_attributes[i]).ppuwrite(ppufile);
  2898. end
  2899. else
  2900. ppufile.putlongint(0);
  2901. end;
  2902. {****************************************************************************
  2903. TORDDEF
  2904. ****************************************************************************}
  2905. constructor torddef.create(t : tordtype;v,b : TConstExprInt; doregister: boolean);
  2906. begin
  2907. inherited create(orddef,doregister);
  2908. low:=v;
  2909. high:=b;
  2910. ordtype:=t;
  2911. setsize;
  2912. end;
  2913. constructor torddef.ppuload(ppufile:tcompilerppufile);
  2914. begin
  2915. inherited ppuload(orddef,ppufile);
  2916. ordtype:=tordtype(ppufile.getbyte);
  2917. low:=ppufile.getexprint;
  2918. high:=ppufile.getexprint;
  2919. setsize;
  2920. ppuload_platform(ppufile);
  2921. end;
  2922. function torddef.getcopy : tstoreddef;
  2923. begin
  2924. result:=corddef.create(ordtype,low,high,true);
  2925. result.typ:=orddef;
  2926. torddef(result).low:=low;
  2927. torddef(result).high:=high;
  2928. torddef(result).ordtype:=ordtype;
  2929. torddef(result).savesize:=savesize;
  2930. end;
  2931. function torddef.alignment:shortint;
  2932. begin
  2933. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_ios]) and
  2934. (ordtype in [s64bit,u64bit]) then
  2935. result := 4
  2936. else
  2937. result := inherited alignment;
  2938. end;
  2939. procedure torddef.setsize;
  2940. const
  2941. sizetbl : array[tordtype] of longint = (
  2942. 0,
  2943. 1,2,4,8,16,
  2944. 1,2,4,8,16,
  2945. 1,1,2,4,8,
  2946. 1,2,4,8,
  2947. 1,2,8,system.high(longint)
  2948. );
  2949. begin
  2950. savesize:=sizetbl[ordtype];
  2951. if savesize=system.high(longint) then
  2952. savesize:=packedbitsize div 8;
  2953. end;
  2954. function torddef.packedbitsize: asizeint;
  2955. var
  2956. sizeval: tconstexprint;
  2957. power: longint;
  2958. begin
  2959. result := 0;
  2960. if ordtype = uvoid then
  2961. exit;
  2962. {$ifndef cpu64bitalu}
  2963. if (ordtype in [s64bit,u64bit]) then
  2964. {$else not cpu64bitalu}
  2965. if (ordtype = u64bit) or
  2966. ((ordtype = s64bit) and
  2967. ((low <= (system.low(int64) div 2)) or
  2968. (high > (system.high(int64) div 2)))) then
  2969. {$endif cpu64bitalu}
  2970. result := 64
  2971. else if (
  2972. (low >= 0) and
  2973. (high <= 1)
  2974. ) or (
  2975. ordtype in [pasbool1,pasbool8,pasbool16,pasbool32,pasbool64,bool8bit,bool16bit,bool32bit,bool64bit]
  2976. ) then
  2977. result := 1
  2978. else
  2979. begin
  2980. if (low>=0) then
  2981. sizeval:=high
  2982. else
  2983. { don't count 0 twice, but take into account that range goes from -n-1..n }
  2984. sizeval:=(cutils.max(-low,high+1)*2)-1;
  2985. { 256 must become 512 etc. }
  2986. nextpowerof2(sizeval+1,power);
  2987. result := power;
  2988. end;
  2989. end;
  2990. function torddef.getvardef : longint;
  2991. const
  2992. basetype2vardef : array[tordtype] of longint = (
  2993. varUndefined,
  2994. varbyte,varword,varlongword,varqword,varUndefined,
  2995. varshortint,varsmallint,varinteger,varint64,varUndefined,
  2996. varboolean,varboolean,varboolean,varboolean,varboolean,
  2997. varboolean,varboolean,varUndefined,varUndefined,
  2998. varUndefined,varUndefined,varCurrency,varEmpty);
  2999. begin
  3000. result:=basetype2vardef[ordtype];
  3001. if result=varEmpty then
  3002. result:=basetype2vardef[range_to_basetype(low,high)];
  3003. end;
  3004. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  3005. begin
  3006. inherited ppuwrite(ppufile);
  3007. ppufile.putbyte(byte(ordtype));
  3008. ppufile.putexprint(low);
  3009. ppufile.putexprint(high);
  3010. writeentry(ppufile,iborddef);
  3011. end;
  3012. function torddef.is_publishable : boolean;
  3013. begin
  3014. is_publishable:=(ordtype<>uvoid);
  3015. end;
  3016. function torddef.GetTypeName : string;
  3017. const
  3018. names : array[tordtype] of string[20] = (
  3019. 'untyped',
  3020. 'Byte','Word','DWord','QWord','UInt128',
  3021. 'ShortInt','SmallInt','LongInt','Int64','Int128',
  3022. 'Boolean','Boolean8','Boolean16','Boolean32','Boolean64',
  3023. 'ByteBool','WordBool','LongBool','QWordBool',
  3024. 'Char','WideChar','Currency','CustomRange');
  3025. begin
  3026. GetTypeName:=names[ordtype];
  3027. end;
  3028. {****************************************************************************
  3029. TFLOATDEF
  3030. ****************************************************************************}
  3031. constructor tfloatdef.create(t: tfloattype; doregister: boolean);
  3032. begin
  3033. inherited create(floatdef,doregister);
  3034. floattype:=t;
  3035. setsize;
  3036. end;
  3037. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  3038. begin
  3039. inherited ppuload(floatdef,ppufile);
  3040. floattype:=tfloattype(ppufile.getbyte);
  3041. setsize;
  3042. ppuload_platform(ppufile);
  3043. end;
  3044. function tfloatdef.getcopy : tstoreddef;
  3045. begin
  3046. result:=cfloatdef.create(floattype,true);
  3047. result.typ:=floatdef;
  3048. tfloatdef(result).savesize:=savesize;
  3049. end;
  3050. function tfloatdef.alignment:shortint;
  3051. begin
  3052. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_ios]) then
  3053. case floattype of
  3054. sc80real,
  3055. s80real: result:=16;
  3056. s64real,
  3057. s64currency,
  3058. s64comp : result:=4;
  3059. else
  3060. result := inherited alignment;
  3061. end
  3062. else
  3063. result := inherited alignment;
  3064. end;
  3065. function tfloatdef.structalignment: shortint;
  3066. begin
  3067. { aix is really annoying: the recommended scalar alignment for both
  3068. int64 and double is 64 bits, but in structs int64 has to be aligned
  3069. to 8 bytes and double to 4 bytes }
  3070. if (target_info.system in systems_aix) and
  3071. (floattype=s64real) then
  3072. result:=4
  3073. else
  3074. result:=alignment;
  3075. end;
  3076. procedure tfloatdef.setsize;
  3077. begin
  3078. case floattype of
  3079. s32real : savesize:=4;
  3080. s80real : savesize:=10;
  3081. sc80real:
  3082. if target_info.system in [system_i386_darwin,
  3083. system_i386_iphonesim,system_x86_64_darwin,
  3084. system_x86_64_iphonesim,
  3085. system_x86_64_linux,system_x86_64_freebsd,
  3086. system_x86_64_openbsd,system_x86_64_netbsd,
  3087. system_x86_64_solaris,system_x86_64_embedded,
  3088. system_x86_64_dragonfly,system_x86_64_haiku] then
  3089. savesize:=16
  3090. else
  3091. savesize:=12;
  3092. s64real,
  3093. s64currency,
  3094. s64comp : savesize:=8;
  3095. else
  3096. savesize:=0;
  3097. end;
  3098. end;
  3099. function tfloatdef.getvardef : longint;
  3100. const
  3101. floattype2vardef : array[tfloattype] of longint = (
  3102. varSingle,varDouble,varUndefined,varUndefined,
  3103. varUndefined,varCurrency,varUndefined);
  3104. begin
  3105. if (upper(typename)='TDATETIME') and
  3106. assigned(owner) and
  3107. assigned(owner.name) and
  3108. (owner.name^='SYSTEM') then
  3109. result:=varDate
  3110. else
  3111. result:=floattype2vardef[floattype];
  3112. end;
  3113. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  3114. begin
  3115. inherited ppuwrite(ppufile);
  3116. ppufile.putbyte(byte(floattype));
  3117. writeentry(ppufile,ibfloatdef);
  3118. end;
  3119. function tfloatdef.is_publishable : boolean;
  3120. begin
  3121. is_publishable:=true;
  3122. end;
  3123. function tfloatdef.GetTypeName : string;
  3124. const
  3125. names : array[tfloattype] of string[20] = (
  3126. 'Single','Double','Extended','CExtended','Comp','Currency','Float128');
  3127. begin
  3128. GetTypeName:=names[floattype];
  3129. end;
  3130. {****************************************************************************
  3131. TFILEDEF
  3132. ****************************************************************************}
  3133. constructor tfiledef.createtext;
  3134. begin
  3135. inherited create(filedef,true);
  3136. filetyp:=ft_text;
  3137. typedfiledef:=nil;
  3138. typedfiledefderef.reset;
  3139. end;
  3140. constructor tfiledef.createuntyped;
  3141. begin
  3142. inherited create(filedef,true);
  3143. filetyp:=ft_untyped;
  3144. typedfiledef:=nil;
  3145. end;
  3146. constructor tfiledef.createtyped(def:tdef);
  3147. begin
  3148. inherited create(filedef,true);
  3149. filetyp:=ft_typed;
  3150. typedfiledef:=def;
  3151. end;
  3152. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  3153. begin
  3154. inherited ppuload(filedef,ppufile);
  3155. filetyp:=tfiletyp(ppufile.getbyte);
  3156. if filetyp=ft_typed then
  3157. ppufile.getderef(typedfiledefderef)
  3158. else
  3159. typedfiledef:=nil;
  3160. ppuload_platform(ppufile);
  3161. end;
  3162. function tfiledef.getcopy : tstoreddef;
  3163. begin
  3164. case filetyp of
  3165. ft_typed:
  3166. result:=cfiledef.createtyped(typedfiledef);
  3167. ft_untyped:
  3168. result:=cfiledef.createuntyped;
  3169. ft_text:
  3170. result:=cfiledef.createtext;
  3171. end;
  3172. end;
  3173. procedure tfiledef.buildderef;
  3174. begin
  3175. inherited buildderef;
  3176. if filetyp=ft_typed then
  3177. typedfiledefderef.build(typedfiledef);
  3178. end;
  3179. procedure tfiledef.deref;
  3180. begin
  3181. inherited deref;
  3182. if filetyp=ft_typed then
  3183. typedfiledef:=tdef(typedfiledefderef.resolve);
  3184. end;
  3185. function tfiledef.size:asizeint;
  3186. begin
  3187. if savesize=0 then
  3188. setsize;
  3189. size:=savesize;
  3190. end;
  3191. procedure tfiledef.setsize;
  3192. begin
  3193. case filetyp of
  3194. ft_text:
  3195. savesize:=search_system_type('TEXTREC').typedef.size;
  3196. ft_typed:
  3197. begin
  3198. savesize:=search_system_type('FILEREC').typedef.size;
  3199. { allocate put/get buffer in iso mode }
  3200. if m_isolike_io in current_settings.modeswitches then
  3201. inc(savesize,typedfiledef.size);
  3202. end;
  3203. ft_untyped:
  3204. savesize:=search_system_type('FILEREC').typedef.size;
  3205. end;
  3206. end;
  3207. function tfiledef.alignment: shortint;
  3208. begin
  3209. case filetyp of
  3210. ft_text:
  3211. result:=search_system_type('TEXTREC').typedef.alignment;
  3212. ft_typed,
  3213. ft_untyped:
  3214. result:=search_system_type('FILEREC').typedef.alignment;
  3215. end;
  3216. end;
  3217. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  3218. begin
  3219. inherited ppuwrite(ppufile);
  3220. ppufile.putbyte(byte(filetyp));
  3221. if filetyp=ft_typed then
  3222. ppufile.putderef(typedfiledefderef);
  3223. writeentry(ppufile,ibfiledef);
  3224. end;
  3225. function tfiledef.GetTypeName : string;
  3226. begin
  3227. case filetyp of
  3228. ft_untyped:
  3229. GetTypeName:='File';
  3230. ft_typed:
  3231. GetTypeName:='File Of '+typedfiledef.typename;
  3232. ft_text:
  3233. GetTypeName:='Text'
  3234. end;
  3235. end;
  3236. function tfiledef.getmangledparaname : TSymStr;
  3237. begin
  3238. case filetyp of
  3239. ft_untyped:
  3240. getmangledparaname:='FILE';
  3241. ft_typed:
  3242. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  3243. ft_text:
  3244. getmangledparaname:='TEXT'
  3245. end;
  3246. end;
  3247. {****************************************************************************
  3248. TVARIANTDEF
  3249. ****************************************************************************}
  3250. constructor tvariantdef.create(v : tvarianttype);
  3251. begin
  3252. inherited create(variantdef,true);
  3253. varianttype:=v;
  3254. setsize;
  3255. end;
  3256. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  3257. begin
  3258. inherited ppuload(variantdef,ppufile);
  3259. varianttype:=tvarianttype(ppufile.getbyte);
  3260. setsize;
  3261. ppuload_platform(ppufile);
  3262. end;
  3263. function tvariantdef.getcopy : tstoreddef;
  3264. begin
  3265. result:=cvariantdef.create(varianttype);
  3266. end;
  3267. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  3268. begin
  3269. inherited ppuwrite(ppufile);
  3270. ppufile.putbyte(byte(varianttype));
  3271. writeentry(ppufile,ibvariantdef);
  3272. end;
  3273. function tvariantdef.getvardef : longint;
  3274. begin
  3275. Result:=varVariant;
  3276. end;
  3277. procedure tvariantdef.setsize;
  3278. begin
  3279. {$ifdef cpu64bitaddr}
  3280. savesize:=24;
  3281. {$else cpu64bitaddr}
  3282. savesize:=16;
  3283. {$endif cpu64bitaddr}
  3284. end;
  3285. function tvariantdef.GetTypeName : string;
  3286. begin
  3287. case varianttype of
  3288. vt_normalvariant:
  3289. GetTypeName:='Variant';
  3290. vt_olevariant:
  3291. GetTypeName:='OleVariant';
  3292. end;
  3293. end;
  3294. function tvariantdef.needs_inittable : boolean;
  3295. begin
  3296. needs_inittable:=true;
  3297. end;
  3298. function tvariantdef.is_publishable : boolean;
  3299. begin
  3300. is_publishable:=true;
  3301. end;
  3302. {****************************************************************************
  3303. TABSTRACtpointerdef
  3304. ****************************************************************************}
  3305. constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef);
  3306. begin
  3307. inherited create(dt,true);
  3308. pointeddef:=def;
  3309. pointeddefderef.reset;
  3310. if df_generic in pointeddef.defoptions then
  3311. include(defoptions,df_generic);
  3312. if df_specialization in pointeddef.defoptions then
  3313. include(defoptions,df_specialization);
  3314. end;
  3315. constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  3316. begin
  3317. inherited ppuload(dt,ppufile);
  3318. ppufile.getderef(pointeddefderef);
  3319. end;
  3320. procedure tabstractpointerdef.buildderef;
  3321. begin
  3322. inherited buildderef;
  3323. pointeddefderef.build(pointeddef);
  3324. end;
  3325. procedure tabstractpointerdef.deref;
  3326. begin
  3327. inherited deref;
  3328. pointeddef:=tdef(pointeddefderef.resolve);
  3329. end;
  3330. function tabstractpointerdef.size: asizeint;
  3331. begin
  3332. Result:=voidpointertype.size;
  3333. end;
  3334. function tabstractpointerdef.alignment: shortint;
  3335. begin
  3336. alignment:=size_2_align(voidpointertype.size);
  3337. end;
  3338. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  3339. begin
  3340. inherited ppuwrite(ppufile);
  3341. ppufile.putderef(pointeddefderef);
  3342. end;
  3343. {****************************************************************************
  3344. tpointerdef
  3345. ****************************************************************************}
  3346. constructor tpointerdef.create(def:tdef);
  3347. begin
  3348. inherited create(pointerdef,def);
  3349. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  3350. if (df_specialization in tstoreddef(def).defoptions)
  3351. {$ifndef genericdef_for_nested}
  3352. { currently, nested procdefs of generic routines get df_specialization,
  3353. but no genericdef }
  3354. and assigned(tstoreddef(def).genericdef)
  3355. {$endif}
  3356. then
  3357. genericdef:=cpointerdef.getreusable(tstoreddef(def).genericdef);
  3358. end;
  3359. class function tpointerdef.getreusable(def: tdef): tpointerdef;
  3360. var
  3361. res: PHashSetItem;
  3362. oldsymtablestack: tsymtablestack;
  3363. begin
  3364. if not assigned(current_module) then
  3365. internalerror(2011071101);
  3366. res:=current_module.ptrdefs.FindOrAdd(@def,sizeof(def));
  3367. if not assigned(res^.Data) then
  3368. begin
  3369. { since these pointerdefs can be reused anywhere in the current
  3370. unit, add them to the global/staticsymtable (or local symtable
  3371. if they're a local def, because otherwise they'll be saved
  3372. to the ppu referencing a local symtable entry that doesn't
  3373. exist in the ppu) }
  3374. oldsymtablestack:=symtablestack;
  3375. { do not simply push/pop current_module.localsymtable, because
  3376. that can have side-effects (e.g., it removes helpers) }
  3377. symtablestack:=nil;
  3378. result:=cpointerdef.create(def);
  3379. setup_reusable_def(def,result,res,oldsymtablestack);
  3380. { res^.Data may still be nil -> don't overwrite result }
  3381. exit;
  3382. end;
  3383. result:=tpointerdef(res^.Data);
  3384. end;
  3385. class function tpointerdef.getreusable_no_free(def: tdef): tpointerdef;
  3386. begin
  3387. result:=getreusable(def);
  3388. if not result.is_registered then
  3389. include(result.defoptions,df_not_registered_no_free);
  3390. end;
  3391. function tpointerdef.size: asizeint;
  3392. begin
  3393. result:=sizeof(pint);
  3394. end;
  3395. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  3396. begin
  3397. inherited ppuload(pointerdef,ppufile);
  3398. has_pointer_math:=(ppufile.getbyte<>0);
  3399. ppuload_platform(ppufile);
  3400. end;
  3401. function tpointerdef.getcopy : tstoreddef;
  3402. begin
  3403. { don't use direct pointeddef if it is a forwarddef because in other case
  3404. one of them will be destroyed on forward type resolve and the second will
  3405. point to garbage }
  3406. if pointeddef.typ=forwarddef then
  3407. result:=cpointerdef.create(tforwarddef(pointeddef).getcopy)
  3408. else
  3409. result:=cpointerdef.create(pointeddef);
  3410. tpointerdef(result).has_pointer_math:=has_pointer_math;
  3411. tpointerdef(result).savesize:=savesize;
  3412. end;
  3413. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  3414. begin
  3415. inherited ppuwrite(ppufile);
  3416. ppufile.putbyte(byte(has_pointer_math));
  3417. writeentry(ppufile,ibpointerdef);
  3418. end;
  3419. function tpointerdef.GetTypeName : string;
  3420. begin
  3421. { parameter types and the resultdef of a procvardef can contain a
  3422. pointer to this procvardef itself, resulting in endless recursion ->
  3423. use the typesym's name instead if it exists (if it doesn't, such as
  3424. for anynonymous procedure types in macpas/iso mode, then there cannot
  3425. be any recursive references to it either) }
  3426. if (pointeddef.typ<>procvardef) or
  3427. not assigned(pointeddef.typesym) then
  3428. GetTypeName:='^'+pointeddef.typename
  3429. else
  3430. GetTypeName:='^'+pointeddef.typesym.realname;
  3431. end;
  3432. function tpointerdef.pointer_arithmetic_int_type:tdef;
  3433. begin
  3434. result:=ptrsinttype;
  3435. end;
  3436. function tpointerdef.pointer_arithmetic_uint_type:tdef;
  3437. begin
  3438. result:=ptruinttype;
  3439. end;
  3440. function tpointerdef.pointer_subtraction_result_type:tdef;
  3441. begin
  3442. result:=ptrsinttype;
  3443. end;
  3444. function tpointerdef.compatible_with_pointerdef_size(ptr: tpointerdef): boolean;
  3445. begin
  3446. result:=true;
  3447. end;
  3448. function tpointerdef.converted_pointer_to_array_range_type:tdef;
  3449. begin
  3450. result:=ptrsinttype;
  3451. end;
  3452. {****************************************************************************
  3453. TCLASSREFDEF
  3454. ****************************************************************************}
  3455. constructor tclassrefdef.create(def:tdef);
  3456. begin
  3457. while (def.typ=objectdef) and tobjectdef(def).is_unique_objpasdef do
  3458. def:=tobjectdef(def).childof;
  3459. inherited create(classrefdef,def);
  3460. if df_specialization in tstoreddef(def).defoptions then
  3461. genericdef:=cclassrefdef.create(tstoreddef(def).genericdef);
  3462. end;
  3463. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  3464. begin
  3465. inherited ppuload(classrefdef,ppufile);
  3466. ppuload_platform(ppufile);
  3467. end;
  3468. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  3469. begin
  3470. inherited ppuwrite(ppufile);
  3471. writeentry(ppufile,ibclassrefdef);
  3472. end;
  3473. function tclassrefdef.getcopy:tstoreddef;
  3474. begin
  3475. if pointeddef.typ=forwarddef then
  3476. result:=cclassrefdef.create(tforwarddef(pointeddef).getcopy)
  3477. else
  3478. result:=cclassrefdef.create(pointeddef);
  3479. end;
  3480. function tclassrefdef.GetTypeName : string;
  3481. begin
  3482. GetTypeName:='Class Of '+pointeddef.typename;
  3483. end;
  3484. function tclassrefdef.is_publishable : boolean;
  3485. begin
  3486. result:=true;
  3487. end;
  3488. function tclassrefdef.rtti_mangledname(rt: trttitype): TSymStr;
  3489. begin
  3490. if (tobjectdef(pointeddef).objecttype<>odt_objcclass) then
  3491. result:=inherited rtti_mangledname(rt)
  3492. else
  3493. result:=tobjectdef(pointeddef).rtti_mangledname(objcmetartti);
  3494. end;
  3495. procedure tclassrefdef.register_created_object_type;
  3496. begin
  3497. tobjectdef(pointeddef).register_created_classref_type;
  3498. end;
  3499. {***************************************************************************
  3500. TSETDEF
  3501. ***************************************************************************}
  3502. constructor tsetdef.create(def: tdef; low, high: asizeint; doregister: boolean);
  3503. var
  3504. setallocbits: aint;
  3505. packedsavesize: aint;
  3506. actual_setalloc: ShortInt;
  3507. begin
  3508. inherited create(setdef,doregister);
  3509. elementdef:=def;
  3510. elementdefderef.reset;
  3511. setmax:=high;
  3512. actual_setalloc:=current_settings.setalloc;
  3513. {$if defined(cpu8bitalu) or defined(cpu16bitalu)}
  3514. if actual_setalloc=0 then
  3515. actual_setalloc:=1;
  3516. {$endif}
  3517. if (actual_setalloc=0) then
  3518. begin
  3519. setbase:=0;
  3520. if (high<32) then
  3521. savesize:=Sizeof(longint)
  3522. else if (high<256) then
  3523. savesize:=32
  3524. else
  3525. savesize:=(high+7) div 8
  3526. end
  3527. else
  3528. begin
  3529. setallocbits:=actual_setalloc*8;
  3530. setbase:=low and not(setallocbits-1);
  3531. packedsavesize:=actual_setalloc*((((high+setallocbits)-setbase)) DIV setallocbits);
  3532. savesize:=packedsavesize;
  3533. {$if not defined(cpu8bitalu) and not defined(cpu16bitalu)}
  3534. if savesize=3 then
  3535. savesize:=4;
  3536. {$endif}
  3537. end;
  3538. end;
  3539. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  3540. begin
  3541. inherited ppuload(setdef,ppufile);
  3542. ppufile.getderef(elementdefderef);
  3543. savesize:=ppufile.getasizeint;
  3544. setbase:=ppufile.getasizeint;
  3545. setmax:=ppufile.getasizeint;
  3546. ppuload_platform(ppufile);
  3547. end;
  3548. function tsetdef.getcopy : tstoreddef;
  3549. begin
  3550. result:=csetdef.create(elementdef,setbase,setmax,true);
  3551. { the copy might have been created with a different setalloc setting }
  3552. tsetdef(result).savesize:=savesize;
  3553. end;
  3554. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  3555. begin
  3556. inherited ppuwrite(ppufile);
  3557. ppufile.putderef(elementdefderef);
  3558. ppufile.putasizeint(savesize);
  3559. ppufile.putasizeint(setbase);
  3560. ppufile.putasizeint(setmax);
  3561. writeentry(ppufile,ibsetdef);
  3562. end;
  3563. procedure tsetdef.buildderef;
  3564. begin
  3565. inherited buildderef;
  3566. elementdefderef.build(elementdef);
  3567. end;
  3568. procedure tsetdef.deref;
  3569. begin
  3570. inherited deref;
  3571. elementdef:=tdef(elementdefderef.resolve);
  3572. end;
  3573. function tsetdef.is_publishable : boolean;
  3574. begin
  3575. is_publishable:=savesize in [1,2,4];
  3576. end;
  3577. function tsetdef.alignment: shortint;
  3578. begin
  3579. Result:=inherited;
  3580. if result>sizeof(aint) then
  3581. result:=sizeof(aint);
  3582. end;
  3583. function tsetdef.GetTypeName : string;
  3584. begin
  3585. if assigned(elementdef) then
  3586. GetTypeName:='Set Of '+elementdef.typename
  3587. else
  3588. GetTypeName:='Empty Set';
  3589. end;
  3590. {***************************************************************************
  3591. TFORMALDEF
  3592. ***************************************************************************}
  3593. constructor tformaldef.create(Atyped:boolean);
  3594. begin
  3595. inherited create(formaldef,true);
  3596. typed:=Atyped;
  3597. savesize:=0;
  3598. end;
  3599. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  3600. begin
  3601. inherited ppuload(formaldef,ppufile);
  3602. typed:=boolean(ppufile.getbyte);
  3603. savesize:=0;
  3604. ppuload_platform(ppufile);
  3605. end;
  3606. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  3607. begin
  3608. inherited ppuwrite(ppufile);
  3609. ppufile.putbyte(byte(typed));
  3610. writeentry(ppufile,ibformaldef);
  3611. end;
  3612. function tformaldef.GetTypeName : string;
  3613. begin
  3614. if typed then
  3615. GetTypeName:='<Typed formal type>'
  3616. else
  3617. GetTypeName:='<Formal type>';
  3618. end;
  3619. {***************************************************************************
  3620. TARRAYDEF
  3621. ***************************************************************************}
  3622. constructor tarraydef.create(l, h: asizeint; def: tdef);
  3623. begin
  3624. inherited create(arraydef,true);
  3625. lowrange:=l;
  3626. highrange:=h;
  3627. rangedef:=def;
  3628. rangedefderef.reset;
  3629. _elementdef:=nil;
  3630. _elementdefderef.reset;
  3631. arrayoptions:=[];
  3632. symtable:=tarraysymtable.create(self);
  3633. end;
  3634. constructor tarraydef.create_vector(l ,h: asizeint; def: tdef);
  3635. begin
  3636. self.create(l,h,def);
  3637. include(arrayoptions,ado_IsVector);
  3638. end;
  3639. constructor tarraydef.create_openarray;
  3640. begin
  3641. self.create(0,-1,sizesinttype)
  3642. end;
  3643. class function tarraydef.getreusable_intern(def: tdef; elems: asizeint; const options: tarraydefoptions): tarraydef;
  3644. var
  3645. res: PHashSetItem;
  3646. oldsymtablestack: tsymtablestack;
  3647. arrdesc: packed record
  3648. def: tdef;
  3649. elecount: asizeint;
  3650. options: tarraydefoptions
  3651. end;
  3652. begin
  3653. if not assigned(current_module) then
  3654. internalerror(2011081301);
  3655. arrdesc.def:=def;
  3656. arrdesc.elecount:=elems;
  3657. arrdesc.options:=options;
  3658. res:=current_module.arraydefs.FindOrAdd(@arrdesc,sizeof(arrdesc));
  3659. if not assigned(res^.Data) then
  3660. begin
  3661. { since these pointerdefs can be reused anywhere in the current
  3662. unit, add them to the global/staticsymtable (or local symtable
  3663. if they're a local def, because otherwise they'll be saved
  3664. to the ppu referencing a local symtable entry that doesn't
  3665. exist in the ppu) }
  3666. oldsymtablestack:=symtablestack;
  3667. { do not simply push/pop current_module.localsymtable, because
  3668. that can have side-effects (e.g., it removes helpers) }
  3669. symtablestack:=nil;
  3670. result:=carraydef.create(0,elems-1,sizesinttype);
  3671. result.elementdef:=def;
  3672. result.arrayoptions:=options;
  3673. setup_reusable_def(def,result,res,oldsymtablestack);
  3674. { res^.Data may still be nil -> don't overwrite result }
  3675. exit;
  3676. end;
  3677. result:=tarraydef(res^.Data);
  3678. end;
  3679. class function tarraydef.getreusable(def: tdef; elems: asizeint): tarraydef;
  3680. begin
  3681. result:=getreusable_intern(def,elems,[]);
  3682. end;
  3683. class function tarraydef.getreusable_vector(def: tdef; elems: asizeint): tarraydef;
  3684. begin
  3685. result:=getreusable_intern(def,elems,[ado_IsVector]);
  3686. end;
  3687. class function tarraydef.getreusable_no_free(def: tdef; elems: asizeint): tarraydef;
  3688. begin
  3689. result:=getreusable(def,elems);
  3690. if not result.is_registered then
  3691. include(result.defoptions,df_not_registered_no_free);
  3692. end;
  3693. class function tarraydef.getreusable_no_free_vector(def: tdef; elems: asizeint): tarraydef;
  3694. begin
  3695. result:=getreusable_vector(def,elems);
  3696. if not result.is_registered then
  3697. include(result.defoptions,df_not_registered_no_free);
  3698. end;
  3699. destructor tarraydef.destroy;
  3700. begin
  3701. symtable.free;
  3702. symtable:=nil;
  3703. inherited;
  3704. end;
  3705. constructor tarraydef.create_from_pointer(def:tpointerdef);
  3706. begin
  3707. { divide by the element size and do -1 so the array will have a valid size,
  3708. further, the element size might be 0 e.g. for empty records, so use max(...,1)
  3709. to avoid a division by zero }
  3710. self.create(0,(high(asizeint) div max(def.pointeddef.size,1))-1,
  3711. def.converted_pointer_to_array_range_type);
  3712. arrayoptions:=[ado_IsConvertedPointer];
  3713. setelementdef(def.pointeddef);
  3714. end;
  3715. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  3716. begin
  3717. inherited ppuload(arraydef,ppufile);
  3718. { the addresses are calculated later }
  3719. ppufile.getderef(_elementdefderef);
  3720. ppufile.getderef(rangedefderef);
  3721. lowrange:=ppufile.getasizeint;
  3722. highrange:=ppufile.getasizeint;
  3723. ppufile.getset(tppuset2(arrayoptions));
  3724. ppuload_platform(ppufile);
  3725. symtable:=tarraysymtable.create(self);
  3726. tarraysymtable(symtable).ppuload(ppufile)
  3727. end;
  3728. function tarraydef.getcopy : tstoreddef;
  3729. begin
  3730. result:=carraydef.create(lowrange,highrange,rangedef);
  3731. tarraydef(result).arrayoptions:=arrayoptions;
  3732. tarraydef(result)._elementdef:=_elementdef;
  3733. end;
  3734. procedure tarraydef.buildderef;
  3735. begin
  3736. inherited buildderef;
  3737. tarraysymtable(symtable).buildderef;
  3738. _elementdefderef.build(_elementdef);
  3739. rangedefderef.build(rangedef);
  3740. end;
  3741. procedure tarraydef.deref;
  3742. begin
  3743. inherited deref;
  3744. tarraysymtable(symtable).deref(false);
  3745. _elementdef:=tdef(_elementdefderef.resolve);
  3746. rangedef:=tdef(rangedefderef.resolve);
  3747. end;
  3748. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  3749. begin
  3750. inherited ppuwrite(ppufile);
  3751. ppufile.putderef(_elementdefderef);
  3752. ppufile.putderef(rangedefderef);
  3753. ppufile.putasizeint(lowrange);
  3754. ppufile.putasizeint(highrange);
  3755. ppufile.putset(tppuset2(arrayoptions));
  3756. writeentry(ppufile,ibarraydef);
  3757. tarraysymtable(symtable).ppuwrite(ppufile);
  3758. end;
  3759. function tarraydef.elesize : asizeint;
  3760. begin
  3761. if (ado_IsBitPacked in arrayoptions) then
  3762. internalerror(2006080101);
  3763. if assigned(_elementdef) then
  3764. result:=_elementdef.size
  3765. else
  3766. result:=0;
  3767. end;
  3768. function tarraydef.elepackedbitsize : asizeint;
  3769. begin
  3770. if not(ado_IsBitPacked in arrayoptions) then
  3771. internalerror(2006080102);
  3772. if assigned(_elementdef) then
  3773. result:=_elementdef.packedbitsize
  3774. else
  3775. result:=0;
  3776. end;
  3777. function tarraydef.elecount : asizeuint;
  3778. var
  3779. qhigh,qlow : qword;
  3780. begin
  3781. if ado_IsDynamicArray in arrayoptions then
  3782. begin
  3783. result:=0;
  3784. exit;
  3785. end;
  3786. if (highrange>0) and (lowrange<0) then
  3787. begin
  3788. qhigh:=highrange;
  3789. if lowrange=low(asizeint) then
  3790. qlow:=high(asizeint) + 1
  3791. else
  3792. qlow:=qword(-lowrange);
  3793. { prevent overflow, return 0 to indicate overflow }
  3794. if qhigh+qlow>qword(high(asizeint)-1) then
  3795. result:=0
  3796. else
  3797. result:=qhigh+qlow+1;
  3798. end
  3799. else
  3800. result:=int64(highrange)-lowrange+1;
  3801. end;
  3802. function tarraydef.size : asizeint;
  3803. var
  3804. cachedelecount : asizeuint;
  3805. cachedelesize : asizeint;
  3806. begin
  3807. if ado_IsDynamicArray in arrayoptions then
  3808. begin
  3809. size:=voidpointertype.size;
  3810. exit;
  3811. end;
  3812. { Tarraydef.size may never be called for an open array! }
  3813. if (highrange=-1) and (lowrange=0) then
  3814. internalerror(99080501);
  3815. if not (ado_IsBitPacked in arrayoptions) then
  3816. cachedelesize:=elesize
  3817. else
  3818. cachedelesize := elepackedbitsize;
  3819. cachedelecount:=elecount;
  3820. if (cachedelesize = 0) then
  3821. begin
  3822. size := 0;
  3823. exit;
  3824. end;
  3825. if (cachedelecount = 0) then
  3826. begin
  3827. size := -1;
  3828. exit;
  3829. end;
  3830. { prevent overflow, return -1 to indicate overflow }
  3831. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  3832. if (cachedelecount > asizeuint(high(asizeint))) or
  3833. ((high(asizeint) div cachedelesize) < asizeint(cachedelecount)) or
  3834. { also lowrange*elesize must be < high(asizeint) to prevent overflow when
  3835. accessing the array, see ncgmem (PFV) }
  3836. ((high(asizeint) div cachedelesize) < abs(lowrange)) then
  3837. begin
  3838. result:=-1;
  3839. exit;
  3840. end;
  3841. result:=cachedelesize*asizeint(cachedelecount);
  3842. if (ado_IsBitPacked in arrayoptions) then
  3843. { can't just add 7 and divide by 8, because that may overflow }
  3844. result:=result div 8 + ord((result mod 8)<>0);
  3845. {$ifdef cpu16bitaddr}
  3846. if result>65535 then
  3847. begin
  3848. result:=-1;
  3849. exit;
  3850. end;
  3851. {$endif cpu16bitaddr}
  3852. end;
  3853. procedure tarraydef.setelementdef(def:tdef);
  3854. begin
  3855. _elementdef:=def;
  3856. if not(
  3857. (ado_IsDynamicArray in arrayoptions) or
  3858. (ado_IsConvertedPointer in arrayoptions) or
  3859. (ado_IsConstructor in arrayoptions) or
  3860. (ado_IsGeneric in arrayoptions) or
  3861. (highrange<lowrange)
  3862. ) and
  3863. (size=-1) then
  3864. Message(sym_e_segment_too_large);
  3865. end;
  3866. function tarraydef.alignment : shortint;
  3867. begin
  3868. if ado_IsVector in arrayoptions then
  3869. alignment:=size
  3870. { alignment of dyn. arrays doesn't depend on the element size }
  3871. else if ado_IsDynamicArray in arrayoptions then
  3872. alignment:=voidpointertype.alignment
  3873. { alignment is the target alignment for the used load size }
  3874. else if (ado_IsBitPacked in arrayoptions) and
  3875. (elementdef.typ in [enumdef,orddef]) then
  3876. alignment:=cgsize_orddef(int_cgsize(packedbitsloadsize(elepackedbitsize))).alignment
  3877. { alignment is the alignment of the elements }
  3878. else
  3879. alignment:=elementdef.alignment
  3880. end;
  3881. function tarraydef.needs_inittable : boolean;
  3882. begin
  3883. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  3884. end;
  3885. function tarraydef.needs_separate_initrtti : boolean;
  3886. begin
  3887. if ado_IsBitPacked in arrayoptions then
  3888. result:=false
  3889. else
  3890. result:=elementdef.needs_separate_initrtti;
  3891. end;
  3892. function tarraydef.GetTypeName : string;
  3893. begin
  3894. if (ado_IsConstString in arrayoptions) then
  3895. result:='Constant String'
  3896. else if (ado_isarrayofconst in arrayoptions) or
  3897. (ado_isConstructor in arrayoptions) then
  3898. begin
  3899. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  3900. GetTypeName:='Array Of Const'
  3901. else
  3902. GetTypeName:='{Array Of Const/Constant Open} Array of '+elementdef.typename;
  3903. end
  3904. else if (ado_IsDynamicArray in arrayoptions) then
  3905. GetTypeName:='{Dynamic} Array Of '+elementdef.typename
  3906. else if ((highrange=-1) and (lowrange=0)) then
  3907. GetTypeName:='{Open} Array Of '+elementdef.typename
  3908. else
  3909. begin
  3910. result := '';
  3911. if (ado_IsBitPacked in arrayoptions) then
  3912. result:='BitPacked ';
  3913. if rangedef.typ=enumdef then
  3914. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  3915. else
  3916. result:=result+'Array['+tostr(lowrange)+'..'+
  3917. tostr(highrange)+'] Of '+elementdef.typename
  3918. end;
  3919. end;
  3920. function tarraydef.getmangledparaname : TSymStr;
  3921. begin
  3922. if ado_isarrayofconst in arrayoptions then
  3923. getmangledparaname:='array_of_const'
  3924. else
  3925. if ((highrange=-1) and (lowrange=0)) then
  3926. getmangledparaname:='array_of_'+elementdef.mangledparaname
  3927. else
  3928. internalerror(200204176);
  3929. end;
  3930. function tarraydef.is_publishable : boolean;
  3931. begin
  3932. Result:=ado_IsDynamicArray in arrayoptions;
  3933. end;
  3934. function tarraydef.is_hwvector: boolean;
  3935. begin
  3936. result:=ado_IsVector in arrayoptions;
  3937. end;
  3938. {***************************************************************************
  3939. tabstractrecorddef
  3940. ***************************************************************************}
  3941. constructor tabstractrecorddef.create(const n:string; dt:tdeftyp;doregister:boolean);
  3942. begin
  3943. inherited create(dt,doregister);
  3944. objname:=stringdup(upper(n));
  3945. objrealname:=stringdup(n);
  3946. objectoptions:=[];
  3947. if assigned(current_module.namespace) then
  3948. begin
  3949. import_lib:=stringdup(current_module.namespace^);
  3950. replace(import_lib^,'.','/');
  3951. end;
  3952. end;
  3953. constructor tabstractrecorddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  3954. begin
  3955. inherited ppuload(dt,ppufile);
  3956. objrealname:=ppufile.getpshortstring;
  3957. objname:=stringdup(upper(objrealname^));
  3958. import_lib:=ppufile.getpshortstring;
  3959. { only used for external C++ classes and Java classes/records }
  3960. if (import_lib^='') then
  3961. stringdispose(import_lib);
  3962. ppufile.getset(tppuset4(objectoptions));
  3963. end;
  3964. procedure tabstractrecorddef.ppuwrite(ppufile: tcompilerppufile);
  3965. begin
  3966. inherited ppuwrite(ppufile);
  3967. ppufile.putstring(objrealname^);
  3968. if assigned(import_lib) then
  3969. ppufile.putstring(import_lib^)
  3970. else
  3971. ppufile.putstring('');
  3972. ppufile.putset(tppuset4(objectoptions));
  3973. end;
  3974. destructor tabstractrecorddef.destroy;
  3975. begin
  3976. stringdispose(objname);
  3977. stringdispose(objrealname);
  3978. stringdispose(import_lib);
  3979. tcinitcode.free;
  3980. inherited destroy;
  3981. end;
  3982. procedure tabstractrecorddef.buildderefimpl;
  3983. begin
  3984. inherited buildderefimpl;
  3985. if not (df_copied_def in defoptions) then
  3986. tstoredsymtable(symtable).buildderefimpl;
  3987. end;
  3988. procedure tabstractrecorddef.derefimpl;
  3989. begin
  3990. inherited derefimpl;
  3991. if not (df_copied_def in defoptions) then
  3992. tstoredsymtable(symtable).derefimpl(false);
  3993. end;
  3994. procedure tabstractrecorddef.check_forwards;
  3995. begin
  3996. { the defs of a copied def are defined for the original type only }
  3997. if not(df_copied_def in defoptions) then
  3998. tstoredsymtable(symtable).check_forwards;
  3999. end;
  4000. function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
  4001. var
  4002. i: longint;
  4003. sym: tsym;
  4004. begin
  4005. for i:=0 to symtable.SymList.Count-1 do
  4006. begin
  4007. sym:=tsym(symtable.SymList[i]);
  4008. if sym.typ=procsym then
  4009. begin
  4010. result:=tprocsym(sym).find_procdef_bytype(pt);
  4011. if assigned(result) then
  4012. exit;
  4013. end;
  4014. end;
  4015. result:=nil;
  4016. end;
  4017. function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
  4018. begin
  4019. if t=gs_record then
  4020. GetSymtable:=symtable
  4021. else
  4022. GetSymtable:=nil;
  4023. end;
  4024. function tabstractrecorddef.is_packed:boolean;
  4025. begin
  4026. result:=tabstractrecordsymtable(symtable).is_packed;
  4027. end;
  4028. function tabstractrecorddef.RttiName: string;
  4029. function generate_full_paramname(maxlength:longint):string;
  4030. const
  4031. commacount : array[boolean] of longint = (0,1);
  4032. var
  4033. fullparas,
  4034. paramname : ansistring;
  4035. module : tmodule;
  4036. sym : tsym;
  4037. def : tdef;
  4038. i : longint;
  4039. begin
  4040. { we want at least enough space for an ellipsis }
  4041. if maxlength<3 then
  4042. internalerror(2014121203);
  4043. fullparas:='';
  4044. for i:=0 to genericparas.count-1 do
  4045. begin
  4046. sym:=tsym(genericparas[i]);
  4047. module:=find_module_from_symtable(sym.owner);
  4048. if not assigned(module) then
  4049. internalerror(2014121202);
  4050. if not (sym.typ in [constsym,symconst.typesym]) then
  4051. internalerror(2020042501);
  4052. if sym.typ=constsym then
  4053. def:=tconstsym(sym).constdef
  4054. else
  4055. def:=ttypesym(sym).typedef;
  4056. paramname:=module.realmodulename^;
  4057. if def.typ in [objectdef,recorddef] then
  4058. paramname:=paramname+'.'+tabstractrecorddef(def).rttiname
  4059. else
  4060. paramname:=paramname+'.'+def.typename;
  4061. if length(fullparas)+commacount[i>0]+length(paramname)>maxlength then
  4062. begin
  4063. if i>0 then
  4064. fullparas:=fullparas+',...'
  4065. else
  4066. fullparas:=fullparas+'...';
  4067. break;
  4068. end;
  4069. { could we fit an ellipsis after this parameter if it should be too long? }
  4070. if (maxlength-(length(fullparas)+commacount[i>0]+length(paramname))<4) and (i<genericparas.count-1) then
  4071. begin
  4072. { then omit already this parameter }
  4073. if i>0 then
  4074. fullparas:=fullparas+',...'
  4075. else
  4076. fullparas:=fullparas+'...';
  4077. break;
  4078. end;
  4079. if i>0 then
  4080. fullparas:=fullparas+',';
  4081. fullparas:=fullparas+paramname;
  4082. end;
  4083. result:=fullparas;
  4084. end;
  4085. var
  4086. nongeneric,
  4087. basename : string;
  4088. i,
  4089. remlength,
  4090. paramcount,
  4091. crcidx : longint;
  4092. begin
  4093. if rttistring='' then
  4094. begin
  4095. if is_specialization then
  4096. begin
  4097. rttistring:=OwnerHierarchyName;
  4098. { there should be two $ characters, one before the CRC and one before the count }
  4099. crcidx:=-1;
  4100. for i:=length(objrealname^) downto 1 do
  4101. if objrealname^[i]='$' then
  4102. begin
  4103. crcidx:=i;
  4104. break;
  4105. end;
  4106. if crcidx<0 then
  4107. internalerror(2014121201);
  4108. basename:=copy(objrealname^,1,crcidx-1);
  4109. split_generic_name(basename,nongeneric,paramcount);
  4110. rttistring:=rttistring+nongeneric+'<';
  4111. remlength:=255-length(rttistring)-1;
  4112. if remlength<4 then
  4113. rttistring:=rttistring+'>'
  4114. else
  4115. rttistring:=rttistring+generate_full_paramname(remlength)+'>';
  4116. end
  4117. else
  4118. if is_generic then
  4119. begin
  4120. rttistring:=OwnerHierarchyName;
  4121. split_generic_name(objrealname^,nongeneric,paramcount);
  4122. rttistring:=rttistring+nongeneric+'<';
  4123. { we don't want any ',' if there is only one parameter }
  4124. for i:=0 to paramcount-0 do
  4125. rttistring:=rttistring+',';
  4126. rttistring:=rttistring+'>';
  4127. end
  4128. else
  4129. rttistring:=OwnerHierarchyName+objrealname^;
  4130. end;
  4131. result:=rttistring;
  4132. end;
  4133. function tabstractrecorddef.search_enumerator_get: tprocdef;
  4134. var
  4135. sym : tsym;
  4136. i : integer;
  4137. pd : tprocdef;
  4138. hashedid : THashedIDString;
  4139. begin
  4140. result:=nil;
  4141. hashedid.id:='GETENUMERATOR';
  4142. sym:=tsym(symtable.FindWithHash(hashedid));
  4143. if assigned(sym) and (sym.typ=procsym) then
  4144. begin
  4145. for i := 0 to Tprocsym(sym).ProcdefList.Count - 1 do
  4146. begin
  4147. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  4148. if (pd.proctypeoption = potype_function) and
  4149. (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) and
  4150. (pd.visibility >= vis_public) then
  4151. begin
  4152. result:=pd;
  4153. exit;
  4154. end;
  4155. end;
  4156. end;
  4157. end;
  4158. function tabstractrecorddef.search_enumerator_move: tprocdef;
  4159. var
  4160. sym : tsym;
  4161. i : integer;
  4162. pd : tprocdef;
  4163. hashedid : THashedIDString;
  4164. begin
  4165. result:=nil;
  4166. // first search for po_enumerator_movenext method modifier
  4167. // then search for public function MoveNext: Boolean
  4168. for i:=0 to symtable.SymList.Count-1 do
  4169. begin
  4170. sym:=TSym(symtable.SymList[i]);
  4171. if (sym.typ=procsym) then
  4172. begin
  4173. pd:=Tprocsym(sym).find_procdef_byoptions([po_enumerator_movenext]);
  4174. if assigned(pd) then
  4175. begin
  4176. result:=pd;
  4177. exit;
  4178. end;
  4179. end;
  4180. end;
  4181. hashedid.id:='MOVENEXT';
  4182. sym:=tsym(symtable.FindWithHash(hashedid));
  4183. if assigned(sym) and (sym.typ=procsym) then
  4184. begin
  4185. for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
  4186. begin
  4187. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  4188. if (pd.proctypeoption = potype_function) and
  4189. is_boolean(pd.returndef) and
  4190. (pd.minparacount = 0) and
  4191. (pd.visibility >= vis_public) then
  4192. begin
  4193. result:=pd;
  4194. exit;
  4195. end;
  4196. end;
  4197. end;
  4198. end;
  4199. function tabstractrecorddef.search_enumerator_current: tsym;
  4200. var
  4201. sym: tsym;
  4202. i: integer;
  4203. hashedid : THashedIDString;
  4204. begin
  4205. result:=nil;
  4206. // first search for ppo_enumerator_current property modifier
  4207. // then search for public property Current
  4208. for i:=0 to symtable.SymList.Count-1 do
  4209. begin
  4210. sym:=TSym(symtable.SymList[i]);
  4211. if (sym.typ=propertysym) and (ppo_enumerator_current in tpropertysym(sym).propoptions) then
  4212. begin
  4213. result:=sym;
  4214. exit;
  4215. end;
  4216. end;
  4217. hashedid.id:='CURRENT';
  4218. sym:=tsym(symtable.FindWithHash(hashedid));
  4219. if assigned(sym) and (sym.typ=propertysym) and
  4220. (sym.visibility >= vis_public) and not tpropertysym(sym).propaccesslist[palt_read].empty then
  4221. begin
  4222. result:=sym;
  4223. exit;
  4224. end;
  4225. end;
  4226. function tabstractrecorddef.jvm_full_typename(with_package_name: boolean): string;
  4227. var
  4228. st: tsymtable;
  4229. enclosingdef: tdef;
  4230. begin
  4231. if typ=objectdef then
  4232. result:=tobjectdef(self).objextname^
  4233. else if assigned(typesym) then
  4234. result:=typesym.realname
  4235. { have to generate anonymous nested type in current unit/class/record }
  4236. else
  4237. internalerror(2011032601);
  4238. { in case of specializations, add some extras to prevent name conflicts
  4239. with nested classes }
  4240. if df_specialization in defoptions then
  4241. result:='$'+result+'$specialization$';
  4242. st:=owner;
  4243. while assigned(st) and
  4244. (st.symtabletype in [objectsymtable,recordsymtable,localsymtable]) do
  4245. begin
  4246. { nested classes are named as "OuterClass$InnerClass" }
  4247. enclosingdef:=tdef(st.defowner);
  4248. if enclosingdef.typ=procdef then
  4249. result:=result+tprocdef(enclosingdef).procsym.realname+'$$'+tostr(tprocdef(enclosingdef).procsym.symid)+'$'
  4250. else if enclosingdef.typ=objectdef then
  4251. result:=tobjectdef(enclosingdef).objextname^+'$'+result
  4252. else if assigned(enclosingdef.typesym) then
  4253. result:=enclosingdef.typesym.realname+'$'+result
  4254. else
  4255. internalerror(2011060305);
  4256. st:=enclosingdef.owner;
  4257. end;
  4258. if with_package_name and
  4259. assigned(import_lib) then
  4260. result:=import_lib^+'/'+result;
  4261. end;
  4262. function tabstractrecorddef.contains_float_field: boolean;
  4263. var
  4264. i : longint;
  4265. begin
  4266. result:=true;
  4267. for i:=0 to symtable.symlist.count-1 do
  4268. begin
  4269. if (tsym(symtable.symlist[i]).typ<>fieldvarsym) or
  4270. (sp_static in tsym(symtable.symlist[i]).symoptions) then
  4271. continue;
  4272. if assigned(tfieldvarsym(symtable.symlist[i]).vardef) then
  4273. begin
  4274. if tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).is_fpuregable then
  4275. exit;
  4276. { search recursively }
  4277. if (tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).typ=recorddef) and
  4278. (tabstractrecorddef(tfieldvarsym(symtable.symlist[i]).vardef).contains_float_field) then
  4279. exit;
  4280. end;
  4281. end;
  4282. result:=false;
  4283. end;
  4284. function tabstractrecorddef.contains_cross_aword_field: boolean;
  4285. var
  4286. i : longint;
  4287. foffset, fsize: aword;
  4288. begin
  4289. result:=true;
  4290. for i:=0 to symtable.symlist.count-1 do
  4291. begin
  4292. if (tsym(symtable.symlist[i]).typ<>fieldvarsym) or
  4293. (sp_static in tsym(symtable.symlist[i]).symoptions) then
  4294. continue;
  4295. if assigned(tfieldvarsym(symtable.symlist[i]).vardef) then
  4296. begin
  4297. if is_packed then
  4298. begin
  4299. foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset;
  4300. fsize:=tfieldvarsym(symtable.symlist[i]).vardef.packedbitsize;
  4301. end
  4302. else
  4303. begin
  4304. foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset*8;
  4305. fsize:=tfieldvarsym(symtable.symlist[i]).vardef.size*8;
  4306. end;
  4307. if (fsize>0) and ((foffset div (sizeof(aword)*8)) <> ((foffset+fsize-1) div (sizeof(aword)*8))) then
  4308. exit;
  4309. { search recursively }
  4310. if (tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).typ=recorddef) and
  4311. (tabstractrecorddef(tfieldvarsym(symtable.symlist[i]).vardef).contains_cross_aword_field) then
  4312. exit;
  4313. end;
  4314. end;
  4315. result:=false;
  4316. end;
  4317. {***************************************************************************
  4318. trecorddef
  4319. ***************************************************************************}
  4320. constructor trecorddef.create(const n:string; p:TSymtable);
  4321. begin
  4322. inherited create(n,recorddef,true);
  4323. symtable:=p;
  4324. { we can own the symtable only if nobody else owns a copy so far }
  4325. if symtable.refcount=1 then
  4326. symtable.defowner:=self;
  4327. isunion:=false;
  4328. cloneddefderef.reset;
  4329. end;
  4330. constructor trecorddef.create_global_internal(const n: string; packrecords, recordalignmin: shortint);
  4331. var
  4332. name : string;
  4333. pname : pshortstring;
  4334. oldsymtablestack: tsymtablestack;
  4335. where : tsymtable;
  4336. ts: ttypesym;
  4337. begin
  4338. { construct name }
  4339. if n<>'' then
  4340. pname:=@n
  4341. else
  4342. begin
  4343. init_defid;
  4344. name:='$InternalRec'+unique_id_str;
  4345. pname:=@name;
  4346. end;
  4347. oldsymtablestack:=symtablestack;
  4348. { do not simply push/pop current_module.localsymtable, because
  4349. that can have side-effects (e.g., it removes helpers) }
  4350. symtablestack:=nil;
  4351. symtable:=trecordsymtable.create(pname^,packrecords,recordalignmin);
  4352. symtable.defowner:=self;
  4353. isunion:=false;
  4354. inherited create(pname^,recorddef,true);
  4355. where:=current_module.localsymtable;
  4356. if not assigned(where) then
  4357. where:=current_module.globalsymtable;
  4358. where.insertdef(self);
  4359. { if we specified a name, then we'll probably want to look up the
  4360. type again by name too -> create typesym }
  4361. if n<>'' then
  4362. begin
  4363. ts:=ctypesym.create(n,self);
  4364. { avoid hints about unused types (these may only be used for
  4365. typed constant data) }
  4366. ts.increfcount;
  4367. where.insert(ts);
  4368. end;
  4369. symtablestack:=oldsymtablestack;
  4370. { don't create RTTI for internal types, these are not exported }
  4371. defstates:=defstates+[ds_rtti_table_written,ds_init_table_written];
  4372. include(defoptions,df_internal);
  4373. end;
  4374. function trecorddef.add_field_by_def(const optionalname: TIDString; def: tdef): tsym;
  4375. var
  4376. sym: tfieldvarsym;
  4377. name: TIDString;
  4378. pname: ^TIDString;
  4379. begin
  4380. if optionalname='' then
  4381. begin
  4382. name:='$f'+tostr(trecordsymtable(symtable).symlist.count);
  4383. pname:=@name
  4384. end
  4385. else
  4386. pname:=@optionalname;
  4387. sym:=cfieldvarsym.create(pname^,vs_value,def,[]);
  4388. symtable.insert(sym);
  4389. trecordsymtable(symtable).addfield(sym,vis_hidden);
  4390. result:=sym;
  4391. end;
  4392. procedure trecorddef.add_fields_from_deflist(fieldtypes: tfplist);
  4393. var
  4394. i: longint;
  4395. begin
  4396. for i:=0 to fieldtypes.count-1 do
  4397. add_field_by_def('',tdef(fieldtypes[i]));
  4398. end;
  4399. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  4400. procedure readvariantrecdesc(var variantrecdesc : pvariantrecdesc);
  4401. var
  4402. i,j : longint;
  4403. begin
  4404. if ppufile.getbyte=1 then
  4405. begin
  4406. new(variantrecdesc);
  4407. ppufile.getderef(variantrecdesc^.variantselectorderef);
  4408. SetLength(variantrecdesc^.branches,ppufile.getasizeint);
  4409. for i:=0 to high(variantrecdesc^.branches) do
  4410. begin
  4411. SetLength(variantrecdesc^.branches[i].values,ppufile.getasizeint);
  4412. for j:=0 to high(variantrecdesc^.branches[i].values) do
  4413. variantrecdesc^.branches[i].values[j]:=ppufile.getexprint;
  4414. readvariantrecdesc(variantrecdesc^.branches[i].nestedvariant);
  4415. end;
  4416. end
  4417. else
  4418. variantrecdesc:=nil;
  4419. end;
  4420. begin
  4421. inherited ppuload(recorddef,ppufile);
  4422. if df_copied_def in defoptions then
  4423. begin
  4424. ppufile.getderef(cloneddefderef);
  4425. ppuload_platform(ppufile);
  4426. end
  4427. else
  4428. begin
  4429. symtable:=trecordsymtable.create(objrealname^,0,0);
  4430. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  4431. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  4432. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  4433. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  4434. trecordsymtable(symtable).recordalignmin:=shortint(ppufile.getbyte);
  4435. trecordsymtable(symtable).datasize:=ppufile.getasizeint;
  4436. trecordsymtable(symtable).paddingsize:=ppufile.getword;
  4437. ppufile.getset(tppuset1(trecordsymtable(symtable).managementoperators));
  4438. { position of ppuload_platform call must correspond
  4439. to position of writeentry in ppuwrite method }
  4440. ppuload_platform(ppufile);
  4441. trecordsymtable(symtable).ppuload(ppufile);
  4442. { the variantrecdesc is needed only for iso-like new statements new(prec,1,2,3 ...);
  4443. but because iso mode supports no units, there is no need to store the variantrecdesc
  4444. in the ppu
  4445. }
  4446. // readvariantrecdesc(variantrecdesc);
  4447. { requires usefieldalignment to be set }
  4448. symtable.defowner:=self;
  4449. end;
  4450. isunion:=false;
  4451. end;
  4452. destructor trecorddef.destroy;
  4453. procedure free_variantrecdesc(var variantrecdesc : pvariantrecdesc);
  4454. var
  4455. i : longint;
  4456. begin
  4457. while assigned(variantrecdesc) do
  4458. begin
  4459. for i:=0 to high(variantrecdesc^.branches) do
  4460. begin
  4461. free_variantrecdesc(variantrecdesc^.branches[i].nestedvariant);
  4462. SetLength(variantrecdesc^.branches[i].values,0);
  4463. end;
  4464. SetLength(variantrecdesc^.branches,0);
  4465. dispose(variantrecdesc);
  4466. variantrecdesc:=nil;
  4467. end;
  4468. end;
  4469. begin
  4470. if assigned(variantrecdesc) then
  4471. free_variantrecdesc(variantrecdesc);
  4472. if assigned(symtable) then
  4473. begin
  4474. symtable.free;
  4475. symtable:=nil;
  4476. end;
  4477. inherited destroy;
  4478. end;
  4479. function trecorddef.getcopy : tstoreddef;
  4480. begin
  4481. result:=crecorddef.create(objrealname^,symtable.getcopy);
  4482. trecorddef(result).isunion:=isunion;
  4483. include(trecorddef(result).defoptions,df_copied_def);
  4484. if assigned(tcinitcode) then
  4485. trecorddef(result).tcinitcode:=tcinitcode.getcopy;
  4486. if assigned(import_lib) then
  4487. trecorddef(result).import_lib:=stringdup(import_lib^);
  4488. end;
  4489. function trecorddef.needs_inittable : boolean;
  4490. begin
  4491. { each record with managed field or with any management operator needs
  4492. init table }
  4493. needs_inittable:=(trecordsymtable(symtable).managementoperators<>[]) or
  4494. trecordsymtable(symtable).needs_init_final
  4495. end;
  4496. function trecorddef.needs_separate_initrtti : boolean;
  4497. begin
  4498. result:=true;
  4499. end;
  4500. function trecorddef.has_non_trivial_init_child(check_parent:boolean):boolean;
  4501. begin
  4502. result:=trecordsymtable(symtable).has_non_trivial_init;
  4503. end;
  4504. procedure trecorddef.buildderef;
  4505. begin
  4506. inherited buildderef;
  4507. if df_copied_def in defoptions then
  4508. cloneddefderef.build(symtable.defowner)
  4509. else
  4510. tstoredsymtable(symtable).buildderef;
  4511. end;
  4512. procedure trecorddef.deref;
  4513. begin
  4514. inherited deref;
  4515. { now dereference the definitions }
  4516. if df_copied_def in defoptions then
  4517. begin
  4518. cloneddef:=trecorddef(cloneddefderef.resolve);
  4519. symtable:=cloneddef.symtable.getcopy;
  4520. end
  4521. else
  4522. tstoredsymtable(symtable).deref(false);
  4523. { internal types, only load from the system unit }
  4524. if assigned(owner) and
  4525. assigned(owner.name) and
  4526. (owner.name^='SYSTEM') then
  4527. begin
  4528. { TGUID }
  4529. if not assigned(rec_tguid) and
  4530. (upper(typename)='TGUID') then
  4531. rec_tguid:=self
  4532. { JMP_BUF }
  4533. else if not assigned(rec_jmp_buf) and
  4534. (upper(typename)='JMP_BUF') then
  4535. rec_jmp_buf:=self
  4536. else if not assigned(rec_exceptaddr) and
  4537. (upper(typename)='TEXCEPTADDR') then
  4538. rec_exceptaddr:=self;
  4539. end;
  4540. end;
  4541. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  4542. procedure writevariantrecdesc(variantrecdesc : pvariantrecdesc);
  4543. var
  4544. i,j : longint;
  4545. begin
  4546. if assigned(variantrecdesc) then
  4547. begin
  4548. ppufile.putbyte(1);
  4549. ppufile.putderef(variantrecdesc^.variantselectorderef);
  4550. ppufile.putasizeint(length(variantrecdesc^.branches));
  4551. for i:=0 to high(variantrecdesc^.branches) do
  4552. begin
  4553. ppufile.putasizeint(length(variantrecdesc^.branches[i].values));
  4554. for j:=0 to high(variantrecdesc^.branches[i].values) do
  4555. ppufile.putexprint(variantrecdesc^.branches[i].values[j]);
  4556. writevariantrecdesc(variantrecdesc^.branches[i].nestedvariant);
  4557. end;
  4558. end
  4559. else
  4560. ppufile.putbyte(0);
  4561. end;
  4562. begin
  4563. inherited ppuwrite(ppufile);
  4564. if df_copied_def in defoptions then
  4565. ppufile.putderef(cloneddefderef)
  4566. else
  4567. begin
  4568. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  4569. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  4570. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  4571. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  4572. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignmin));
  4573. ppufile.putasizeint(trecordsymtable(symtable).datasize);
  4574. ppufile.putword(trecordsymtable(symtable).paddingsize);
  4575. ppufile.putset(tppuset1(trecordsymtable(symtable).managementoperators));
  4576. { the variantrecdesc is needed only for iso-like new statements new(prec,1,2,3 ...);
  4577. but because iso mode supports no units, there is no need to store the variantrecdesc
  4578. in the ppu
  4579. }
  4580. // writevariantrecdesc(variantrecdesc);
  4581. end;
  4582. writeentry(ppufile,ibrecorddef);
  4583. if not(df_copied_def in defoptions) then
  4584. trecordsymtable(symtable).ppuwrite(ppufile);
  4585. end;
  4586. function trecorddef.size:asizeint;
  4587. begin
  4588. result:=trecordsymtable(symtable).datasize;
  4589. end;
  4590. function trecorddef.alignment:shortint;
  4591. begin
  4592. alignment:=trecordsymtable(symtable).recordalignment;
  4593. end;
  4594. function trecorddef.padalignment:shortint;
  4595. begin
  4596. padalignment := trecordsymtable(symtable).padalignment;
  4597. end;
  4598. function trecorddef.GetTypeName : string;
  4599. begin
  4600. GetTypeName:='<record type>'
  4601. end;
  4602. {***************************************************************************
  4603. TABSTRACTPROCDEF
  4604. ***************************************************************************}
  4605. constructor tabstractprocdef.create(dt:tdeftyp;level:byte;doregister:boolean);
  4606. begin
  4607. inherited create(dt,doregister);
  4608. parast:=tparasymtable.create(self,level);
  4609. paras:=nil;
  4610. minparacount:=0;
  4611. maxparacount:=0;
  4612. proctypeoption:=potype_none;
  4613. proccalloption:=pocall_none;
  4614. procoptions:=[];
  4615. returndef:=voidtype;
  4616. returndefderef.reset;
  4617. savesize:=sizeof(pint);
  4618. callerargareasize:=0;
  4619. calleeargareasize:=0;
  4620. has_paraloc_info:=callnoside;
  4621. funcretloc[callerside].init;
  4622. funcretloc[calleeside].init;
  4623. check_mark_as_nested;
  4624. end;
  4625. destructor tabstractprocdef.destroy;
  4626. begin
  4627. if assigned(paras) then
  4628. begin
  4629. {$ifdef MEMDEBUG}
  4630. memprocpara.start;
  4631. {$endif MEMDEBUG}
  4632. paras.free;
  4633. paras:=nil;
  4634. {$ifdef MEMDEBUG}
  4635. memprocpara.stop;
  4636. {$endif MEMDEBUG}
  4637. end;
  4638. if assigned(parast) then
  4639. begin
  4640. {$ifdef MEMDEBUG}
  4641. memprocparast.start;
  4642. {$endif MEMDEBUG}
  4643. parast.free;
  4644. parast:=nil;
  4645. {$ifdef MEMDEBUG}
  4646. memprocparast.stop;
  4647. {$endif MEMDEBUG}
  4648. end;
  4649. funcretloc[callerside].done;
  4650. funcretloc[calleeside].done;
  4651. inherited destroy;
  4652. end;
  4653. procedure tabstractprocdef.count_para(p:TObject;arg:pointer);
  4654. begin
  4655. if (tsym(p).typ<>paravarsym) then
  4656. exit;
  4657. inc(plongint(arg)^);
  4658. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  4659. begin
  4660. if not assigned(tparavarsym(p).defaultconstsym) then
  4661. inc(minparacount);
  4662. inc(maxparacount);
  4663. end;
  4664. end;
  4665. procedure tabstractprocdef.insert_para(p:TObject;arg:pointer);
  4666. begin
  4667. if (tsym(p).typ<>paravarsym) then
  4668. exit;
  4669. paras.add(p);
  4670. end;
  4671. procedure tabstractprocdef.calcparas;
  4672. var
  4673. paracount : longint;
  4674. begin
  4675. { This can already be assigned when
  4676. we need to reresolve this unit (PFV) }
  4677. if assigned(paras) then
  4678. paras.free;
  4679. paras:=tparalist.create(false);
  4680. paracount:=0;
  4681. minparacount:=0;
  4682. maxparacount:=0;
  4683. parast.SymList.ForEachCall(@count_para,@paracount);
  4684. paras.capacity:=paracount;
  4685. { Insert parameters in table }
  4686. parast.SymList.ForEachCall(@insert_para,nil);
  4687. { Order parameters }
  4688. paras.sortparas;
  4689. end;
  4690. function tabstractprocdef.mangledprocparanames(oldlen : longint) : string;
  4691. var
  4692. crc : dword;
  4693. hp : TParavarsym;
  4694. hs : TSymStr;
  4695. newlen,
  4696. i : integer;
  4697. begin
  4698. result:='';
  4699. hp:=nil;
  4700. { add parameter types }
  4701. for i:=0 to paras.count-1 do
  4702. begin
  4703. hp:=tparavarsym(paras[i]);
  4704. if not(vo_is_hidden_para in hp.varoptions) then
  4705. result:=result+'$'+hp.vardef.mangledparaname;
  4706. end;
  4707. { add resultdef, add $$ as separator to make it unique from a
  4708. parameter separator }
  4709. if not is_void(returndef) then
  4710. result:=result+'$$'+returndef.mangledparaname;
  4711. newlen:=length(result)+oldlen;
  4712. { Replace with CRC if the parameter line is very long }
  4713. if (newlen-oldlen>12) and
  4714. ((newlen>100) or (newlen-oldlen>64)) then
  4715. begin
  4716. crc:=0;
  4717. for i:=0 to paras.count-1 do
  4718. begin
  4719. hp:=tparavarsym(paras[i]);
  4720. if not(vo_is_hidden_para in hp.varoptions) then
  4721. begin
  4722. hs:=hp.vardef.mangledparaname;
  4723. crc:=UpdateCrc32(crc,hs[1],length(hs));
  4724. end;
  4725. end;
  4726. if not is_void(returndef) then
  4727. begin
  4728. { add a little prefix so that x(integer; integer) is different from x(integer):integer }
  4729. hs:='$$'+returndef.mangledparaname;
  4730. crc:=UpdateCrc32(crc,hs[1],length(hs));
  4731. end;
  4732. result:='$crc'+hexstr(crc,8);
  4733. end;
  4734. end;
  4735. procedure tabstractprocdef.buildderef;
  4736. begin
  4737. { released procdef? }
  4738. if not assigned(parast) then
  4739. exit;
  4740. inherited buildderef;
  4741. returndefderef.build(returndef);
  4742. if po_explicitparaloc in procoptions then
  4743. funcretloc[callerside].buildderef;
  4744. { parast }
  4745. tparasymtable(parast).buildderef;
  4746. end;
  4747. procedure tabstractprocdef.deref;
  4748. begin
  4749. inherited deref;
  4750. returndef:=tdef(returndefderef.resolve);
  4751. if po_explicitparaloc in procoptions then
  4752. begin
  4753. funcretloc[callerside].deref;
  4754. has_paraloc_info:=callerside;
  4755. end
  4756. else
  4757. begin
  4758. { deref is called after loading from a ppu, but also after another
  4759. unit has been reloaded/recompiled and all references must be
  4760. re-resolved. Since the funcretloc contains a reference to a tdef,
  4761. reset it so that we won't try to access the stale def }
  4762. funcretloc[callerside].init;
  4763. has_paraloc_info:=callnoside;
  4764. end;
  4765. { parast }
  4766. tparasymtable(parast).deref(false);
  4767. { recalculated parameters }
  4768. calcparas;
  4769. end;
  4770. constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  4771. begin
  4772. inherited ppuload(dt,ppufile);
  4773. parast:=nil;
  4774. Paras:=nil;
  4775. minparacount:=0;
  4776. maxparacount:=0;
  4777. ppufile.getderef(returndefderef);
  4778. proctypeoption:=tproctypeoption(ppufile.getbyte);
  4779. proccalloption:=tproccalloption(ppufile.getbyte);
  4780. ppufile.getset(tppuset8(procoptions));
  4781. funcretloc[callerside].init;
  4782. if po_explicitparaloc in procoptions then
  4783. funcretloc[callerside].ppuload(ppufile);
  4784. savesize:=sizeof(pint);
  4785. if (po_explicitparaloc in procoptions) then
  4786. has_paraloc_info:=callerside;
  4787. end;
  4788. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  4789. var
  4790. oldintfcrc : boolean;
  4791. begin
  4792. { released procdef? }
  4793. if not assigned(parast) then
  4794. exit;
  4795. inherited ppuwrite(ppufile);
  4796. ppufile.putderef(returndefderef);
  4797. oldintfcrc:=ppufile.do_interface_crc;
  4798. ppufile.do_interface_crc:=false;
  4799. ppufile.putbyte(ord(proctypeoption));
  4800. ppufile.putbyte(ord(proccalloption));
  4801. ppufile.putset(tppuset8(procoptions));
  4802. ppufile.do_interface_crc:=oldintfcrc;
  4803. if (po_explicitparaloc in procoptions) then
  4804. funcretloc[callerside].ppuwrite(ppufile);
  4805. end;
  4806. function tabstractprocdef.typename_paras(pno: tprocnameoptions) : ansistring;
  4807. var
  4808. hs,s : ansistring;
  4809. hp : TParavarsym;
  4810. hpc : tconstsym;
  4811. first : boolean;
  4812. i,j : integer;
  4813. begin
  4814. s:='';
  4815. first:=true;
  4816. for i:=0 to paras.count-1 do
  4817. begin
  4818. hp:=tparavarsym(paras[i]);
  4819. if not(vo_is_hidden_para in hp.varoptions) or
  4820. (pno_showhidden in pno) then
  4821. begin
  4822. if first then
  4823. begin
  4824. s:=s+'(';
  4825. first:=false;
  4826. end
  4827. else
  4828. s:=s+';';
  4829. if vo_is_hidden_para in hp.varoptions then
  4830. s:=s+'<';
  4831. case hp.varspez of
  4832. vs_var :
  4833. s:=s+'var ';
  4834. vs_const :
  4835. s:=s+'const ';
  4836. vs_out :
  4837. s:=s+'out ';
  4838. vs_constref :
  4839. s:=s+'constref ';
  4840. else
  4841. ;
  4842. end;
  4843. if (pno_paranames in pno) then
  4844. s:=s+hp.realname+':';
  4845. if hp.univpara then
  4846. s:=s+'univ ';
  4847. if assigned(hp.vardef.typesym) then
  4848. begin
  4849. hs:=hp.vardef.typesym.realname;
  4850. if hs[1]<>'$' then
  4851. s:=s+hp.vardef.OwnerHierarchyName+hs
  4852. else
  4853. s:=s+hp.vardef.GetTypeName;
  4854. end
  4855. else
  4856. s:=s+hp.vardef.GetTypeName;
  4857. { default value }
  4858. if assigned(hp.defaultconstsym) then
  4859. begin
  4860. hpc:=tconstsym(hp.defaultconstsym);
  4861. hs:='';
  4862. case hpc.consttyp of
  4863. constwstring:
  4864. begin
  4865. if pcompilerwidestring(hpc.value.valueptr)^.len>0 then
  4866. begin
  4867. setlength(hs,pcompilerwidestring(hpc.value.valueptr)^.len);
  4868. for j:=0 to pcompilerwidestring(hpc.value.valueptr)^.len-1 do
  4869. begin
  4870. if (ord(pcompilerwidestring(hpc.value.valueptr)^.data[j])<127) and
  4871. not(byte(pcompilerwidestring(hpc.value.valueptr)^.data[j]) in [0,10,13]) then
  4872. hs[j+1]:=char(pcompilerwidestring(hpc.value.valueptr)^.data[j])
  4873. else
  4874. hs[j+1]:='.';
  4875. end;
  4876. end;
  4877. end;
  4878. conststring,
  4879. constresourcestring :
  4880. begin
  4881. if hpc.value.len>0 then
  4882. begin
  4883. setLength(hs,hpc.value.len);
  4884. { don't write past the end of hs if the constant
  4885. is > 255 chars }
  4886. move(hpc.value.valueptr^,hs[1],length(hs));
  4887. { make sure that constant strings with newline chars
  4888. don't create a linebreak in the assembler code,
  4889. since comments are line-based. Also remove nulls
  4890. because the comments are written as a pchar. }
  4891. ReplaceCase(hs,#0,'.');
  4892. ReplaceCase(hs,#10,'.');
  4893. ReplaceCase(hs,#13,'.');
  4894. end;
  4895. end;
  4896. constreal :
  4897. str(pbestreal(hpc.value.valueptr)^,hs);
  4898. constpointer :
  4899. hs:=tostr(hpc.value.valueordptr);
  4900. constord :
  4901. begin
  4902. if is_boolean(hpc.constdef) then
  4903. begin
  4904. if hpc.value.valueord<>0 then
  4905. hs:='TRUE'
  4906. else
  4907. hs:='FALSE';
  4908. end
  4909. else
  4910. hs:=tostr(hpc.value.valueord);
  4911. end;
  4912. constnil :
  4913. hs:='nil';
  4914. constset :
  4915. hs:='<set>';
  4916. constguid:
  4917. hs:=guid2string(pguid(hpc.value.valueptr)^);
  4918. constnone:
  4919. internalerror(2019050704);
  4920. end;
  4921. if hs<>'' then
  4922. s:=s+'=`'+hs+'`';
  4923. end;
  4924. if vo_is_hidden_para in hp.varoptions then
  4925. s:=s+'>';
  4926. end;
  4927. end;
  4928. if not first then
  4929. s:=s+')';
  4930. if (po_varargs in procoptions) then
  4931. s:=s+';VarArgs';
  4932. typename_paras:=s;
  4933. end;
  4934. function tabstractprocdef.is_methodpointer:boolean;
  4935. begin
  4936. result:=false;
  4937. end;
  4938. function tabstractprocdef.is_addressonly:boolean;
  4939. begin
  4940. result:=true;
  4941. end;
  4942. function tabstractprocdef.no_self_node: boolean;
  4943. begin
  4944. Result:=([po_staticmethod,po_classmethod]<=procoptions)or
  4945. (proctypeoption in [potype_class_constructor,potype_class_destructor,potype_operator]);
  4946. end;
  4947. function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef;
  4948. var
  4949. j, nestinglevel: longint;
  4950. pvs, npvs: tparavarsym;
  4951. begin
  4952. nestinglevel:=parast.symtablelevel;
  4953. if newtyp=procdef then
  4954. begin
  4955. if (copytyp<>pc_bareproc) then
  4956. result:=cprocdef.create(nestinglevel,true)
  4957. else
  4958. result:=cprocdef.create(normal_function_level,true);
  4959. tprocdef(result).visibility:=vis_public;
  4960. end
  4961. else
  4962. begin
  4963. result:=cprocvardef.create(nestinglevel);
  4964. end;
  4965. tabstractprocdef(result).returndef:=returndef;
  4966. tabstractprocdef(result).returndefderef:=returndefderef;
  4967. pvs:=nil;
  4968. npvs:=nil;
  4969. for j:=0 to parast.symlist.count-1 do
  4970. begin
  4971. case tsym(parast.symlist[j]).typ of
  4972. paravarsym:
  4973. begin
  4974. pvs:=tparavarsym(parast.symlist[j]);
  4975. { in case of bare proc, don't copy self, vmt or framepointer
  4976. parameters }
  4977. if (copytyp in [pc_bareproc,pc_normal_no_hidden]) and
  4978. (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result,vo_is_funcret]*pvs.varoptions)<>[]) then
  4979. continue;
  4980. if paraprefix='' then
  4981. npvs:=cparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
  4982. pvs.vardef,pvs.varoptions)
  4983. else if not(vo_is_high_para in pvs.varoptions) then
  4984. npvs:=cparavarsym.create(paraprefix+pvs.realname,pvs.paranr,pvs.varspez,
  4985. pvs.vardef,pvs.varoptions)
  4986. else
  4987. npvs:=cparavarsym.create('$high'+paraprefix+copy(pvs.name,5,length(pvs.name)),pvs.paranr,pvs.varspez,
  4988. pvs.vardef,pvs.varoptions);
  4989. npvs.defaultconstsym:=pvs.defaultconstsym;
  4990. tabstractprocdef(result).parast.insert(npvs);
  4991. end;
  4992. constsym:
  4993. begin
  4994. // ignore, reuse original constym. Should also be duplicated
  4995. // be safe though
  4996. end;
  4997. symconst.typesym:
  4998. begin
  4999. // reuse original, part of generic declaration
  5000. end
  5001. else
  5002. internalerror(201160604);
  5003. end;
  5004. end;
  5005. tabstractprocdef(result).savesize:=savesize;
  5006. if (typ<>procvardef) and
  5007. (newtyp=procvardef) then
  5008. begin
  5009. { procvars can't be (class)constructures/destructors etc }
  5010. if proctypeoption=potype_constructor then
  5011. begin
  5012. tabstractprocdef(result).returndef:=tdef(owner.defowner);
  5013. if not(is_implicit_pointer_object_type(returndef) or
  5014. (returndef.typ<>objectdef)) then
  5015. tabstractprocdef(result).returndef:=cpointerdef.getreusable(tabstractprocdef(result).returndef);
  5016. tabstractprocdef(result).proctypeoption:=potype_function;
  5017. end
  5018. else if is_void(returndef) then
  5019. tabstractprocdef(result).proctypeoption:=potype_procedure
  5020. else
  5021. tabstractprocdef(result).proctypeoption:=potype_function;
  5022. end
  5023. else
  5024. tabstractprocdef(result).proctypeoption:=proctypeoption;
  5025. tabstractprocdef(result).proccalloption:=proccalloption;
  5026. tabstractprocdef(result).procoptions:=procoptions;
  5027. if (copytyp=pc_bareproc) then
  5028. tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions*[po_explicitparaloc,po_hascallingconvention,po_varargs,po_iocheck,po_has_importname,po_has_importdll];
  5029. if newtyp=procvardef then
  5030. tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions-[po_has_importname,po_has_importdll];
  5031. if copytyp=pc_address_only then
  5032. include(tabstractprocdef(result).procoptions,po_addressonly);
  5033. tabstractprocdef(result).callerargareasize:=callerargareasize;
  5034. tabstractprocdef(result).calleeargareasize:=calleeargareasize;
  5035. tabstractprocdef(result).maxparacount:=maxparacount;
  5036. tabstractprocdef(result).minparacount:=minparacount;
  5037. if po_explicitparaloc in procoptions then
  5038. tabstractprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
  5039. { recalculate parameter info }
  5040. tabstractprocdef(result).has_paraloc_info:=callnoside;
  5041. {$ifdef m68k}
  5042. tabstractprocdef(result).exp_funcretloc:=exp_funcretloc;
  5043. {$endif}
  5044. if (typ=procdef) and
  5045. (newtyp=procvardef) and
  5046. (owner.symtabletype=ObjectSymtable) then
  5047. include(tprocvardef(result).procoptions,po_methodpointer);
  5048. end;
  5049. function tabstractprocdef.compatible_with_pointerdef_size(ptr: tpointerdef): boolean;
  5050. begin
  5051. result:=is_addressonly;
  5052. end;
  5053. procedure tabstractprocdef.check_mark_as_nested;
  5054. begin
  5055. { nested procvars require that nested functions use the Delphi-style
  5056. nested procedure calling convention }
  5057. if (parast.symtablelevel>normal_function_level) and
  5058. (m_nested_procvars in current_settings.modeswitches) then
  5059. include(procoptions,po_delphi_nested_cc);
  5060. end;
  5061. procedure tabstractprocdef.init_paraloc_info(side: tcallercallee);
  5062. begin
  5063. if (side in [callerside,callbothsides]) and
  5064. not(has_paraloc_info in [callerside,callbothsides]) then
  5065. begin
  5066. if not is_c_variadic(self) then
  5067. callerargareasize:=paramanager.create_paraloc_info(self,callerside)
  5068. else
  5069. callerargareasize:=paramanager.create_varargs_paraloc_info(self,callerside,nil);
  5070. if has_paraloc_info in [calleeside,callbothsides] then
  5071. has_paraloc_info:=callbothsides
  5072. else
  5073. has_paraloc_info:=callerside;
  5074. end;
  5075. if (side in [calleeside,callbothsides]) and
  5076. not(has_paraloc_info in [calleeside,callbothsides]) then
  5077. begin
  5078. if not is_c_variadic(self) then
  5079. calleeargareasize:=paramanager.create_paraloc_info(self,calleeside)
  5080. else
  5081. callerargareasize:=paramanager.create_varargs_paraloc_info(self,calleeside,nil);
  5082. if has_paraloc_info in [callerside,callbothsides] then
  5083. has_paraloc_info:=callbothsides
  5084. else
  5085. has_paraloc_info:=calleeside;
  5086. end;
  5087. end;
  5088. procedure tabstractprocdef.done_paraloc_info(side: tcallercallee);
  5089. var
  5090. i: longint;
  5091. begin
  5092. if (side in [callerside,callbothsides]) and
  5093. (has_paraloc_info in [callerside,callbothsides]) then
  5094. begin
  5095. funcretloc[callerside].done;
  5096. for i:=0 to paras.count-1 do
  5097. tparavarsym(paras[i]).paraloc[callerside].done;
  5098. if has_paraloc_info=callerside then
  5099. has_paraloc_info:=callnoside
  5100. else
  5101. has_paraloc_info:=calleeside;
  5102. end;
  5103. if (side in [calleeside,callbothsides]) and
  5104. (has_paraloc_info in [calleeside,callbothsides]) then
  5105. begin
  5106. funcretloc[calleeside].done;
  5107. for i:=0 to paras.count-1 do
  5108. tparavarsym(paras[i]).paraloc[calleeside].done;
  5109. if has_paraloc_info=calleeside then
  5110. has_paraloc_info:=callnoside
  5111. else
  5112. has_paraloc_info:=callerside;
  5113. end;
  5114. end;
  5115. function tabstractprocdef.stack_tainting_parameter(side: tcallercallee): boolean;
  5116. var
  5117. p: tparavarsym;
  5118. ploc: PCGParalocation;
  5119. i: longint;
  5120. begin
  5121. result:=false;
  5122. init_paraloc_info(side);
  5123. for i:=0 to parast.SymList.Count-1 do
  5124. if tsym(parast.SymList[i]).typ=paravarsym then
  5125. begin
  5126. p:=tparavarsym(parast.SymList[i]);
  5127. if not p.is_used then
  5128. continue;
  5129. { check if no parameter is located on the stack }
  5130. if (is_open_array(p.vardef) or
  5131. is_array_of_const(p.vardef)) and (p.varspez=vs_value) then
  5132. begin
  5133. result:=true;
  5134. exit;
  5135. end;
  5136. ploc:=p.paraloc[side].location;
  5137. while assigned(ploc) do
  5138. begin
  5139. if (ploc^.loc=LOC_REFERENCE) then
  5140. begin
  5141. result:=true;
  5142. exit
  5143. end;
  5144. ploc:=ploc^.next;
  5145. end;
  5146. end;
  5147. end;
  5148. function tabstractprocdef.is_pushleftright: boolean;
  5149. begin
  5150. result:=false;
  5151. end;
  5152. function tabstractprocdef.address_type: tdef;
  5153. begin
  5154. result:=voidcodepointertype;
  5155. end;
  5156. function tabstractprocdef.ofs_address_type:tdef;
  5157. begin
  5158. result:=address_type;
  5159. end;
  5160. procedure tabstractprocdef.declared_far;
  5161. begin
  5162. Message1(parser_w_proc_directive_ignored,'FAR');
  5163. end;
  5164. procedure tabstractprocdef.declared_near;
  5165. begin
  5166. Message1(parser_w_proc_directive_ignored,'NEAR');
  5167. end;
  5168. function tabstractprocdef.generate_safecall_wrapper: boolean;
  5169. begin
  5170. {$ifdef SUPPORT_SAFECALL}
  5171. result:=
  5172. (proccalloption=pocall_safecall) and
  5173. not(po_assembler in procoptions) and
  5174. (tf_safecall_exceptions in target_info.flags);
  5175. {$else SUPPORT_SAFECALL}
  5176. result:=false;
  5177. {$endif}
  5178. end;
  5179. {***************************************************************************
  5180. TPROCDEF
  5181. ***************************************************************************}
  5182. function tprocdef.getparentfpsym: tsym;
  5183. begin
  5184. if not assigned(_parentfpsym) then
  5185. begin
  5186. _parentfpsym:=tsym(parast.Find('parentfp'));
  5187. if not assigned(_parentfpsym) then
  5188. internalerror(200309281);
  5189. end;
  5190. result:=_parentfpsym;
  5191. end;
  5192. function tprocdef.Getis_implemented: boolean;
  5193. begin
  5194. result:=not assigned(implprocdefinfo) or implprocdefinfo^.is_implemented;
  5195. end;
  5196. procedure tprocdef.Setis_implemented(AValue: boolean);
  5197. begin
  5198. if not assigned(implprocdefinfo) then
  5199. internalerror(2020062101);
  5200. implprocdefinfo^.is_implemented:=AValue;
  5201. end;
  5202. function tprocdef.store_localst: boolean;
  5203. begin
  5204. result:=has_inlininginfo or (df_generic in defoptions);
  5205. end;
  5206. function tprocdef.GetResultName: PShortString;
  5207. begin
  5208. if not assigned(implprocdefinfo) then
  5209. internalerror(2014010301);
  5210. result:=implprocdefinfo^.resultname;
  5211. end;
  5212. procedure tprocdef.SetResultName(AValue: PShortString);
  5213. begin
  5214. if not assigned(implprocdefinfo) then
  5215. internalerror(2014010302);
  5216. implprocdefinfo^.resultname:=AValue;
  5217. end;
  5218. function tprocdef.GetParentFPInitBlock: tnode;
  5219. begin
  5220. if not assigned(implprocdefinfo) then
  5221. internalerror(2014010303);
  5222. result:=implprocdefinfo^.parentfpinitblock;
  5223. end;
  5224. function tprocdef.GetParentFPStruct: tsym;
  5225. begin
  5226. if not assigned(implprocdefinfo) then
  5227. internalerror(2014010304);
  5228. result:=implprocdefinfo^.parentfpstruct;
  5229. end;
  5230. function tprocdef.GetParentFPStructPtrType: tdef;
  5231. begin
  5232. if not assigned(implprocdefinfo) then
  5233. internalerror(2014010305);
  5234. result:=implprocdefinfo^.parentfpstructptrtype;
  5235. end;
  5236. procedure tprocdef.SetParentFPInitBlock(AValue: tnode);
  5237. begin
  5238. if not assigned(implprocdefinfo) then
  5239. internalerror(2014010306);
  5240. implprocdefinfo^.parentfpinitblock:=AValue;
  5241. end;
  5242. function tprocdef.Getprocendtai: tai;
  5243. begin
  5244. if not assigned(implprocdefinfo) then
  5245. internalerror(2014010307);
  5246. result:=implprocdefinfo^.procendtai;
  5247. end;
  5248. function tprocdef.Getprocstarttai: tai;
  5249. begin
  5250. if not assigned(implprocdefinfo) then
  5251. internalerror(2014010308);
  5252. result:=implprocdefinfo^.procstarttai;
  5253. end;
  5254. procedure tprocdef.Setprocendtai(AValue: tai);
  5255. begin
  5256. if not assigned(implprocdefinfo) then
  5257. internalerror(2014010309);
  5258. implprocdefinfo^.procendtai:=AValue;
  5259. end;
  5260. function tprocdef.Getskpara: pointer;
  5261. begin
  5262. if not assigned(implprocdefinfo) then
  5263. internalerror(2014010310);
  5264. result:=implprocdefinfo^.skpara;
  5265. end;
  5266. procedure tprocdef.Setskpara(AValue: pointer);
  5267. begin
  5268. if not assigned(implprocdefinfo) then
  5269. internalerror(2014010311);
  5270. implprocdefinfo^.skpara:=AValue;
  5271. end;
  5272. function tprocdef.Getpersonality: tprocdef;
  5273. begin
  5274. if not assigned(implprocdefinfo) then
  5275. internalerror(2016121704);
  5276. result:=implprocdefinfo^.personality;
  5277. end;
  5278. procedure tprocdef.Setpersonality(AValue: tprocdef);
  5279. begin
  5280. if not assigned(implprocdefinfo) then
  5281. internalerror(2016121705);
  5282. implprocdefinfo^.personality:=AValue;
  5283. end;
  5284. function tprocdef.Getforwarddef: boolean;
  5285. begin
  5286. if not assigned(implprocdefinfo) then
  5287. internalerror(2014010312);
  5288. result:=implprocdefinfo^.forwarddef;
  5289. end;
  5290. function tprocdef.Gethasforward: boolean;
  5291. begin
  5292. if not assigned(implprocdefinfo) then
  5293. internalerror(2014010313);
  5294. result:=implprocdefinfo^.hasforward;
  5295. end;
  5296. function tprocdef.Getinterfacedef: boolean;
  5297. begin
  5298. if not assigned(implprocdefinfo) then
  5299. internalerror(2014010314);
  5300. result:=implprocdefinfo^.interfacedef;
  5301. end;
  5302. procedure tprocdef.Setforwarddef(AValue: boolean);
  5303. begin
  5304. if not assigned(implprocdefinfo) then
  5305. internalerror(2014010315);
  5306. implprocdefinfo^.forwarddef:=AValue;
  5307. end;
  5308. procedure tprocdef.Sethasforward(AValue: boolean);
  5309. begin
  5310. if not assigned(implprocdefinfo) then
  5311. internalerror(2014010316);
  5312. implprocdefinfo^.hasforward:=AValue;
  5313. end;
  5314. function tprocdef.GetIsEmpty: boolean;
  5315. begin
  5316. result:=pio_empty in implprocoptions;
  5317. end;
  5318. procedure tprocdef.SetIsEmpty(AValue: boolean);
  5319. begin
  5320. if AValue then
  5321. include(implprocoptions,pio_empty)
  5322. else
  5323. exclude(implprocoptions,pio_empty);
  5324. end;
  5325. function tprocdef.GetHasInliningInfo: boolean;
  5326. begin
  5327. result:=pio_has_inlininginfo in implprocoptions;
  5328. end;
  5329. procedure tprocdef.SetHasInliningInfo(AValue: boolean);
  5330. begin
  5331. if AValue then
  5332. include(implprocoptions,pio_has_inlininginfo)
  5333. else
  5334. exclude(implprocoptions,pio_has_inlininginfo);
  5335. end;
  5336. procedure tprocdef.Setinterfacedef(AValue: boolean);
  5337. begin
  5338. if not assigned(implprocdefinfo) then
  5339. internalerror(2014010317);
  5340. implprocdefinfo^.interfacedef:=AValue;
  5341. end;
  5342. procedure tprocdef.Setprocstarttai(AValue: tai);
  5343. begin
  5344. if not assigned(implprocdefinfo) then
  5345. internalerror(2014010318);
  5346. implprocdefinfo^.procstarttai:=AValue;
  5347. end;
  5348. procedure tprocdef.SetParentFPStruct(AValue: tsym);
  5349. begin
  5350. if not assigned(implprocdefinfo) then
  5351. internalerror(2014010319);
  5352. implprocdefinfo^.parentfpstruct:=AValue;
  5353. end;
  5354. procedure tprocdef.SetParentFPStructPtrType(AValue: tdef);
  5355. begin
  5356. if not assigned(implprocdefinfo) then
  5357. internalerror(2014010320);
  5358. implprocdefinfo^.parentfpstructptrtype:=AValue;
  5359. end;
  5360. constructor tprocdef.create(level:byte;doregister:boolean);
  5361. begin
  5362. inherited create(procdef,level,doregister);
  5363. implprocdefinfo:=allocmem(sizeof(implprocdefinfo^));
  5364. localst:=tlocalsymtable.create(self,parast.symtablelevel);
  5365. {$ifdef symansistr}
  5366. _mangledname:='';
  5367. {$else symansistr}
  5368. _mangledname:=nil;
  5369. {$endif symansistr}
  5370. {$ifndef DISABLE_FAST_OVERLOAD_PATCH}
  5371. seenmarker := nil;
  5372. {$endif}
  5373. fileinfo:=current_filepos;
  5374. extnumber:=$ffff;
  5375. aliasnames:=TCmdStrList.create;
  5376. funcretsym:=nil;
  5377. funcretsymderef.reset;
  5378. procsymderef.reset;
  5379. forwarddef:=true;
  5380. interfacedef:=false;
  5381. hasforward:=false;
  5382. struct := nil;
  5383. structderef.reset;
  5384. import_dll:=nil;
  5385. import_name:=nil;
  5386. import_nr:=0;
  5387. inlininginfo:=nil;
  5388. deprecatedmsg:=nil;
  5389. genericdecltokenbuf:=nil;
  5390. if cs_opt_fastmath in current_settings.optimizerswitches then
  5391. include(implprocoptions, pio_fastmath);
  5392. end;
  5393. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  5394. var
  5395. i,aliasnamescount,sizeleft : longint;
  5396. level : byte;
  5397. buf : array[0..255] of byte;
  5398. begin
  5399. inherited ppuload(procdef,ppufile);
  5400. {$ifdef symansistr}
  5401. if po_has_mangledname in procoptions then
  5402. _mangledname:=ppufile.getansistring
  5403. else
  5404. _mangledname:='';
  5405. {$else symansistr}
  5406. if po_has_mangledname in procoptions then
  5407. _mangledname:=ppufile.getpshortstring
  5408. else
  5409. _mangledname:=nil;
  5410. {$endif symansistr}
  5411. extnumber:=ppufile.getword;
  5412. level:=ppufile.getbyte;
  5413. ppufile.getderef(structderef);
  5414. ppufile.getderef(procsymderef);
  5415. ppufile.getposinfo(fileinfo);
  5416. visibility:=tvisibility(ppufile.getbyte);
  5417. ppufile.getset(tppuset2(symoptions));
  5418. if sp_has_deprecated_msg in symoptions then
  5419. deprecatedmsg:=ppufile.getpshortstring
  5420. else
  5421. deprecatedmsg:=nil;
  5422. { import stuff }
  5423. if po_has_importdll in procoptions then
  5424. import_dll:=ppufile.getpshortstring
  5425. else
  5426. import_dll:=nil;
  5427. if po_has_importname in procoptions then
  5428. import_name:=ppufile.getpshortstring
  5429. else
  5430. import_name:=nil;
  5431. import_nr:=ppufile.getword;
  5432. if (po_msgint in procoptions) then
  5433. messageinf.i:=ppufile.getlongint;
  5434. if (po_msgstr in procoptions) then
  5435. messageinf.str:=ppufile.getpshortstring;
  5436. if (po_dispid in procoptions) then
  5437. dispid:=ppufile.getlongint;
  5438. { inline stuff }
  5439. ppufile.getset(tppuset1(implprocoptions));
  5440. if has_inlininginfo then
  5441. begin
  5442. ppufile.getderef(funcretsymderef);
  5443. new(inlininginfo);
  5444. ppufile.getset(tppuset4(inlininginfo^.flags));
  5445. end
  5446. else
  5447. begin
  5448. inlininginfo:=nil;
  5449. funcretsym:=nil;
  5450. end;
  5451. aliasnames:=TCmdStrList.create;
  5452. { count alias names }
  5453. aliasnamescount:=ppufile.getbyte;
  5454. for i:=1 to aliasnamescount do
  5455. aliasnames.insert(ppufile.getstring);
  5456. { load the token stream containing the declaration }
  5457. sizeleft:=ppufile.getlongint;
  5458. if sizeleft>0 then
  5459. begin
  5460. init_genericdecl;
  5461. while sizeleft>0 do
  5462. begin
  5463. if sizeleft>sizeof(buf) then
  5464. i:=sizeof(buf)
  5465. else
  5466. i:=sizeleft;
  5467. ppufile.getdata(buf,i);
  5468. genericdecltokenbuf.write(buf,i);
  5469. dec(sizeleft,i);
  5470. end;
  5471. end;
  5472. ppuload_platform(ppufile);
  5473. { load para symtable }
  5474. parast:=tparasymtable.create(self,level);
  5475. tparasymtable(parast).ppuload(ppufile);
  5476. { load local symtable }
  5477. if store_localst then
  5478. begin
  5479. localst:=tlocalsymtable.create(self,level);
  5480. tlocalsymtable(localst).ppuload(ppufile);
  5481. end
  5482. else
  5483. localst:=nil;
  5484. { inline stuff }
  5485. if has_inlininginfo then
  5486. inlininginfo^.code:=ppuloadnodetree(ppufile);
  5487. { default values for no persistent data }
  5488. if (cs_link_deffile in current_settings.globalswitches) and
  5489. (tf_need_export in target_info.flags) and
  5490. (po_exports in procoptions) then
  5491. deffile.AddExport(mangledname);
  5492. { Disable po_has_inlining until the derefimpl is done }
  5493. has_inlininginfo:=false;
  5494. end;
  5495. destructor tprocdef.destroy;
  5496. begin
  5497. aliasnames.free;
  5498. aliasnames:=nil;
  5499. if assigned(localst) and
  5500. (localst.symtabletype<>staticsymtable) then
  5501. begin
  5502. {$ifdef MEMDEBUG}
  5503. memproclocalst.start;
  5504. {$endif MEMDEBUG}
  5505. localst.free;
  5506. localst:=nil;
  5507. {$ifdef MEMDEBUG}
  5508. memproclocalst.start;
  5509. {$endif MEMDEBUG}
  5510. end;
  5511. if assigned(inlininginfo) then
  5512. begin
  5513. {$ifdef MEMDEBUG}
  5514. memprocnodetree.start;
  5515. {$endif MEMDEBUG}
  5516. tnode(inlininginfo^.code).free;
  5517. {$ifdef MEMDEBUG}
  5518. memprocnodetree.start;
  5519. {$endif MEMDEBUG}
  5520. dispose(inlininginfo);
  5521. inlininginfo:=nil;
  5522. end;
  5523. freeimplprocdefinfo;
  5524. genericdecltokenbuf.free;
  5525. genericdecltokenbuf:=nil;
  5526. stringdispose(import_dll);
  5527. stringdispose(import_name);
  5528. stringdispose(deprecatedmsg);
  5529. if (po_msgstr in procoptions) then
  5530. stringdispose(messageinf.str);
  5531. {$ifndef symansistr}
  5532. if assigned(_mangledname) then
  5533. begin
  5534. {$ifdef MEMDEBUG}
  5535. memmanglednames.start;
  5536. {$endif MEMDEBUG}
  5537. stringdispose(_mangledname);
  5538. {$ifdef MEMDEBUG}
  5539. memmanglednames.stop;
  5540. {$endif MEMDEBUG}
  5541. end;
  5542. {$endif symansistr}
  5543. inherited destroy;
  5544. end;
  5545. procedure tprocdef.freeimplprocdefinfo;
  5546. begin
  5547. if assigned(implprocdefinfo) then
  5548. begin
  5549. stringdispose(implprocdefinfo^.resultname);
  5550. freemem(implprocdefinfo);
  5551. implprocdefinfo:=nil;
  5552. end;
  5553. end;
  5554. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  5555. var
  5556. oldintfcrc : boolean;
  5557. aliasnamescount,i,sizeleft : longint;
  5558. item : TCmdStrListItem;
  5559. buf : array[0..255] of byte;
  5560. begin
  5561. { released procdef? }
  5562. if not assigned(parast) then
  5563. exit;
  5564. inherited ppuwrite(ppufile);
  5565. {$ifdef symansistr}
  5566. if po_has_mangledname in procoptions then
  5567. ppufile.putansistring(_mangledname);
  5568. {$else symansistr}
  5569. if po_has_mangledname in procoptions then
  5570. ppufile.putstring(_mangledname^);
  5571. {$endif symansistr}
  5572. ppufile.putword(extnumber);
  5573. ppufile.putbyte(parast.symtablelevel);
  5574. ppufile.putderef(structderef);
  5575. ppufile.putderef(procsymderef);
  5576. ppufile.putposinfo(fileinfo);
  5577. ppufile.putbyte(byte(visibility));
  5578. ppufile.putset(tppuset2(symoptions));
  5579. if sp_has_deprecated_msg in symoptions then
  5580. ppufile.putstring(deprecatedmsg^);
  5581. { import }
  5582. if po_has_importdll in procoptions then
  5583. ppufile.putstring(import_dll^);
  5584. if po_has_importname in procoptions then
  5585. ppufile.putstring(import_name^);
  5586. ppufile.putword(import_nr);
  5587. if (po_msgint in procoptions) then
  5588. ppufile.putlongint(messageinf.i);
  5589. if (po_msgstr in procoptions) then
  5590. ppufile.putstring(messageinf.str^);
  5591. if (po_dispid in procoptions) then
  5592. ppufile.putlongint(dispid);
  5593. { inline stuff }
  5594. oldintfcrc:=ppufile.do_crc;
  5595. ppufile.do_crc:=false;
  5596. ppufile.putset(tppuset1(implprocoptions));
  5597. if has_inlininginfo then
  5598. begin
  5599. ppufile.putderef(funcretsymderef);
  5600. ppufile.putset(tppuset4(inlininginfo^.flags));
  5601. end;
  5602. { count alias names }
  5603. aliasnamescount:=0;
  5604. item:=TCmdStrListItem(aliasnames.first);
  5605. while assigned(item) do
  5606. begin
  5607. inc(aliasnamescount);
  5608. item:=TCmdStrListItem(item.next);
  5609. end;
  5610. if aliasnamescount>255 then
  5611. internalerror(200711021);
  5612. ppufile.putbyte(aliasnamescount);
  5613. item:=TCmdStrListItem(aliasnames.first);
  5614. while assigned(item) do
  5615. begin
  5616. ppufile.putstring(item.str);
  5617. item:=TCmdStrListItem(item.next);
  5618. end;
  5619. ppufile.do_crc:=oldintfcrc;
  5620. { generic tokens for the declaration }
  5621. if assigned(genericdecltokenbuf) and (genericdecltokenbuf.size>0) then
  5622. begin
  5623. sizeleft:=genericdecltokenbuf.size;
  5624. genericdecltokenbuf.seek(0);
  5625. ppufile.putlongint(sizeleft);
  5626. while sizeleft>0 do
  5627. begin
  5628. if sizeleft>sizeof(buf) then
  5629. i:=sizeof(buf)
  5630. else
  5631. i:=sizeleft;
  5632. genericdecltokenbuf.read(buf,i);
  5633. ppufile.putdata(buf,i);
  5634. dec(sizeleft,i);
  5635. end;
  5636. end
  5637. else
  5638. ppufile.putlongint(0);
  5639. { write this entry }
  5640. writeentry(ppufile,ibprocdef);
  5641. { Save the para symtable, this is taken from the interface }
  5642. tparasymtable(parast).ppuwrite(ppufile);
  5643. { save localsymtable for inline procedures or when local
  5644. browser info is requested, this has no influence on the crc }
  5645. if store_localst and not ppufile.crc_only then
  5646. begin
  5647. oldintfcrc:=ppufile.do_crc;
  5648. ppufile.do_crc:=false;
  5649. tlocalsymtable(localst).ppuwrite(ppufile);
  5650. ppufile.do_crc:=oldintfcrc;
  5651. end;
  5652. { node tree for inlining }
  5653. oldintfcrc:=ppufile.do_crc;
  5654. ppufile.do_crc:=false;
  5655. if has_inlininginfo then
  5656. ppuwritenodetree(ppufile,inlininginfo^.code);
  5657. ppufile.do_crc:=oldintfcrc;
  5658. end;
  5659. function tprocdef.fullprocname(showhidden:boolean):string;
  5660. var
  5661. pno: tprocnameoptions;
  5662. begin
  5663. pno:=[];
  5664. if showhidden then
  5665. include(pno,pno_showhidden);
  5666. result:=customprocname(pno);
  5667. end;
  5668. function tprocdef.customprocname(pno: tprocnameoptions):ansistring;
  5669. var
  5670. s, rn : ansistring;
  5671. t : ttoken;
  5672. syssym : tsyssym;
  5673. begin
  5674. {$ifdef EXTDEBUG}
  5675. include(pno,pno_showhidden);
  5676. {$endif EXTDEBUG}
  5677. s:='';
  5678. if proctypeoption=potype_operator then
  5679. begin
  5680. for t:=NOTOKEN to last_overloaded do
  5681. if procsym.realname='$'+overloaded_names[t] then
  5682. begin
  5683. s:='operator ';
  5684. if (pno_ownername in pno) and
  5685. assigned(struct) then
  5686. s:=s+struct.RttiName+'.';
  5687. s:=s+arraytokeninfo[t].str;
  5688. if not (pno_noparams in pno) then
  5689. s:=s+typename_paras(pno);
  5690. break;
  5691. end;
  5692. end
  5693. else
  5694. begin
  5695. if (po_classmethod in procoptions) and
  5696. not(pno_noclassmarker in pno) then
  5697. s:='class ';
  5698. case proctypeoption of
  5699. potype_constructor,
  5700. potype_class_constructor:
  5701. s:=s+'constructor ';
  5702. potype_class_destructor,
  5703. potype_destructor:
  5704. s:=s+'destructor ';
  5705. else
  5706. if (pno_proctypeoption in pno) then
  5707. begin
  5708. if assigned(returndef) and
  5709. not(is_void(returndef)) then
  5710. s:=s+'function '
  5711. else
  5712. s:=s+'procedure ';
  5713. end;
  5714. end;
  5715. if (pno_ownername in pno) and
  5716. (owner.symtabletype in [recordsymtable,objectsymtable]) then
  5717. s:=s+tabstractrecorddef(owner.defowner).RttiName+'.';
  5718. if (po_compilerproc in procoptions) and (extnumber<>$ffff) then
  5719. begin
  5720. syssym:=tsyssym.find_by_number(extnumber);
  5721. if not assigned(syssym) then
  5722. internalerror(2016060305);
  5723. rn:=syssym.realname;
  5724. end
  5725. else
  5726. rn:=procsym.realname;
  5727. if (pno_noleadingdollar in pno) and
  5728. (rn[1]='$') then
  5729. delete(rn,1,1);
  5730. s:=s+rn;
  5731. if not (pno_noparams in pno) then
  5732. s:=s+typename_paras(pno);
  5733. end;
  5734. if not(proctypeoption in [potype_constructor,potype_destructor,
  5735. potype_class_constructor,potype_class_destructor]) and
  5736. assigned(returndef) and
  5737. not(is_void(returndef)) then
  5738. s:=s+':'+returndef.GetTypeName;
  5739. if assigned(owner) and (owner.symtabletype=localsymtable) then
  5740. s:=s+' is nested'
  5741. else if po_is_block in procoptions then
  5742. s:=s+' is block';
  5743. s:=s+';';
  5744. if po_far in procoptions then
  5745. s:=s+' far;';
  5746. { forced calling convention? }
  5747. if (po_hascallingconvention in procoptions) then
  5748. s:=s+' '+ProcCallOptionStr[proccalloption]+';';
  5749. if (po_staticmethod in procoptions) and
  5750. not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
  5751. s:=s+' Static;';
  5752. if pno_mangledname in pno then
  5753. s:=s+' -- mangled name: '+mangledname;
  5754. customprocname:=s;
  5755. end;
  5756. function tprocdef.is_methodpointer:boolean;
  5757. begin
  5758. { don't check assigned(_class), that's also the case for nested
  5759. procedures inside methods }
  5760. result:=(owner.symtabletype=ObjectSymtable)and not no_self_node;
  5761. end;
  5762. function tprocdef.is_addressonly:boolean;
  5763. begin
  5764. result:=assigned(owner) and
  5765. not is_methodpointer and
  5766. (not(m_nested_procvars in current_settings.modeswitches) or
  5767. not is_nested_pd(self));
  5768. end;
  5769. procedure tprocdef.make_external;
  5770. begin
  5771. include(procoptions,po_external);
  5772. forwarddef:=false;
  5773. end;
  5774. procedure tprocdef.init_genericdecl;
  5775. begin
  5776. if assigned(genericdecltokenbuf) then
  5777. internalerror(2015061901);
  5778. genericdecltokenbuf:=tdynamicarray.create(256);
  5779. end;
  5780. function tprocdef.get_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean;
  5781. begin
  5782. result:=false;
  5783. if proctypeoption=potype_constructor then
  5784. begin
  5785. result:=true;
  5786. ressym:=tsym(parast.Find('self'));
  5787. resdef:=tabstractnormalvarsym(ressym).vardef;
  5788. { and TP-style constructors return a pointer to self }
  5789. if is_object(resdef) then
  5790. resdef:=cpointerdef.getreusable(resdef);
  5791. end
  5792. else if (proccalloption=pocall_safecall) and
  5793. (tf_safecall_exceptions in target_info.flags) then
  5794. begin
  5795. result:=true;
  5796. ressym:=tsym(localst.Find('safecallresult'));
  5797. resdef:=tabstractnormalvarsym(ressym).vardef;
  5798. end
  5799. else if not is_void(returndef) then
  5800. begin
  5801. result:=true;
  5802. ressym:=funcretsym;
  5803. resdef:=tabstractnormalvarsym(ressym).vardef;
  5804. end;
  5805. end;
  5806. function tprocdef.get_safecall_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean;
  5807. begin
  5808. result:=false;
  5809. if (proctypeoption<>potype_constructor) and
  5810. (proccalloption=pocall_safecall) and
  5811. (tf_safecall_exceptions in target_info.flags) then
  5812. begin
  5813. result:=true;
  5814. ressym:=tsym(localst.Find('safecallresult'));
  5815. resdef:=tabstractnormalvarsym(ressym).vardef;
  5816. end
  5817. end;
  5818. function tprocdef.has_alias_name(const s: TSymStr): boolean;
  5819. var
  5820. item : TCmdStrListItem;
  5821. begin
  5822. result:=true;
  5823. if mangledname=s then
  5824. exit;
  5825. item:=TCmdStrListItem(aliasnames.first);
  5826. while assigned(item) do
  5827. begin
  5828. if item.str=s then
  5829. exit;
  5830. item:=TCmdStrListItem(item.next);
  5831. end;
  5832. result:=false;
  5833. end;
  5834. function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
  5835. begin
  5836. case t of
  5837. gs_local :
  5838. GetSymtable:=localst;
  5839. gs_para :
  5840. GetSymtable:=parast;
  5841. else
  5842. GetSymtable:=nil;
  5843. end;
  5844. end;
  5845. function tprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
  5846. var
  5847. j : longint;
  5848. begin
  5849. result:=inherited;
  5850. if newtyp=procvardef then
  5851. begin
  5852. { create new paralist }
  5853. tprocvardef(result).calcparas;
  5854. exit;
  5855. end;
  5856. { don't copy mangled name, can be different }
  5857. tprocdef(result).messageinf:=messageinf;
  5858. tprocdef(result).dispid:=dispid;
  5859. if po_msgstr in procoptions then
  5860. tprocdef(result).messageinf.str:=stringdup(messageinf.str^);
  5861. tprocdef(result).symoptions:=symoptions;
  5862. if assigned(deprecatedmsg) then
  5863. tprocdef(result).deprecatedmsg:=stringdup(deprecatedmsg^);
  5864. { will have to be associated with appropriate procsym }
  5865. tprocdef(result).procsym:=nil;
  5866. { don't create aliases for bare copies, nor copy the funcretsym as
  5867. the function result parameter will be inserted again if necessary
  5868. (e.g. if the calling convention is changed) }
  5869. if not(copytyp in [pc_bareproc,pc_normal_no_hidden]) then
  5870. begin
  5871. tprocdef(result).aliasnames.concatListcopy(aliasnames);
  5872. if assigned(funcretsym) then
  5873. begin
  5874. if funcretsym.owner=parast then
  5875. begin
  5876. j:=parast.symlist.indexof(funcretsym);
  5877. if j<0 then
  5878. internalerror(2011040606);
  5879. tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
  5880. end
  5881. else if funcretsym.owner=localst then
  5882. begin
  5883. { nothing to do, will be inserted for the new procdef while
  5884. parsing its body (by pdecsub.insert_funcret_local) }
  5885. end
  5886. else
  5887. internalerror(2011040605);
  5888. end;
  5889. end;
  5890. { will have to be associated with a new struct }
  5891. tprocdef(result).struct:=nil;
  5892. if assigned(implprocdefinfo) then
  5893. begin
  5894. if assigned(resultname) then
  5895. tprocdef(result).resultname:=stringdup(resultname^);
  5896. tprocdef(result).synthetickind:=synthetickind;
  5897. end;
  5898. if assigned(import_dll) then
  5899. tprocdef(result).import_dll:=stringdup(import_dll^);
  5900. if assigned(import_name) then
  5901. tprocdef(result).import_name:=stringdup(import_name^);
  5902. tprocdef(result).import_nr:=import_nr;
  5903. tprocdef(result).extnumber:=$ffff;
  5904. tprocdef(result).visibility:=visibility;
  5905. { we need a separate implementation for the copied def }
  5906. tprocdef(result).forwarddef:=true;
  5907. tprocdef(result).interfacedef:=true;
  5908. { create new paralist }
  5909. tprocdef(result).calcparas;
  5910. end;
  5911. function tprocdef.getcopy: tstoreddef;
  5912. begin
  5913. result:=getcopyas(procdef,pc_normal,'');
  5914. end;
  5915. procedure tprocdef.buildderef;
  5916. begin
  5917. inherited buildderef;
  5918. structderef.build(struct);
  5919. { procsym that originaly defined this definition, should be in the
  5920. same symtable }
  5921. procsymderef.build(procsym);
  5922. end;
  5923. procedure tprocdef.buildderefimpl;
  5924. begin
  5925. inherited buildderefimpl;
  5926. { Localst is not available for main/unit init }
  5927. if store_localst and assigned(localst) then
  5928. begin
  5929. tlocalsymtable(localst).buildderef;
  5930. tlocalsymtable(localst).buildderefimpl;
  5931. end;
  5932. { inline tree }
  5933. if has_inlininginfo then
  5934. begin
  5935. funcretsymderef.build(funcretsym);
  5936. inlininginfo^.code.buildderefimpl;
  5937. end;
  5938. end;
  5939. procedure tprocdef.deref;
  5940. begin
  5941. inherited deref;
  5942. struct:=tabstractrecorddef(structderef.resolve);
  5943. { procsym that originaly defined this definition, should be in the
  5944. same symtable }
  5945. procsym:=tprocsym(procsymderef.resolve);
  5946. end;
  5947. procedure tprocdef.derefimpl;
  5948. begin
  5949. { Enable has_inlininginfo when the inlininginfo
  5950. structure is available. The has_inlininginfo was disabled
  5951. after the load, since the data was invalid }
  5952. if assigned(inlininginfo) then
  5953. has_inlininginfo:=true;
  5954. { Locals }
  5955. if store_localst and assigned(localst) then
  5956. begin
  5957. tlocalsymtable(localst).deref(false);
  5958. tlocalsymtable(localst).derefimpl(false);
  5959. end;
  5960. { Inline }
  5961. if has_inlininginfo then
  5962. begin
  5963. inlininginfo^.code.derefimpl;
  5964. { funcretsym, this is always located in the localst }
  5965. funcretsym:=tsym(funcretsymderef.resolve);
  5966. end
  5967. else
  5968. begin
  5969. { safety }
  5970. { Not safe! A unit may be reresolved after its interface has been
  5971. parsed but before its implementation has been parsed, and in that
  5972. case the funcretsym is still required!
  5973. funcretsym:=nil; }
  5974. end;
  5975. end;
  5976. function tprocdef.GetTypeName : string;
  5977. begin
  5978. GetTypeName := FullProcName(false);
  5979. end;
  5980. function tprocdef.mangledname : TSymStr;
  5981. begin
  5982. {$ifdef symansistr}
  5983. if _mangledname='' then
  5984. begin
  5985. result:=defaultmangledname;
  5986. _mangledname:=result;
  5987. end
  5988. else
  5989. result:=_mangledname;
  5990. {$else symansistr}
  5991. if not assigned(_mangledname) then
  5992. begin
  5993. result:=defaultmangledname;
  5994. _mangledname:=stringdup(mangledname);
  5995. end
  5996. else
  5997. result:=_mangledname^;
  5998. {$endif symansistr}
  5999. end;
  6000. function tprocdef.defaultmangledname: TSymStr;
  6001. var
  6002. n : TSymStr;
  6003. begin
  6004. n:=procsym.name;
  6005. { make sure that the mangled names of these overloadable methods types is
  6006. unique even if it's made lowercase (e.g. for section names) }
  6007. if proctypeoption in [potype_operator,potype_class_constructor,potype_class_destructor] then
  6008. n:='$'+n;
  6009. { we need to use the symtable where the procsym is inserted,
  6010. because that is visible to the world }
  6011. defaultmangledname:=make_mangledname('',procsym.owner,n);
  6012. defaultmangledname:=defaultmangledname+mangledprocparanames(Length(defaultmangledname))
  6013. end;
  6014. function tprocdef.cplusplusmangledname : TSymStr;
  6015. function getcppparaname(p : tdef) : TSymStr;
  6016. const
  6017. {$ifdef NAMEMANGLING_GCC2}
  6018. ordtype2str : array[tordtype] of string[2] = (
  6019. '',
  6020. 'Uc','Us','Ui','Us','',
  6021. 'Sc','s','i','x','',
  6022. 'b','b','b','b','b','b',
  6023. 'c','w','x');
  6024. {$else NAMEMANGLING_GCC2}
  6025. ordtype2str : array[tordtype] of string[1] = (
  6026. 'v',
  6027. 'h','t','j','y','',
  6028. 'a','s','i','x','',
  6029. 'b','b','b','b','b',
  6030. 'b','b','b','b',
  6031. 'c','w','x','C');
  6032. floattype2str : array[tfloattype] of string[1] = (
  6033. 'f','d','e','e',
  6034. 'd','d','g');
  6035. {$endif NAMEMANGLING_GCC2}
  6036. var
  6037. s : TSymStr;
  6038. begin
  6039. case p.typ of
  6040. orddef:
  6041. begin
  6042. s:=ordtype2str[torddef(p).ordtype];
  6043. if s='C' then
  6044. s:=ordtype2str[range_to_basetype(torddef(p).low,torddef(p).high)];
  6045. end;
  6046. pointerdef:
  6047. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  6048. {$ifndef NAMEMANGLING_GCC2}
  6049. floatdef:
  6050. s:=floattype2str[tfloatdef(p).floattype];
  6051. {$endif NAMEMANGLING_GCC2}
  6052. else
  6053. internalerror(2103001);
  6054. end;
  6055. getcppparaname:=s;
  6056. end;
  6057. var
  6058. s,s2 : TSymStr;
  6059. hp : TParavarsym;
  6060. i : integer;
  6061. begin
  6062. {$ifdef NAMEMANGLING_GCC2}
  6063. { outdated gcc 2.x name mangling scheme }
  6064. s := procsym.realname;
  6065. if procsym.owner.symtabletype=ObjectSymtable then
  6066. begin
  6067. s2:=upper(tobjectdef(procsym.owner.defowner).objrealname^);
  6068. case proctypeoption of
  6069. potype_destructor:
  6070. s:='_$_'+tostr(length(s2))+s2;
  6071. potype_constructor:
  6072. s:='___'+tostr(length(s2))+s2;
  6073. else
  6074. s:='_'+s+'__'+tostr(length(s2))+s2;
  6075. end;
  6076. end
  6077. else s:=s+'__';
  6078. s:=s+'F';
  6079. { concat modifiers }
  6080. { !!!!! }
  6081. { now we handle the parameters }
  6082. if maxparacount>0 then
  6083. begin
  6084. for i:=0 to paras.count-1 do
  6085. begin
  6086. hp:=tparavarsym(paras[i]);
  6087. { no hidden parameters form part of a C++ mangled name:
  6088. a) self is not included
  6089. b) there are no "high" or other hidden parameters
  6090. }
  6091. if vo_is_hidden_para in hp.varoptions then
  6092. continue;
  6093. s2:=getcppparaname(hp.vardef);
  6094. if hp.varspez in [vs_var,vs_out] then
  6095. s2:='R'+s2;
  6096. s:=s+s2;
  6097. end;
  6098. end
  6099. else
  6100. s:=s+'v';
  6101. cplusplusmangledname:=s;
  6102. {$else NAMEMANGLING_GCC2}
  6103. { gcc 3.x and 4.x name mangling scheme }
  6104. { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling }
  6105. if procsym.owner.symtabletype=ObjectSymtable then
  6106. begin
  6107. s:='_ZN';
  6108. s2:=tobjectdef(procsym.owner.defowner).objextname^;
  6109. s:=s+tostr(length(s2))+s2;
  6110. case proctypeoption of
  6111. potype_constructor:
  6112. s:=s+'C1';
  6113. potype_destructor:
  6114. s:=s+'D1';
  6115. else
  6116. s:=s+tostr(length(procsym.realname))+procsym.realname;
  6117. end;
  6118. s:=s+'E';
  6119. end
  6120. else
  6121. s:=procsym.realname;
  6122. { now we handle the parameters }
  6123. if maxparacount>0 then
  6124. begin
  6125. for i:=0 to paras.count-1 do
  6126. begin
  6127. hp:=tparavarsym(paras[i]);
  6128. { no hidden parameters form part of a C++ mangled name:
  6129. a) self is not included
  6130. b) there are no "high" or other hidden parameters
  6131. }
  6132. if vo_is_hidden_para in hp.varoptions then
  6133. continue;
  6134. s2:=getcppparaname(hp.vardef);
  6135. if hp.varspez in [vs_var,vs_out] then
  6136. s2:='R'+s2;
  6137. s:=s+s2;
  6138. end;
  6139. end
  6140. else
  6141. s:=s+'v';
  6142. cplusplusmangledname:=s;
  6143. {$endif NAMEMANGLING_GCC2}
  6144. end;
  6145. function tprocdef.objcmangledname : TSymStr;
  6146. var
  6147. manglednamelen: longint;
  6148. iscatmethod : boolean;
  6149. begin
  6150. if not (po_msgstr in procoptions) then
  6151. internalerror(2009030901);
  6152. { we may very well need longer strings to handle these... }
  6153. manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+
  6154. length('+"[ ]"')+length(messageinf.str^);
  6155. iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions;
  6156. if (iscatmethod) then
  6157. inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()'));
  6158. if manglednamelen>255 then
  6159. Message1(parser_e_objc_message_name_too_long,messageinf.str^);
  6160. if not(po_classmethod in procoptions) then
  6161. result:='"-['
  6162. else
  6163. result:='"+[';
  6164. { quotes are necessary because the +/- otherwise confuse the assembler
  6165. into expecting a number
  6166. }
  6167. if iscatmethod then
  6168. result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'(';
  6169. result:=result+tobjectdef(procsym.owner.defowner).objextname^;
  6170. if iscatmethod then
  6171. result:=result+')';
  6172. result:=result+' '+messageinf.str^+']"';
  6173. end;
  6174. procedure tprocdef.setmangledname(const s : TSymStr);
  6175. begin
  6176. { This is not allowed anymore, the forward declaration
  6177. already needs to create the correct mangledname, no changes
  6178. afterwards are allowed (PFV) }
  6179. { Exception: interface definitions in mode macpas, since in that }
  6180. { case no reference to the old name can exist yet (JM) }
  6181. {$ifdef symansistr}
  6182. if _mangledname<>'' then
  6183. if ((m_mac in current_settings.modeswitches) and
  6184. (interfacedef)) then
  6185. _mangledname:=''
  6186. else
  6187. internalerror(200411171);
  6188. {$else symansistr}
  6189. if assigned(_mangledname) then
  6190. if ((m_mac in current_settings.modeswitches) and
  6191. (interfacedef)) then
  6192. stringdispose(_mangledname)
  6193. else
  6194. internalerror(200411171);
  6195. {$endif symansistr}
  6196. {$ifdef jvm}
  6197. { this routine can be called for compilerproces. can't set mangled
  6198. name since it must be calculated, but it uses import_name when set
  6199. -> set that one }
  6200. import_name:=stringdup(s);
  6201. include(procoptions,po_has_importname);
  6202. include(procoptions,po_has_mangledname);
  6203. {$else}
  6204. {$ifdef symansistr}
  6205. _mangledname:=s;
  6206. {$else symansistr}
  6207. _mangledname:=stringdup(s);
  6208. {$endif symansistr}
  6209. {$endif jvm}
  6210. include(procoptions,po_has_mangledname);
  6211. end;
  6212. function tprocdef.needsglobalasmsym: boolean;
  6213. begin
  6214. result:=
  6215. (cs_profile in current_settings.moduleswitches) or
  6216. { smart linking using a library requires to promote
  6217. all non-nested procedures to AB_GLOBAL
  6218. otherwise you get undefined symbol error at linking
  6219. for msdos target with -CX option for instance }
  6220. (create_smartlink_library and not is_nested_pd(self)) or
  6221. (po_global in procoptions);
  6222. end;
  6223. procedure tprocdef.setcompilerprocname;
  6224. begin
  6225. procsym.realname:='$'+lower(procsym.name);
  6226. end;
  6227. {***************************************************************************
  6228. TPROCVARDEF
  6229. ***************************************************************************}
  6230. constructor tprocvardef.create(level:byte);
  6231. begin
  6232. inherited create(procvardef,level,true);
  6233. end;
  6234. class function tprocvardef.getreusableprocaddr(def: tabstractprocdef; copytyp: tcacheableproccopytyp): tprocvardef;
  6235. var
  6236. res: PHashSetItem;
  6237. oldsymtablestack: tsymtablestack;
  6238. key: packed record
  6239. def: tabstractprocdef;
  6240. copytyp: tcacheableproccopytyp;
  6241. end;
  6242. begin
  6243. if not assigned(current_module) then
  6244. internalerror(2011081302);
  6245. key.def:=def;
  6246. key.copytyp:=copytyp;
  6247. res:=current_module.procaddrdefs.FindOrAdd(@key,sizeof(key));
  6248. if not assigned(res^.Data) then
  6249. begin
  6250. { since these pointerdefs can be reused anywhere in the current
  6251. unit, add them to the global/staticsymtable (or local symtable
  6252. if they're a local def, because otherwise they'll be saved
  6253. to the ppu referencing a local symtable entry that doesn't
  6254. exist in the ppu) }
  6255. oldsymtablestack:=symtablestack;
  6256. { do not simply push/pop current_module.localsymtable, because
  6257. that can have side-effects (e.g., it removes helpers) }
  6258. symtablestack:=nil;
  6259. result:=tprocvardef(def.getcopyas(procvardef,copytyp,''));
  6260. setup_reusable_def(def,result,res,oldsymtablestack);
  6261. { res^.Data may still be nil -> don't overwrite result }
  6262. exit;
  6263. end;
  6264. result:=tprocvardef(res^.Data);
  6265. end;
  6266. class function tprocvardef.getreusableprocaddr_no_free(def: tabstractprocdef): tprocvardef;
  6267. begin
  6268. result:=getreusableprocaddr(def,pc_address_only);
  6269. if not result.is_registered then
  6270. include(result.defoptions,df_not_registered_no_free);
  6271. end;
  6272. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  6273. begin
  6274. inherited ppuload(procvardef,ppufile);
  6275. { load para symtable }
  6276. parast:=tparasymtable.create(self,ppufile.getbyte);
  6277. ppuload_platform(ppufile);
  6278. tparasymtable(parast).ppuload(ppufile);
  6279. end;
  6280. function tprocvardef.getcopy : tstoreddef;
  6281. var
  6282. i : tcallercallee;
  6283. j : longint;
  6284. begin
  6285. result:=cprocvardef.create(parast.symtablelevel);
  6286. tprocvardef(result).returndef:=returndef;
  6287. tprocvardef(result).returndefderef:=returndefderef;
  6288. tprocvardef(result).parast:=parast.getcopy;
  6289. tprocvardef(result).savesize:=savesize;
  6290. { create paralist copy }
  6291. calcparas;
  6292. tprocvardef(result).paras:=tparalist.create(false);
  6293. tprocvardef(result).paras.count:=paras.count;
  6294. for j:=0 to paras.count-1 do
  6295. tprocvardef(result).paras[j]:=paras[j];
  6296. tprocvardef(result).proctypeoption:=proctypeoption;
  6297. tprocvardef(result).proccalloption:=proccalloption;
  6298. tprocvardef(result).procoptions:=procoptions;
  6299. tprocvardef(result).callerargareasize:=callerargareasize;
  6300. tprocvardef(result).calleeargareasize:=calleeargareasize;
  6301. tprocvardef(result).maxparacount:=maxparacount;
  6302. tprocvardef(result).minparacount:=minparacount;
  6303. for i:=low(funcretloc) to high(funcretloc) do
  6304. tprocvardef(result).funcretloc[i]:=funcretloc[i].getcopy;
  6305. tprocvardef(result).has_paraloc_info:=has_paraloc_info;
  6306. {$ifdef m68k}
  6307. tprocvardef(result).exp_funcretloc:=exp_funcretloc;
  6308. {$endif}
  6309. end;
  6310. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  6311. begin
  6312. inherited ppuwrite(ppufile);
  6313. { Save the para symtable level (necessary to distinguish nested
  6314. procvars) }
  6315. ppufile.putbyte(parast.symtablelevel);
  6316. { Write this entry }
  6317. writeentry(ppufile,ibprocvardef);
  6318. { Save the para symtable, this is taken from the interface }
  6319. tparasymtable(parast).ppuwrite(ppufile);
  6320. end;
  6321. function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
  6322. begin
  6323. case t of
  6324. gs_para :
  6325. GetSymtable:=parast;
  6326. else
  6327. GetSymtable:=nil;
  6328. end;
  6329. end;
  6330. function tprocvardef.size : asizeint;
  6331. begin
  6332. { we return false for is_addressonly for a block (because it's not a
  6333. simple pointer to a function), but they are handled as implicit
  6334. pointers to a datastructure that contains everything ->
  6335. voidpointertype.size instead of voidcodepointertype.size }
  6336. if po_is_block in procoptions then
  6337. size:=voidpointertype.size
  6338. else if not is_addressonly then
  6339. begin
  6340. if is_nested_pd(self) then
  6341. size:=voidcodepointertype.size+parentfpvoidpointertype.size
  6342. else
  6343. size:=voidcodepointertype.size+voidpointertype.size;
  6344. end
  6345. else
  6346. size:=voidcodepointertype.size;
  6347. end;
  6348. function tprocvardef.is_methodpointer:boolean;
  6349. begin
  6350. result:=(po_methodpointer in procoptions);
  6351. end;
  6352. function tprocvardef.is_addressonly:boolean;
  6353. begin
  6354. result:=((not(po_methodpointer in procoptions) or (po_staticmethod in procoptions)) and
  6355. not(po_is_block in procoptions) and
  6356. not is_nested_pd(self)) or
  6357. (po_addressonly in procoptions);
  6358. end;
  6359. function tprocvardef.getmangledparaname:TSymStr;
  6360. begin
  6361. if not(po_methodpointer in procoptions) then
  6362. if not is_nested_pd(self) then
  6363. result:='procvar'
  6364. else
  6365. { we need the manglednames here, because nestedprocvars can be anonymous, e.g.
  6366. having not a type name or not an unique one, see webtbs/tw27515.pp
  6367. Further, use $_ ... _$ delimiters to avoid ambiguous names, see webtbs/tw27515.pp }
  6368. result:='$_nestedprovar'+mangledprocparanames(0)+'_$'
  6369. else
  6370. result:='procvarofobj'
  6371. end;
  6372. function tprocvardef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
  6373. begin
  6374. result:=inherited;
  6375. tabstractprocdef(result).calcparas;
  6376. end;
  6377. function tprocvardef.is_publishable : boolean;
  6378. begin
  6379. is_publishable:=(po_methodpointer in procoptions);
  6380. end;
  6381. function tprocvardef.GetTypeName : string;
  6382. var
  6383. s: string;
  6384. pno : tprocnameoptions;
  6385. begin
  6386. {$ifdef EXTDEBUG}
  6387. pno:=[pno_showhidden];
  6388. {$else EXTDEBUG}
  6389. pno:=[];
  6390. {$endif EXTDEBUG}
  6391. s:='<';
  6392. if po_is_block in procoptions then
  6393. s := s+'reference to'
  6394. else if po_classmethod in procoptions then
  6395. s := s+'class method type of'
  6396. else
  6397. if po_addressonly in procoptions then
  6398. s := s+'address of'
  6399. else
  6400. s := s+'procedure variable type of';
  6401. if assigned(returndef) and
  6402. (returndef<>voidtype) then
  6403. s:=s+' function'+typename_paras(pno)+':'+returndef.GetTypeName
  6404. else
  6405. s:=s+' procedure'+typename_paras(pno);
  6406. if po_methodpointer in procoptions then
  6407. s := s+' of object';
  6408. if is_nested_pd(self) then
  6409. s := s+' is nested';
  6410. if po_far in procoptions then
  6411. s := s+';far';
  6412. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  6413. end;
  6414. {***************************************************************************
  6415. TOBJECTDEF
  6416. ***************************************************************************}
  6417. constructor tobjectdef.create(ot:tobjecttyp;const n:string;c:tobjectdef;doregister:boolean);
  6418. begin
  6419. inherited create(n,objectdef,doregister);
  6420. fcurrent_dispid:=0;
  6421. objecttype:=ot;
  6422. childof:=nil;
  6423. childofderef.reset;
  6424. vmt_fieldderef.reset;
  6425. extendeddefderef.reset;
  6426. cloneddefderef.reset;
  6427. if objecttype=odt_helper then
  6428. owner.includeoption(sto_has_helper);
  6429. symtable:=tObjectSymtable.create(self,n,current_settings.packrecords,
  6430. current_settings.alignment.recordalignmin);
  6431. { create space for vmt !! }
  6432. vmtentries:=TFPList.Create;
  6433. set_parent(c);
  6434. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  6435. prepareguid;
  6436. { setup implemented interfaces }
  6437. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  6438. ImplementedInterfaces:=TFPObjectList.Create(true)
  6439. else
  6440. ImplementedInterfaces:=nil;
  6441. writing_class_record_dbginfo:=false;
  6442. end;
  6443. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  6444. var
  6445. i,
  6446. implintfcount : longint;
  6447. d, getterd : tderef;
  6448. ImplIntf : TImplementedInterface;
  6449. vmtentry : pvmtentry;
  6450. begin
  6451. inherited ppuload(objectdef,ppufile);
  6452. objecttype:=tobjecttyp(ppufile.getbyte);
  6453. helpertype:=thelpertype(ppufile.getbyte);
  6454. objextname:=ppufile.getpshortstring;
  6455. { only used for external Objective-C classes/protocols }
  6456. if (objextname^='') then
  6457. stringdispose(objextname);
  6458. symtable:=tObjectSymtable.create(self,objrealname^,0,0);
  6459. tObjectSymtable(symtable).datasize:=ppufile.getasizeint;
  6460. tObjectSymtable(symtable).paddingsize:=ppufile.getword;
  6461. tObjectSymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  6462. tObjectSymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  6463. tObjectSymtable(symtable).recordalignmin:=shortint(ppufile.getbyte);
  6464. ppufile.getderef(vmt_fieldderef);
  6465. ppufile.getderef(childofderef);
  6466. { load guid }
  6467. iidstr:=nil;
  6468. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  6469. begin
  6470. new(iidguid);
  6471. ppufile.getguid(iidguid^);
  6472. iidstr:=ppufile.getpshortstring;
  6473. end;
  6474. abstractcnt:=ppufile.getlongint;
  6475. if objecttype=odt_helper then
  6476. ppufile.getderef(extendeddefderef);
  6477. vmtentries:=TFPList.Create;
  6478. vmtentries.count:=ppufile.getlongint;
  6479. for i:=0 to vmtentries.count-1 do
  6480. begin
  6481. ppufile.getderef(d);
  6482. new(vmtentry);
  6483. vmtentry^.procdef:=nil;
  6484. vmtentry^.procdefderef:=d;
  6485. vmtentry^.visibility:=tvisibility(ppufile.getbyte);
  6486. vmtentries[i]:=vmtentry;
  6487. end;
  6488. { load implemented interfaces }
  6489. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  6490. begin
  6491. ImplementedInterfaces:=TFPObjectList.Create(true);
  6492. implintfcount:=ppufile.getlongint;
  6493. for i:=0 to implintfcount-1 do
  6494. begin
  6495. ppufile.getderef(d);
  6496. ppufile.getderef(getterd);
  6497. ImplIntf:=TImplementedInterface.Create_deref(d,getterd);
  6498. ImplIntf.IOffset:=ppufile.getlongint;
  6499. byte(ImplIntf.IType):=ppufile.getbyte;
  6500. ImplementedInterfaces.Add(ImplIntf);
  6501. end;
  6502. end
  6503. else
  6504. ImplementedInterfaces:=nil;
  6505. if df_copied_def in defoptions then
  6506. begin
  6507. ppufile.getderef(cloneddefderef);
  6508. ppuload_platform(ppufile);
  6509. end
  6510. else
  6511. begin
  6512. ppuload_platform(ppufile);
  6513. tObjectSymtable(symtable).ppuload(ppufile);
  6514. end;
  6515. { handles the predefined class tobject }
  6516. { the last TOBJECT which is loaded gets }
  6517. { it ! }
  6518. if (childof=nil) and
  6519. (objecttype in [odt_class,odt_javaclass]) and
  6520. (objname^='TOBJECT') then
  6521. class_tobject:=self;
  6522. if (childof=nil) and
  6523. (objecttype=odt_interfacecom) then
  6524. if (objname^='IUNKNOWN') then
  6525. interface_iunknown:=self
  6526. else
  6527. if (objname^='IDISPATCH') then
  6528. interface_idispatch:=self;
  6529. if (childof=nil) and
  6530. (objecttype=odt_objcclass) and
  6531. (objname^='PROTOCOL') then
  6532. objc_protocoltype:=self;
  6533. if (objecttype=odt_javaclass) and
  6534. not(oo_is_formal in objectoptions) then
  6535. begin
  6536. if (objname^='JLOBJECT') then
  6537. java_jlobject:=self
  6538. else if (objname^='JLTHROWABLE') then
  6539. java_jlthrowable:=self
  6540. else if (objname^='FPCBASERECORDTYPE') then
  6541. java_fpcbaserecordtype:=self
  6542. else if (objname^='JLSTRING') then
  6543. java_jlstring:=self
  6544. else if (objname^='ANSISTRINGCLASS') then
  6545. java_ansistring:=self
  6546. else if (objname^='SHORTSTRINGCLASS') then
  6547. java_shortstring:=self
  6548. else if (objname^='JLENUM') then
  6549. java_jlenum:=self
  6550. else if (objname^='JUENUMSET') then
  6551. java_juenumset:=self
  6552. else if (objname^='FPCBITSET') then
  6553. java_jubitset:=self
  6554. else if (objname^='FPCBASEPROCVARTYPE') then
  6555. java_procvarbase:=self;
  6556. end;
  6557. writing_class_record_dbginfo:=false;
  6558. end;
  6559. destructor tobjectdef.destroy;
  6560. var
  6561. i: longint;
  6562. begin
  6563. if assigned(symtable) then
  6564. begin
  6565. symtable.free;
  6566. symtable:=nil;
  6567. end;
  6568. stringdispose(objextname);
  6569. stringdispose(iidstr);
  6570. if assigned(ImplementedInterfaces) then
  6571. begin
  6572. ImplementedInterfaces.free;
  6573. ImplementedInterfaces:=nil;
  6574. end;
  6575. if assigned(iidguid) then
  6576. begin
  6577. dispose(iidguid);
  6578. iidguid:=nil;
  6579. end;
  6580. if assigned(vmtentries) then
  6581. begin
  6582. for i:=0 to vmtentries.count-1 do
  6583. dispose(pvmtentry(vmtentries[i]));
  6584. vmtentries.free;
  6585. vmtentries:=nil;
  6586. end;
  6587. if assigned(vmcallstaticinfo) then
  6588. begin
  6589. freemem(vmcallstaticinfo);
  6590. vmcallstaticinfo:=nil;
  6591. end;
  6592. inherited destroy;
  6593. end;
  6594. function tobjectdef.getcopy : tstoreddef;
  6595. var
  6596. i : longint;
  6597. begin
  6598. result:=cobjectdef.create(objecttype,objrealname^,childof,true);
  6599. { the constructor allocates a symtable which we release to avoid memory leaks }
  6600. tobjectdef(result).symtable.free;
  6601. tobjectdef(result).symtable:=symtable.getcopy;
  6602. if assigned(objextname) then
  6603. tobjectdef(result).objextname:=stringdup(objextname^);
  6604. if assigned(import_lib) then
  6605. tobjectdef(result).import_lib:=stringdup(import_lib^);
  6606. tobjectdef(result).objectoptions:=objectoptions;
  6607. include(tobjectdef(result).defoptions,df_copied_def);
  6608. tobjectdef(result).extendeddef:=extendeddef;
  6609. if assigned(tcinitcode) then
  6610. tobjectdef(result).tcinitcode:=tcinitcode.getcopy;
  6611. tobjectdef(result).vmt_field:=vmt_field;
  6612. if assigned(iidguid) then
  6613. begin
  6614. new(tobjectdef(result).iidguid);
  6615. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  6616. end;
  6617. if assigned(iidstr) then
  6618. tobjectdef(result).iidstr:=stringdup(iidstr^);
  6619. tobjectdef(result).abstractcnt:=abstractcnt;
  6620. if assigned(ImplementedInterfaces) then
  6621. begin
  6622. for i:=0 to ImplementedInterfaces.count-1 do
  6623. tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
  6624. end;
  6625. tobjectdef(result).copyvmtentries(self);
  6626. end;
  6627. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  6628. var
  6629. i : longint;
  6630. vmtentry : pvmtentry;
  6631. ImplIntf : TImplementedInterface;
  6632. old_do_indirect_crc: boolean;
  6633. begin
  6634. { if class1 in unit A changes, and class2 in unit B inherits from it
  6635. (so unit B uses unit A), then unit B with class2 will be recompiled.
  6636. However, if there is also a class3 in unit C that only depends on
  6637. unit B, then unit C will not be recompiled because nothing changed
  6638. to the interface of unit B. Nevertheless, unit C can indirectly
  6639. depend on unit A via derefs, and these must be updated -> the
  6640. indirect crc keeps track of such changes. }
  6641. old_do_indirect_crc:=ppufile.do_indirect_crc;
  6642. ppufile.do_indirect_crc:=true;
  6643. inherited ppuwrite(ppufile);
  6644. ppufile.putbyte(byte(objecttype));
  6645. ppufile.putbyte(byte(helpertype));
  6646. if assigned(objextname) then
  6647. ppufile.putstring(objextname^)
  6648. else
  6649. ppufile.putstring('');
  6650. ppufile.putasizeint(tObjectSymtable(symtable).datasize);
  6651. ppufile.putword(tObjectSymtable(symtable).paddingsize);
  6652. ppufile.putbyte(byte(tObjectSymtable(symtable).fieldalignment));
  6653. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignment));
  6654. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignmin));
  6655. ppufile.putderef(vmt_fieldderef);
  6656. ppufile.putderef(childofderef);
  6657. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  6658. begin
  6659. ppufile.putguid(iidguid^);
  6660. ppufile.putstring(iidstr^);
  6661. end;
  6662. ppufile.putlongint(abstractcnt);
  6663. if objecttype=odt_helper then
  6664. ppufile.putderef(extendeddefderef);
  6665. ppufile.putlongint(vmtentries.count);
  6666. for i:=0 to vmtentries.count-1 do
  6667. begin
  6668. vmtentry:=pvmtentry(vmtentries[i]);
  6669. ppufile.putderef(vmtentry^.procdefderef);
  6670. ppufile.putbyte(byte(vmtentry^.visibility));
  6671. end;
  6672. if assigned(ImplementedInterfaces) then
  6673. begin
  6674. ppufile.putlongint(ImplementedInterfaces.Count);
  6675. for i:=0 to ImplementedInterfaces.Count-1 do
  6676. begin
  6677. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  6678. ppufile.putderef(ImplIntf.intfdefderef);
  6679. ppufile.putderef(ImplIntf.ImplementsGetterDeref);
  6680. ppufile.putlongint(ImplIntf.Ioffset);
  6681. ppufile.putbyte(byte(ImplIntf.IType));
  6682. end;
  6683. end;
  6684. if df_copied_def in defoptions then
  6685. ppufile.putderef(cloneddefderef);
  6686. writeentry(ppufile,ibobjectdef);
  6687. if not(df_copied_def in defoptions) then
  6688. tObjectSymtable(symtable).ppuwrite(ppufile);
  6689. ppufile.do_indirect_crc:=old_do_indirect_crc;
  6690. end;
  6691. function tobjectdef.GetTypeName:string;
  6692. begin
  6693. { in this case we will go in endless recursion, because then }
  6694. { there is no tsym associated yet with the def. It can occur }
  6695. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  6696. { instead of the actual type name }
  6697. if not assigned(typesym) then
  6698. result:='<Currently Parsed Class>'
  6699. else
  6700. result:=typesymbolprettyname;
  6701. end;
  6702. procedure tobjectdef.buildderef;
  6703. var
  6704. i : longint;
  6705. vmtentry : pvmtentry;
  6706. begin
  6707. inherited buildderef;
  6708. vmt_fieldderef.build(vmt_field);
  6709. childofderef.build(childof);
  6710. if df_copied_def in defoptions then
  6711. cloneddefderef.build(symtable.defowner)
  6712. else
  6713. tstoredsymtable(symtable).buildderef;
  6714. if objecttype=odt_helper then
  6715. extendeddefderef.build(extendeddef);
  6716. for i:=0 to vmtentries.count-1 do
  6717. begin
  6718. vmtentry:=pvmtentry(vmtentries[i]);
  6719. vmtentry^.procdefderef.build(vmtentry^.procdef);
  6720. end;
  6721. if assigned(ImplementedInterfaces) then
  6722. begin
  6723. for i:=0 to ImplementedInterfaces.count-1 do
  6724. TImplementedInterface(ImplementedInterfaces[i]).buildderef;
  6725. end;
  6726. end;
  6727. procedure tobjectdef.deref;
  6728. var
  6729. i : longint;
  6730. vmtentry : pvmtentry;
  6731. begin
  6732. inherited deref;
  6733. vmt_field:=tsym(vmt_fieldderef.resolve);
  6734. childof:=tobjectdef(childofderef.resolve);
  6735. if df_copied_def in defoptions then
  6736. begin
  6737. cloneddef:=tobjectdef(cloneddefderef.resolve);
  6738. symtable:=cloneddef.symtable.getcopy;
  6739. end
  6740. else
  6741. tstoredsymtable(symtable).deref(false);
  6742. if objecttype=odt_helper then
  6743. extendeddef:=tdef(extendeddefderef.resolve);
  6744. for i:=0 to vmtentries.count-1 do
  6745. begin
  6746. vmtentry:=pvmtentry(vmtentries[i]);
  6747. vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve);
  6748. end;
  6749. if assigned(ImplementedInterfaces) then
  6750. begin
  6751. for i:=0 to ImplementedInterfaces.count-1 do
  6752. TImplementedInterface(ImplementedInterfaces[i]).deref;
  6753. end;
  6754. end;
  6755. procedure create_class_helper_for_procdef(def: tobject; arg: pointer);
  6756. var
  6757. pd: tprocdef absolute def;
  6758. st: tsymtable;
  6759. psym: tsym;
  6760. nname: TIDString;
  6761. begin
  6762. if (tdef(def).typ<>procdef) then
  6763. exit;
  6764. { pd.owner = objcclass symtable -> defowner = objcclassdef ->
  6765. owner = symtable in which objcclassdef is defined
  6766. }
  6767. st:=pd.owner.defowner.owner;
  6768. nname:=class_helper_prefix+tprocsym(pd.procsym).name;
  6769. { check for an existing procsym with our special name }
  6770. psym:=tsym(st.find(nname));
  6771. if not assigned(psym) then
  6772. begin
  6773. psym:=cprocsym.create(nname);
  6774. { avoid warning about this symbol being unused }
  6775. psym.IncRefCount;
  6776. { don't check for duplicates:
  6777. a) we checked above
  6778. b) in case we are in the implementation section of a unit, this
  6779. will also check for this symbol in the interface section
  6780. (since you normally cannot have symbols with the same name
  6781. both interface and implementation), and it's possible to
  6782. have class helpers for the same class in the interface and
  6783. in the implementation, and they cannot be merged since only
  6784. the once in the interface must be saved to the ppu/visible
  6785. from other units }
  6786. st.insert(psym,false);
  6787. end
  6788. else if (psym.typ<>procsym) then
  6789. internalerror(2009111501);
  6790. { add ourselves to this special procsym }
  6791. tprocsym(psym).procdeflist.add(def);
  6792. end;
  6793. procedure tobjectdef.derefimpl;
  6794. begin
  6795. inherited derefimpl;
  6796. { the procdefs are not owned by the class helper procsyms, so they
  6797. are not stored/restored either -> re-add them here }
  6798. if (objecttype in [odt_objcclass,odt_objcprotocol]) or
  6799. (oo_is_classhelper in objectoptions) then
  6800. symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
  6801. end;
  6802. procedure tobjectdef.copyvmtentries(objdef:tobjectdef);
  6803. var
  6804. i : longint;
  6805. vmtentry : pvmtentry;
  6806. begin
  6807. if vmtentries.count<>0 then
  6808. internalerror(2019081401);
  6809. vmtentries.count:=objdef.vmtentries.count;
  6810. for i:=0 to objdef.vmtentries.count-1 do
  6811. begin
  6812. new(vmtentry);
  6813. vmtentry^:=pvmtentry(objdef.vmtentries[i])^;
  6814. vmtentries[i]:=vmtentry;
  6815. end;
  6816. end;
  6817. function tobjectdef.getparentdef:tdef;
  6818. begin
  6819. { TODO: Remove getparentdef hack}
  6820. { With 2 forward declared classes with the child class before the
  6821. parent class the child class is written earlier to the ppu. Leaving it
  6822. possible to have a reference to the parent class for property overriding,
  6823. but the parent class still has the childof not resolved yet (PFV) }
  6824. if childof=nil then
  6825. childof:=tobjectdef(childofderef.resolve);
  6826. result:=childof;
  6827. end;
  6828. procedure tobjectdef.prepareguid;
  6829. begin
  6830. { set up guid }
  6831. if not assigned(iidguid) then
  6832. begin
  6833. new(iidguid);
  6834. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  6835. end;
  6836. { setup iidstring }
  6837. if not assigned(iidstr) then
  6838. iidstr:=stringdup(''); { default is empty string }
  6839. end;
  6840. procedure tobjectdef.set_parent( c : tobjectdef);
  6841. begin
  6842. if assigned(childof) then
  6843. exit;
  6844. childof:=c;
  6845. if not assigned(c) then
  6846. exit;
  6847. { inherit options and status }
  6848. objectoptions:=objectoptions+(c.objectoptions*inherited_objectoptions);
  6849. { initially has the same number of abstract methods as the parent }
  6850. abstractcnt:=c.abstractcnt;
  6851. { add the data of the anchestor class/object }
  6852. if (objecttype in [odt_class,odt_object,odt_objcclass,odt_javaclass]) then
  6853. begin
  6854. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize+tObjectSymtable(c.symtable).datasize;
  6855. { inherit recordalignment }
  6856. tObjectSymtable(symtable).recordalignment:=tObjectSymtable(c.symtable).recordalignment;
  6857. { if both the parent and this record use C-alignment, also inherit
  6858. the current field alignment }
  6859. if (tObjectSymtable(c.symtable).usefieldalignment=C_alignment) and
  6860. (tObjectSymtable(symtable).usefieldalignment=C_alignment) then
  6861. tObjectSymtable(symtable).fieldalignment:=tObjectSymtable(c.symtable).fieldalignment;
  6862. { the padding is not inherited for Objective-C classes (maybe not
  6863. for cppclass either?) }
  6864. if objecttype=odt_objcclass then
  6865. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-tObjectSymtable(c.symtable).paddingsize;
  6866. if (oo_has_vmt in objectoptions) and
  6867. (oo_has_vmt in c.objectoptions) then
  6868. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-sizeof(pint);
  6869. { if parent has a vmt field then the offset is the same for the child PM }
  6870. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  6871. begin
  6872. vmt_field:=c.vmt_field;
  6873. include(objectoptions,oo_has_vmt);
  6874. end;
  6875. end;
  6876. end;
  6877. procedure tobjectdef.insertvmt;
  6878. begin
  6879. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  6880. exit;
  6881. if (oo_has_vmt in objectoptions) then
  6882. internalerror(2020100816)
  6883. else
  6884. begin
  6885. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,
  6886. tObjectSymtable(symtable).fieldalignment);
  6887. if (tf_requires_proper_alignment in target_info.flags) then
  6888. begin
  6889. { Align VMT pointer and whole object instance if target CPU requires alignment. }
  6890. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(pint));
  6891. tObjectSymtable(symtable).alignrecord(tObjectSymtable(symtable).datasize,sizeof(pint));
  6892. end;
  6893. vmt_field:=cfieldvarsym.create('_vptr$'+objname^,vs_value,voidpointertype,[]);
  6894. hidesym(vmt_field);
  6895. tObjectSymtable(symtable).insert(vmt_field);
  6896. tObjectSymtable(symtable).addfield(tfieldvarsym(vmt_field),vis_hidden);
  6897. include(objectoptions,oo_has_vmt);
  6898. end;
  6899. end;
  6900. function tobjectdef.vmt_offset: asizeint;
  6901. begin
  6902. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  6903. result:=0
  6904. else if (tObjectSymtable(symtable).usefieldalignment<>bit_alignment) then
  6905. result:=tfieldvarsym(vmt_field).fieldoffset
  6906. else
  6907. result:=tfieldvarsym(vmt_field).fieldoffset div 8;
  6908. end;
  6909. procedure tobjectdef.check_forwards;
  6910. begin
  6911. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol,odt_interfacejava]) then
  6912. inherited;
  6913. if (oo_is_forward in objectoptions) then
  6914. begin
  6915. { ok, in future, the forward can be resolved }
  6916. Message1(sym_e_class_forward_not_resolved,objrealname^);
  6917. exclude(objectoptions,oo_is_forward);
  6918. end;
  6919. end;
  6920. function tobjectdef.find_destructor: tprocdef;
  6921. var
  6922. objdef: tobjectdef;
  6923. begin
  6924. objdef:=self;
  6925. while assigned(objdef) do
  6926. begin
  6927. result:=objdef.find_procdef_bytype(potype_destructor);
  6928. if assigned(result) then
  6929. exit;
  6930. objdef:=objdef.childof;
  6931. end;
  6932. result:=nil;
  6933. end;
  6934. function tobjectdef.implements_any_interfaces: boolean;
  6935. begin
  6936. result := (ImplementedInterfaces.Count > 0) or
  6937. (assigned(childof) and childof.implements_any_interfaces);
  6938. end;
  6939. function tobjectdef.size : asizeint;
  6940. begin
  6941. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  6942. result:=voidpointertype.size
  6943. else
  6944. result:=tObjectSymtable(symtable).datasize;
  6945. end;
  6946. function tobjectdef.alignment:shortint;
  6947. begin
  6948. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  6949. alignment:=voidpointertype.alignment
  6950. else
  6951. alignment:=tObjectSymtable(symtable).recordalignment;
  6952. end;
  6953. function tobjectdef.vmtmethodoffset(index:longint):longint;
  6954. begin
  6955. { for offset of methods for classes, see rtl/inc/objpash.inc }
  6956. case objecttype of
  6957. odt_class:
  6958. { the +2*sizeof(pint) is size and -size }
  6959. vmtmethodoffset:=index*voidcodepointertype.size+10*voidpointertype.size+2*sizeof(pint);
  6960. odt_helper,
  6961. odt_objcclass,
  6962. odt_objcprotocol:
  6963. vmtmethodoffset:=0;
  6964. odt_interfacecom,odt_interfacecorba,odt_dispinterface:
  6965. vmtmethodoffset:=index*voidcodepointertype.size;
  6966. odt_javaclass,
  6967. odt_interfacejava:
  6968. { invalid }
  6969. vmtmethodoffset:=-1;
  6970. else
  6971. { the +2*sizeof(pint) is size and -size }
  6972. {$ifdef WITHDMT}
  6973. vmtmethodoffset:=index*voidcodepointertype.size+2*voidpointertype.size+2*sizeof(pint);
  6974. {$else WITHDMT}
  6975. vmtmethodoffset:=index*voidcodepointertype.size+1*voidpointertype.size+2*sizeof(pint);
  6976. {$endif WITHDMT}
  6977. end;
  6978. end;
  6979. function tobjectdef.vmt_mangledname : TSymStr;
  6980. begin
  6981. if not(oo_has_vmt in objectoptions) then
  6982. Message1(parser_n_object_has_no_vmt,objrealname^);
  6983. if not is_unique_objpasdef then
  6984. vmt_mangledname:=make_mangledname('VMT',owner,objname^)
  6985. else
  6986. vmt_mangledname:=childof.vmt_mangledname;
  6987. end;
  6988. function tobjectdef.vmt_def: trecorddef;
  6989. var
  6990. where: tsymtable;
  6991. vmttypesym: tsymentry;
  6992. begin
  6993. if not is_unique_objpasdef then
  6994. begin
  6995. where:=get_top_level_symtable(true);
  6996. vmttypesym:=where.Find('vmtdef$'+mangledparaname);
  6997. if not assigned(vmttypesym) or
  6998. (vmttypesym.typ<>symconst.typesym) or
  6999. (ttypesym(vmttypesym).typedef.typ<>recorddef) then
  7000. internalerror(2015052501);
  7001. result:=trecorddef(ttypesym(vmttypesym).typedef);
  7002. end
  7003. else
  7004. result:=childof.vmt_def;
  7005. end;
  7006. function tobjectdef.needs_inittable : boolean;
  7007. var
  7008. hp : tobjectdef;
  7009. begin
  7010. case objecttype of
  7011. odt_helper,
  7012. odt_class :
  7013. needs_inittable:=false;
  7014. odt_dispinterface,
  7015. odt_interfacecom:
  7016. needs_inittable:=true;
  7017. odt_interfacecorba:
  7018. begin
  7019. hp:=childof;
  7020. while assigned(hp) do
  7021. begin
  7022. if hp=interface_iunknown then
  7023. begin
  7024. needs_inittable:=true;
  7025. exit;
  7026. end;
  7027. hp:=hp.childof;
  7028. end;
  7029. needs_inittable:=false;
  7030. end;
  7031. odt_object:
  7032. needs_inittable:=
  7033. tObjectSymtable(symtable).needs_init_final or
  7034. (assigned(childof) and
  7035. childof.needs_inittable);
  7036. odt_cppclass,
  7037. odt_objcclass,
  7038. odt_objcprotocol,
  7039. odt_javaclass,
  7040. odt_interfacejava:
  7041. needs_inittable:=false;
  7042. else
  7043. internalerror(200108267);
  7044. end;
  7045. end;
  7046. function tobjectdef.needs_separate_initrtti : boolean;
  7047. begin
  7048. result:=not (objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  7049. end;
  7050. function tobjectdef.has_non_trivial_init_child(check_parent:boolean):boolean;
  7051. begin
  7052. if objecttype in [odt_class,odt_object] then
  7053. begin
  7054. result:=tobjectsymtable(symtable).has_non_trivial_init or
  7055. (check_parent and assigned(childof) and childof.has_non_trivial_init_child(true));
  7056. end
  7057. else
  7058. result:=false;
  7059. end;
  7060. function tobjectdef.rtti_mangledname(rt: trttitype): TSymStr;
  7061. begin
  7062. if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
  7063. begin
  7064. if not is_unique_objpasdef then
  7065. result:=inherited rtti_mangledname(rt)
  7066. else
  7067. result:=childof.rtti_mangledname(rt)
  7068. end
  7069. else
  7070. begin
  7071. { necessary in case of a dynamic array of nsobject, or
  7072. if an nsobject field appears in a record that needs
  7073. init/finalisation }
  7074. if rt=initrtti then
  7075. begin
  7076. result:=voidpointertype.rtti_mangledname(rt);
  7077. exit;
  7078. end;
  7079. if not(target_info.system in systems_objc_nfabi) then
  7080. begin
  7081. result:=target_asm.labelprefix;
  7082. case objecttype of
  7083. odt_objcclass:
  7084. begin
  7085. case rt of
  7086. objcclassrtti:
  7087. if not(oo_is_classhelper in objectoptions) then
  7088. result:=result+'_OBJC_CLASS_'
  7089. else
  7090. result:=result+'_OBJC_CATEGORY_';
  7091. objcmetartti:
  7092. if not(oo_is_classhelper in objectoptions) then
  7093. result:=result+'_OBJC_METACLASS_'
  7094. else
  7095. internalerror(2009111511);
  7096. else
  7097. internalerror(2009092302);
  7098. end;
  7099. end;
  7100. odt_objcprotocol:
  7101. result:=result+'_OBJC_PROTOCOL_';
  7102. else
  7103. ;
  7104. end;
  7105. end
  7106. else
  7107. begin
  7108. case objecttype of
  7109. odt_objcclass:
  7110. begin
  7111. if (oo_is_classhelper in objectoptions) and
  7112. (rt<>objcclassrtti) then
  7113. internalerror(2009111512);
  7114. case rt of
  7115. objcclassrtti:
  7116. if not(oo_is_classhelper in objectoptions) then
  7117. result:='_OBJC_CLASS_$_'
  7118. else
  7119. result:='_OBJC_$_CATEGORY_';
  7120. objcmetartti:
  7121. result:='_OBJC_METACLASS_$_';
  7122. objcclassrortti:
  7123. result:=lower(target_asm.labelprefix)+'_OBJC_CLASS_RO_$_';
  7124. objcmetarortti:
  7125. result:=lower(target_asm.labelprefix)+'_OBJC_METACLASS_RO_$_';
  7126. else
  7127. internalerror(2009092303);
  7128. end;
  7129. end;
  7130. odt_objcprotocol:
  7131. begin
  7132. result:=lower(target_asm.labelprefix);
  7133. case rt of
  7134. objcclassrtti:
  7135. result:=result+'_OBJC_PROTOCOL_$_';
  7136. objcmetartti:
  7137. result:=result+'_OBJC_LABEL_PROTOCOL_$_';
  7138. else
  7139. internalerror(2009092501);
  7140. end;
  7141. end;
  7142. else
  7143. internalerror(2013113005);
  7144. end;
  7145. end;
  7146. result:=result+objextname^;
  7147. end;
  7148. end;
  7149. function tobjectdef.is_unique_objpasdef: boolean;
  7150. begin
  7151. result:=
  7152. (df_unique in defoptions) and
  7153. is_class_or_interface_or_dispinterface(self)
  7154. end;
  7155. function tobjectdef.members_need_inittable : boolean;
  7156. begin
  7157. members_need_inittable:=tObjectSymtable(symtable).needs_init_final;
  7158. end;
  7159. function tobjectdef.is_publishable : boolean;
  7160. begin
  7161. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface];
  7162. end;
  7163. function tobjectdef.get_next_dispid: longint;
  7164. begin
  7165. inc(fcurrent_dispid);
  7166. result:=fcurrent_dispid;
  7167. end;
  7168. function tobjectdef.search_enumerator_get: tprocdef;
  7169. begin
  7170. result:=inherited;
  7171. if not assigned(result) and assigned(childof) then
  7172. result:=childof.search_enumerator_get;
  7173. end;
  7174. function tobjectdef.search_enumerator_move: tprocdef;
  7175. begin
  7176. result:=inherited;
  7177. if not assigned(result) and assigned(childof) then
  7178. result:=childof.search_enumerator_move;
  7179. end;
  7180. function tobjectdef.search_enumerator_current: tsym;
  7181. begin
  7182. result:=inherited;
  7183. if not assigned(result) and assigned(childof) then
  7184. result:=childof.search_enumerator_current;
  7185. end;
  7186. procedure tobjectdef.register_created_classref_type;
  7187. begin
  7188. if not classref_created_in_current_module then
  7189. begin
  7190. classref_created_in_current_module:=true;
  7191. current_module.wpoinfo.addcreatedobjtypeforclassref(self);
  7192. end;
  7193. end;
  7194. procedure tobjectdef.register_created_object_type;
  7195. begin
  7196. if not created_in_current_module then
  7197. begin
  7198. created_in_current_module:=true;
  7199. current_module.wpoinfo.addcreatedobjtype(self);
  7200. end;
  7201. end;
  7202. procedure tobjectdef.register_maybe_created_object_type;
  7203. begin
  7204. { if we know it has been created for sure, no need
  7205. to also record that it maybe can be created in
  7206. this module
  7207. }
  7208. if not (created_in_current_module) and
  7209. not (maybe_created_in_current_module) then
  7210. begin
  7211. maybe_created_in_current_module:=true;
  7212. current_module.wpoinfo.addmaybecreatedbyclassref(self);
  7213. end;
  7214. end;
  7215. procedure tobjectdef.register_vmt_call(index: longint);
  7216. begin
  7217. if (is_object(self) or is_class(self)) then
  7218. current_module.wpoinfo.addcalledvmtentry(self,index);
  7219. end;
  7220. procedure check_and_finish_msg(data: tobject; arg: pointer);
  7221. var
  7222. def: tdef absolute data;
  7223. pd: tprocdef absolute data;
  7224. i,
  7225. paracount: longint;
  7226. begin
  7227. if (def.typ=procdef) then
  7228. begin
  7229. { add all messages also under a dummy name to the symtable in
  7230. which the objcclass/protocol/category is declared, so they can
  7231. be called via id.<name>
  7232. }
  7233. create_class_helper_for_procdef(pd,nil);
  7234. { we have to wait until now to set the mangled name because it
  7235. depends on the (possibly external) class name, which is defined
  7236. at the very end. }
  7237. if not(po_msgstr in pd.procoptions) then
  7238. begin
  7239. CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
  7240. { recover to avoid internalerror later on }
  7241. include(pd.procoptions,po_msgstr);
  7242. pd.messageinf.str:=stringdup('MissingDeclaration');
  7243. end;
  7244. { Mangled name is already set in case this is a copy of
  7245. another type. }
  7246. if not(po_has_mangledname in pd.procoptions) then
  7247. begin
  7248. { check whether the number of formal parameters is correct,
  7249. and whether they have valid Objective-C types }
  7250. paracount:=0;
  7251. for i:=1 to length(pd.messageinf.str^) do
  7252. if pd.messageinf.str^[i]=':' then
  7253. inc(paracount);
  7254. for i:=0 to pd.paras.count-1 do
  7255. if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
  7256. not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
  7257. dec(paracount);
  7258. if (paracount<>0) then
  7259. MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
  7260. pd.setmangledname(pd.objcmangledname);
  7261. end
  7262. else
  7263. { all checks already done }
  7264. exit;
  7265. if not(oo_is_external in pd.struct.objectoptions) then
  7266. begin
  7267. if (po_varargs in pd.procoptions) then
  7268. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external)
  7269. else
  7270. begin
  7271. { check for "array of const" parameters }
  7272. for i:=0 to pd.parast.symlist.count-1 do
  7273. begin
  7274. if (tsym(pd.parast.symlist[i]).typ=paravarsym) and
  7275. is_array_of_const(tparavarsym(pd.parast.symlist[i]).vardef) then
  7276. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external);
  7277. end;
  7278. end;
  7279. end;
  7280. end;
  7281. end;
  7282. procedure mark_private_fields_used(data: tobject; arg: pointer);
  7283. var
  7284. sym: tsym absolute data;
  7285. begin
  7286. if (sym.typ=fieldvarsym) and
  7287. (tfieldvarsym(sym).visibility in [vis_private,vis_strictprivate]) then
  7288. sym.IncRefCount;
  7289. end;
  7290. procedure tobjectdef.finish_objc_data;
  7291. begin
  7292. self.symtable.DefList.foreachcall(@check_and_finish_msg,nil);
  7293. if (oo_is_external in objectoptions) then
  7294. self.symtable.SymList.ForEachCall(@mark_private_fields_used,nil);
  7295. end;
  7296. procedure verify_objc_vardef(data: tobject; arg: pointer);
  7297. var
  7298. sym: tabstractvarsym absolute data;
  7299. res: pboolean absolute arg;
  7300. founderrordef: tdef;
  7301. begin
  7302. if not(tsym(data).typ in [paravarsym,fieldvarsym]) then
  7303. exit;
  7304. if (sym.typ=paravarsym) and
  7305. ((vo_is_hidden_para in tparavarsym(sym).varoptions) or
  7306. is_array_of_const(tparavarsym(sym).vardef)) then
  7307. exit;
  7308. if not objcchecktype(sym.vardef,founderrordef) then
  7309. begin
  7310. MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  7311. res^:=false;
  7312. end;
  7313. end;
  7314. procedure verify_objc_procdef_paras(data: tobject; arg: pointer);
  7315. var
  7316. def: tdef absolute data;
  7317. res: pboolean absolute arg;
  7318. founderrordef: tdef;
  7319. begin
  7320. if (def.typ<>procdef) then
  7321. exit;
  7322. { check parameter types for validity }
  7323. tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg);
  7324. { check the result type for validity }
  7325. if not objcchecktype(tprocdef(def).returndef,founderrordef) then
  7326. begin
  7327. MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  7328. res^:=false;
  7329. end;
  7330. end;
  7331. function tobjectdef.check_objc_types: boolean;
  7332. begin
  7333. { done in separate step from finish_objc_data, because when
  7334. finish_objc_data is called, not all forwarddefs have been resolved
  7335. yet and we need to know all types here }
  7336. result:=true;
  7337. self.symtable.symlist.foreachcall(@verify_objc_vardef,@result);
  7338. self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result);
  7339. end;
  7340. procedure do_cpp_import_info(data: tobject; arg: pointer);
  7341. var
  7342. def: tdef absolute data;
  7343. pd: tprocdef absolute data;
  7344. begin
  7345. if (def.typ=procdef) then
  7346. begin
  7347. pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
  7348. if (oo_is_external in pd.struct.objectoptions) then
  7349. begin
  7350. { copied from psub.read_proc }
  7351. if assigned(tobjectdef(pd.struct).import_lib) then
  7352. current_module.AddExternalImport(tobjectdef(pd.struct).import_lib^,pd.mangledname,pd.mangledname,0,false,false)
  7353. else
  7354. begin
  7355. { add import name to external list for DLL scanning }
  7356. if tf_has_dllscanner in target_info.flags then
  7357. current_module.dllscannerinputlist.Add(pd.mangledname,pd);
  7358. end;
  7359. end;
  7360. end;
  7361. end;
  7362. procedure tobjectdef.finish_cpp_data;
  7363. begin
  7364. self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
  7365. end;
  7366. {****************************************************************************
  7367. TImplementedInterface
  7368. ****************************************************************************}
  7369. function TImplementedInterface.GetIOffset: longint;
  7370. begin
  7371. if (fIOffset=-1) and
  7372. (IType in [etFieldValue,etFieldValueClass]) then
  7373. result:=tfieldvarsym(ImplementsField).fieldoffset
  7374. else
  7375. result:=fIOffset;
  7376. end;
  7377. constructor TImplementedInterface.create(aintf: tobjectdef);
  7378. begin
  7379. inherited create;
  7380. intfdef:=aintf;
  7381. intfdefderef.reset;
  7382. IOffset:=-1;
  7383. IType:=etStandard;
  7384. NameMappings:=nil;
  7385. procdefs:=nil;
  7386. end;
  7387. constructor TImplementedInterface.create_deref(intfd,getterd:tderef);
  7388. begin
  7389. inherited create;
  7390. intfdef:=nil;
  7391. intfdefderef:=intfd;
  7392. ImplementsGetterDeref:=getterd;
  7393. IOffset:=-1;
  7394. IType:=etStandard;
  7395. NameMappings:=nil;
  7396. procdefs:=nil;
  7397. end;
  7398. destructor TImplementedInterface.destroy;
  7399. var
  7400. i : longint;
  7401. mappedname : pshortstring;
  7402. begin
  7403. if assigned(NameMappings) then
  7404. begin
  7405. for i:=0 to NameMappings.Count-1 do
  7406. begin
  7407. mappedname:=pshortstring(NameMappings[i]);
  7408. stringdispose(mappedname);
  7409. end;
  7410. NameMappings.free;
  7411. NameMappings:=nil;
  7412. end;
  7413. if assigned(procdefs) then
  7414. begin
  7415. procdefs.free;
  7416. procdefs:=nil;
  7417. end;
  7418. inherited destroy;
  7419. end;
  7420. procedure TImplementedInterface.buildderef;
  7421. begin
  7422. intfdefderef.build(intfdef);
  7423. ImplementsGetterDeref.build(ImplementsGetter);
  7424. end;
  7425. procedure TImplementedInterface.deref;
  7426. begin
  7427. intfdef:=tobjectdef(intfdefderef.resolve);
  7428. ImplementsGetter:=tsym(ImplementsGetterDeref.resolve);
  7429. end;
  7430. procedure TImplementedInterface.AddMapping(const origname,newname: string);
  7431. begin
  7432. if not assigned(NameMappings) then
  7433. NameMappings:=TFPHashList.Create;
  7434. NameMappings.Add(origname,stringdup(newname));
  7435. end;
  7436. function TImplementedInterface.GetMapping(const origname: string):string;
  7437. var
  7438. mappedname : pshortstring;
  7439. begin
  7440. result:='';
  7441. if not assigned(NameMappings) then
  7442. exit;
  7443. mappedname:=PShortstring(NameMappings.Find(origname));
  7444. if assigned(mappedname) then
  7445. result:=mappedname^;
  7446. end;
  7447. procedure TImplementedInterface.AddImplProc(pd:tprocdef);
  7448. begin
  7449. if not assigned(procdefs) then
  7450. procdefs:=TFPObjectList.Create(false);
  7451. { duplicate entries must be stored, because multiple }
  7452. { interfaces can declare methods with the same name }
  7453. { and all of these get their own VMT entry }
  7454. procdefs.Add(pd);
  7455. end;
  7456. function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  7457. var
  7458. i : longint;
  7459. begin
  7460. result:=false;
  7461. { interfaces being implemented through delegation are not mergable (FK) }
  7462. if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) or not(assigned(MergingIntf.ProcDefs)) then
  7463. exit;
  7464. weight:=0;
  7465. { empty interface is mergeable }
  7466. if ProcDefs.Count=0 then
  7467. begin
  7468. result:=true;
  7469. exit;
  7470. end;
  7471. { The interface to merge must at least the number of
  7472. procedures of this interface }
  7473. if MergingIntf.ProcDefs.Count<ProcDefs.Count then
  7474. exit;
  7475. for i:=0 to ProcDefs.Count-1 do
  7476. begin
  7477. if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
  7478. exit;
  7479. end;
  7480. weight:=ProcDefs.Count;
  7481. result:=true;
  7482. end;
  7483. function TImplementedInterface.getcopy:TImplementedInterface;
  7484. begin
  7485. Result:=TImplementedInterface.Create(nil);
  7486. { 1) the procdefs list will be freed once for each copy
  7487. 2) since the procdefs list owns its elements, those will also be freed for each copy
  7488. 3) idem for the name mappings
  7489. }
  7490. { warning: this is completely wrong on so many levels...
  7491. Move(pointer(self)^,pointer(result)^,InstanceSize);
  7492. We need to make clean copies of the different fields
  7493. this is not implemented yet, and thus we generate an internal
  7494. error instead PM 2011-06-14 }
  7495. internalerror(2011061401);
  7496. end;
  7497. {****************************************************************************
  7498. TFORWARDDEF
  7499. ****************************************************************************}
  7500. constructor tforwarddef.create(const s:string;const pos:tfileposinfo);
  7501. begin
  7502. inherited create(forwarddef,true);
  7503. tosymname:=stringdup(s);
  7504. forwardpos:=pos;
  7505. end;
  7506. function tforwarddef.GetTypeName:string;
  7507. begin
  7508. GetTypeName:='unresolved forward to '+tosymname^;
  7509. end;
  7510. destructor tforwarddef.destroy;
  7511. begin
  7512. stringdispose(tosymname);
  7513. inherited destroy;
  7514. end;
  7515. function tforwarddef.getcopy:tstoreddef;
  7516. begin
  7517. result:=cforwarddef.create(tosymname^, forwardpos);
  7518. end;
  7519. {****************************************************************************
  7520. TUNDEFINEDDEF
  7521. ****************************************************************************}
  7522. constructor tundefineddef.create(doregister:boolean);
  7523. begin
  7524. inherited create(undefineddef,doregister);
  7525. end;
  7526. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  7527. begin
  7528. inherited ppuload(undefineddef,ppufile);
  7529. ppuload_platform(ppufile);
  7530. end;
  7531. function tundefineddef.GetTypeName:string;
  7532. begin
  7533. GetTypeName:='<undefined type>';
  7534. end;
  7535. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  7536. begin
  7537. inherited ppuwrite(ppufile);
  7538. writeentry(ppufile,ibundefineddef);
  7539. end;
  7540. {****************************************************************************
  7541. TERRORDEF
  7542. ****************************************************************************}
  7543. constructor terrordef.create;
  7544. begin
  7545. inherited create(errordef,true);
  7546. { prevent consecutive faults }
  7547. savesize:=1;
  7548. end;
  7549. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  7550. begin
  7551. { Can't write errordefs to ppu }
  7552. internalerror(200411063);
  7553. end;
  7554. function terrordef.GetTypeName:string;
  7555. begin
  7556. GetTypeName:='<erroneous type>';
  7557. end;
  7558. function terrordef.getmangledparaname:TSymStr;
  7559. begin
  7560. getmangledparaname:='error';
  7561. end;
  7562. {****************************************************************************
  7563. Definition Helpers
  7564. ****************************************************************************}
  7565. function is_interfacecom(def: tdef): boolean;
  7566. begin
  7567. is_interfacecom:=
  7568. assigned(def) and
  7569. (def.typ=objectdef) and
  7570. (tobjectdef(def).objecttype=odt_interfacecom);
  7571. end;
  7572. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  7573. begin
  7574. is_interfacecom_or_dispinterface:=
  7575. assigned(def) and
  7576. (def.typ=objectdef) and
  7577. (tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface]);
  7578. end;
  7579. function is_any_interface_kind(def: tdef): boolean;
  7580. begin
  7581. result:=
  7582. assigned(def) and
  7583. (def.typ=objectdef) and
  7584. ((tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface,odt_interfacecorba,odt_interfacejava,odt_objcprotocol]) or
  7585. is_objccategory(def));
  7586. end;
  7587. function is_interfacecorba(def: tdef): boolean;
  7588. begin
  7589. is_interfacecorba:=
  7590. assigned(def) and
  7591. (def.typ=objectdef) and
  7592. (tobjectdef(def).objecttype=odt_interfacecorba);
  7593. end;
  7594. function is_interface(def: tdef): boolean;
  7595. begin
  7596. is_interface:=
  7597. assigned(def) and
  7598. (def.typ=objectdef) and
  7599. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  7600. end;
  7601. function is_dispinterface(def: tdef): boolean;
  7602. begin
  7603. result:=
  7604. assigned(def) and
  7605. (def.typ=objectdef) and
  7606. (tobjectdef(def).objecttype=odt_dispinterface);
  7607. end;
  7608. function is_class(def: tdef): boolean;
  7609. begin
  7610. is_class:=
  7611. assigned(def) and
  7612. (def.typ=objectdef) and
  7613. (tobjectdef(def).objecttype=odt_class);
  7614. end;
  7615. function is_object(def: tdef): boolean;
  7616. begin
  7617. is_object:=
  7618. assigned(def) and
  7619. (def.typ=objectdef) and
  7620. (tobjectdef(def).objecttype=odt_object);
  7621. end;
  7622. function is_cppclass(def: tdef): boolean;
  7623. begin
  7624. is_cppclass:=
  7625. assigned(def) and
  7626. (def.typ=objectdef) and
  7627. (tobjectdef(def).objecttype=odt_cppclass);
  7628. end;
  7629. function is_objcclass(def: tdef): boolean;
  7630. begin
  7631. is_objcclass:=
  7632. assigned(def) and
  7633. (def.typ=objectdef) and
  7634. (tobjectdef(def).objecttype=odt_objcclass);
  7635. end;
  7636. function is_objectpascal_helper(def: tdef): boolean;
  7637. begin
  7638. result:=
  7639. assigned(def) and
  7640. (def.typ=objectdef) and
  7641. (tobjectdef(def).objecttype=odt_helper);
  7642. end;
  7643. function is_objcclassref(def: tdef): boolean;
  7644. begin
  7645. is_objcclassref:=
  7646. assigned(def) and
  7647. (def.typ=classrefdef) and
  7648. is_objcclass(tclassrefdef(def).pointeddef);
  7649. end;
  7650. function is_objcprotocol(def: tdef): boolean;
  7651. begin
  7652. result:=
  7653. assigned(def) and
  7654. (def.typ=objectdef) and
  7655. (tobjectdef(def).objecttype=odt_objcprotocol);
  7656. end;
  7657. function is_objccategory(def: tdef): boolean;
  7658. begin
  7659. result:=
  7660. assigned(def) and
  7661. (def.typ=objectdef) and
  7662. { if used as a forward type }
  7663. ((tobjectdef(def).objecttype=odt_objccategory) or
  7664. { if used as after it has been resolved }
  7665. ((tobjectdef(def).objecttype=odt_objcclass) and
  7666. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  7667. end;
  7668. function is_objc_class_or_protocol(def: tdef): boolean;
  7669. begin
  7670. result:=
  7671. assigned(def) and
  7672. (def.typ=objectdef) and
  7673. (tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]);
  7674. end;
  7675. function is_objc_protocol_or_category(def: tdef): boolean;
  7676. begin
  7677. result:=
  7678. assigned(def) and
  7679. (def.typ=objectdef) and
  7680. ((tobjectdef(def).objecttype = odt_objcprotocol) or
  7681. ((tobjectdef(def).objecttype = odt_objcclass) and
  7682. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  7683. end;
  7684. function is_classhelper(def: tdef): boolean;
  7685. begin
  7686. result:=
  7687. is_objectpascal_helper(def) or
  7688. is_objccategory(def);
  7689. end;
  7690. function is_class_or_interface(def: tdef): boolean;
  7691. begin
  7692. result:=
  7693. assigned(def) and
  7694. (def.typ=objectdef) and
  7695. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  7696. end;
  7697. function is_class_or_interface_or_objc(def: tdef): boolean;
  7698. begin
  7699. result:=
  7700. assigned(def) and
  7701. (def.typ=objectdef) and
  7702. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]);
  7703. end;
  7704. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  7705. begin
  7706. result:=
  7707. assigned(def) and
  7708. (def.typ=objectdef) and
  7709. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  7710. end;
  7711. function is_class_or_interface_or_dispinterface_or_objc_or_java(def: tdef): boolean;
  7712. begin
  7713. result:=
  7714. assigned(def) and
  7715. (def.typ=objectdef) and
  7716. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  7717. end;
  7718. function is_class_or_interface_or_object(def: tdef): boolean;
  7719. begin
  7720. result:=
  7721. assigned(def) and
  7722. (def.typ=objectdef) and
  7723. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_object]);
  7724. end;
  7725. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  7726. begin
  7727. result:=
  7728. assigned(def) and
  7729. (def.typ=objectdef) and
  7730. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  7731. end;
  7732. function is_implicit_pointer_object_type(def: tdef): boolean;
  7733. begin
  7734. result:=
  7735. assigned(def) and
  7736. (((def.typ=objectdef) and
  7737. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava])) or
  7738. ((target_info.system in systems_jvm) and
  7739. (def.typ=recorddef)));
  7740. end;
  7741. function is_implicit_array_pointer(def: tdef): boolean;
  7742. begin
  7743. result:=is_dynamic_array(def) or is_dynamicstring(def);
  7744. end;
  7745. function is_class_or_object(def: tdef): boolean;
  7746. begin
  7747. result:=
  7748. assigned(def) and
  7749. (def.typ=objectdef) and
  7750. (tobjectdef(def).objecttype in [odt_class,odt_object]);
  7751. end;
  7752. function is_record(def: tdef): boolean;
  7753. begin
  7754. result:=
  7755. assigned(def) and
  7756. (def.typ=recorddef);
  7757. end;
  7758. function is_javaclass(def: tdef): boolean;
  7759. begin
  7760. result:=
  7761. assigned(def) and
  7762. (def.typ=objectdef) and
  7763. (tobjectdef(def).objecttype=odt_javaclass);
  7764. end;
  7765. function is_javaclassref(def: tdef): boolean;
  7766. begin
  7767. is_javaclassref:=
  7768. assigned(def) and
  7769. (def.typ=classrefdef) and
  7770. is_javaclass(tclassrefdef(def).pointeddef);
  7771. end;
  7772. function is_javainterface(def: tdef): boolean;
  7773. begin
  7774. result:=
  7775. assigned(def) and
  7776. (def.typ=objectdef) and
  7777. (tobjectdef(def).objecttype=odt_interfacejava);
  7778. end;
  7779. function is_java_class_or_interface(def: tdef): boolean;
  7780. begin
  7781. result:=
  7782. assigned(def) and
  7783. (def.typ=objectdef) and
  7784. (tobjectdef(def).objecttype in [odt_javaclass,odt_interfacejava]);
  7785. end;
  7786. procedure loadobjctypes;
  7787. begin
  7788. objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_CLASS',true).typedef);
  7789. objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER',true).typedef);
  7790. objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID',true).typedef);
  7791. objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL',true).typedef);
  7792. objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT',true).typedef);
  7793. end;
  7794. procedure maybeloadcocoatypes;
  7795. var
  7796. tsym: ttypesym;
  7797. cocoaunit: string[15];
  7798. begin
  7799. if assigned(objc_fastenumeration) then
  7800. exit;
  7801. if not(target_info.system in [system_arm_ios,system_i386_iphonesim,system_aarch64_ios,system_x86_64_iphonesim]) then
  7802. cocoaunit:='COCOAALL'
  7803. else
  7804. cocoaunit:='IPHONEALL';
  7805. tsym:=search_named_unit_globaltype(cocoaunit,'NSFASTENUMERATIONPROTOCOL',false);
  7806. if assigned(tsym) then
  7807. objc_fastenumeration:=tobjectdef(tsym.typedef)
  7808. else
  7809. objc_fastenumeration:=nil;
  7810. tsym:=search_named_unit_globaltype(cocoaunit,'NSFASTENUMERATIONSTATE',false);
  7811. if assigned(tsym) then
  7812. objc_fastenumerationstate:=trecorddef(tsym.typedef)
  7813. else
  7814. objc_fastenumerationstate:=nil;
  7815. end;
  7816. function use_vectorfpu(def : tdef) : boolean;
  7817. begin
  7818. {$ifdef x86}
  7819. {$define use_vectorfpuimplemented}
  7820. use_vectorfpu:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  7821. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  7822. {$endif x86}
  7823. {$ifdef arm}
  7824. {$define use_vectorfpuimplemented}
  7825. use_vectorfpu:=FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype];
  7826. {$endif arm}
  7827. {$ifdef aarch64}
  7828. {$define use_vectorfpuimplemented}
  7829. use_vectorfpu:=true;
  7830. {$endif aarch64}
  7831. {$ifndef use_vectorfpuimplemented}
  7832. use_vectorfpu:=false;
  7833. {$endif}
  7834. end;
  7835. end.