symdef.pas 272 KB

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