symdef.pas 297 KB

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