symdef.pas 269 KB

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