symdef.pas 271 KB

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