symdef.pas 213 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603
  1. {
  2. Symbol table implementation for the definitions
  3. Copyright (c) 1998-2005 by Florian Klaempfl, Pierre Muller
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit symdef;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cclasses,
  23. { global }
  24. globtype,globals,tokens,constexp,
  25. { symtable }
  26. symconst,symbase,symtype,
  27. { ppu }
  28. ppu,
  29. { node }
  30. node,
  31. { aasm }
  32. aasmbase,aasmtai,aasmdata,
  33. cpubase,cpuinfo,
  34. cgbase,cgutils,
  35. parabase
  36. ;
  37. type
  38. {************************************************
  39. TDef
  40. ************************************************}
  41. { tstoreddef }
  42. tstoreddef = class(tdef)
  43. protected
  44. typesymderef : tderef;
  45. public
  46. {$ifdef EXTDEBUG}
  47. fileinfo : tfileposinfo;
  48. {$endif}
  49. { generic support }
  50. genericdef : tstoreddef;
  51. genericdefderef : tderef;
  52. generictokenbuf : tdynamicarray;
  53. constructor create(dt:tdeftyp);
  54. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  55. destructor destroy;override;
  56. function getcopy : tstoreddef;virtual;
  57. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  58. procedure buildderef;override;
  59. procedure buildderefimpl;override;
  60. procedure deref;override;
  61. procedure derefimpl;override;
  62. function size:asizeint;override;
  63. function getvardef:longint;override;
  64. function alignment:shortint;override;
  65. function is_publishable : boolean;override;
  66. function needs_inittable : boolean;override;
  67. function rtti_mangledname(rt:trttitype):string;override;
  68. function OwnerHierarchyName: string; override;
  69. function in_currentunit: boolean;
  70. { regvars }
  71. function is_intregable : boolean;
  72. function is_fpuregable : boolean;
  73. { generics }
  74. procedure initgeneric;
  75. private
  76. savesize : asizeuint;
  77. end;
  78. tfiletyp = (ft_text,ft_typed,ft_untyped);
  79. tfiledef = class(tstoreddef)
  80. filetyp : tfiletyp;
  81. typedfiledef : tdef;
  82. typedfiledefderef : tderef;
  83. constructor createtext;
  84. constructor createuntyped;
  85. constructor createtyped(def : tdef);
  86. constructor ppuload(ppufile:tcompilerppufile);
  87. function getcopy : tstoreddef;override;
  88. procedure ppuwrite(ppufile:tcompilerppufile);override;
  89. procedure buildderef;override;
  90. procedure deref;override;
  91. function GetTypeName:string;override;
  92. function getmangledparaname:TSymStr;override;
  93. procedure setsize;
  94. end;
  95. tvariantdef = class(tstoreddef)
  96. varianttype : tvarianttype;
  97. constructor create(v : tvarianttype);
  98. constructor ppuload(ppufile:tcompilerppufile);
  99. function getcopy : tstoreddef;override;
  100. function GetTypeName:string;override;
  101. procedure ppuwrite(ppufile:tcompilerppufile);override;
  102. function getvardef:longint;override;
  103. procedure setsize;
  104. function is_publishable : boolean;override;
  105. function needs_inittable : boolean;override;
  106. end;
  107. tformaldef = class(tstoreddef)
  108. typed:boolean;
  109. constructor create(Atyped:boolean);
  110. constructor ppuload(ppufile:tcompilerppufile);
  111. procedure ppuwrite(ppufile:tcompilerppufile);override;
  112. function GetTypeName:string;override;
  113. end;
  114. tforwarddef = class(tstoreddef)
  115. tosymname : pshortstring;
  116. forwardpos : tfileposinfo;
  117. constructor create(const s:string;const pos:tfileposinfo);
  118. destructor destroy;override;
  119. function getcopy:tstoreddef;override;
  120. function GetTypeName:string;override;
  121. end;
  122. tundefineddef = class(tstoreddef)
  123. constructor create;
  124. constructor ppuload(ppufile:tcompilerppufile);
  125. procedure ppuwrite(ppufile:tcompilerppufile);override;
  126. function GetTypeName:string;override;
  127. end;
  128. terrordef = class(tstoreddef)
  129. constructor create;
  130. procedure ppuwrite(ppufile:tcompilerppufile);override;
  131. function GetTypeName:string;override;
  132. function getmangledparaname : TSymStr;override;
  133. end;
  134. tabstractpointerdef = class(tstoreddef)
  135. pointeddef : tdef;
  136. pointeddefderef : tderef;
  137. constructor create(dt:tdeftyp;def:tdef);
  138. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  139. procedure ppuwrite(ppufile:tcompilerppufile);override;
  140. procedure buildderef;override;
  141. procedure deref;override;
  142. end;
  143. tpointerdef = class(tabstractpointerdef)
  144. is_far : boolean;
  145. has_pointer_math : boolean;
  146. constructor create(def:tdef);
  147. constructor createfar(def:tdef);
  148. function getcopy:tstoreddef;override;
  149. constructor ppuload(ppufile:tcompilerppufile);
  150. procedure ppuwrite(ppufile:tcompilerppufile);override;
  151. function GetTypeName:string;override;
  152. end;
  153. tprocdef = class;
  154. { tabstractrecorddef }
  155. tabstractrecorddef= class(tstoreddef)
  156. objname,
  157. objrealname : PShortString;
  158. { for C++ classes: name of the library this class is imported from }
  159. { for Java classes/records: package name }
  160. import_lib : PShortString;
  161. symtable : TSymtable;
  162. cloneddef : tabstractrecorddef;
  163. cloneddefderef : tderef;
  164. objectoptions : tobjectoptions;
  165. { for targets that initialise typed constants via explicit assignments
  166. instead of by generating an initialised data sectino }
  167. tcinitcode : tnode;
  168. constructor create(const n:string; dt:tdeftyp);
  169. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  170. procedure ppuwrite(ppufile:tcompilerppufile);override;
  171. destructor destroy; override;
  172. procedure check_forwards; virtual;
  173. function find_procdef_bytype(pt:tproctypeoption): tprocdef;
  174. function GetSymtable(t:tGetSymtable):TSymtable;override;
  175. function is_packed:boolean;
  176. function RttiName: string;
  177. { enumerator support }
  178. function search_enumerator_get: tprocdef; virtual;
  179. function search_enumerator_move: tprocdef; virtual;
  180. function search_enumerator_current: tsym; virtual;
  181. { JVM }
  182. function jvm_full_typename(with_package_name: boolean): string;
  183. end;
  184. trecorddef = class(tabstractrecorddef)
  185. public
  186. isunion : boolean;
  187. constructor create(const n:string; p:TSymtable);
  188. constructor ppuload(ppufile:tcompilerppufile);
  189. destructor destroy;override;
  190. function getcopy : tstoreddef;override;
  191. procedure ppuwrite(ppufile:tcompilerppufile);override;
  192. procedure buildderef;override;
  193. procedure deref;override;
  194. function size:asizeint;override;
  195. function alignment : shortint;override;
  196. function padalignment: shortint;
  197. function GetTypeName:string;override;
  198. { debug }
  199. function needs_inittable : boolean;override;
  200. { jvm }
  201. function is_related(d : tdef) : boolean;override;
  202. end;
  203. tobjectdef = class;
  204. { TImplementedInterface }
  205. TImplementedInterface = class
  206. IntfDef : tobjectdef;
  207. IntfDefDeref : tderef;
  208. IType : tinterfaceentrytype;
  209. IOffset : longint;
  210. VtblImplIntf : TImplementedInterface;
  211. NameMappings : TFPHashList;
  212. ProcDefs : TFPObjectList;
  213. ImplementsGetter : tsym;
  214. constructor create(aintf: tobjectdef);
  215. constructor create_deref(d:tderef);
  216. destructor destroy; override;
  217. function getcopy:TImplementedInterface;
  218. procedure buildderef;
  219. procedure deref;
  220. procedure AddMapping(const origname, newname: string);
  221. function GetMapping(const origname: string):string;
  222. procedure AddImplProc(pd:tprocdef);
  223. function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  224. end;
  225. { tvmtentry }
  226. tvmtentry = record
  227. procdef : tprocdef;
  228. procdefderef : tderef;
  229. visibility : tvisibility;
  230. end;
  231. pvmtentry = ^tvmtentry;
  232. { tobjectdef }
  233. tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
  234. pmvcallstaticinfo = ^tmvcallstaticinfo;
  235. tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
  236. tobjectdef = class(tabstractrecorddef)
  237. private
  238. fcurrent_dispid: longint;
  239. public
  240. dwarf_struct_lab : tasmsymbol;
  241. childof : tobjectdef;
  242. childofderef : tderef;
  243. { for Object Pascal helpers }
  244. extendeddef : tabstractrecorddef;
  245. extendeddefderef: tderef;
  246. { for Objective-C: protocols and classes can have the same name there }
  247. objextname : pshortstring;
  248. { to be able to have a variable vmt position }
  249. { and no vmt field for objects without virtuals }
  250. vmtentries : TFPList;
  251. vmcallstaticinfo : pmvcallstaticinfo;
  252. vmt_offset : longint;
  253. iidguid : pguid;
  254. iidstr : pshortstring;
  255. { store implemented interfaces defs and name mappings }
  256. ImplementedInterfaces : TFPObjectList;
  257. { number of abstract methods (used by JVM target to determine whether
  258. or not the class should be marked as abstract: must be done if 1 or
  259. more abstract methods) }
  260. abstractcnt : longint;
  261. writing_class_record_dbginfo,
  262. { a class of this type has been created in this module }
  263. created_in_current_module,
  264. { a loadvmtnode for this class has been created in this
  265. module, so if a classrefdef variable of this or a parent
  266. class is used somewhere to instantiate a class, then this
  267. class may be instantiated
  268. }
  269. maybe_created_in_current_module,
  270. { a "class of" this particular class has been created in
  271. this module
  272. }
  273. classref_created_in_current_module : boolean;
  274. objecttype : tobjecttyp;
  275. constructor create(ot:tobjecttyp;const n:string;c:tobjectdef);
  276. constructor ppuload(ppufile:tcompilerppufile);
  277. destructor destroy;override;
  278. function getcopy : tstoreddef;override;
  279. procedure ppuwrite(ppufile:tcompilerppufile);override;
  280. function GetTypeName:string;override;
  281. procedure buildderef;override;
  282. procedure deref;override;
  283. procedure buildderefimpl;override;
  284. procedure derefimpl;override;
  285. procedure resetvmtentries;
  286. procedure copyvmtentries(objdef:tobjectdef);
  287. function getparentdef:tdef;override;
  288. function size : asizeint;override;
  289. function alignment:shortint;override;
  290. function vmtmethodoffset(index:longint):longint;
  291. function members_need_inittable : boolean;
  292. function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  293. { this should be called when this class implements an interface }
  294. procedure prepareguid;
  295. function is_publishable : boolean;override;
  296. function is_related(d : tdef) : boolean;override;
  297. function needs_inittable : boolean;override;
  298. function rtti_mangledname(rt:trttitype):string;override;
  299. function vmt_mangledname : TSymStr;
  300. procedure check_forwards; override;
  301. procedure insertvmt;
  302. procedure set_parent(c : tobjectdef);
  303. function find_destructor: tprocdef;
  304. function implements_any_interfaces: boolean;
  305. { dispinterface support }
  306. function get_next_dispid: longint;
  307. { enumerator support }
  308. function search_enumerator_get: tprocdef; override;
  309. function search_enumerator_move: tprocdef; override;
  310. function search_enumerator_current: tsym; override;
  311. { WPO }
  312. procedure register_created_object_type;override;
  313. procedure register_maybe_created_object_type;
  314. procedure register_created_classref_type;
  315. procedure register_vmt_call(index:longint);
  316. { ObjC }
  317. procedure finish_objc_data;
  318. function check_objc_types: boolean;
  319. { C++ }
  320. procedure finish_cpp_data;
  321. end;
  322. tclassrefdef = class(tabstractpointerdef)
  323. constructor create(def:tdef);
  324. constructor ppuload(ppufile:tcompilerppufile);
  325. procedure ppuwrite(ppufile:tcompilerppufile);override;
  326. function getcopy:tstoreddef;override;
  327. function GetTypeName:string;override;
  328. function is_publishable : boolean;override;
  329. function rtti_mangledname(rt:trttitype):string;override;
  330. procedure register_created_object_type;override;
  331. end;
  332. tarraydef = class(tstoreddef)
  333. lowrange,
  334. highrange : asizeint;
  335. rangedef : tdef;
  336. rangedefderef : tderef;
  337. arrayoptions : tarraydefoptions;
  338. symtable : TSymtable;
  339. protected
  340. _elementdef : tdef;
  341. _elementdefderef : tderef;
  342. procedure setelementdef(def:tdef);
  343. public
  344. function elesize : asizeint;
  345. function elepackedbitsize : asizeint;
  346. function elecount : asizeuint;
  347. constructor create_from_pointer(def:tdef);
  348. constructor create(l,h:asizeint;def:tdef);
  349. constructor ppuload(ppufile:tcompilerppufile);
  350. destructor destroy; override;
  351. function getcopy : tstoreddef;override;
  352. procedure ppuwrite(ppufile:tcompilerppufile);override;
  353. function GetTypeName:string;override;
  354. function getmangledparaname : TSymStr;override;
  355. procedure buildderef;override;
  356. procedure deref;override;
  357. function size : asizeint;override;
  358. function alignment : shortint;override;
  359. { returns the label of the range check string }
  360. function needs_inittable : boolean;override;
  361. property elementdef : tdef read _elementdef write setelementdef;
  362. function is_publishable : boolean;override;
  363. end;
  364. torddef = class(tstoreddef)
  365. low,high : TConstExprInt;
  366. ordtype : tordtype;
  367. constructor create(t : tordtype;v,b : TConstExprInt);
  368. constructor ppuload(ppufile:tcompilerppufile);
  369. function getcopy : tstoreddef;override;
  370. procedure ppuwrite(ppufile:tcompilerppufile);override;
  371. function is_publishable : boolean;override;
  372. function GetTypeName:string;override;
  373. function alignment:shortint;override;
  374. procedure setsize;
  375. function packedbitsize: asizeint; override;
  376. function getvardef : longint;override;
  377. end;
  378. tfloatdef = class(tstoreddef)
  379. floattype : tfloattype;
  380. constructor create(t : tfloattype);
  381. constructor ppuload(ppufile:tcompilerppufile);
  382. function getcopy : tstoreddef;override;
  383. procedure ppuwrite(ppufile:tcompilerppufile);override;
  384. function GetTypeName:string;override;
  385. function is_publishable : boolean;override;
  386. function alignment:shortint;override;
  387. procedure setsize;
  388. function getvardef:longint;override;
  389. end;
  390. { tabstractprocdef }
  391. tprocnameoption = (pno_showhidden, pno_proctypeoption, pno_paranames,
  392. pno_ownername, pno_noclassmarker, pno_noleadingdollar);
  393. tprocnameoptions = set of tprocnameoption;
  394. tproccopytyp = (pc_normal,
  395. { always creates a top-level function, removes all
  396. special parameters (self, vmt, parentfp, ...) }
  397. pc_procvar2bareproc);
  398. tabstractprocdef = class(tstoreddef)
  399. { saves a definition to the return type }
  400. returndef : tdef;
  401. returndefderef : tderef;
  402. parast : TSymtable;
  403. paras : tparalist;
  404. proctypeoption : tproctypeoption;
  405. proccalloption : tproccalloption;
  406. procoptions : tprocoptions;
  407. callerargareasize,
  408. calleeargareasize: pint;
  409. {$ifdef m68k}
  410. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  411. {$endif}
  412. funcretloc : array[tcallercallee] of TCGPara;
  413. has_paraloc_info : tcallercallee; { paraloc info is available }
  414. { number of user visible parameters }
  415. maxparacount,
  416. minparacount : byte;
  417. constructor create(dt:tdeftyp;level:byte);
  418. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  419. destructor destroy;override;
  420. procedure ppuwrite(ppufile:tcompilerppufile);override;
  421. procedure buildderef;override;
  422. procedure deref;override;
  423. procedure calcparas;
  424. function typename_paras(pno: tprocnameoptions): ansistring;
  425. function is_methodpointer:boolean;virtual;
  426. function is_addressonly:boolean;virtual;
  427. function no_self_node:boolean;
  428. { get either a copy as a procdef or procvardef }
  429. function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef;
  430. procedure check_mark_as_nested;
  431. procedure init_paraloc_info(side: tcallercallee);
  432. function stack_tainting_parameter(side: tcallercallee): boolean;
  433. private
  434. procedure count_para(p:TObject;arg:pointer);
  435. procedure insert_para(p:TObject;arg:pointer);
  436. end;
  437. tprocvardef = class(tabstractprocdef)
  438. {$ifdef jvm}
  439. { class representing this procvar on the Java side }
  440. classdef : tobjectdef;
  441. classdefderef : tderef;
  442. {$endif}
  443. constructor create(level:byte);
  444. constructor ppuload(ppufile:tcompilerppufile);
  445. function getcopy : tstoreddef;override;
  446. procedure ppuwrite(ppufile:tcompilerppufile);override;
  447. {$ifdef jvm}
  448. procedure buildderef;override;
  449. procedure deref;override;
  450. {$endif}
  451. function GetSymtable(t:tGetSymtable):TSymtable;override;
  452. function size : asizeint;override;
  453. function GetTypeName:string;override;
  454. function is_publishable : boolean;override;
  455. function is_methodpointer:boolean;override;
  456. function is_addressonly:boolean;override;
  457. function getmangledparaname:TSymStr;override;
  458. end;
  459. tmessageinf = record
  460. case integer of
  461. 0 : (str : pshortstring);
  462. 1 : (i : longint);
  463. end;
  464. tinlininginfo = record
  465. { node tree }
  466. code : tnode;
  467. flags : tprocinfoflags;
  468. end;
  469. pinlininginfo = ^tinlininginfo;
  470. { kinds of synthetic procdefs that can be generated }
  471. tsynthetickind = (
  472. tsk_none,
  473. tsk_anon_inherited, // anonymous inherited call
  474. tsk_jvm_clone, // Java-style clone method
  475. tsk_record_deepcopy, // deepcopy for records field by field
  476. tsk_record_initialize, // initialize for records field by field (explicit rather than via rtti)
  477. tsk_empty, // an empty routine
  478. tsk_tcinit, // initialisation of typed constants
  479. tsk_callthrough, // call through to another routine with the same parameters/return type (its def is stored in the skpara field)
  480. tsk_jvm_enum_values, // Java "values" class method of JLEnum descendants
  481. tsk_jvm_enum_valueof, // Java "valueOf" class method of JLEnum descendants
  482. tsk_jvm_enum_classconstr, // Java class constructor for JLEnum descendants
  483. tsk_jvm_enum_jumps_constr, // Java constructor for JLEnum descendants for enums with jumps
  484. tsk_jvm_enum_fpcordinal, // Java FPCOrdinal function that returns the enum's ordinal value from an FPC POV
  485. tsk_jvm_enum_fpcvalueof, // Java FPCValueOf function that returns the enum instance corresponding to an ordinal from an FPC POV
  486. tsk_jvm_enum_long2set, // Java fpcLongToEnumSet function that returns an enumset corresponding to a bit pattern in a jlong
  487. tsk_jvm_enum_bitset2set, // Java fpcBitSetToEnumSet function that returns an enumset corresponding to a BitSet
  488. tsk_jvm_enum_set2Set, // Java fpcEnumSetToEnumSet function that returns an enumset corresponding to another enumset (different enum kind)
  489. tsk_jvm_procvar_invoke, // Java invoke method that calls a wrapped procvar
  490. tsk_jvm_virtual_clmethod // Java wrapper for virtual class method
  491. );
  492. {$ifdef oldregvars}
  493. { register variables }
  494. pregvarinfo = ^tregvarinfo;
  495. tregvarinfo = record
  496. regvars : array[1..maxvarregs] of tsym;
  497. regvars_para : array[1..maxvarregs] of boolean;
  498. regvars_refs : array[1..maxvarregs] of longint;
  499. fpuregvars : array[1..maxfpuvarregs] of tsym;
  500. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  501. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  502. end;
  503. {$endif oldregvars}
  504. { tprocdef }
  505. tprocdef = class(tabstractprocdef)
  506. private
  507. {$ifdef symansistr}
  508. _mangledname : ansistring;
  509. {$else symansistr}
  510. _mangledname : pshortstring;
  511. {$endif}
  512. public
  513. messageinf : tmessageinf;
  514. dispid : longint;
  515. {$ifndef EXTDEBUG}
  516. { where is this function defined and what were the symbol
  517. flags, needed here because there
  518. is only one symbol for all overloaded functions
  519. EXTDEBUG has fileinfo in tdef (PFV) }
  520. fileinfo : tfileposinfo;
  521. {$endif}
  522. symoptions : tsymoptions;
  523. deprecatedmsg : pshortstring;
  524. { symbol owning this definition }
  525. procsym : tsym;
  526. procsymderef : tderef;
  527. { alias names }
  528. aliasnames : TCmdStrList;
  529. { symtables }
  530. localst : TSymtable;
  531. funcretsym : tsym;
  532. funcretsymderef : tderef;
  533. struct : tabstractrecorddef;
  534. structderef : tderef;
  535. {$if defined(powerpc) or defined(m68k)}
  536. { library symbol for AmigaOS/MorphOS }
  537. libsym : tsym;
  538. libsymderef : tderef;
  539. {$endif powerpc or m68k}
  540. { name of the result variable to insert in the localsymtable }
  541. resultname : pshortstring;
  542. { import info }
  543. import_dll,
  544. import_name : pshortstring;
  545. { info for inlining the subroutine, if this pointer is nil,
  546. the procedure can't be inlined }
  547. inlininginfo : pinlininginfo;
  548. {$ifdef jvm}
  549. { generated assembler code; used by JVM backend so it can afterwards
  550. easily write out all methods grouped per class }
  551. exprasmlist : TAsmList;
  552. {$endif jvm}
  553. { temporary reference to structure containing copies of all local
  554. variables and parameters accessed by nested routines; reference to
  555. this structure is passed as "parent frame pointer" on targets that
  556. lack this concept (at least JVM and LLVM); no need to save to/
  557. restore from ppu, since nested routines are always in the same
  558. unit (no need to save to ppu) }
  559. parentfpstruct: tsym;
  560. { pointer to parentfpstruct's type (not yet valid during parsing, so
  561. cannot be used for $parentfp parameter) (no need to save to ppu) }
  562. parentfpstructptrtype: tdef;
  563. { code to copy the parameters accessed from nested routines into the
  564. parentfpstruct (no need to save to ppu) }
  565. parentfpinitblock: tnode;
  566. {$ifdef oldregvars}
  567. regvarinfo: pregvarinfo;
  568. {$endif oldregvars}
  569. { interrupt vector }
  570. interruptvector : longint;
  571. { First/last assembler symbol/instruction in aasmoutput list.
  572. Note: initialised after compiling the code for the procdef, but
  573. not saved to/restored from ppu. Used when inserting debug info }
  574. procstarttai,
  575. procendtai : tai;
  576. import_nr : word;
  577. extnumber : word;
  578. {$ifdef i386}
  579. fpu_used : byte;
  580. {$endif i386}
  581. visibility : tvisibility;
  582. { set to a value different from tsk_none in case this procdef is for
  583. a routine that has to be internally generated by the compiler }
  584. synthetickind : tsynthetickind;
  585. { optional parameter for the synthetic routine generation logic }
  586. skpara: pointer;
  587. { true, if the procedure is only declared
  588. (forward procedure) }
  589. forwarddef,
  590. { true if the procedure is declared in the interface }
  591. interfacedef : boolean;
  592. { true if the procedure has a forward declaration }
  593. hasforward : boolean;
  594. constructor create(level:byte);
  595. constructor ppuload(ppufile:tcompilerppufile);
  596. destructor destroy;override;
  597. procedure ppuwrite(ppufile:tcompilerppufile);override;
  598. procedure buildderef;override;
  599. procedure buildderefimpl;override;
  600. procedure deref;override;
  601. procedure derefimpl;override;
  602. function GetSymtable(t:tGetSymtable):TSymtable;override;
  603. { warnings:
  604. * the symtablestack top has to be the symtable to which the copy
  605. should be added
  606. * getcopy does not create a finished/ready-to-use procdef; it
  607. needs to be finalised afterwards by calling
  608. symcreat.finish_copied_procdef() afterwards
  609. }
  610. function getcopy: tstoreddef; override;
  611. function GetTypeName : string;override;
  612. function mangledname : TSymStr;
  613. procedure setmangledname(const s : TSymStr);
  614. function fullprocname(showhidden:boolean):string;
  615. function customprocname(pno: tprocnameoptions):ansistring;
  616. function defaultmangledname: TSymStr;
  617. function cplusplusmangledname : TSymStr;
  618. function objcmangledname : TSymStr;
  619. {$ifdef jvm}
  620. function jvmmangledbasename(signature: boolean): TSymStr;
  621. {$endif}
  622. function is_methodpointer:boolean;override;
  623. function is_addressonly:boolean;override;
  624. procedure make_external;
  625. end;
  626. { single linked list of overloaded procs }
  627. pprocdeflist = ^tprocdeflist;
  628. tprocdeflist = record
  629. def : tprocdef;
  630. defderef : tderef;
  631. next : pprocdeflist;
  632. end;
  633. tstringdef = class(tstoreddef)
  634. stringtype : tstringtype;
  635. len : asizeint;
  636. constructor createshort(l : byte);
  637. constructor loadshort(ppufile:tcompilerppufile);
  638. constructor createlong(l : asizeint);
  639. constructor loadlong(ppufile:tcompilerppufile);
  640. constructor createansi;
  641. constructor loadansi(ppufile:tcompilerppufile);
  642. constructor createwide;
  643. constructor loadwide(ppufile:tcompilerppufile);
  644. constructor createunicode;
  645. constructor loadunicode(ppufile:tcompilerppufile);
  646. function getcopy : tstoreddef;override;
  647. function stringtypname:string;
  648. procedure ppuwrite(ppufile:tcompilerppufile);override;
  649. function GetTypeName:string;override;
  650. function getmangledparaname:TSymStr;override;
  651. function is_publishable : boolean;override;
  652. function alignment : shortint;override;
  653. function needs_inittable : boolean;override;
  654. function getvardef:longint;override;
  655. function is_related(d : tdef) : boolean;override;
  656. end;
  657. { tenumdef }
  658. tenumdef = class(tstoreddef)
  659. minval,
  660. maxval : asizeint;
  661. basedef : tenumdef;
  662. basedefderef : tderef;
  663. symtable : TSymtable;
  664. {$ifdef jvm}
  665. { class representing this enum on the Java side }
  666. classdef : tobjectdef;
  667. classdefderef : tderef;
  668. {$endif}
  669. has_jumps : boolean;
  670. constructor create;
  671. constructor create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  672. constructor ppuload(ppufile:tcompilerppufile);
  673. destructor destroy;override;
  674. function getcopy : tstoreddef;override;
  675. procedure ppuwrite(ppufile:tcompilerppufile);override;
  676. procedure buildderef;override;
  677. procedure deref;override;
  678. function GetTypeName:string;override;
  679. function is_publishable : boolean;override;
  680. procedure calcsavesize;
  681. function packedbitsize: asizeint; override;
  682. procedure setmax(_max:asizeint);
  683. procedure setmin(_min:asizeint);
  684. function min:asizeint;
  685. function max:asizeint;
  686. function getfirstsym:tsym;
  687. { returns basedef if assigned, otherwise self }
  688. function getbasedef: tenumdef;
  689. end;
  690. tsetdef = class(tstoreddef)
  691. elementdef : tdef;
  692. elementdefderef : tderef;
  693. setbase,
  694. setmax : aword;
  695. constructor create(def:tdef;low, high : asizeint);
  696. constructor ppuload(ppufile:tcompilerppufile);
  697. function getcopy : tstoreddef;override;
  698. procedure ppuwrite(ppufile:tcompilerppufile);override;
  699. procedure buildderef;override;
  700. procedure deref;override;
  701. function GetTypeName:string;override;
  702. function is_publishable : boolean;override;
  703. end;
  704. tdefawaresymtablestack = class(TSymtablestack)
  705. private
  706. procedure addhelpers(st: TSymtable);
  707. procedure removehelpers(st: TSymtable);
  708. public
  709. procedure push(st: TSymtable); override;
  710. procedure pop(st: TSymtable); override;
  711. end;
  712. var
  713. current_structdef: tabstractrecorddef; { used for private functions check !! }
  714. current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class }
  715. current_specializedef: tstoreddef; { used to implement usage of generic class in itself }
  716. { default types }
  717. generrordef, { error in definition }
  718. voidpointertype, { pointer for Void-pointeddef }
  719. charpointertype, { pointer for Char-pointeddef }
  720. widecharpointertype, { pointer for WideChar-pointeddef }
  721. voidfarpointertype,
  722. cundefinedtype,
  723. cformaltype, { unique formal definition }
  724. ctypedformaltype, { unique typed formal definition }
  725. voidtype, { Void (procedure) }
  726. cchartype, { Char }
  727. cwidechartype, { WideChar }
  728. pasbool8type, { boolean type }
  729. pasbool16type,
  730. pasbool32type,
  731. pasbool64type,
  732. bool8type,
  733. bool16type,
  734. bool32type,
  735. bool64type, { implement me }
  736. u8inttype, { 8-Bit unsigned integer }
  737. s8inttype, { 8-Bit signed integer }
  738. u16inttype, { 16-Bit unsigned integer }
  739. s16inttype, { 16-Bit signed integer }
  740. u32inttype, { 32-Bit unsigned integer }
  741. s32inttype, { 32-Bit signed integer }
  742. u64inttype, { 64-bit unsigned integer }
  743. s64inttype, { 64-bit signed integer }
  744. s32floattype, { 32 bit floating point number }
  745. s64floattype, { 64 bit floating point number }
  746. s80floattype, { 80 bit floating point number }
  747. sc80floattype, { 80 bit floating point number but stored like in C }
  748. s64currencytype, { pointer to a currency type }
  749. cshortstringtype, { pointer to type of short string const }
  750. clongstringtype, { pointer to type of long string const }
  751. cansistringtype, { pointer to type of ansi string const }
  752. cwidestringtype, { pointer to type of wide string const }
  753. cunicodestringtype,
  754. openshortstringtype, { pointer to type of an open shortstring,
  755. needed for readln() }
  756. openchararraytype, { pointer to type of an open array of char,
  757. needed for readln() }
  758. cfiletype, { get the same definition for all file }
  759. { used for stabs }
  760. methodpointertype, { typecasting of methodpointers to extract self }
  761. hresultdef,
  762. { we use only one variant def for every variant class }
  763. cvarianttype,
  764. colevarianttype,
  765. { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
  766. sinttype,
  767. uinttype,
  768. { unsigned and signed ord type with the same size as a pointer }
  769. ptruinttype,
  770. ptrsinttype,
  771. { several types to simulate more or less C++ objects for GDB }
  772. vmttype,
  773. vmtarraytype,
  774. pvmttype : tdef; { type of classrefs, used for stabs }
  775. { pointer to the anchestor of all classes }
  776. class_tobject : tobjectdef;
  777. { pointer to the ancestor of all COM interfaces }
  778. interface_iunknown : tobjectdef;
  779. { pointer to the ancestor of all dispinterfaces }
  780. interface_idispatch : tobjectdef;
  781. { pointer to the TGUID type
  782. of all interfaces }
  783. rec_tguid : trecorddef;
  784. { pointer to jump buffer }
  785. rec_jmp_buf : trecorddef;
  786. { Objective-C base types }
  787. objc_metaclasstype,
  788. objc_superclasstype,
  789. objc_idtype,
  790. objc_seltype : tpointerdef;
  791. objc_objecttype : trecorddef;
  792. { base type of @protocol(protocolname) Objective-C statements }
  793. objc_protocoltype : tobjectdef;
  794. { helper types for for-in "fast enumeration" support in Objective-C 2.0 }
  795. objc_fastenumeration : tobjectdef;
  796. objc_fastenumerationstate : trecorddef;
  797. { Java base types }
  798. { java.lang.Object }
  799. java_jlobject : tobjectdef;
  800. { java.lang.Throwable }
  801. java_jlthrowable : tobjectdef;
  802. { FPC base type for records }
  803. java_fpcbaserecordtype : tobjectdef;
  804. { java.lang.String }
  805. java_jlstring : tobjectdef;
  806. { java.lang.Enum }
  807. java_jlenum : tobjectdef;
  808. { java.util.EnumSet }
  809. java_juenumset : tobjectdef;
  810. { java.util.BitSet }
  811. java_jubitset : tobjectdef;
  812. { FPC java implementation of ansistrings }
  813. java_ansistring : tobjectdef;
  814. { FPC java implementation of shortstrings }
  815. java_shortstring : tobjectdef;
  816. { FPC java procvar base class }
  817. java_procvarbase : tobjectdef;
  818. const
  819. {$ifdef i386}
  820. pbestrealtype : ^tdef = @s80floattype;
  821. {$endif}
  822. {$ifdef x86_64}
  823. pbestrealtype : ^tdef = @s80floattype;
  824. {$endif}
  825. {$ifdef m68k}
  826. pbestrealtype : ^tdef = @s64floattype;
  827. {$endif}
  828. {$ifdef alpha}
  829. pbestrealtype : ^tdef = @s64floattype;
  830. {$endif}
  831. {$ifdef powerpc}
  832. pbestrealtype : ^tdef = @s64floattype;
  833. {$endif}
  834. {$ifdef POWERPC64}
  835. pbestrealtype : ^tdef = @s64floattype;
  836. {$endif}
  837. {$ifdef ia64}
  838. pbestrealtype : ^tdef = @s64floattype;
  839. {$endif}
  840. {$ifdef SPARC}
  841. pbestrealtype : ^tdef = @s64floattype;
  842. {$endif SPARC}
  843. {$ifdef vis}
  844. pbestrealtype : ^tdef = @s64floattype;
  845. {$endif vis}
  846. {$ifdef ARM}
  847. pbestrealtype : ^tdef = @s64floattype;
  848. {$endif ARM}
  849. {$ifdef MIPS}
  850. pbestrealtype : ^tdef = @s64floattype;
  851. {$endif MIPS}
  852. {$ifdef AVR}
  853. pbestrealtype : ^tdef = @s64floattype;
  854. {$endif AVR}
  855. {$ifdef JVM}
  856. pbestrealtype : ^tdef = @s64floattype;
  857. {$endif JVM}
  858. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  859. function make_dllmangledname(const dllname,importname:TSymStr;
  860. import_nr : word; pco : tproccalloption):TSymStr;
  861. { should be in the types unit, but the types unit uses the node stuff :( }
  862. function is_interfacecom(def: tdef): boolean;
  863. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  864. function is_any_interface_kind(def: tdef): boolean;
  865. function is_interfacecorba(def: tdef): boolean;
  866. function is_interface(def: tdef): boolean;
  867. function is_dispinterface(def: tdef): boolean;
  868. function is_object(def: tdef): boolean;
  869. function is_class(def: tdef): boolean;
  870. function is_cppclass(def: tdef): boolean;
  871. function is_objectpascal_helper(def: tdef): boolean;
  872. function is_objcclass(def: tdef): boolean;
  873. function is_objcclassref(def: tdef): boolean;
  874. function is_objcprotocol(def: tdef): boolean;
  875. function is_objccategory(def: tdef): boolean;
  876. function is_objc_class_or_protocol(def: tdef): boolean;
  877. function is_objc_protocol_or_category(def: tdef): boolean;
  878. function is_classhelper(def: tdef): boolean;
  879. function is_class_or_interface(def: tdef): boolean;
  880. function is_class_or_interface_or_objc(def: tdef): boolean;
  881. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  882. function is_class_or_interface_or_object(def: tdef): boolean;
  883. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  884. function is_implicit_pointer_object_type(def: tdef): boolean;
  885. function is_class_or_object(def: tdef): boolean;
  886. function is_record(def: tdef): boolean;
  887. function is_javaclass(def: tdef): boolean;
  888. function is_javaclassref(def: tdef): boolean;
  889. function is_javainterface(def: tdef): boolean;
  890. function is_java_class_or_interface(def: tdef): boolean;
  891. procedure loadobjctypes;
  892. procedure maybeloadcocoatypes;
  893. function use_vectorfpu(def : tdef) : boolean;
  894. { returns a pointerdef for def, reusing an existing one in case it exists
  895. in the current module }
  896. function getpointerdef(def: tdef): tpointerdef;
  897. implementation
  898. uses
  899. SysUtils,
  900. cutils,
  901. { global }
  902. verbose,
  903. { target }
  904. systems,aasmcpu,paramgr,
  905. { symtable }
  906. symsym,symtable,symutil,defutil,objcdef,
  907. {$ifdef jvm}
  908. jvmdef,
  909. {$endif}
  910. { module }
  911. fmodule,
  912. { other }
  913. gendef,
  914. fpccrc
  915. ;
  916. {****************************************************************************
  917. Helpers
  918. ****************************************************************************}
  919. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  920. var
  921. s,hs,
  922. prefix : TSymStr;
  923. oldlen,
  924. newlen,
  925. i : longint;
  926. crc : dword;
  927. hp : tparavarsym;
  928. begin
  929. prefix:='';
  930. if not assigned(st) then
  931. internalerror(200204212);
  932. { sub procedures }
  933. while (st.symtabletype=localsymtable) do
  934. begin
  935. if st.defowner.typ<>procdef then
  936. internalerror(200204173);
  937. { Add the full mangledname of procedure to prevent
  938. conflicts with 2 overloads having both a nested procedure
  939. with the same name, see tb0314 (PFV) }
  940. s:=tprocdef(st.defowner).procsym.name;
  941. oldlen:=length(s);
  942. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  943. begin
  944. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  945. if not(vo_is_hidden_para in hp.varoptions) then
  946. s:=s+'$'+hp.vardef.mangledparaname;
  947. end;
  948. if not is_void(tprocdef(st.defowner).returndef) then
  949. s:=s+'$$'+tprocdef(st.defowner).returndef.mangledparaname;
  950. newlen:=length(s);
  951. { Replace with CRC if the parameter line is very long }
  952. if (newlen-oldlen>12) and
  953. ((newlen+length(prefix)>100) or (newlen-oldlen>32)) then
  954. begin
  955. crc:=0;
  956. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  957. begin
  958. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  959. if not(vo_is_hidden_para in hp.varoptions) then
  960. begin
  961. hs:=hp.vardef.mangledparaname;
  962. crc:=UpdateCrc32(crc,hs[1],length(hs));
  963. end;
  964. end;
  965. hs:=hp.vardef.mangledparaname;
  966. crc:=UpdateCrc32(crc,hs[1],length(hs));
  967. s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
  968. end;
  969. if prefix<>'' then
  970. prefix:=s+'_'+prefix
  971. else
  972. prefix:=s;
  973. if length(prefix)>100 then
  974. begin
  975. crc:=0;
  976. crc:=UpdateCrc32(crc,prefix[1],length(prefix));
  977. prefix:='$CRC'+hexstr(crc,8);
  978. end;
  979. st:=st.defowner.owner;
  980. end;
  981. { object/classes symtable, nested type definitions in classes require the while loop }
  982. while st.symtabletype in [ObjectSymtable,recordsymtable] do
  983. begin
  984. if not (st.defowner.typ in [objectdef,recorddef]) then
  985. internalerror(200204174);
  986. prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
  987. st:=st.defowner.owner;
  988. end;
  989. { symtable must now be static or global }
  990. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  991. internalerror(200204175);
  992. result:='';
  993. if typeprefix<>'' then
  994. result:=result+typeprefix+'_';
  995. { Add P$ for program, which can have the same name as
  996. a unit }
  997. if (TSymtable(main_module.localsymtable)=st) and
  998. (not main_module.is_unit) then
  999. result:=result+'P$'+st.name^
  1000. else
  1001. result:=result+st.name^;
  1002. if prefix<>'' then
  1003. result:=result+'_'+prefix;
  1004. if suffix<>'' then
  1005. result:=result+'_'+suffix;
  1006. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  1007. { Further, the Mac OS X 10.5 linker does not consider symbols which do not }
  1008. { start with '_' as regular symbols (it does not generate N_GSYM entries }
  1009. { those in the debug map, leading to troubles with dsymutil). So always }
  1010. { add an underscore on darwin. }
  1011. if (target_info.system in systems_darwin) then
  1012. result := '_' + result;
  1013. end;
  1014. function make_dllmangledname(const dllname,importname:TSymStr;import_nr : word; pco : tproccalloption):TSymStr;
  1015. var
  1016. crc : cardinal;
  1017. i : longint;
  1018. use_crc : boolean;
  1019. dllprefix : TSymStr;
  1020. begin
  1021. if (target_info.system in (systems_all_windows + systems_nativent +
  1022. [system_i386_emx, system_i386_os2]))
  1023. and (dllname <> '') then
  1024. begin
  1025. dllprefix:=lower(ExtractFileName(dllname));
  1026. { Remove .dll suffix if present }
  1027. if copy(dllprefix,length(dllprefix)-3,length(dllprefix))='.dll' then
  1028. dllprefix:=copy(dllprefix,1,length(dllprefix)-4);
  1029. use_crc:=false;
  1030. for i:=1 to length(dllprefix) do
  1031. if not (dllprefix[i] in ['a'..'z','A'..'Z','_','0'..'9']) then
  1032. begin
  1033. use_crc:=true;
  1034. break;
  1035. end;
  1036. if use_crc then
  1037. begin
  1038. crc:=0;
  1039. crc:=UpdateCrc32(crc,dllprefix[1],length(dllprefix));
  1040. dllprefix:='_$dll$crc$'+hexstr(crc,8)+'$';
  1041. end
  1042. else
  1043. dllprefix:='_$dll$'+dllprefix+'$';
  1044. if importname<>'' then
  1045. result:=dllprefix+importname
  1046. else
  1047. result:=dllprefix+'_index_'+tostr(import_nr);
  1048. { Replace ? and @ in import name, since GNU AS does not allow these characters in symbol names. }
  1049. { This allows to import VC++ mangled names from DLLs. }
  1050. { Do not perform replacement, if external symbol is not imported from DLL. }
  1051. if (dllname<>'') then
  1052. begin
  1053. Replace(result,'?','__q$$');
  1054. {$ifdef arm}
  1055. { @ symbol is not allowed in ARM assembler only }
  1056. Replace(result,'@','__a$$');
  1057. {$endif arm}
  1058. end;
  1059. end
  1060. else
  1061. begin
  1062. if importname<>'' then
  1063. begin
  1064. if not(pco in [pocall_cdecl,pocall_cppdecl]) then
  1065. result:=importname
  1066. else
  1067. result:=target_info.Cprefix+importname;
  1068. end
  1069. else
  1070. result:='_index_'+tostr(import_nr);
  1071. end;
  1072. end;
  1073. {****************************************************************************
  1074. TDEFAWARESYMTABLESTACK
  1075. (symtablestack descendant that does some special actions on
  1076. the pushed/popped symtables)
  1077. ****************************************************************************}
  1078. procedure tdefawaresymtablestack.addhelpers(st: TSymtable);
  1079. var
  1080. i: integer;
  1081. s: string;
  1082. list: TFPObjectList;
  1083. def: tdef;
  1084. begin
  1085. { search the symtable from first to last; the helper to use will be the
  1086. last one in the list }
  1087. for i:=0 to st.symlist.count-1 do
  1088. begin
  1089. if not (st.symlist[i] is ttypesym) then
  1090. continue;
  1091. def:=ttypesym(st.SymList[i]).typedef;
  1092. if is_objectpascal_helper(def) then
  1093. begin
  1094. s:=make_mangledname('',tobjectdef(def).extendeddef.symtable,'');
  1095. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  1096. if not assigned(list) then
  1097. begin
  1098. list:=TFPObjectList.Create(false);
  1099. current_module.extendeddefs.Add(s,list);
  1100. end;
  1101. list.Add(def);
  1102. end
  1103. else
  1104. { add nested helpers as well }
  1105. if def.typ in [recorddef,objectdef] then
  1106. addhelpers(tabstractrecorddef(def).symtable);
  1107. end;
  1108. end;
  1109. procedure tdefawaresymtablestack.removehelpers(st: TSymtable);
  1110. var
  1111. i, j: integer;
  1112. tmpst: TSymtable;
  1113. list: TFPObjectList;
  1114. begin
  1115. for i:=current_module.extendeddefs.count-1 downto 0 do
  1116. begin
  1117. list:=TFPObjectList(current_module.extendeddefs[i]);
  1118. for j:=list.count-1 downto 0 do
  1119. begin
  1120. if not (list[j] is tobjectdef) then
  1121. Internalerror(2011031501);
  1122. tmpst:=tobjectdef(list[j]).owner;
  1123. repeat
  1124. if tmpst=st then
  1125. begin
  1126. list.delete(j);
  1127. break;
  1128. end
  1129. else
  1130. begin
  1131. if assigned(tmpst.defowner) then
  1132. tmpst:=tmpst.defowner.owner
  1133. else
  1134. tmpst:=nil;
  1135. end;
  1136. until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]);
  1137. end;
  1138. if list.count=0 then
  1139. current_module.extendeddefs.delete(i);
  1140. end;
  1141. end;
  1142. procedure tdefawaresymtablestack.push(st: TSymtable);
  1143. begin
  1144. { nested helpers will be added as well }
  1145. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1146. (sto_has_helper in st.tableoptions) then
  1147. addhelpers(st);
  1148. inherited push(st);
  1149. end;
  1150. procedure tdefawaresymtablestack.pop(st: TSymtable);
  1151. begin
  1152. inherited pop(st);
  1153. { nested helpers will be removed as well }
  1154. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1155. (sto_has_helper in st.tableoptions) then
  1156. removehelpers(st);
  1157. end;
  1158. {****************************************************************************
  1159. TDEF (base class for definitions)
  1160. ****************************************************************************}
  1161. constructor tstoreddef.create(dt:tdeftyp);
  1162. var
  1163. insertstack : psymtablestackitem;
  1164. begin
  1165. inherited create(dt);
  1166. savesize := 0;
  1167. {$ifdef EXTDEBUG}
  1168. fileinfo := current_filepos;
  1169. {$endif}
  1170. generictokenbuf:=nil;
  1171. genericdef:=nil;
  1172. { Don't register forwarddefs, they are disposed at the
  1173. end of an type block }
  1174. if (dt=forwarddef) then
  1175. exit;
  1176. { Register in current_module }
  1177. if assigned(current_module) then
  1178. begin
  1179. current_module.deflist.Add(self);
  1180. DefId:=current_module.deflist.Count-1;
  1181. end;
  1182. { Register in symtable stack }
  1183. if assigned(symtablestack) then
  1184. begin
  1185. insertstack:=symtablestack.stack;
  1186. while assigned(insertstack) and
  1187. (insertstack^.symtable.symtabletype=withsymtable) do
  1188. insertstack:=insertstack^.next;
  1189. if not assigned(insertstack) then
  1190. internalerror(200602044);
  1191. insertstack^.symtable.insertdef(self);
  1192. end;
  1193. end;
  1194. destructor tstoreddef.destroy;
  1195. begin
  1196. { Direct calls are not allowed, use symtable.deletedef() }
  1197. if assigned(owner) then
  1198. internalerror(200612311);
  1199. if assigned(generictokenbuf) then
  1200. begin
  1201. generictokenbuf.free;
  1202. generictokenbuf:=nil;
  1203. end;
  1204. inherited destroy;
  1205. end;
  1206. constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1207. var
  1208. sizeleft,i : longint;
  1209. buf : array[0..255] of byte;
  1210. begin
  1211. inherited create(dt);
  1212. DefId:=ppufile.getlongint;
  1213. current_module.deflist[DefId]:=self;
  1214. {$ifdef EXTDEBUG}
  1215. fillchar(fileinfo,sizeof(fileinfo),0);
  1216. {$endif}
  1217. { load }
  1218. ppufile.getderef(typesymderef);
  1219. ppufile.getsmallset(defoptions);
  1220. ppufile.getsmallset(defstates);
  1221. if df_generic in defoptions then
  1222. begin
  1223. sizeleft:=ppufile.getlongint;
  1224. initgeneric;
  1225. while sizeleft>0 do
  1226. begin
  1227. if sizeleft>sizeof(buf) then
  1228. i:=sizeof(buf)
  1229. else
  1230. i:=sizeleft;
  1231. ppufile.getdata(buf,i);
  1232. generictokenbuf.write(buf,i);
  1233. dec(sizeleft,i);
  1234. end;
  1235. end;
  1236. if df_specialization in defoptions then
  1237. ppufile.getderef(genericdefderef);
  1238. end;
  1239. function Tstoreddef.rtti_mangledname(rt:trttitype):string;
  1240. var
  1241. prefix : string[4];
  1242. begin
  1243. if rt=fullrtti then
  1244. begin
  1245. prefix:='RTTI';
  1246. include(defstates,ds_rtti_table_used);
  1247. end
  1248. else
  1249. begin
  1250. prefix:='INIT';
  1251. include(defstates,ds_init_table_used);
  1252. end;
  1253. if assigned(typesym) and
  1254. (owner.symtabletype in [staticsymtable,globalsymtable]) then
  1255. result:=make_mangledname(prefix,owner,typesym.name)
  1256. else
  1257. result:=make_mangledname(prefix,findunitsymtable(owner),'DEF'+tostr(DefId))
  1258. end;
  1259. function tstoreddef.OwnerHierarchyName: string;
  1260. var
  1261. tmp: tdef;
  1262. begin
  1263. tmp:=self;
  1264. result:='';
  1265. repeat
  1266. if tmp.owner.symtabletype in [ObjectSymtable,recordsymtable] then
  1267. tmp:=tdef(tmp.owner.defowner)
  1268. else
  1269. break;
  1270. result:=tabstractrecorddef(tmp).objrealname^+'.'+result;
  1271. until tmp=nil;
  1272. end;
  1273. function tstoreddef.in_currentunit: boolean;
  1274. var
  1275. st: tsymtable;
  1276. begin
  1277. st:=owner;
  1278. while not(st.symtabletype in [globalsymtable,staticsymtable]) do
  1279. st:=st.defowner.owner;
  1280. result:=st.iscurrentunit;
  1281. end;
  1282. function tstoreddef.getcopy : tstoreddef;
  1283. begin
  1284. Message(sym_e_cant_create_unique_type);
  1285. getcopy:=terrordef.create;
  1286. end;
  1287. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  1288. var
  1289. sizeleft,i : longint;
  1290. buf : array[0..255] of byte;
  1291. oldintfcrc : boolean;
  1292. begin
  1293. ppufile.putlongint(DefId);
  1294. ppufile.putderef(typesymderef);
  1295. ppufile.putsmallset(defoptions);
  1296. oldintfcrc:=ppufile.do_crc;
  1297. ppufile.do_crc:=false;
  1298. ppufile.putsmallset(defstates);
  1299. if df_generic in defoptions then
  1300. begin
  1301. if assigned(generictokenbuf) then
  1302. begin
  1303. sizeleft:=generictokenbuf.size;
  1304. generictokenbuf.seek(0);
  1305. end
  1306. else
  1307. sizeleft:=0;
  1308. ppufile.putlongint(sizeleft);
  1309. while sizeleft>0 do
  1310. begin
  1311. if sizeleft>sizeof(buf) then
  1312. i:=sizeof(buf)
  1313. else
  1314. i:=sizeleft;
  1315. generictokenbuf.read(buf,i);
  1316. ppufile.putdata(buf,i);
  1317. dec(sizeleft,i);
  1318. end;
  1319. end;
  1320. ppufile.do_crc:=oldintfcrc;
  1321. if df_specialization in defoptions then
  1322. ppufile.putderef(genericdefderef);
  1323. end;
  1324. procedure tstoreddef.buildderef;
  1325. begin
  1326. typesymderef.build(typesym);
  1327. genericdefderef.build(genericdef);
  1328. end;
  1329. procedure tstoreddef.buildderefimpl;
  1330. begin
  1331. end;
  1332. procedure tstoreddef.deref;
  1333. begin
  1334. typesym:=ttypesym(typesymderef.resolve);
  1335. if df_specialization in defoptions then
  1336. genericdef:=tstoreddef(genericdefderef.resolve);
  1337. end;
  1338. procedure tstoreddef.derefimpl;
  1339. begin
  1340. end;
  1341. function tstoreddef.size : asizeint;
  1342. begin
  1343. size:=savesize;
  1344. end;
  1345. function tstoreddef.getvardef:longint;
  1346. begin
  1347. result:=varUndefined;
  1348. end;
  1349. function tstoreddef.alignment : shortint;
  1350. begin
  1351. { natural alignment by default }
  1352. alignment:=size_2_align(savesize);
  1353. { can happen if savesize = 0, e.g. for voiddef or
  1354. an empty record
  1355. }
  1356. if (alignment=0) then
  1357. alignment:=1;
  1358. end;
  1359. { returns true, if the definition can be published }
  1360. function tstoreddef.is_publishable : boolean;
  1361. begin
  1362. is_publishable:=false;
  1363. end;
  1364. { needs an init table }
  1365. function tstoreddef.needs_inittable : boolean;
  1366. begin
  1367. needs_inittable:=false;
  1368. end;
  1369. function tstoreddef.is_intregable : boolean;
  1370. var
  1371. recsize,temp: longint;
  1372. begin
  1373. is_intregable:=false;
  1374. case typ of
  1375. orddef,
  1376. pointerdef,
  1377. enumdef,
  1378. classrefdef:
  1379. is_intregable:=true;
  1380. procvardef :
  1381. is_intregable:=tprocvardef(self).is_addressonly;
  1382. objectdef:
  1383. is_intregable:=(is_implicit_pointer_object_type(self)) and not needs_inittable;
  1384. setdef:
  1385. is_intregable:=is_smallset(self);
  1386. recorddef:
  1387. begin
  1388. recsize:=size;
  1389. is_intregable:=
  1390. ispowerof2(recsize,temp) and
  1391. (recsize <= sizeof(asizeint));
  1392. end;
  1393. end;
  1394. end;
  1395. function tstoreddef.is_fpuregable : boolean;
  1396. begin
  1397. {$ifdef x86}
  1398. result:=use_vectorfpu(self);
  1399. {$else x86}
  1400. result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches);
  1401. {$endif x86}
  1402. end;
  1403. procedure tstoreddef.initgeneric;
  1404. begin
  1405. if assigned(generictokenbuf) then
  1406. internalerror(200512131);
  1407. generictokenbuf:=tdynamicarray.create(256);
  1408. end;
  1409. {****************************************************************************
  1410. Tstringdef
  1411. ****************************************************************************}
  1412. constructor tstringdef.createshort(l : byte);
  1413. begin
  1414. inherited create(stringdef);
  1415. stringtype:=st_shortstring;
  1416. len:=l;
  1417. savesize:=len+1;
  1418. end;
  1419. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  1420. begin
  1421. inherited ppuload(stringdef,ppufile);
  1422. stringtype:=st_shortstring;
  1423. len:=ppufile.getbyte;
  1424. savesize:=len+1;
  1425. end;
  1426. constructor tstringdef.createlong(l : asizeint);
  1427. begin
  1428. inherited create(stringdef);
  1429. stringtype:=st_longstring;
  1430. len:=l;
  1431. savesize:=sizeof(pint);
  1432. end;
  1433. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1434. begin
  1435. inherited ppuload(stringdef,ppufile);
  1436. stringtype:=st_longstring;
  1437. len:=ppufile.getasizeint;
  1438. savesize:=sizeof(pint);
  1439. end;
  1440. constructor tstringdef.createansi;
  1441. begin
  1442. inherited create(stringdef);
  1443. stringtype:=st_ansistring;
  1444. len:=-1;
  1445. savesize:=sizeof(pint);
  1446. end;
  1447. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1448. begin
  1449. inherited ppuload(stringdef,ppufile);
  1450. stringtype:=st_ansistring;
  1451. len:=ppufile.getaint;
  1452. savesize:=sizeof(pint);
  1453. end;
  1454. constructor tstringdef.createwide;
  1455. begin
  1456. inherited create(stringdef);
  1457. stringtype:=st_widestring;
  1458. len:=-1;
  1459. savesize:=sizeof(pint);
  1460. end;
  1461. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1462. begin
  1463. inherited ppuload(stringdef,ppufile);
  1464. stringtype:=st_widestring;
  1465. len:=ppufile.getaint;
  1466. savesize:=sizeof(pint);
  1467. end;
  1468. constructor tstringdef.createunicode;
  1469. begin
  1470. inherited create(stringdef);
  1471. stringtype:=st_unicodestring;
  1472. len:=-1;
  1473. savesize:=sizeof(pint);
  1474. end;
  1475. constructor tstringdef.loadunicode(ppufile:tcompilerppufile);
  1476. begin
  1477. inherited ppuload(stringdef,ppufile);
  1478. stringtype:=st_unicodestring;
  1479. len:=ppufile.getaint;
  1480. savesize:=sizeof(pint);
  1481. end;
  1482. function tstringdef.getcopy : tstoreddef;
  1483. begin
  1484. result:=tstringdef.create(typ);
  1485. result.typ:=stringdef;
  1486. tstringdef(result).stringtype:=stringtype;
  1487. tstringdef(result).len:=len;
  1488. tstringdef(result).savesize:=savesize;
  1489. end;
  1490. function tstringdef.stringtypname:string;
  1491. const
  1492. typname:array[tstringtype] of string[10]=(
  1493. 'shortstr','longstr','ansistr','widestr','unicodestr'
  1494. );
  1495. begin
  1496. stringtypname:=typname[stringtype];
  1497. end;
  1498. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  1499. begin
  1500. inherited ppuwrite(ppufile);
  1501. if stringtype=st_shortstring then
  1502. begin
  1503. {$ifdef extdebug}
  1504. if len > 255 then internalerror(12122002);
  1505. {$endif}
  1506. ppufile.putbyte(byte(len))
  1507. end
  1508. else
  1509. ppufile.putaint(len);
  1510. case stringtype of
  1511. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1512. st_longstring : ppufile.writeentry(iblongstringdef);
  1513. st_ansistring : ppufile.writeentry(ibansistringdef);
  1514. st_widestring : ppufile.writeentry(ibwidestringdef);
  1515. st_unicodestring : ppufile.writeentry(ibunicodestringdef);
  1516. end;
  1517. end;
  1518. function tstringdef.needs_inittable : boolean;
  1519. begin
  1520. needs_inittable:=stringtype in [st_ansistring,st_widestring,st_unicodestring];
  1521. end;
  1522. function tstringdef.GetTypeName : string;
  1523. const
  1524. names : array[tstringtype] of string[15] = (
  1525. 'ShortString','LongString','AnsiString','WideString','UnicodeString');
  1526. begin
  1527. GetTypeName:=names[stringtype];
  1528. end;
  1529. function tstringdef.getvardef : longint;
  1530. const
  1531. vardef : array[tstringtype] of longint = (
  1532. varUndefined,varUndefined,varString,varOleStr,varUString);
  1533. begin
  1534. result:=vardef[stringtype];
  1535. end;
  1536. function tstringdef.is_related(d: tdef): boolean;
  1537. begin
  1538. result:=
  1539. (target_info.system=system_jvm_java32) and
  1540. (((stringtype in [st_unicodestring,st_widestring]) and
  1541. ((d=java_jlobject) or
  1542. (d=java_jlstring))) or
  1543. ((stringtype=st_ansistring) and
  1544. ((d=java_jlobject) or
  1545. (d=java_ansistring))));
  1546. end;
  1547. function tstringdef.alignment : shortint;
  1548. begin
  1549. case stringtype of
  1550. st_unicodestring,
  1551. st_widestring,
  1552. st_ansistring:
  1553. alignment:=size_2_align(savesize);
  1554. st_longstring,
  1555. st_shortstring:
  1556. { char to string accesses byte 0 and 1 with one word access }
  1557. if (tf_requires_proper_alignment in target_info.flags) or
  1558. { macpas needs an alignment of 2 (MetroWerks compatible) }
  1559. (m_mac in current_settings.modeswitches) then
  1560. alignment:=size_2_align(2)
  1561. else
  1562. alignment:=size_2_align(1);
  1563. else
  1564. internalerror(200412301);
  1565. end;
  1566. end;
  1567. function tstringdef.getmangledparaname : TSymStr;
  1568. begin
  1569. getmangledparaname:='STRING';
  1570. end;
  1571. function tstringdef.is_publishable : boolean;
  1572. begin
  1573. is_publishable:=true;
  1574. end;
  1575. {****************************************************************************
  1576. TENUMDEF
  1577. ****************************************************************************}
  1578. constructor tenumdef.create;
  1579. begin
  1580. inherited create(enumdef);
  1581. minval:=0;
  1582. maxval:=0;
  1583. calcsavesize;
  1584. has_jumps:=false;
  1585. basedef:=nil;
  1586. symtable:=tenumsymtable.create(self);
  1587. end;
  1588. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  1589. begin
  1590. inherited create(enumdef);
  1591. minval:=_min;
  1592. maxval:=_max;
  1593. basedef:=_basedef;
  1594. calcsavesize;
  1595. has_jumps:=false;
  1596. symtable:=basedef.symtable.getcopy;
  1597. include(defoptions, df_copied_def);
  1598. end;
  1599. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  1600. begin
  1601. inherited ppuload(enumdef,ppufile);
  1602. minval:=ppufile.getaint;
  1603. maxval:=ppufile.getaint;
  1604. savesize:=ppufile.getaint;
  1605. has_jumps:=false;
  1606. {$ifdef jvm}
  1607. ppufile.getderef(classdefderef);
  1608. {$endif}
  1609. if df_copied_def in defoptions then
  1610. begin
  1611. symtable:=nil;
  1612. ppufile.getderef(basedefderef);
  1613. end
  1614. else
  1615. begin
  1616. // create with nil defowner first to prevent values changes on insert
  1617. symtable:=tenumsymtable.create(nil);
  1618. tenumsymtable(symtable).ppuload(ppufile);
  1619. symtable.defowner:=self;
  1620. end;
  1621. end;
  1622. destructor tenumdef.destroy;
  1623. begin
  1624. symtable.free;
  1625. symtable:=nil;
  1626. inherited destroy;
  1627. end;
  1628. function tenumdef.getcopy : tstoreddef;
  1629. begin
  1630. if assigned(basedef) then
  1631. result:=tenumdef.create_subrange(basedef,minval,maxval)
  1632. else
  1633. begin
  1634. result:=tenumdef.create;
  1635. tenumdef(result).minval:=minval;
  1636. tenumdef(result).maxval:=maxval;
  1637. tenumdef(result).symtable.free;
  1638. tenumdef(result).symtable:=symtable.getcopy;
  1639. tenumdef(result).basedef:=self;
  1640. end;
  1641. {$ifdef jvm}
  1642. tenumdef(result).classdef:=classdef;
  1643. {$endif}
  1644. tenumdef(result).has_jumps:=has_jumps;
  1645. tenumdef(result).basedefderef:=basedefderef;
  1646. include(tenumdef(result).defoptions,df_copied_def);
  1647. end;
  1648. procedure tenumdef.calcsavesize;
  1649. begin
  1650. if (current_settings.packenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
  1651. savesize:=8
  1652. else
  1653. if (current_settings.packenum=4) or (min<low(smallint)) or (max>high(word)) then
  1654. savesize:=4
  1655. else
  1656. if (current_settings.packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  1657. savesize:=2
  1658. else
  1659. savesize:=1;
  1660. end;
  1661. function tenumdef.packedbitsize: asizeint;
  1662. var
  1663. sizeval: tconstexprint;
  1664. power: longint;
  1665. begin
  1666. result := 0;
  1667. if (minval >= 0) and
  1668. (maxval <= 1) then
  1669. result := 1
  1670. else
  1671. begin
  1672. if (minval>=0) then
  1673. sizeval:=maxval
  1674. else
  1675. { don't count 0 twice }
  1676. sizeval:=(cutils.max(-minval,maxval)*2)-1;
  1677. { 256 must become 512 etc. }
  1678. nextpowerof2(sizeval+1,power);
  1679. result := power;
  1680. end;
  1681. end;
  1682. procedure tenumdef.setmax(_max:asizeint);
  1683. begin
  1684. maxval:=_max;
  1685. calcsavesize;
  1686. end;
  1687. procedure tenumdef.setmin(_min:asizeint);
  1688. begin
  1689. minval:=_min;
  1690. calcsavesize;
  1691. end;
  1692. function tenumdef.min:asizeint;
  1693. begin
  1694. min:=minval;
  1695. end;
  1696. function tenumdef.max:asizeint;
  1697. begin
  1698. max:=maxval;
  1699. end;
  1700. function tenumdef.getfirstsym: tsym;
  1701. var
  1702. i:integer;
  1703. begin
  1704. for i := 0 to symtable.SymList.Count - 1 do
  1705. begin
  1706. result:=tsym(symtable.SymList[i]);
  1707. if tenumsym(result).value=minval then
  1708. exit;
  1709. end;
  1710. result:=nil;
  1711. end;
  1712. function tenumdef.getbasedef: tenumdef;
  1713. begin
  1714. if not assigned(basedef) then
  1715. result:=self
  1716. else
  1717. result:=basedef;
  1718. end;
  1719. procedure tenumdef.buildderef;
  1720. begin
  1721. inherited buildderef;
  1722. if df_copied_def in defoptions then
  1723. basedefderef.build(basedef)
  1724. else
  1725. tenumsymtable(symtable).buildderef;
  1726. {$ifdef jvm}
  1727. classdefderef.build(classdef);
  1728. {$endif}
  1729. end;
  1730. procedure tenumdef.deref;
  1731. begin
  1732. inherited deref;
  1733. if df_copied_def in defoptions then
  1734. begin
  1735. basedef:=tenumdef(basedefderef.resolve);
  1736. symtable:=basedef.symtable.getcopy;
  1737. end
  1738. else
  1739. tenumsymtable(symtable).deref;
  1740. {$ifdef jvm}
  1741. classdef:=tobjectdef(classdefderef.resolve);
  1742. {$endif}
  1743. end;
  1744. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  1745. begin
  1746. inherited ppuwrite(ppufile);
  1747. ppufile.putaint(min);
  1748. ppufile.putaint(max);
  1749. ppufile.putaint(savesize);
  1750. {$ifdef jvm}
  1751. ppufile.putderef(classdefderef);
  1752. {$endif}
  1753. if df_copied_def in defoptions then
  1754. ppufile.putderef(basedefderef);
  1755. ppufile.writeentry(ibenumdef);
  1756. if not (df_copied_def in defoptions) then
  1757. tenumsymtable(symtable).ppuwrite(ppufile);
  1758. end;
  1759. function tenumdef.is_publishable : boolean;
  1760. begin
  1761. is_publishable:=true;
  1762. end;
  1763. function tenumdef.GetTypeName : string;
  1764. begin
  1765. GetTypeName:='<enumeration type>';
  1766. end;
  1767. {****************************************************************************
  1768. TORDDEF
  1769. ****************************************************************************}
  1770. constructor torddef.create(t : tordtype;v,b : TConstExprInt);
  1771. begin
  1772. inherited create(orddef);
  1773. low:=v;
  1774. high:=b;
  1775. ordtype:=t;
  1776. setsize;
  1777. end;
  1778. constructor torddef.ppuload(ppufile:tcompilerppufile);
  1779. begin
  1780. inherited ppuload(orddef,ppufile);
  1781. ordtype:=tordtype(ppufile.getbyte);
  1782. low:=ppufile.getexprint;
  1783. high:=ppufile.getexprint;
  1784. setsize;
  1785. end;
  1786. function torddef.getcopy : tstoreddef;
  1787. begin
  1788. result:=torddef.create(ordtype,low,high);
  1789. result.typ:=orddef;
  1790. torddef(result).low:=low;
  1791. torddef(result).high:=high;
  1792. torddef(result).ordtype:=ordtype;
  1793. torddef(result).savesize:=savesize;
  1794. end;
  1795. function torddef.alignment:shortint;
  1796. begin
  1797. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) and
  1798. (ordtype in [s64bit,u64bit]) then
  1799. result := 4
  1800. else
  1801. result := inherited alignment;
  1802. end;
  1803. procedure torddef.setsize;
  1804. const
  1805. sizetbl : array[tordtype] of longint = (
  1806. 0,
  1807. 1,2,4,8,
  1808. 1,2,4,8,
  1809. 1,2,4,8,
  1810. 1,2,4,8,
  1811. 1,2,8
  1812. );
  1813. begin
  1814. savesize:=sizetbl[ordtype];
  1815. end;
  1816. function torddef.packedbitsize: asizeint;
  1817. var
  1818. sizeval: tconstexprint;
  1819. power: longint;
  1820. begin
  1821. result := 0;
  1822. if ordtype = uvoid then
  1823. exit;
  1824. {$ifndef cpu64bitalu}
  1825. if (ordtype in [s64bit,u64bit]) then
  1826. {$else not cpu64bitalu}
  1827. if (ordtype = u64bit) or
  1828. ((ordtype = s64bit) and
  1829. ((low <= (system.low(int64) div 2)) or
  1830. (high > (system.high(int64) div 2)))) then
  1831. {$endif cpu64bitalu}
  1832. result := 64
  1833. else if (low >= 0) and
  1834. (high <= 1) then
  1835. result := 1
  1836. else
  1837. begin
  1838. if (low>=0) then
  1839. sizeval:=high
  1840. else
  1841. { don't count 0 twice }
  1842. sizeval:=(cutils.max(-low,high)*2)-1;
  1843. { 256 must become 512 etc. }
  1844. nextpowerof2(sizeval+1,power);
  1845. result := power;
  1846. end;
  1847. end;
  1848. function torddef.getvardef : longint;
  1849. const
  1850. basetype2vardef : array[tordtype] of longint = (
  1851. varUndefined,
  1852. varbyte,varword,varlongword,varqword,
  1853. varshortint,varsmallint,varinteger,varint64,
  1854. varboolean,varboolean,varboolean,varboolean,
  1855. varboolean,varboolean,varUndefined,varUndefined,
  1856. varUndefined,varUndefined,varCurrency);
  1857. begin
  1858. result:=basetype2vardef[ordtype];
  1859. end;
  1860. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  1861. begin
  1862. inherited ppuwrite(ppufile);
  1863. ppufile.putbyte(byte(ordtype));
  1864. ppufile.putexprint(low);
  1865. ppufile.putexprint(high);
  1866. ppufile.writeentry(iborddef);
  1867. end;
  1868. function torddef.is_publishable : boolean;
  1869. begin
  1870. is_publishable:=(ordtype<>uvoid);
  1871. end;
  1872. function torddef.GetTypeName : string;
  1873. const
  1874. names : array[tordtype] of string[20] = (
  1875. 'untyped',
  1876. 'Byte','Word','DWord','QWord',
  1877. 'ShortInt','SmallInt','LongInt','Int64',
  1878. 'Boolean','Boolean16','Boolean32','Boolean64',
  1879. 'ByteBool','WordBool','LongBool','QWordBool',
  1880. 'Char','WideChar','Currency');
  1881. begin
  1882. GetTypeName:=names[ordtype];
  1883. end;
  1884. {****************************************************************************
  1885. TFLOATDEF
  1886. ****************************************************************************}
  1887. constructor tfloatdef.create(t : tfloattype);
  1888. begin
  1889. inherited create(floatdef);
  1890. floattype:=t;
  1891. setsize;
  1892. end;
  1893. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  1894. begin
  1895. inherited ppuload(floatdef,ppufile);
  1896. floattype:=tfloattype(ppufile.getbyte);
  1897. setsize;
  1898. end;
  1899. function tfloatdef.getcopy : tstoreddef;
  1900. begin
  1901. result:=tfloatdef.create(floattype);
  1902. result.typ:=floatdef;
  1903. tfloatdef(result).savesize:=savesize;
  1904. end;
  1905. function tfloatdef.alignment:shortint;
  1906. begin
  1907. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) then
  1908. case floattype of
  1909. s80real: result:=16;
  1910. s64real,
  1911. s64currency,
  1912. s64comp : result:=4;
  1913. else
  1914. result := inherited alignment;
  1915. end
  1916. else
  1917. result := inherited alignment;
  1918. end;
  1919. procedure tfloatdef.setsize;
  1920. begin
  1921. case floattype of
  1922. s32real : savesize:=4;
  1923. s80real : savesize:=10;
  1924. sc80real:
  1925. if target_info.system in [system_i386_darwin,system_i386_iphonesim,system_x86_64_darwin,
  1926. system_x86_64_linux,system_x86_64_freebsd,
  1927. system_x86_64_solaris,system_x86_64_embedded] then
  1928. savesize:=16
  1929. else
  1930. savesize:=12;
  1931. s64real,
  1932. s64currency,
  1933. s64comp : savesize:=8;
  1934. else
  1935. savesize:=0;
  1936. end;
  1937. end;
  1938. function tfloatdef.getvardef : longint;
  1939. const
  1940. floattype2vardef : array[tfloattype] of longint = (
  1941. varSingle,varDouble,varUndefined,varUndefined,
  1942. varUndefined,varCurrency,varUndefined);
  1943. begin
  1944. if (upper(typename)='TDATETIME') and
  1945. assigned(owner) and
  1946. assigned(owner.name) and
  1947. (owner.name^='SYSTEM') then
  1948. result:=varDate
  1949. else
  1950. result:=floattype2vardef[floattype];
  1951. end;
  1952. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  1953. begin
  1954. inherited ppuwrite(ppufile);
  1955. ppufile.putbyte(byte(floattype));
  1956. ppufile.writeentry(ibfloatdef);
  1957. end;
  1958. function tfloatdef.is_publishable : boolean;
  1959. begin
  1960. is_publishable:=true;
  1961. end;
  1962. function tfloatdef.GetTypeName : string;
  1963. const
  1964. names : array[tfloattype] of string[20] = (
  1965. 'Single','Double','Extended','CExtended','Comp','Currency','Float128');
  1966. begin
  1967. GetTypeName:=names[floattype];
  1968. end;
  1969. {****************************************************************************
  1970. TFILEDEF
  1971. ****************************************************************************}
  1972. constructor tfiledef.createtext;
  1973. begin
  1974. inherited create(filedef);
  1975. filetyp:=ft_text;
  1976. typedfiledef:=nil;
  1977. setsize;
  1978. end;
  1979. constructor tfiledef.createuntyped;
  1980. begin
  1981. inherited create(filedef);
  1982. filetyp:=ft_untyped;
  1983. typedfiledef:=nil;
  1984. setsize;
  1985. end;
  1986. constructor tfiledef.createtyped(def:tdef);
  1987. begin
  1988. inherited create(filedef);
  1989. filetyp:=ft_typed;
  1990. typedfiledef:=def;
  1991. setsize;
  1992. end;
  1993. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  1994. begin
  1995. inherited ppuload(filedef,ppufile);
  1996. filetyp:=tfiletyp(ppufile.getbyte);
  1997. if filetyp=ft_typed then
  1998. ppufile.getderef(typedfiledefderef)
  1999. else
  2000. typedfiledef:=nil;
  2001. setsize;
  2002. end;
  2003. function tfiledef.getcopy : tstoreddef;
  2004. begin
  2005. case filetyp of
  2006. ft_typed:
  2007. result:=tfiledef.createtyped(typedfiledef);
  2008. ft_untyped:
  2009. result:=tfiledef.createuntyped;
  2010. ft_text:
  2011. result:=tfiledef.createtext;
  2012. else
  2013. internalerror(2004121201);
  2014. end;
  2015. end;
  2016. procedure tfiledef.buildderef;
  2017. begin
  2018. inherited buildderef;
  2019. if filetyp=ft_typed then
  2020. typedfiledefderef.build(typedfiledef);
  2021. end;
  2022. procedure tfiledef.deref;
  2023. begin
  2024. inherited deref;
  2025. if filetyp=ft_typed then
  2026. typedfiledef:=tdef(typedfiledefderef.resolve);
  2027. end;
  2028. procedure tfiledef.setsize;
  2029. begin
  2030. {$ifdef cpu64bitaddr}
  2031. case filetyp of
  2032. ft_text :
  2033. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  2034. savesize:=632{+8}
  2035. else
  2036. savesize:=628{+8};
  2037. ft_typed,
  2038. ft_untyped :
  2039. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  2040. savesize:=372
  2041. else
  2042. savesize:=368;
  2043. end;
  2044. {$endif cpu64bitaddr}
  2045. {$ifdef cpu32bitaddr}
  2046. case filetyp of
  2047. ft_text :
  2048. savesize:=592{+4};
  2049. ft_typed,
  2050. ft_untyped :
  2051. savesize:=332;
  2052. end;
  2053. {$endif cpu32bitaddr}
  2054. {$ifdef cpu8bitaddr}
  2055. case filetyp of
  2056. ft_text :
  2057. savesize:=127;
  2058. ft_typed,
  2059. ft_untyped :
  2060. savesize:=127;
  2061. end;
  2062. {$endif cpu8bitaddr}
  2063. end;
  2064. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  2065. begin
  2066. inherited ppuwrite(ppufile);
  2067. ppufile.putbyte(byte(filetyp));
  2068. if filetyp=ft_typed then
  2069. ppufile.putderef(typedfiledefderef);
  2070. ppufile.writeentry(ibfiledef);
  2071. end;
  2072. function tfiledef.GetTypeName : string;
  2073. begin
  2074. case filetyp of
  2075. ft_untyped:
  2076. GetTypeName:='File';
  2077. ft_typed:
  2078. GetTypeName:='File Of '+typedfiledef.typename;
  2079. ft_text:
  2080. GetTypeName:='Text'
  2081. end;
  2082. end;
  2083. function tfiledef.getmangledparaname : TSymStr;
  2084. begin
  2085. case filetyp of
  2086. ft_untyped:
  2087. getmangledparaname:='FILE';
  2088. ft_typed:
  2089. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  2090. ft_text:
  2091. getmangledparaname:='TEXT'
  2092. end;
  2093. end;
  2094. {****************************************************************************
  2095. TVARIANTDEF
  2096. ****************************************************************************}
  2097. constructor tvariantdef.create(v : tvarianttype);
  2098. begin
  2099. inherited create(variantdef);
  2100. varianttype:=v;
  2101. setsize;
  2102. end;
  2103. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  2104. begin
  2105. inherited ppuload(variantdef,ppufile);
  2106. varianttype:=tvarianttype(ppufile.getbyte);
  2107. setsize;
  2108. end;
  2109. function tvariantdef.getcopy : tstoreddef;
  2110. begin
  2111. result:=tvariantdef.create(varianttype);
  2112. end;
  2113. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  2114. begin
  2115. inherited ppuwrite(ppufile);
  2116. ppufile.putbyte(byte(varianttype));
  2117. ppufile.writeentry(ibvariantdef);
  2118. end;
  2119. function tvariantdef.getvardef : longint;
  2120. begin
  2121. Result:=varVariant;
  2122. end;
  2123. procedure tvariantdef.setsize;
  2124. begin
  2125. {$ifdef cpu64bitaddr}
  2126. savesize:=24;
  2127. {$else cpu64bitaddr}
  2128. savesize:=16;
  2129. {$endif cpu64bitaddr}
  2130. end;
  2131. function tvariantdef.GetTypeName : string;
  2132. begin
  2133. case varianttype of
  2134. vt_normalvariant:
  2135. GetTypeName:='Variant';
  2136. vt_olevariant:
  2137. GetTypeName:='OleVariant';
  2138. end;
  2139. end;
  2140. function tvariantdef.needs_inittable : boolean;
  2141. begin
  2142. needs_inittable:=true;
  2143. end;
  2144. function tvariantdef.is_publishable : boolean;
  2145. begin
  2146. is_publishable:=true;
  2147. end;
  2148. {****************************************************************************
  2149. TABSTRACtpointerdef
  2150. ****************************************************************************}
  2151. constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef);
  2152. begin
  2153. inherited create(dt);
  2154. pointeddef:=def;
  2155. savesize:=sizeof(pint);
  2156. end;
  2157. constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2158. begin
  2159. inherited ppuload(dt,ppufile);
  2160. ppufile.getderef(pointeddefderef);
  2161. savesize:=sizeof(pint);
  2162. end;
  2163. procedure tabstractpointerdef.buildderef;
  2164. begin
  2165. inherited buildderef;
  2166. pointeddefderef.build(pointeddef);
  2167. end;
  2168. procedure tabstractpointerdef.deref;
  2169. begin
  2170. inherited deref;
  2171. pointeddef:=tdef(pointeddefderef.resolve);
  2172. end;
  2173. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2174. begin
  2175. inherited ppuwrite(ppufile);
  2176. ppufile.putderef(pointeddefderef);
  2177. end;
  2178. {****************************************************************************
  2179. tpointerdef
  2180. ****************************************************************************}
  2181. constructor tpointerdef.create(def:tdef);
  2182. begin
  2183. inherited create(pointerdef,def);
  2184. is_far:=false;
  2185. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2186. end;
  2187. constructor tpointerdef.createfar(def:tdef);
  2188. begin
  2189. inherited create(pointerdef,def);
  2190. is_far:=true;
  2191. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2192. end;
  2193. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  2194. begin
  2195. inherited ppuload(pointerdef,ppufile);
  2196. is_far:=(ppufile.getbyte<>0);
  2197. has_pointer_math:=(ppufile.getbyte<>0);
  2198. end;
  2199. function tpointerdef.getcopy : tstoreddef;
  2200. begin
  2201. { don't use direct pointeddef if it is a forwarddef because in other case
  2202. one of them will be destroyed on forward type resolve and the second will
  2203. point to garbage }
  2204. if pointeddef.typ=forwarddef then
  2205. result:=tpointerdef.create(tforwarddef(pointeddef).getcopy)
  2206. else
  2207. result:=tpointerdef.create(pointeddef);
  2208. tpointerdef(result).is_far:=is_far;
  2209. tpointerdef(result).has_pointer_math:=has_pointer_math;
  2210. tpointerdef(result).savesize:=savesize;
  2211. end;
  2212. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2213. begin
  2214. inherited ppuwrite(ppufile);
  2215. ppufile.putbyte(byte(is_far));
  2216. ppufile.putbyte(byte(has_pointer_math));
  2217. ppufile.writeentry(ibpointerdef);
  2218. end;
  2219. function tpointerdef.GetTypeName : string;
  2220. begin
  2221. if is_far then
  2222. GetTypeName:='^'+pointeddef.typename+';far'
  2223. else
  2224. GetTypeName:='^'+pointeddef.typename;
  2225. end;
  2226. {****************************************************************************
  2227. TCLASSREFDEF
  2228. ****************************************************************************}
  2229. constructor tclassrefdef.create(def:tdef);
  2230. begin
  2231. inherited create(classrefdef,def);
  2232. end;
  2233. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  2234. begin
  2235. inherited ppuload(classrefdef,ppufile);
  2236. end;
  2237. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  2238. begin
  2239. inherited ppuwrite(ppufile);
  2240. ppufile.writeentry(ibclassrefdef);
  2241. end;
  2242. function tclassrefdef.getcopy:tstoreddef;
  2243. begin
  2244. if pointeddef.typ=forwarddef then
  2245. result:=tclassrefdef.create(tforwarddef(pointeddef).getcopy)
  2246. else
  2247. result:=tclassrefdef.create(pointeddef);
  2248. tclassrefdef(result).savesize:=savesize;
  2249. end;
  2250. function tclassrefdef.GetTypeName : string;
  2251. begin
  2252. GetTypeName:='Class Of '+pointeddef.typename;
  2253. end;
  2254. function tclassrefdef.is_publishable : boolean;
  2255. begin
  2256. result:=true;
  2257. end;
  2258. function tclassrefdef.rtti_mangledname(rt: trttitype): string;
  2259. begin
  2260. if (tobjectdef(pointeddef).objecttype<>odt_objcclass) then
  2261. result:=inherited rtti_mangledname(rt)
  2262. else
  2263. result:=tobjectdef(pointeddef).rtti_mangledname(objcmetartti);
  2264. end;
  2265. procedure tclassrefdef.register_created_object_type;
  2266. begin
  2267. tobjectdef(pointeddef).register_created_classref_type;
  2268. end;
  2269. {***************************************************************************
  2270. TSETDEF
  2271. ***************************************************************************}
  2272. constructor tsetdef.create(def:tdef;low, high : asizeint);
  2273. var
  2274. setallocbits: aint;
  2275. packedsavesize: aint;
  2276. begin
  2277. inherited create(setdef);
  2278. elementdef:=def;
  2279. setmax:=high;
  2280. if (current_settings.setalloc=0) then
  2281. begin
  2282. setbase:=0;
  2283. if (high<32) then
  2284. savesize:=Sizeof(longint)
  2285. else if (high<256) then
  2286. savesize:=32
  2287. else
  2288. savesize:=(high+7) div 8
  2289. end
  2290. else
  2291. begin
  2292. setallocbits:=current_settings.setalloc*8;
  2293. setbase:=low and not(setallocbits-1);
  2294. packedsavesize:=current_settings.setalloc*((((high+setallocbits)-setbase)) DIV setallocbits);
  2295. savesize:=packedsavesize;
  2296. if savesize=3 then
  2297. savesize:=4;
  2298. end;
  2299. end;
  2300. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  2301. begin
  2302. inherited ppuload(setdef,ppufile);
  2303. ppufile.getderef(elementdefderef);
  2304. savesize:=ppufile.getaint;
  2305. setbase:=ppufile.getaint;
  2306. setmax:=ppufile.getaint;
  2307. end;
  2308. function tsetdef.getcopy : tstoreddef;
  2309. begin
  2310. result:=tsetdef.create(elementdef,setbase,setmax);
  2311. { the copy might have been created with a different setalloc setting }
  2312. tsetdef(result).savesize:=savesize;
  2313. end;
  2314. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  2315. begin
  2316. inherited ppuwrite(ppufile);
  2317. ppufile.putderef(elementdefderef);
  2318. ppufile.putaint(savesize);
  2319. ppufile.putaint(setbase);
  2320. ppufile.putaint(setmax);
  2321. ppufile.writeentry(ibsetdef);
  2322. end;
  2323. procedure tsetdef.buildderef;
  2324. begin
  2325. inherited buildderef;
  2326. elementdefderef.build(elementdef);
  2327. end;
  2328. procedure tsetdef.deref;
  2329. begin
  2330. inherited deref;
  2331. elementdef:=tdef(elementdefderef.resolve);
  2332. end;
  2333. function tsetdef.is_publishable : boolean;
  2334. begin
  2335. is_publishable:=savesize in [1,2,4];
  2336. end;
  2337. function tsetdef.GetTypeName : string;
  2338. begin
  2339. if assigned(elementdef) then
  2340. GetTypeName:='Set Of '+elementdef.typename
  2341. else
  2342. GetTypeName:='Empty Set';
  2343. end;
  2344. {***************************************************************************
  2345. TFORMALDEF
  2346. ***************************************************************************}
  2347. constructor tformaldef.create(Atyped:boolean);
  2348. begin
  2349. inherited create(formaldef);
  2350. typed:=Atyped;
  2351. savesize:=0;
  2352. end;
  2353. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  2354. begin
  2355. inherited ppuload(formaldef,ppufile);
  2356. typed:=boolean(ppufile.getbyte);
  2357. savesize:=0;
  2358. end;
  2359. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  2360. begin
  2361. inherited ppuwrite(ppufile);
  2362. ppufile.putbyte(byte(typed));
  2363. ppufile.writeentry(ibformaldef);
  2364. end;
  2365. function tformaldef.GetTypeName : string;
  2366. begin
  2367. if typed then
  2368. GetTypeName:='<Typed formal type>'
  2369. else
  2370. GetTypeName:='<Formal type>';
  2371. end;
  2372. {***************************************************************************
  2373. TARRAYDEF
  2374. ***************************************************************************}
  2375. constructor tarraydef.create(l,h:asizeint;def:tdef);
  2376. begin
  2377. inherited create(arraydef);
  2378. lowrange:=l;
  2379. highrange:=h;
  2380. rangedef:=def;
  2381. _elementdef:=nil;
  2382. arrayoptions:=[];
  2383. symtable:=tarraysymtable.create(self);
  2384. end;
  2385. destructor tarraydef.destroy;
  2386. begin
  2387. symtable.free;
  2388. symtable:=nil;
  2389. inherited;
  2390. end;
  2391. constructor tarraydef.create_from_pointer(def:tdef);
  2392. begin
  2393. { use -1 so that the elecount will not overflow }
  2394. self.create(0,high(asizeint)-1,s32inttype);
  2395. arrayoptions:=[ado_IsConvertedPointer];
  2396. setelementdef(def);
  2397. end;
  2398. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  2399. begin
  2400. inherited ppuload(arraydef,ppufile);
  2401. { the addresses are calculated later }
  2402. ppufile.getderef(_elementdefderef);
  2403. ppufile.getderef(rangedefderef);
  2404. lowrange:=ppufile.getaint;
  2405. highrange:=ppufile.getaint;
  2406. ppufile.getsmallset(arrayoptions);
  2407. symtable:=tarraysymtable.create(self);
  2408. tarraysymtable(symtable).ppuload(ppufile)
  2409. end;
  2410. function tarraydef.getcopy : tstoreddef;
  2411. begin
  2412. result:=tarraydef.create(lowrange,highrange,rangedef);
  2413. tarraydef(result).arrayoptions:=arrayoptions;
  2414. tarraydef(result)._elementdef:=_elementdef;
  2415. end;
  2416. procedure tarraydef.buildderef;
  2417. begin
  2418. inherited buildderef;
  2419. tarraysymtable(symtable).buildderef;
  2420. _elementdefderef.build(_elementdef);
  2421. rangedefderef.build(rangedef);
  2422. end;
  2423. procedure tarraydef.deref;
  2424. begin
  2425. inherited deref;
  2426. tarraysymtable(symtable).deref;
  2427. _elementdef:=tdef(_elementdefderef.resolve);
  2428. rangedef:=tdef(rangedefderef.resolve);
  2429. end;
  2430. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  2431. begin
  2432. inherited ppuwrite(ppufile);
  2433. ppufile.putderef(_elementdefderef);
  2434. ppufile.putderef(rangedefderef);
  2435. ppufile.putaint(lowrange);
  2436. ppufile.putaint(highrange);
  2437. ppufile.putsmallset(arrayoptions);
  2438. ppufile.writeentry(ibarraydef);
  2439. tarraysymtable(symtable).ppuwrite(ppufile);
  2440. end;
  2441. function tarraydef.elesize : asizeint;
  2442. begin
  2443. if (ado_IsBitPacked in arrayoptions) then
  2444. internalerror(2006080101);
  2445. if assigned(_elementdef) then
  2446. result:=_elementdef.size
  2447. else
  2448. result:=0;
  2449. end;
  2450. function tarraydef.elepackedbitsize : asizeint;
  2451. begin
  2452. if not(ado_IsBitPacked in arrayoptions) then
  2453. internalerror(2006080102);
  2454. if assigned(_elementdef) then
  2455. result:=_elementdef.packedbitsize
  2456. else
  2457. result:=0;
  2458. end;
  2459. function tarraydef.elecount : asizeuint;
  2460. var
  2461. qhigh,qlow : qword;
  2462. begin
  2463. if ado_IsDynamicArray in arrayoptions then
  2464. begin
  2465. result:=0;
  2466. exit;
  2467. end;
  2468. if (highrange>0) and (lowrange<0) then
  2469. begin
  2470. qhigh:=highrange;
  2471. qlow:=qword(-lowrange);
  2472. { prevent overflow, return 0 to indicate overflow }
  2473. if qhigh+qlow>qword(high(asizeint)-1) then
  2474. result:=0
  2475. else
  2476. result:=qhigh+qlow+1;
  2477. end
  2478. else
  2479. result:=int64(highrange)-lowrange+1;
  2480. end;
  2481. function tarraydef.size : asizeint;
  2482. var
  2483. cachedelecount : asizeuint;
  2484. cachedelesize : asizeint;
  2485. begin
  2486. if ado_IsDynamicArray in arrayoptions then
  2487. begin
  2488. size:=sizeof(pint);
  2489. exit;
  2490. end;
  2491. { Tarraydef.size may never be called for an open array! }
  2492. if highrange<lowrange then
  2493. internalerror(99080501);
  2494. if not (ado_IsBitPacked in arrayoptions) then
  2495. cachedelesize:=elesize
  2496. else
  2497. cachedelesize := elepackedbitsize;
  2498. cachedelecount:=elecount;
  2499. if (cachedelesize = 0) then
  2500. begin
  2501. size := 0;
  2502. exit;
  2503. end;
  2504. if (cachedelecount = 0) then
  2505. begin
  2506. size := -1;
  2507. exit;
  2508. end;
  2509. { prevent overflow, return -1 to indicate overflow }
  2510. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  2511. if (cachedelecount > asizeuint(high(asizeint))) or
  2512. ((high(asizeint) div cachedelesize) < asizeint(cachedelecount)) or
  2513. { also lowrange*elesize must be < high(asizeint) to prevent overflow when
  2514. accessing the array, see ncgmem (PFV) }
  2515. ((high(asizeint) div cachedelesize) < abs(lowrange)) then
  2516. begin
  2517. result:=-1;
  2518. exit;
  2519. end;
  2520. result:=cachedelesize*asizeint(cachedelecount);
  2521. if (ado_IsBitPacked in arrayoptions) then
  2522. { can't just add 7 and divide by 8, because that may overflow }
  2523. result:=result div 8 + ord((result mod 8)<>0);
  2524. end;
  2525. procedure tarraydef.setelementdef(def:tdef);
  2526. begin
  2527. _elementdef:=def;
  2528. if not(
  2529. (ado_IsDynamicArray in arrayoptions) or
  2530. (ado_IsConvertedPointer in arrayoptions) or
  2531. (highrange<lowrange)
  2532. ) and
  2533. (size=-1) then
  2534. Message(sym_e_segment_too_large);
  2535. end;
  2536. function tarraydef.alignment : shortint;
  2537. begin
  2538. { alignment of dyn. arrays doesn't depend on the element size }
  2539. if (ado_IsDynamicArray in arrayoptions) then
  2540. alignment:=size_2_align(sizeof(pint))
  2541. { alignment is the alignment of the elements }
  2542. else if (elementdef.typ in [arraydef,recorddef,orddef,enumdef,floatdef]) or
  2543. ((elementdef.typ=objectdef) and
  2544. is_object(elementdef)) then
  2545. alignment:=elementdef.alignment
  2546. { alignment is the size of the elements }
  2547. else if not (ado_IsBitPacked in arrayoptions) then
  2548. alignment:=size_2_align(elesize)
  2549. else
  2550. alignment:=packedbitsloadsize(elepackedbitsize);
  2551. end;
  2552. function tarraydef.needs_inittable : boolean;
  2553. begin
  2554. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  2555. end;
  2556. function tarraydef.GetTypeName : string;
  2557. begin
  2558. if (ado_IsConstString in arrayoptions) then
  2559. result:='Constant String'
  2560. else if (ado_isarrayofconst in arrayoptions) or
  2561. (ado_isConstructor in arrayoptions) then
  2562. begin
  2563. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  2564. GetTypeName:='Array Of Const'
  2565. else
  2566. GetTypeName:='{Array Of Const/Constant Open} Array of '+elementdef.typename;
  2567. end
  2568. else if (ado_IsDynamicArray in arrayoptions) then
  2569. GetTypeName:='{Dynamic} Array Of '+elementdef.typename
  2570. else if ((highrange=-1) and (lowrange=0)) then
  2571. GetTypeName:='{Open} Array Of '+elementdef.typename
  2572. else
  2573. begin
  2574. result := '';
  2575. if (ado_IsBitPacked in arrayoptions) then
  2576. result:='BitPacked ';
  2577. if rangedef.typ=enumdef then
  2578. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  2579. else
  2580. result:=result+'Array['+tostr(lowrange)+'..'+
  2581. tostr(highrange)+'] Of '+elementdef.typename
  2582. end;
  2583. end;
  2584. function tarraydef.getmangledparaname : TSymStr;
  2585. begin
  2586. if ado_isarrayofconst in arrayoptions then
  2587. getmangledparaname:='array_of_const'
  2588. else
  2589. if ((highrange=-1) and (lowrange=0)) then
  2590. getmangledparaname:='array_of_'+elementdef.mangledparaname
  2591. else
  2592. internalerror(200204176);
  2593. end;
  2594. function tarraydef.is_publishable : boolean;
  2595. begin
  2596. Result:=ado_IsDynamicArray in arrayoptions;
  2597. end;
  2598. {***************************************************************************
  2599. tabstractrecorddef
  2600. ***************************************************************************}
  2601. constructor tabstractrecorddef.create(const n:string; dt:tdeftyp);
  2602. begin
  2603. inherited create(dt);
  2604. objname:=stringdup(upper(n));
  2605. objrealname:=stringdup(n);
  2606. objectoptions:=[];
  2607. if assigned(current_module.namespace) then
  2608. begin
  2609. import_lib:=stringdup(current_module.namespace^);
  2610. replace(import_lib^,'.','/');
  2611. end;
  2612. end;
  2613. constructor tabstractrecorddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2614. begin
  2615. inherited ppuload(dt,ppufile);
  2616. objrealname:=stringdup(ppufile.getstring);
  2617. objname:=stringdup(upper(objrealname^));
  2618. import_lib:=stringdup(ppufile.getstring);
  2619. { only used for external C++ classes and Java classes/records }
  2620. if (import_lib^='') then
  2621. stringdispose(import_lib);
  2622. ppufile.getsmallset(objectoptions);
  2623. end;
  2624. procedure tabstractrecorddef.ppuwrite(ppufile: tcompilerppufile);
  2625. begin
  2626. inherited ppuwrite(ppufile);
  2627. ppufile.putstring(objrealname^);
  2628. if assigned(import_lib) then
  2629. ppufile.putstring(import_lib^)
  2630. else
  2631. ppufile.putstring('');
  2632. ppufile.putsmallset(objectoptions);
  2633. end;
  2634. destructor tabstractrecorddef.destroy;
  2635. begin
  2636. stringdispose(objname);
  2637. stringdispose(objrealname);
  2638. stringdispose(import_lib);
  2639. tcinitcode.free;
  2640. inherited destroy;
  2641. end;
  2642. procedure tabstractrecorddef.check_forwards;
  2643. begin
  2644. tstoredsymtable(symtable).check_forwards;
  2645. end;
  2646. function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
  2647. var
  2648. i: longint;
  2649. sym: tsym;
  2650. begin
  2651. for i:=0 to symtable.SymList.Count-1 do
  2652. begin
  2653. sym:=tsym(symtable.SymList[i]);
  2654. if sym.typ=procsym then
  2655. begin
  2656. result:=tprocsym(sym).find_procdef_bytype(pt);
  2657. if assigned(result) then
  2658. exit;
  2659. end;
  2660. end;
  2661. result:=nil;
  2662. end;
  2663. function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
  2664. begin
  2665. if t=gs_record then
  2666. GetSymtable:=symtable
  2667. else
  2668. GetSymtable:=nil;
  2669. end;
  2670. function tabstractrecorddef.is_packed:boolean;
  2671. begin
  2672. result:=tabstractrecordsymtable(symtable).is_packed;
  2673. end;
  2674. function tabstractrecorddef.RttiName: string;
  2675. begin
  2676. Result:=OwnerHierarchyName+objrealname^;
  2677. end;
  2678. function tabstractrecorddef.search_enumerator_get: tprocdef;
  2679. var
  2680. sym : tsym;
  2681. i : integer;
  2682. pd : tprocdef;
  2683. hashedid : THashedIDString;
  2684. begin
  2685. result:=nil;
  2686. hashedid.id:='GETENUMERATOR';
  2687. sym:=tsym(symtable.FindWithHash(hashedid));
  2688. if assigned(sym) and (sym.typ=procsym) then
  2689. begin
  2690. for i := 0 to Tprocsym(sym).ProcdefList.Count - 1 do
  2691. begin
  2692. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2693. if (pd.proctypeoption = potype_function) and
  2694. (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) and
  2695. (pd.visibility >= vis_public) then
  2696. begin
  2697. result:=pd;
  2698. exit;
  2699. end;
  2700. end;
  2701. end;
  2702. end;
  2703. function tabstractrecorddef.search_enumerator_move: tprocdef;
  2704. var
  2705. sym : tsym;
  2706. i : integer;
  2707. pd : tprocdef;
  2708. hashedid : THashedIDString;
  2709. begin
  2710. result:=nil;
  2711. // first search for po_enumerator_movenext method modifier
  2712. // then search for public function MoveNext: Boolean
  2713. for i:=0 to symtable.SymList.Count-1 do
  2714. begin
  2715. sym:=TSym(symtable.SymList[i]);
  2716. if (sym.typ=procsym) then
  2717. begin
  2718. pd:=Tprocsym(sym).find_procdef_byoptions([po_enumerator_movenext]);
  2719. if assigned(pd) then
  2720. begin
  2721. result:=pd;
  2722. exit;
  2723. end;
  2724. end;
  2725. end;
  2726. hashedid.id:='MOVENEXT';
  2727. sym:=tsym(symtable.FindWithHash(hashedid));
  2728. if assigned(sym) and (sym.typ=procsym) then
  2729. begin
  2730. for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
  2731. begin
  2732. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2733. if (pd.proctypeoption = potype_function) and
  2734. is_boolean(pd.returndef) and
  2735. (pd.minparacount = 0) and
  2736. (pd.visibility >= vis_public) then
  2737. begin
  2738. result:=pd;
  2739. exit;
  2740. end;
  2741. end;
  2742. end;
  2743. end;
  2744. function tabstractrecorddef.search_enumerator_current: tsym;
  2745. var
  2746. sym: tsym;
  2747. i: integer;
  2748. hashedid : THashedIDString;
  2749. begin
  2750. result:=nil;
  2751. // first search for ppo_enumerator_current property modifier
  2752. // then search for public property Current
  2753. for i:=0 to symtable.SymList.Count-1 do
  2754. begin
  2755. sym:=TSym(symtable.SymList[i]);
  2756. if (sym.typ=propertysym) and (ppo_enumerator_current in tpropertysym(sym).propoptions) then
  2757. begin
  2758. result:=sym;
  2759. exit;
  2760. end;
  2761. end;
  2762. hashedid.id:='CURRENT';
  2763. sym:=tsym(symtable.FindWithHash(hashedid));
  2764. if assigned(sym) and (sym.typ=propertysym) and
  2765. (sym.visibility >= vis_public) and not tpropertysym(sym).propaccesslist[palt_read].empty then
  2766. begin
  2767. result:=sym;
  2768. exit;
  2769. end;
  2770. end;
  2771. function tabstractrecorddef.jvm_full_typename(with_package_name: boolean): string;
  2772. var
  2773. st: tsymtable;
  2774. enclosingdef: tdef;
  2775. begin
  2776. if typ=objectdef then
  2777. result:=tobjectdef(self).objextname^
  2778. else if assigned(typesym) then
  2779. result:=typesym.realname
  2780. { have to generate anonymous nested type in current unit/class/record }
  2781. else
  2782. internalerror(2011032601);
  2783. st:=owner;
  2784. while assigned(st) and
  2785. (st.symtabletype in [objectsymtable,recordsymtable,localsymtable]) do
  2786. begin
  2787. { nested classes are named as "OuterClass$InnerClass" }
  2788. enclosingdef:=tdef(st.defowner);
  2789. if enclosingdef.typ=procdef then
  2790. result:=result+tprocdef(enclosingdef).procsym.realname+'$$'+tostr(tprocdef(enclosingdef).procsym.symid)+'$'
  2791. else if enclosingdef.typ=objectdef then
  2792. result:=tobjectdef(enclosingdef).objextname^+'$'+result
  2793. else if assigned(enclosingdef.typesym) then
  2794. result:=enclosingdef.typesym.realname+'$'+result
  2795. else
  2796. internalerror(2011060305);
  2797. st:=enclosingdef.owner;
  2798. end;
  2799. if with_package_name and
  2800. assigned(import_lib) then
  2801. result:=import_lib^+'/'+result;
  2802. end;
  2803. {***************************************************************************
  2804. trecorddef
  2805. ***************************************************************************}
  2806. constructor trecorddef.create(const n:string; p:TSymtable);
  2807. begin
  2808. inherited create(n,recorddef);
  2809. symtable:=p;
  2810. { we can own the symtable only if nobody else owns a copy so far }
  2811. if symtable.refcount=1 then
  2812. symtable.defowner:=self;
  2813. isunion:=false;
  2814. end;
  2815. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  2816. begin
  2817. inherited ppuload(recorddef,ppufile);
  2818. if df_copied_def in defoptions then
  2819. ppufile.getderef(cloneddefderef)
  2820. else
  2821. begin
  2822. symtable:=trecordsymtable.create(objrealname^,0);
  2823. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  2824. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  2825. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  2826. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  2827. trecordsymtable(symtable).datasize:=ppufile.getasizeint;
  2828. trecordsymtable(symtable).paddingsize:=ppufile.getword;
  2829. trecordsymtable(symtable).ppuload(ppufile);
  2830. { requires usefieldalignment to be set }
  2831. symtable.defowner:=self;
  2832. end;
  2833. isunion:=false;
  2834. end;
  2835. destructor trecorddef.destroy;
  2836. begin
  2837. if assigned(symtable) then
  2838. begin
  2839. symtable.free;
  2840. symtable:=nil;
  2841. end;
  2842. inherited destroy;
  2843. end;
  2844. function trecorddef.getcopy : tstoreddef;
  2845. begin
  2846. result:=trecorddef.create(objrealname^,symtable.getcopy);
  2847. trecorddef(result).isunion:=isunion;
  2848. include(trecorddef(result).defoptions,df_copied_def);
  2849. if assigned(tcinitcode) then
  2850. trecorddef(result).tcinitcode:=tcinitcode.getcopy;
  2851. if assigned(import_lib) then
  2852. trecorddef(result).import_lib:=stringdup(import_lib^);
  2853. end;
  2854. function trecorddef.needs_inittable : boolean;
  2855. begin
  2856. needs_inittable:=trecordsymtable(symtable).needs_init_final
  2857. end;
  2858. function trecorddef.is_related(d: tdef): boolean;
  2859. begin
  2860. { records are implemented via classes in the JVM target, and are
  2861. all descendents of the java_fpcbaserecordtype class }
  2862. is_related:=false;
  2863. if (target_info.system=system_jvm_java32) then
  2864. begin
  2865. if d.typ=objectdef then
  2866. begin
  2867. d:=find_real_class_definition(tobjectdef(d),false);
  2868. if (d=java_jlobject) or
  2869. (d=java_fpcbaserecordtype) then
  2870. is_related:=true
  2871. end;
  2872. end;
  2873. end;
  2874. procedure trecorddef.buildderef;
  2875. begin
  2876. inherited buildderef;
  2877. if df_copied_def in defoptions then
  2878. cloneddefderef.build(symtable.defowner)
  2879. else
  2880. tstoredsymtable(symtable).buildderef;
  2881. end;
  2882. procedure trecorddef.deref;
  2883. begin
  2884. inherited deref;
  2885. { now dereference the definitions }
  2886. if df_copied_def in defoptions then
  2887. begin
  2888. cloneddef:=trecorddef(cloneddefderef.resolve);
  2889. symtable:=cloneddef.symtable.getcopy;
  2890. end
  2891. else
  2892. tstoredsymtable(symtable).deref;
  2893. { assign TGUID? load only from system unit }
  2894. if not(assigned(rec_tguid)) and
  2895. (upper(typename)='TGUID') and
  2896. assigned(owner) and
  2897. assigned(owner.name) and
  2898. (owner.name^='SYSTEM') then
  2899. rec_tguid:=self;
  2900. { assign JMP_BUF? load only from system unit }
  2901. if not(assigned(rec_jmp_buf)) and
  2902. (upper(typename)='JMP_BUF') and
  2903. assigned(owner) and
  2904. assigned(owner.name) and
  2905. (owner.name^='SYSTEM') then
  2906. rec_jmp_buf:=self;
  2907. end;
  2908. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  2909. begin
  2910. inherited ppuwrite(ppufile);
  2911. if df_copied_def in defoptions then
  2912. ppufile.putderef(cloneddefderef)
  2913. else
  2914. begin
  2915. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  2916. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  2917. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  2918. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  2919. ppufile.putasizeint(trecordsymtable(symtable).datasize);
  2920. ppufile.putword(trecordsymtable(symtable).paddingsize);
  2921. end;
  2922. ppufile.writeentry(ibrecorddef);
  2923. if not(df_copied_def in defoptions) then
  2924. trecordsymtable(symtable).ppuwrite(ppufile);
  2925. end;
  2926. function trecorddef.size:asizeint;
  2927. begin
  2928. result:=trecordsymtable(symtable).datasize;
  2929. end;
  2930. function trecorddef.alignment:shortint;
  2931. begin
  2932. alignment:=trecordsymtable(symtable).recordalignment;
  2933. end;
  2934. function trecorddef.padalignment:shortint;
  2935. begin
  2936. padalignment := trecordsymtable(symtable).padalignment;
  2937. end;
  2938. function trecorddef.GetTypeName : string;
  2939. begin
  2940. GetTypeName:='<record type>'
  2941. end;
  2942. {***************************************************************************
  2943. TABSTRACTPROCDEF
  2944. ***************************************************************************}
  2945. constructor tabstractprocdef.create(dt:tdeftyp;level:byte);
  2946. begin
  2947. inherited create(dt);
  2948. parast:=tparasymtable.create(self,level);
  2949. paras:=nil;
  2950. minparacount:=0;
  2951. maxparacount:=0;
  2952. proctypeoption:=potype_none;
  2953. proccalloption:=pocall_none;
  2954. procoptions:=[];
  2955. returndef:=voidtype;
  2956. savesize:=sizeof(pint);
  2957. callerargareasize:=0;
  2958. calleeargareasize:=0;
  2959. has_paraloc_info:=callnoside;
  2960. funcretloc[callerside].init;
  2961. funcretloc[calleeside].init;
  2962. check_mark_as_nested;
  2963. end;
  2964. destructor tabstractprocdef.destroy;
  2965. begin
  2966. if assigned(paras) then
  2967. begin
  2968. {$ifdef MEMDEBUG}
  2969. memprocpara.start;
  2970. {$endif MEMDEBUG}
  2971. paras.free;
  2972. paras:=nil;
  2973. {$ifdef MEMDEBUG}
  2974. memprocpara.stop;
  2975. {$endif MEMDEBUG}
  2976. end;
  2977. if assigned(parast) then
  2978. begin
  2979. {$ifdef MEMDEBUG}
  2980. memprocparast.start;
  2981. {$endif MEMDEBUG}
  2982. parast.free;
  2983. parast:=nil;
  2984. {$ifdef MEMDEBUG}
  2985. memprocparast.stop;
  2986. {$endif MEMDEBUG}
  2987. end;
  2988. funcretloc[callerside].done;
  2989. funcretloc[calleeside].done;
  2990. inherited destroy;
  2991. end;
  2992. procedure tabstractprocdef.count_para(p:TObject;arg:pointer);
  2993. begin
  2994. if (tsym(p).typ<>paravarsym) then
  2995. exit;
  2996. inc(plongint(arg)^);
  2997. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  2998. begin
  2999. if not assigned(tparavarsym(p).defaultconstsym) then
  3000. inc(minparacount);
  3001. inc(maxparacount);
  3002. end;
  3003. end;
  3004. procedure tabstractprocdef.insert_para(p:TObject;arg:pointer);
  3005. begin
  3006. if (tsym(p).typ<>paravarsym) then
  3007. exit;
  3008. paras.add(p);
  3009. end;
  3010. procedure tabstractprocdef.calcparas;
  3011. var
  3012. paracount : longint;
  3013. begin
  3014. { This can already be assigned when
  3015. we need to reresolve this unit (PFV) }
  3016. if assigned(paras) then
  3017. paras.free;
  3018. paras:=tparalist.create(false);
  3019. paracount:=0;
  3020. minparacount:=0;
  3021. maxparacount:=0;
  3022. parast.SymList.ForEachCall(@count_para,@paracount);
  3023. paras.capacity:=paracount;
  3024. { Insert parameters in table }
  3025. parast.SymList.ForEachCall(@insert_para,nil);
  3026. { Order parameters }
  3027. paras.sortparas;
  3028. end;
  3029. procedure tabstractprocdef.buildderef;
  3030. begin
  3031. { released procdef? }
  3032. if not assigned(parast) then
  3033. exit;
  3034. inherited buildderef;
  3035. returndefderef.build(returndef);
  3036. if po_explicitparaloc in procoptions then
  3037. funcretloc[callerside].buildderef;
  3038. { parast }
  3039. tparasymtable(parast).buildderef;
  3040. end;
  3041. procedure tabstractprocdef.deref;
  3042. begin
  3043. inherited deref;
  3044. returndef:=tdef(returndefderef.resolve);
  3045. if po_explicitparaloc in procoptions then
  3046. begin
  3047. funcretloc[callerside].deref;
  3048. has_paraloc_info:=callerside;
  3049. end
  3050. else
  3051. begin
  3052. { deref is called after loading from a ppu, but also after another
  3053. unit has been reloaded/recompiled and all references must be
  3054. re-resolved. Since the funcretloc contains a reference to a tdef,
  3055. reset it so that we won't try to access the stale def }
  3056. funcretloc[callerside].init;
  3057. has_paraloc_info:=callnoside;
  3058. end;
  3059. { parast }
  3060. tparasymtable(parast).deref;
  3061. { recalculated parameters }
  3062. calcparas;
  3063. end;
  3064. constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  3065. begin
  3066. inherited ppuload(dt,ppufile);
  3067. parast:=nil;
  3068. Paras:=nil;
  3069. minparacount:=0;
  3070. maxparacount:=0;
  3071. ppufile.getderef(returndefderef);
  3072. { TODO: remove fpu_used loading}
  3073. ppufile.getbyte;
  3074. proctypeoption:=tproctypeoption(ppufile.getbyte);
  3075. proccalloption:=tproccalloption(ppufile.getbyte);
  3076. ppufile.getnormalset(procoptions);
  3077. funcretloc[callerside].init;
  3078. if po_explicitparaloc in procoptions then
  3079. funcretloc[callerside].ppuload(ppufile);
  3080. savesize:=sizeof(pint);
  3081. if (po_explicitparaloc in procoptions) then
  3082. has_paraloc_info:=callerside;
  3083. end;
  3084. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  3085. var
  3086. oldintfcrc : boolean;
  3087. begin
  3088. { released procdef? }
  3089. if not assigned(parast) then
  3090. exit;
  3091. inherited ppuwrite(ppufile);
  3092. ppufile.putderef(returndefderef);
  3093. oldintfcrc:=ppufile.do_interface_crc;
  3094. ppufile.do_interface_crc:=false;
  3095. ppufile.putbyte(0);
  3096. ppufile.putbyte(ord(proctypeoption));
  3097. ppufile.putbyte(ord(proccalloption));
  3098. ppufile.putnormalset(procoptions);
  3099. ppufile.do_interface_crc:=oldintfcrc;
  3100. if (po_explicitparaloc in procoptions) then
  3101. funcretloc[callerside].ppuwrite(ppufile);
  3102. end;
  3103. function tabstractprocdef.typename_paras(pno: tprocnameoptions) : ansistring;
  3104. var
  3105. hs,s : ansistring;
  3106. hp : TParavarsym;
  3107. hpc : tconstsym;
  3108. first : boolean;
  3109. i : integer;
  3110. begin
  3111. s:='';
  3112. first:=true;
  3113. for i:=0 to paras.count-1 do
  3114. begin
  3115. hp:=tparavarsym(paras[i]);
  3116. if not(vo_is_hidden_para in hp.varoptions) or
  3117. (pno_showhidden in pno) then
  3118. begin
  3119. if first then
  3120. begin
  3121. s:=s+'(';
  3122. first:=false;
  3123. end
  3124. else
  3125. s:=s+';';
  3126. if vo_is_hidden_para in hp.varoptions then
  3127. s:=s+'<';
  3128. case hp.varspez of
  3129. vs_var :
  3130. s:=s+'var ';
  3131. vs_const :
  3132. s:=s+'const ';
  3133. vs_out :
  3134. s:=s+'out ';
  3135. vs_constref :
  3136. s:=s+'constref ';
  3137. end;
  3138. if (pno_paranames in pno) then
  3139. s:=s+hp.realname+':';
  3140. if hp.univpara then
  3141. s:=s+'univ ';
  3142. if assigned(hp.vardef.typesym) then
  3143. begin
  3144. hs:=hp.vardef.typesym.realname;
  3145. if hs[1]<>'$' then
  3146. s:=s+hp.vardef.OwnerHierarchyName+hs
  3147. else
  3148. s:=s+hp.vardef.GetTypeName;
  3149. end
  3150. else
  3151. s:=s+hp.vardef.GetTypeName;
  3152. { default value }
  3153. if assigned(hp.defaultconstsym) then
  3154. begin
  3155. hpc:=tconstsym(hp.defaultconstsym);
  3156. hs:='';
  3157. case hpc.consttyp of
  3158. conststring,
  3159. constresourcestring :
  3160. begin
  3161. If hpc.value.len>0 then
  3162. begin
  3163. setLength(hs,hpc.value.len);
  3164. { don't write past the end of hs if the constant
  3165. is > 255 chars }
  3166. move(hpc.value.valueptr^,hs[1],length(hs));
  3167. { make sure that constant strings with newline chars
  3168. don't create a linebreak in the assembler code,
  3169. since comments are line-based. Also remove nulls
  3170. because the comments are written as a pchar. }
  3171. ReplaceCase(hs,#0,'.');
  3172. ReplaceCase(hs,#10,'.');
  3173. ReplaceCase(hs,#13,'.');
  3174. end;
  3175. end;
  3176. constreal :
  3177. str(pbestreal(hpc.value.valueptr)^,hs);
  3178. constpointer :
  3179. hs:=tostr(hpc.value.valueordptr);
  3180. constord :
  3181. begin
  3182. if is_boolean(hpc.constdef) then
  3183. begin
  3184. if hpc.value.valueord<>0 then
  3185. hs:='TRUE'
  3186. else
  3187. hs:='FALSE';
  3188. end
  3189. else
  3190. hs:=tostr(hpc.value.valueord);
  3191. end;
  3192. constnil :
  3193. hs:='nil';
  3194. constset :
  3195. hs:='<set>';
  3196. end;
  3197. if hs<>'' then
  3198. s:=s+'="'+hs+'"';
  3199. end;
  3200. if vo_is_hidden_para in hp.varoptions then
  3201. s:=s+'>';
  3202. end;
  3203. end;
  3204. if not first then
  3205. s:=s+')';
  3206. if (po_varargs in procoptions) then
  3207. s:=s+';VarArgs';
  3208. typename_paras:=s;
  3209. end;
  3210. function tabstractprocdef.is_methodpointer:boolean;
  3211. begin
  3212. result:=false;
  3213. end;
  3214. function tabstractprocdef.is_addressonly:boolean;
  3215. begin
  3216. result:=true;
  3217. end;
  3218. function tabstractprocdef.no_self_node: boolean;
  3219. begin
  3220. Result:=([po_staticmethod,po_classmethod]<=procoptions)or
  3221. (proctypeoption in [potype_class_constructor,potype_class_destructor,potype_operator]);
  3222. end;
  3223. function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef;
  3224. var
  3225. j, nestinglevel: longint;
  3226. pvs, npvs: tparavarsym;
  3227. csym, ncsym: tconstsym;
  3228. begin
  3229. nestinglevel:=parast.symtablelevel;
  3230. if newtyp=procdef then
  3231. begin
  3232. if (typ=procdef) or
  3233. (copytyp<>pc_procvar2bareproc) then
  3234. result:=tprocdef.create(nestinglevel)
  3235. else
  3236. result:=tprocdef.create(normal_function_level);
  3237. tprocdef(result).visibility:=vis_public;
  3238. end
  3239. else
  3240. begin
  3241. result:=tprocvardef.create(nestinglevel);
  3242. end;
  3243. tabstractprocdef(result).returndef:=returndef;
  3244. tabstractprocdef(result).returndefderef:=returndefderef;
  3245. tabstractprocdef(result).parast:=tparasymtable.create(tabstractprocdef(result),parast.symtablelevel);
  3246. pvs:=nil;
  3247. npvs:=nil;
  3248. for j:=0 to parast.symlist.count-1 do
  3249. begin
  3250. case tsym(parast.symlist[j]).typ of
  3251. paravarsym:
  3252. begin
  3253. pvs:=tparavarsym(parast.symlist[j]);
  3254. { in case of bare proc, don't copy self, vmt or framepointer
  3255. parameters }
  3256. if (copytyp=pc_procvar2bareproc) and
  3257. (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result]*pvs.varoptions)<>[]) then
  3258. continue;
  3259. npvs:=tparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
  3260. pvs.vardef,pvs.varoptions);
  3261. npvs.defaultconstsym:=pvs.defaultconstsym;
  3262. tabstractprocdef(result).parast.insert(npvs);
  3263. end;
  3264. constsym:
  3265. begin
  3266. // ignore, reuse original constym. Should also be duplicated
  3267. // be safe though
  3268. end
  3269. else
  3270. internalerror(201160604);
  3271. end;
  3272. end;
  3273. tabstractprocdef(result).savesize:=savesize;
  3274. tabstractprocdef(result).proctypeoption:=proctypeoption;
  3275. tabstractprocdef(result).proccalloption:=proccalloption;
  3276. tabstractprocdef(result).procoptions:=procoptions;
  3277. if (copytyp=pc_procvar2bareproc) then
  3278. tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions*[po_explicitparaloc,po_hascallingconvention,po_varargs,po_iocheck];
  3279. tabstractprocdef(result).callerargareasize:=callerargareasize;
  3280. tabstractprocdef(result).calleeargareasize:=calleeargareasize;
  3281. tabstractprocdef(result).maxparacount:=maxparacount;
  3282. tabstractprocdef(result).minparacount:=minparacount;
  3283. if po_explicitparaloc in procoptions then
  3284. tabstractprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
  3285. { recalculate parameter info }
  3286. tabstractprocdef(result).has_paraloc_info:=callnoside;
  3287. {$ifdef m68k}
  3288. tabstractprocdef(result).exp_funcretloc:=exp_funcretloc;
  3289. {$endif}
  3290. if (typ=procdef) and
  3291. (newtyp=procvardef) and
  3292. (owner.symtabletype=ObjectSymtable) then
  3293. include(tprocvardef(result).procoptions,po_methodpointer);
  3294. end;
  3295. procedure tabstractprocdef.check_mark_as_nested;
  3296. begin
  3297. { nested procvars require that nested functions use the Delphi-style
  3298. nested procedure calling convention }
  3299. if (parast.symtablelevel>normal_function_level) and
  3300. (m_nested_procvars in current_settings.modeswitches) then
  3301. include(procoptions,po_delphi_nested_cc);
  3302. end;
  3303. procedure tabstractprocdef.init_paraloc_info(side: tcallercallee);
  3304. begin
  3305. if (side in [callerside,callbothsides]) and
  3306. not(has_paraloc_info in [callerside,callbothsides]) then
  3307. begin
  3308. callerargareasize:=paramanager.create_paraloc_info(self,callerside);
  3309. if has_paraloc_info in [calleeside,callbothsides] then
  3310. has_paraloc_info:=callbothsides
  3311. else
  3312. has_paraloc_info:=callerside;
  3313. end;
  3314. if (side in [calleeside,callbothsides]) and
  3315. not(has_paraloc_info in [calleeside,callbothsides]) then
  3316. begin
  3317. calleeargareasize:=paramanager.create_paraloc_info(self,calleeside);
  3318. if has_paraloc_info in [callerside,callbothsides] then
  3319. has_paraloc_info:=callbothsides
  3320. else
  3321. has_paraloc_info:=calleeside;
  3322. end;
  3323. end;
  3324. function tabstractprocdef.stack_tainting_parameter(side: tcallercallee): boolean;
  3325. var
  3326. p: tparavarsym;
  3327. ploc: PCGParalocation;
  3328. i: longint;
  3329. begin
  3330. result:=false;
  3331. init_paraloc_info(side);
  3332. for i:=0 to parast.SymList.Count-1 do
  3333. if tsym(parast.SymList[i]).typ=paravarsym then
  3334. begin
  3335. p:=tparavarsym(parast.SymList[i]);
  3336. { check if no parameter is located on the stack }
  3337. if is_open_array(p.vardef) or
  3338. is_array_of_const(p.vardef) then
  3339. begin
  3340. result:=true;
  3341. exit;
  3342. end;
  3343. ploc:=p.paraloc[side].location;
  3344. while assigned(ploc) do
  3345. begin
  3346. if (ploc^.loc=LOC_REFERENCE) then
  3347. begin
  3348. result:=true;
  3349. exit
  3350. end;
  3351. ploc:=ploc^.next;
  3352. end;
  3353. end;
  3354. end;
  3355. {***************************************************************************
  3356. TPROCDEF
  3357. ***************************************************************************}
  3358. constructor tprocdef.create(level:byte);
  3359. begin
  3360. inherited create(procdef,level);
  3361. localst:=tlocalsymtable.create(self,parast.symtablelevel);
  3362. {$ifdef symansistr}
  3363. _mangledname:='';
  3364. {$else symansistr}
  3365. _mangledname:=nil;
  3366. {$endif symansistr}
  3367. fileinfo:=current_filepos;
  3368. extnumber:=$ffff;
  3369. aliasnames:=TCmdStrList.create;
  3370. funcretsym:=nil;
  3371. forwarddef:=true;
  3372. interfacedef:=false;
  3373. hasforward:=false;
  3374. struct := nil;
  3375. import_dll:=nil;
  3376. import_name:=nil;
  3377. import_nr:=0;
  3378. inlininginfo:=nil;
  3379. deprecatedmsg:=nil;
  3380. {$ifdef i386}
  3381. fpu_used:=maxfpuregs;
  3382. {$endif i386}
  3383. interruptvector:=-1;
  3384. end;
  3385. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  3386. var
  3387. i,aliasnamescount : longint;
  3388. level : byte;
  3389. begin
  3390. inherited ppuload(procdef,ppufile);
  3391. {$ifdef symansistr}
  3392. if po_has_mangledname in procoptions then
  3393. _mangledname:=ppufile.getansistring
  3394. else
  3395. _mangledname:='';
  3396. {$else symansistr}
  3397. if po_has_mangledname in procoptions then
  3398. _mangledname:=stringdup(ppufile.getstring)
  3399. else
  3400. _mangledname:=nil;
  3401. {$endif symansistr}
  3402. extnumber:=ppufile.getword;
  3403. level:=ppufile.getbyte;
  3404. ppufile.getderef(structderef);
  3405. ppufile.getderef(procsymderef);
  3406. ppufile.getposinfo(fileinfo);
  3407. visibility:=tvisibility(ppufile.getbyte);
  3408. ppufile.getsmallset(symoptions);
  3409. if sp_has_deprecated_msg in symoptions then
  3410. deprecatedmsg:=stringdup(ppufile.getstring)
  3411. else
  3412. deprecatedmsg:=nil;
  3413. {$ifdef powerpc}
  3414. { library symbol for AmigaOS/MorphOS }
  3415. ppufile.getderef(libsymderef);
  3416. {$endif powerpc}
  3417. { import stuff }
  3418. if po_has_importdll in procoptions then
  3419. import_dll:=stringdup(ppufile.getstring)
  3420. else
  3421. import_dll:=nil;
  3422. if po_has_importname in procoptions then
  3423. import_name:=stringdup(ppufile.getstring)
  3424. else
  3425. import_name:=nil;
  3426. import_nr:=ppufile.getword;
  3427. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3428. if target_info.system in systems_interrupt_table then
  3429. interruptvector:=ppufile.getlongint;
  3430. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3431. if (po_msgint in procoptions) then
  3432. messageinf.i:=ppufile.getlongint;
  3433. if (po_msgstr in procoptions) then
  3434. messageinf.str:=stringdup(ppufile.getstring);
  3435. if (po_dispid in procoptions) then
  3436. dispid:=ppufile.getlongint;
  3437. { inline stuff }
  3438. if (po_has_inlininginfo in procoptions) then
  3439. begin
  3440. ppufile.getderef(funcretsymderef);
  3441. new(inlininginfo);
  3442. ppufile.getsmallset(inlininginfo^.flags);
  3443. end
  3444. else
  3445. begin
  3446. inlininginfo:=nil;
  3447. funcretsym:=nil;
  3448. end;
  3449. aliasnames:=TCmdStrList.create;
  3450. { count alias names }
  3451. aliasnamescount:=ppufile.getbyte;
  3452. for i:=1 to aliasnamescount do
  3453. aliasnames.insert(ppufile.getstring);
  3454. { load para symtable }
  3455. parast:=tparasymtable.create(self,level);
  3456. tparasymtable(parast).ppuload(ppufile);
  3457. { load local symtable }
  3458. if (po_has_inlininginfo in procoptions) then
  3459. begin
  3460. localst:=tlocalsymtable.create(self,level);
  3461. tlocalsymtable(localst).ppuload(ppufile);
  3462. end
  3463. else
  3464. localst:=nil;
  3465. { inline stuff }
  3466. if (po_has_inlininginfo in procoptions) then
  3467. inlininginfo^.code:=ppuloadnodetree(ppufile);
  3468. { default values for no persistent data }
  3469. if (cs_link_deffile in current_settings.globalswitches) and
  3470. (tf_need_export in target_info.flags) and
  3471. (po_exports in procoptions) then
  3472. deffile.AddExport(mangledname);
  3473. forwarddef:=false;
  3474. interfacedef:=false;
  3475. hasforward:=false;
  3476. { Disable po_has_inlining until the derefimpl is done }
  3477. exclude(procoptions,po_has_inlininginfo);
  3478. {$ifdef i386}
  3479. fpu_used:=maxfpuregs;
  3480. {$endif i386}
  3481. end;
  3482. destructor tprocdef.destroy;
  3483. begin
  3484. aliasnames.free;
  3485. aliasnames:=nil;
  3486. if assigned(localst) and
  3487. (localst.symtabletype<>staticsymtable) then
  3488. begin
  3489. {$ifdef MEMDEBUG}
  3490. memproclocalst.start;
  3491. {$endif MEMDEBUG}
  3492. localst.free;
  3493. localst:=nil;
  3494. {$ifdef MEMDEBUG}
  3495. memproclocalst.start;
  3496. {$endif MEMDEBUG}
  3497. end;
  3498. if assigned(inlininginfo) then
  3499. begin
  3500. {$ifdef MEMDEBUG}
  3501. memprocnodetree.start;
  3502. {$endif MEMDEBUG}
  3503. tnode(inlininginfo^.code).free;
  3504. {$ifdef MEMDEBUG}
  3505. memprocnodetree.start;
  3506. {$endif MEMDEBUG}
  3507. dispose(inlininginfo);
  3508. inlininginfo:=nil;
  3509. end;
  3510. {$ifdef jvm}
  3511. exprasmlist.free;
  3512. {$endif}
  3513. stringdispose(resultname);
  3514. stringdispose(import_dll);
  3515. stringdispose(import_name);
  3516. stringdispose(deprecatedmsg);
  3517. if (po_msgstr in procoptions) then
  3518. stringdispose(messageinf.str);
  3519. {$ifndef symansistr}
  3520. if assigned(_mangledname) then
  3521. begin
  3522. {$ifdef MEMDEBUG}
  3523. memmanglednames.start;
  3524. {$endif MEMDEBUG}
  3525. stringdispose(_mangledname);
  3526. {$ifdef MEMDEBUG}
  3527. memmanglednames.stop;
  3528. {$endif MEMDEBUG}
  3529. end;
  3530. {$endif symansistr}
  3531. inherited destroy;
  3532. end;
  3533. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  3534. var
  3535. oldintfcrc : boolean;
  3536. aliasnamescount : longint;
  3537. item : TCmdStrListItem;
  3538. begin
  3539. { released procdef? }
  3540. if not assigned(parast) then
  3541. exit;
  3542. inherited ppuwrite(ppufile);
  3543. {$ifdef symansistr}
  3544. if po_has_mangledname in procoptions then
  3545. ppufile.putansistring(_mangledname);
  3546. {$else symansistr}
  3547. if po_has_mangledname in procoptions then
  3548. ppufile.putstring(_mangledname^);
  3549. {$endif symansistr}
  3550. ppufile.putword(extnumber);
  3551. ppufile.putbyte(parast.symtablelevel);
  3552. ppufile.putderef(structderef);
  3553. ppufile.putderef(procsymderef);
  3554. ppufile.putposinfo(fileinfo);
  3555. ppufile.putbyte(byte(visibility));
  3556. ppufile.putsmallset(symoptions);
  3557. if sp_has_deprecated_msg in symoptions then
  3558. ppufile.putstring(deprecatedmsg^);
  3559. {$ifdef powerpc}
  3560. { library symbol for AmigaOS/MorphOS }
  3561. ppufile.putderef(libsymderef);
  3562. {$endif powerpc}
  3563. { import }
  3564. if po_has_importdll in procoptions then
  3565. ppufile.putstring(import_dll^);
  3566. if po_has_importname in procoptions then
  3567. ppufile.putstring(import_name^);
  3568. ppufile.putword(import_nr);
  3569. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3570. if target_info.system in systems_interrupt_table then
  3571. ppufile.putlongint(interruptvector);
  3572. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3573. if (po_msgint in procoptions) then
  3574. ppufile.putlongint(messageinf.i);
  3575. if (po_msgstr in procoptions) then
  3576. ppufile.putstring(messageinf.str^);
  3577. if (po_dispid in procoptions) then
  3578. ppufile.putlongint(dispid);
  3579. { inline stuff }
  3580. oldintfcrc:=ppufile.do_crc;
  3581. ppufile.do_crc:=false;
  3582. if (po_has_inlininginfo in procoptions) then
  3583. begin
  3584. ppufile.putderef(funcretsymderef);
  3585. ppufile.putsmallset(inlininginfo^.flags);
  3586. end;
  3587. { count alias names }
  3588. aliasnamescount:=0;
  3589. item:=TCmdStrListItem(aliasnames.first);
  3590. while assigned(item) do
  3591. begin
  3592. inc(aliasnamescount);
  3593. item:=TCmdStrListItem(item.next);
  3594. end;
  3595. if aliasnamescount>255 then
  3596. internalerror(200711021);
  3597. ppufile.putbyte(aliasnamescount);
  3598. item:=TCmdStrListItem(aliasnames.first);
  3599. while assigned(item) do
  3600. begin
  3601. ppufile.putstring(item.str);
  3602. item:=TCmdStrListItem(item.next);
  3603. end;
  3604. ppufile.do_crc:=oldintfcrc;
  3605. { write this entry }
  3606. ppufile.writeentry(ibprocdef);
  3607. { Save the para symtable, this is taken from the interface }
  3608. tparasymtable(parast).ppuwrite(ppufile);
  3609. { save localsymtable for inline procedures or when local
  3610. browser info is requested, this has no influence on the crc }
  3611. if (po_has_inlininginfo in procoptions) then
  3612. begin
  3613. oldintfcrc:=ppufile.do_crc;
  3614. ppufile.do_crc:=false;
  3615. tlocalsymtable(localst).ppuwrite(ppufile);
  3616. ppufile.do_crc:=oldintfcrc;
  3617. end;
  3618. { node tree for inlining }
  3619. oldintfcrc:=ppufile.do_crc;
  3620. ppufile.do_crc:=false;
  3621. if (po_has_inlininginfo in procoptions) then
  3622. ppuwritenodetree(ppufile,inlininginfo^.code);
  3623. ppufile.do_crc:=oldintfcrc;
  3624. end;
  3625. function tprocdef.fullprocname(showhidden:boolean):string;
  3626. var
  3627. pno: tprocnameoptions;
  3628. begin
  3629. pno:=[];
  3630. if showhidden then
  3631. include(pno,pno_showhidden);
  3632. result:=customprocname(pno);
  3633. end;
  3634. function tprocdef.customprocname(pno: tprocnameoptions):ansistring;
  3635. var
  3636. s, rn : ansistring;
  3637. t : ttoken;
  3638. begin
  3639. {$ifdef EXTDEBUG}
  3640. include(pno,pno_showhidden);
  3641. {$endif EXTDEBUG}
  3642. s:='';
  3643. if proctypeoption=potype_operator then
  3644. begin
  3645. for t:=NOTOKEN to last_overloaded do
  3646. if procsym.realname='$'+overloaded_names[t] then
  3647. begin
  3648. s:='operator ';
  3649. if (pno_ownername in pno) and
  3650. assigned(struct) then
  3651. s:=s+struct.RttiName+'.';
  3652. s:=s+arraytokeninfo[t].str+typename_paras(pno);
  3653. break;
  3654. end;
  3655. end
  3656. else
  3657. begin
  3658. if (po_classmethod in procoptions) and
  3659. not(pno_noclassmarker in pno) then
  3660. s:='class ';
  3661. case proctypeoption of
  3662. potype_constructor,
  3663. potype_class_constructor:
  3664. s:=s+'constructor ';
  3665. potype_class_destructor,
  3666. potype_destructor:
  3667. s:=s+'destructor ';
  3668. else
  3669. if (pno_proctypeoption in pno) and
  3670. assigned(returndef) and
  3671. not(is_void(returndef)) then
  3672. s:=s+'function '
  3673. else
  3674. s:=s+'procedure ';
  3675. end;
  3676. if (pno_ownername in pno) and
  3677. (owner.symtabletype in [recordsymtable,objectsymtable]) then
  3678. s:=s+tabstractrecorddef(owner.defowner).RttiName+'.';
  3679. rn:=procsym.realname;
  3680. if (pno_noleadingdollar in pno) and
  3681. (rn[1]='$') then
  3682. delete(rn,1,1);
  3683. s:=s+rn+typename_paras(pno);
  3684. end;
  3685. if not(proctypeoption in [potype_constructor,potype_destructor,
  3686. potype_class_constructor,potype_class_destructor]) and
  3687. assigned(returndef) and
  3688. not(is_void(returndef)) then
  3689. s:=s+':'+returndef.GetTypeName;
  3690. if owner.symtabletype=localsymtable then
  3691. s:=s+' is nested';
  3692. s:=s+';';
  3693. { forced calling convention? }
  3694. if (po_hascallingconvention in procoptions) then
  3695. s:=s+' '+ProcCallOptionStr[proccalloption]+';';
  3696. if (po_staticmethod in procoptions) and
  3697. not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
  3698. s:=s+' Static;';
  3699. customprocname:=s;
  3700. end;
  3701. function tprocdef.is_methodpointer:boolean;
  3702. begin
  3703. { don't check assigned(_class), that's also the case for nested
  3704. procedures inside methods }
  3705. result:=owner.symtabletype=ObjectSymtable;
  3706. end;
  3707. function tprocdef.is_addressonly:boolean;
  3708. begin
  3709. result:=assigned(owner) and
  3710. (owner.symtabletype<>ObjectSymtable) and
  3711. (not(m_nested_procvars in current_settings.modeswitches) or
  3712. not is_nested_pd(self));
  3713. end;
  3714. procedure tprocdef.make_external;
  3715. begin
  3716. include(procoptions,po_external);
  3717. forwarddef:=false;
  3718. end;
  3719. function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
  3720. begin
  3721. case t of
  3722. gs_local :
  3723. GetSymtable:=localst;
  3724. gs_para :
  3725. GetSymtable:=parast;
  3726. else
  3727. GetSymtable:=nil;
  3728. end;
  3729. end;
  3730. function tprocdef.getcopy: tstoreddef;
  3731. var
  3732. i : tcallercallee;
  3733. j : longint;
  3734. pvs : tparavarsym;
  3735. begin
  3736. result:=inherited getcopyas(procdef,pc_normal);
  3737. { don't copy mangled name, can be different }
  3738. tprocdef(result).messageinf:=messageinf;
  3739. tprocdef(result).dispid:=dispid;
  3740. if po_msgstr in procoptions then
  3741. tprocdef(result).messageinf.str:=stringdup(messageinf.str^);
  3742. tprocdef(result).symoptions:=symoptions;
  3743. if assigned(deprecatedmsg) then
  3744. tprocdef(result).deprecatedmsg:=stringdup(deprecatedmsg^);
  3745. { will have to be associated with appropriate procsym }
  3746. tprocdef(result).procsym:=nil;
  3747. tprocdef(result).aliasnames.concatListcopy(aliasnames);
  3748. if assigned(funcretsym) then
  3749. begin
  3750. if funcretsym.owner=parast then
  3751. begin
  3752. j:=parast.symlist.indexof(funcretsym);
  3753. if j<0 then
  3754. internalerror(2011040606);
  3755. tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
  3756. end
  3757. else if funcretsym.owner=localst then
  3758. begin
  3759. { nothing to do, will be inserted for the new procdef while
  3760. parsing its body (by pdecsub.insert_funcret_local) }
  3761. end
  3762. else
  3763. internalerror(2011040605);
  3764. end;
  3765. { will have to be associated with a new struct }
  3766. tprocdef(result).struct:=nil;
  3767. {$if defined(powerpc) or defined(m68k)}
  3768. tprocdef(result).libsym:=libsym;
  3769. {$endif powerpc or m68k}
  3770. if assigned(resultname) then
  3771. tprocdef(result).resultname:=stringdup(resultname^);
  3772. if assigned(import_dll) then
  3773. tprocdef(result).import_dll:=stringdup(import_dll^);
  3774. if assigned(import_name) then
  3775. tprocdef(result).import_name:=stringdup(import_name^);
  3776. tprocdef(result).import_nr:=import_nr;
  3777. tprocdef(result).extnumber:=$ffff;
  3778. {$ifdef i386}
  3779. tprocdef(result).fpu_used:=fpu_used;
  3780. {$endif i386}
  3781. tprocdef(result).visibility:=visibility;
  3782. tprocdef(result).synthetickind:=synthetickind;
  3783. { we need a separate implementation for the copied def }
  3784. tprocdef(result).forwarddef:=true;
  3785. tprocdef(result).interfacedef:=true;
  3786. { create new paralist }
  3787. tprocdef(result).calcparas;
  3788. end;
  3789. procedure tprocdef.buildderef;
  3790. begin
  3791. inherited buildderef;
  3792. structderef.build(struct);
  3793. { procsym that originaly defined this definition, should be in the
  3794. same symtable }
  3795. procsymderef.build(procsym);
  3796. {$ifdef powerpc}
  3797. { library symbol for AmigaOS/MorphOS }
  3798. libsymderef.build(libsym);
  3799. {$endif powerpc}
  3800. end;
  3801. procedure tprocdef.buildderefimpl;
  3802. begin
  3803. inherited buildderefimpl;
  3804. { Localst is not available for main/unit init }
  3805. if assigned(localst) then
  3806. begin
  3807. tlocalsymtable(localst).buildderef;
  3808. tlocalsymtable(localst).buildderefimpl;
  3809. end;
  3810. { inline tree }
  3811. if (po_has_inlininginfo in procoptions) then
  3812. begin
  3813. funcretsymderef.build(funcretsym);
  3814. inlininginfo^.code.buildderefimpl;
  3815. end;
  3816. end;
  3817. procedure tprocdef.deref;
  3818. begin
  3819. inherited deref;
  3820. struct:=tabstractrecorddef(structderef.resolve);
  3821. { procsym that originaly defined this definition, should be in the
  3822. same symtable }
  3823. procsym:=tprocsym(procsymderef.resolve);
  3824. {$ifdef powerpc}
  3825. { library symbol for AmigaOS/MorphOS }
  3826. libsym:=tsym(libsymderef.resolve);
  3827. {$endif powerpc}
  3828. end;
  3829. procedure tprocdef.derefimpl;
  3830. begin
  3831. { Enable has_inlininginfo when the inlininginfo
  3832. structure is available. The has_inlininginfo was disabled
  3833. after the load, since the data was invalid }
  3834. if assigned(inlininginfo) then
  3835. include(procoptions,po_has_inlininginfo);
  3836. { Locals }
  3837. if assigned(localst) then
  3838. begin
  3839. tlocalsymtable(localst).deref;
  3840. tlocalsymtable(localst).derefimpl;
  3841. end;
  3842. { Inline }
  3843. if (po_has_inlininginfo in procoptions) then
  3844. begin
  3845. inlininginfo^.code.derefimpl;
  3846. { funcretsym, this is always located in the localst }
  3847. funcretsym:=tsym(funcretsymderef.resolve);
  3848. end
  3849. else
  3850. begin
  3851. { safety }
  3852. { Not safe! A unit may be reresolved after its interface has been
  3853. parsed but before its implementation has been parsed, and in that
  3854. case the funcretsym is still required!
  3855. funcretsym:=nil; }
  3856. end;
  3857. end;
  3858. function tprocdef.GetTypeName : string;
  3859. begin
  3860. GetTypeName := FullProcName(false);
  3861. end;
  3862. function tprocdef.mangledname : TSymStr;
  3863. begin
  3864. {$ifdef symansistr}
  3865. if _mangledname<>'' then
  3866. {$else symansistr}
  3867. if assigned(_mangledname) then
  3868. {$endif symansistr}
  3869. begin
  3870. {$ifdef compress}
  3871. {$error add support for ansistrings in case of symansistr}
  3872. mangledname:=minilzw_decode(_mangledname^);
  3873. {$else}
  3874. {$ifdef symansistr}
  3875. mangledname:=_mangledname;
  3876. {$else symansistr}
  3877. mangledname:=_mangledname^;
  3878. {$endif symansistr}
  3879. {$endif}
  3880. exit;
  3881. end;
  3882. {$ifndef jvm}
  3883. mangledname:=defaultmangledname;
  3884. {$else not jvm}
  3885. mangledname:=jvmmangledbasename(false);
  3886. if (po_has_importdll in procoptions) then
  3887. begin
  3888. { import_dll comes from "external 'import_dll_name' name 'external_name'" }
  3889. if assigned(import_dll) then
  3890. mangledname:=import_dll^+'/'+mangledname
  3891. else
  3892. internalerror(2010122607);
  3893. end
  3894. else
  3895. jvmaddtypeownerprefix(owner,mangledname);
  3896. {$endif not jvm}
  3897. {$ifdef compress}
  3898. {$error add support for ansistrings in case of symansistr}
  3899. _mangledname:=stringdup(minilzw_encode(mangledname));
  3900. {$else}
  3901. {$ifdef symansistr}
  3902. _mangledname:=mangledname;
  3903. {$else symansistr}
  3904. _mangledname:=stringdup(mangledname);
  3905. {$endif symansistr}
  3906. {$endif}
  3907. end;
  3908. function tprocdef.defaultmangledname: TSymStr;
  3909. var
  3910. hp : TParavarsym;
  3911. hs : TSymStr;
  3912. crc : dword;
  3913. newlen,
  3914. oldlen,
  3915. i : integer;
  3916. begin
  3917. { we need to use the symtable where the procsym is inserted,
  3918. because that is visible to the world }
  3919. defaultmangledname:=make_mangledname('',procsym.owner,procsym.name);
  3920. oldlen:=length(defaultmangledname);
  3921. { add parameter types }
  3922. for i:=0 to paras.count-1 do
  3923. begin
  3924. hp:=tparavarsym(paras[i]);
  3925. if not(vo_is_hidden_para in hp.varoptions) then
  3926. defaultmangledname:=defaultmangledname+'$'+hp.vardef.mangledparaname;
  3927. end;
  3928. { add resultdef, add $$ as separator to make it unique from a
  3929. parameter separator }
  3930. if not is_void(returndef) then
  3931. defaultmangledname:=defaultmangledname+'$$'+returndef.mangledparaname;
  3932. newlen:=length(defaultmangledname);
  3933. { Replace with CRC if the parameter line is very long }
  3934. if (newlen-oldlen>12) and
  3935. ((newlen>100) or (newlen-oldlen>64)) then
  3936. begin
  3937. crc:=0;
  3938. for i:=0 to paras.count-1 do
  3939. begin
  3940. hp:=tparavarsym(paras[i]);
  3941. if not(vo_is_hidden_para in hp.varoptions) then
  3942. begin
  3943. hs:=hp.vardef.mangledparaname;
  3944. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3945. end;
  3946. end;
  3947. hs:=hp.vardef.mangledparaname;
  3948. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3949. defaultmangledname:=Copy(defaultmangledname,1,oldlen)+'$crc'+hexstr(crc,8);
  3950. end;
  3951. end;
  3952. function tprocdef.cplusplusmangledname : TSymStr;
  3953. function getcppparaname(p : tdef) : TSymStr;
  3954. const
  3955. {$ifdef NAMEMANGLING_GCC2}
  3956. ordtype2str : array[tordtype] of string[2] = (
  3957. '',
  3958. 'Uc','Us','Ui','Us',
  3959. 'Sc','s','i','x',
  3960. 'b','b','b','b','b',
  3961. 'c','w','x');
  3962. {$else NAMEMANGLING_GCC2}
  3963. ordtype2str : array[tordtype] of string[1] = (
  3964. 'v',
  3965. 'h','t','j','y',
  3966. 'a','s','i','x',
  3967. 'b','b','b','b',
  3968. 'b','b','b','b',
  3969. 'c','w','x');
  3970. floattype2str : array[tfloattype] of string[1] = (
  3971. 'f','d','e','e',
  3972. 'd','d','g');
  3973. {$endif NAMEMANGLING_GCC2}
  3974. var
  3975. s : TSymStr;
  3976. begin
  3977. case p.typ of
  3978. orddef:
  3979. s:=ordtype2str[torddef(p).ordtype];
  3980. pointerdef:
  3981. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  3982. {$ifndef NAMEMANGLING_GCC2}
  3983. floatdef:
  3984. s:=floattype2str[tfloatdef(p).floattype];
  3985. {$endif NAMEMANGLING_GCC2}
  3986. else
  3987. internalerror(2103001);
  3988. end;
  3989. getcppparaname:=s;
  3990. end;
  3991. var
  3992. s,s2 : TSymStr;
  3993. hp : TParavarsym;
  3994. i : integer;
  3995. begin
  3996. {$ifdef NAMEMANGLING_GCC2}
  3997. { outdated gcc 2.x name mangling scheme }
  3998. s := procsym.realname;
  3999. if procsym.owner.symtabletype=ObjectSymtable then
  4000. begin
  4001. s2:=upper(tobjectdef(procsym.owner.defowner).objrealname^);
  4002. case proctypeoption of
  4003. potype_destructor:
  4004. s:='_$_'+tostr(length(s2))+s2;
  4005. potype_constructor:
  4006. s:='___'+tostr(length(s2))+s2;
  4007. else
  4008. s:='_'+s+'__'+tostr(length(s2))+s2;
  4009. end;
  4010. end
  4011. else s:=s+'__';
  4012. s:=s+'F';
  4013. { concat modifiers }
  4014. { !!!!! }
  4015. { now we handle the parameters }
  4016. if maxparacount>0 then
  4017. begin
  4018. for i:=0 to paras.count-1 do
  4019. begin
  4020. hp:=tparavarsym(paras[i]);
  4021. { no hidden parameters form part of a C++ mangled name:
  4022. a) self is not included
  4023. b) there are no "high" or other hidden parameters
  4024. }
  4025. if vo_is_hidden_para in hp.varoptions then
  4026. continue;
  4027. s2:=getcppparaname(hp.vardef);
  4028. if hp.varspez in [vs_var,vs_out] then
  4029. s2:='R'+s2;
  4030. s:=s+s2;
  4031. end;
  4032. end
  4033. else
  4034. s:=s+'v';
  4035. cplusplusmangledname:=s;
  4036. {$else NAMEMANGLING_GCC2}
  4037. { gcc 3.x and 4.x name mangling scheme }
  4038. { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling }
  4039. if procsym.owner.symtabletype=ObjectSymtable then
  4040. begin
  4041. s:='_ZN';
  4042. s2:=tobjectdef(procsym.owner.defowner).objextname^;
  4043. s:=s+tostr(length(s2))+s2;
  4044. case proctypeoption of
  4045. potype_constructor:
  4046. s:=s+'C1';
  4047. potype_destructor:
  4048. s:=s+'D1';
  4049. else
  4050. s:=s+tostr(length(procsym.realname))+procsym.realname;
  4051. end;
  4052. s:=s+'E';
  4053. end
  4054. else
  4055. s:=procsym.realname;
  4056. { now we handle the parameters }
  4057. if maxparacount>0 then
  4058. begin
  4059. for i:=0 to paras.count-1 do
  4060. begin
  4061. hp:=tparavarsym(paras[i]);
  4062. { no hidden parameters form part of a C++ mangled name:
  4063. a) self is not included
  4064. b) there are no "high" or other hidden parameters
  4065. }
  4066. if vo_is_hidden_para in hp.varoptions then
  4067. continue;
  4068. s2:=getcppparaname(hp.vardef);
  4069. if hp.varspez in [vs_var,vs_out] then
  4070. s2:='R'+s2;
  4071. s:=s+s2;
  4072. end;
  4073. end
  4074. else
  4075. s:=s+'v';
  4076. cplusplusmangledname:=s;
  4077. {$endif NAMEMANGLING_GCC2}
  4078. end;
  4079. function tprocdef.objcmangledname : TSymStr;
  4080. var
  4081. manglednamelen: longint;
  4082. iscatmethod : boolean;
  4083. begin
  4084. if not (po_msgstr in procoptions) then
  4085. internalerror(2009030901);
  4086. { we may very well need longer strings to handle these... }
  4087. manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+
  4088. length('+"[ ]"')+length(messageinf.str^);
  4089. iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions;
  4090. if (iscatmethod) then
  4091. inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()'));
  4092. if manglednamelen>255 then
  4093. Message1(parser_e_objc_message_name_too_long,messageinf.str^);
  4094. if not(po_classmethod in procoptions) then
  4095. result:='"-['
  4096. else
  4097. result:='"+[';
  4098. { quotes are necessary because the +/- otherwise confuse the assembler
  4099. into expecting a number
  4100. }
  4101. if iscatmethod then
  4102. result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'(';
  4103. result:=result+tobjectdef(procsym.owner.defowner).objextname^;
  4104. if iscatmethod then
  4105. result:=result+')';
  4106. result:=result+' '+messageinf.str^+']"';
  4107. end;
  4108. {$ifdef jvm}
  4109. function tprocdef.jvmmangledbasename(signature: boolean): TSymStr;
  4110. var
  4111. vs: tparavarsym;
  4112. i: longint;
  4113. founderror: tdef;
  4114. tmpresult: TSymStr;
  4115. container: tsymtable;
  4116. begin
  4117. { format:
  4118. * method definition (in Jasmin):
  4119. (private|protected|public) [static] method(parametertypes)returntype
  4120. * method invocation
  4121. package/class/method(parametertypes)returntype
  4122. -> store common part: method(parametertypes)returntype and
  4123. adorn as required when using it.
  4124. }
  4125. if not signature then
  4126. begin
  4127. { method name }
  4128. { special names for constructors and class constructors }
  4129. if proctypeoption=potype_constructor then
  4130. tmpresult:='<init>'
  4131. else if proctypeoption in [potype_class_constructor,potype_unitinit] then
  4132. tmpresult:='<clinit>'
  4133. else if po_has_importname in procoptions then
  4134. begin
  4135. if assigned(import_name) then
  4136. tmpresult:=import_name^
  4137. else
  4138. internalerror(2010122608);
  4139. end
  4140. else
  4141. begin
  4142. tmpresult:=procsym.realname;
  4143. if tmpresult[1]='$' then
  4144. tmpresult:=copy(tmpresult,2,length(tmpresult)-1);
  4145. { nested functions }
  4146. container:=owner;
  4147. while container.symtabletype=localsymtable do
  4148. begin
  4149. tmpresult:='$'+tprocdef(owner.defowner).procsym.realname+'$'+tostr(tprocdef(owner.defowner).procsym.symid)+'$'+tmpresult;
  4150. container:=container.defowner.owner;
  4151. end;
  4152. end;
  4153. end
  4154. else
  4155. tmpresult:='';
  4156. { parameter types }
  4157. tmpresult:=tmpresult+'(';
  4158. { not the case for the main program (not required for defaultmangledname
  4159. because setmangledname() is called for the main program; in case of
  4160. the JVM, this only sets the importname, however) }
  4161. if assigned(paras) then
  4162. begin
  4163. init_paraloc_info(callerside);
  4164. for i:=0 to paras.count-1 do
  4165. begin
  4166. vs:=tparavarsym(paras[i]);
  4167. { function result is not part of the mangled name }
  4168. if vo_is_funcret in vs.varoptions then
  4169. exit;
  4170. { self pointer neither, except for class methods (the JVM only
  4171. supports static class methods natively, so the self pointer
  4172. here is a regular parameter as far as the JVM is concerned }
  4173. if not(po_classmethod in procoptions) and
  4174. (vo_is_self in vs.varoptions) then
  4175. continue;
  4176. { passing by reference is emulated by passing an array of one
  4177. element containing the value; for types that aren't pointers
  4178. in regular Pascal, simply passing the underlying pointer type
  4179. does achieve regular call-by-reference semantics though;
  4180. formaldefs always have to be passed like that because their
  4181. contents can be replaced }
  4182. if paramanager.push_copyout_param(vs.varspez,vs.vardef,proccalloption) then
  4183. tmpresult:=tmpresult+'[';
  4184. { Add the parameter type. }
  4185. if not jvmaddencodedtype(vs.vardef,false,tmpresult,signature,founderror) then
  4186. { an internalerror here is also triggered in case of errors in the source code }
  4187. tmpresult:='<error>';
  4188. end;
  4189. end;
  4190. tmpresult:=tmpresult+')';
  4191. { And the type of the function result (void in case of a procedure and
  4192. constructor). }
  4193. if (proctypeoption in [potype_constructor,potype_class_constructor]) then
  4194. jvmaddencodedtype(voidtype,false,tmpresult,signature,founderror)
  4195. else if not jvmaddencodedtype(returndef,false,tmpresult,signature,founderror) then
  4196. { an internalerror here is also triggered in case of errors in the source code }
  4197. tmpresult:='<error>';
  4198. result:=tmpresult;
  4199. end;
  4200. {$endif jvm}
  4201. procedure tprocdef.setmangledname(const s : TSymStr);
  4202. begin
  4203. { This is not allowed anymore, the forward declaration
  4204. already needs to create the correct mangledname, no changes
  4205. afterwards are allowed (PFV) }
  4206. { Exception: interface definitions in mode macpas, since in that }
  4207. { case no reference to the old name can exist yet (JM) }
  4208. {$ifdef symansistr}
  4209. if _mangledname<>'' then
  4210. if ((m_mac in current_settings.modeswitches) and
  4211. (interfacedef)) then
  4212. _mangledname:=''
  4213. else
  4214. internalerror(200411171);
  4215. {$else symansistr}
  4216. if assigned(_mangledname) then
  4217. if ((m_mac in current_settings.modeswitches) and
  4218. (interfacedef)) then
  4219. stringdispose(_mangledname)
  4220. else
  4221. internalerror(200411171);
  4222. {$endif symansistr}
  4223. {$ifdef jvm}
  4224. { this routine can be called for compilerproces. can't set mangled
  4225. name since it must be calculated, but it uses import_name when set
  4226. -> set that one }
  4227. import_name:=stringdup(s);
  4228. include(procoptions,po_has_importname);
  4229. include(procoptions,po_has_mangledname);
  4230. {$else}
  4231. {$ifdef compress}
  4232. {$error add support for symansistr}
  4233. _mangledname:=stringdup(minilzw_encode(s));
  4234. {$else}
  4235. {$ifdef symansistr}
  4236. _mangledname:=s;
  4237. {$else symansistr}
  4238. _mangledname:=stringdup(s);
  4239. {$endif symansistr}
  4240. {$endif}
  4241. {$endif jvm}
  4242. include(procoptions,po_has_mangledname);
  4243. end;
  4244. {***************************************************************************
  4245. TPROCVARDEF
  4246. ***************************************************************************}
  4247. constructor tprocvardef.create(level:byte);
  4248. begin
  4249. inherited create(procvardef,level);
  4250. end;
  4251. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  4252. begin
  4253. inherited ppuload(procvardef,ppufile);
  4254. { load para symtable }
  4255. parast:=tparasymtable.create(self,ppufile.getbyte);
  4256. {$ifdef jvm}
  4257. ppufile.getderef(classdefderef);
  4258. {$endif}
  4259. tparasymtable(parast).ppuload(ppufile);
  4260. end;
  4261. function tprocvardef.getcopy : tstoreddef;
  4262. var
  4263. i : tcallercallee;
  4264. j : longint;
  4265. begin
  4266. result:=tprocvardef.create(parast.symtablelevel);
  4267. tprocvardef(result).returndef:=returndef;
  4268. tprocvardef(result).returndefderef:=returndefderef;
  4269. tprocvardef(result).parast:=parast.getcopy;
  4270. tprocvardef(result).savesize:=savesize;
  4271. { create paralist copy }
  4272. tprocvardef(result).paras:=tparalist.create(false);
  4273. tprocvardef(result).paras.count:=paras.count;
  4274. for j:=0 to paras.count-1 do
  4275. tprocvardef(result).paras[j]:=paras[j];
  4276. tprocvardef(result).proctypeoption:=proctypeoption;
  4277. tprocvardef(result).proccalloption:=proccalloption;
  4278. tprocvardef(result).procoptions:=procoptions;
  4279. tprocvardef(result).callerargareasize:=callerargareasize;
  4280. tprocvardef(result).calleeargareasize:=calleeargareasize;
  4281. tprocvardef(result).maxparacount:=maxparacount;
  4282. tprocvardef(result).minparacount:=minparacount;
  4283. for i:=low(tcallercallee) to high(tcallercallee) do
  4284. tprocvardef(result).funcretloc[i]:=funcretloc[i].getcopy;
  4285. tprocvardef(result).has_paraloc_info:=has_paraloc_info;
  4286. {$ifdef m68k}
  4287. tprocvardef(result).exp_funcretloc:=exp_funcretloc;
  4288. {$endif}
  4289. {$ifdef jvm}
  4290. tprocvardef(result).classdef:=classdef;
  4291. {$endif}
  4292. end;
  4293. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  4294. begin
  4295. inherited ppuwrite(ppufile);
  4296. { Save the para symtable level (necessary to distinguish nested
  4297. procvars) }
  4298. ppufile.putbyte(parast.symtablelevel);
  4299. {$ifdef jvm}
  4300. ppufile.putderef(classdefderef);
  4301. {$endif}
  4302. { Write this entry }
  4303. ppufile.writeentry(ibprocvardef);
  4304. { Save the para symtable, this is taken from the interface }
  4305. tparasymtable(parast).ppuwrite(ppufile);
  4306. end;
  4307. {$ifdef jvm}
  4308. procedure tprocvardef.buildderef;
  4309. begin
  4310. inherited buildderef;
  4311. classdefderef.build(classdef);
  4312. end;
  4313. procedure tprocvardef.deref;
  4314. begin
  4315. inherited deref;
  4316. classdef:=tobjectdef(classdefderef.resolve);
  4317. end;
  4318. {$endif}
  4319. function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
  4320. begin
  4321. case t of
  4322. gs_para :
  4323. GetSymtable:=parast;
  4324. else
  4325. GetSymtable:=nil;
  4326. end;
  4327. end;
  4328. function tprocvardef.size : asizeint;
  4329. begin
  4330. if ((po_methodpointer in procoptions) or
  4331. is_nested_pd(self)) and
  4332. not(po_addressonly in procoptions) then
  4333. size:=2*sizeof(pint)
  4334. else
  4335. size:=sizeof(pint);
  4336. end;
  4337. function tprocvardef.is_methodpointer:boolean;
  4338. begin
  4339. result:=(po_methodpointer in procoptions);
  4340. end;
  4341. function tprocvardef.is_addressonly:boolean;
  4342. begin
  4343. result:=(not(po_methodpointer in procoptions) and
  4344. not is_nested_pd(self)) or
  4345. (po_addressonly in procoptions);
  4346. end;
  4347. function tprocvardef.getmangledparaname:TSymStr;
  4348. begin
  4349. if not(po_methodpointer in procoptions) then
  4350. if not is_nested_pd(self) then
  4351. result:='procvar'
  4352. else
  4353. result:='nestedprovar'
  4354. else
  4355. result:='procvarofobj'
  4356. end;
  4357. function tprocvardef.is_publishable : boolean;
  4358. begin
  4359. is_publishable:=(po_methodpointer in procoptions);
  4360. end;
  4361. function tprocvardef.GetTypeName : string;
  4362. var
  4363. s: string;
  4364. pno : tprocnameoptions;
  4365. begin
  4366. {$ifdef EXTDEBUG}
  4367. pno:=[pno_showhidden];
  4368. {$else EXTDEBUG}
  4369. pno:=[];
  4370. {$endif EXTDEBUG}
  4371. s:='<';
  4372. if po_classmethod in procoptions then
  4373. s := s+'class method type of'
  4374. else
  4375. if po_addressonly in procoptions then
  4376. s := s+'address of'
  4377. else
  4378. s := s+'procedure variable type of';
  4379. if assigned(returndef) and
  4380. (returndef<>voidtype) then
  4381. s:=s+' function'+typename_paras(pno)+':'+returndef.GetTypeName
  4382. else
  4383. s:=s+' procedure'+typename_paras(pno);
  4384. if po_methodpointer in procoptions then
  4385. s := s+' of object';
  4386. if is_nested_pd(self) then
  4387. s := s+' is nested';
  4388. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  4389. end;
  4390. {***************************************************************************
  4391. TOBJECTDEF
  4392. ***************************************************************************}
  4393. constructor tobjectdef.create(ot:tobjecttyp;const n:string;c:tobjectdef);
  4394. begin
  4395. inherited create(n,objectdef);
  4396. fcurrent_dispid:=0;
  4397. objecttype:=ot;
  4398. childof:=nil;
  4399. if objecttype=odt_helper then
  4400. owner.includeoption(sto_has_helper);
  4401. symtable:=tObjectSymtable.create(self,n,current_settings.packrecords);
  4402. { create space for vmt !! }
  4403. vmtentries:=TFPList.Create;
  4404. vmt_offset:=0;
  4405. set_parent(c);
  4406. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  4407. prepareguid;
  4408. { setup implemented interfaces }
  4409. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  4410. ImplementedInterfaces:=TFPObjectList.Create(true)
  4411. else
  4412. ImplementedInterfaces:=nil;
  4413. writing_class_record_dbginfo:=false;
  4414. end;
  4415. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  4416. var
  4417. i,
  4418. implintfcount : longint;
  4419. d : tderef;
  4420. ImplIntf : TImplementedInterface;
  4421. vmtentry : pvmtentry;
  4422. begin
  4423. inherited ppuload(objectdef,ppufile);
  4424. objecttype:=tobjecttyp(ppufile.getbyte);
  4425. objextname:=stringdup(ppufile.getstring);
  4426. { only used for external Objective-C classes/protocols }
  4427. if (objextname^='') then
  4428. stringdispose(objextname);
  4429. symtable:=tObjectSymtable.create(self,objrealname^,0);
  4430. tObjectSymtable(symtable).datasize:=ppufile.getasizeint;
  4431. tObjectSymtable(symtable).paddingsize:=ppufile.getword;
  4432. tObjectSymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  4433. tObjectSymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  4434. vmt_offset:=ppufile.getlongint;
  4435. ppufile.getderef(childofderef);
  4436. { load guid }
  4437. iidstr:=nil;
  4438. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4439. begin
  4440. new(iidguid);
  4441. ppufile.getguid(iidguid^);
  4442. iidstr:=stringdup(ppufile.getstring);
  4443. end;
  4444. abstractcnt:=ppufile.getlongint;
  4445. if objecttype=odt_helper then
  4446. ppufile.getderef(extendeddefderef);
  4447. vmtentries:=TFPList.Create;
  4448. vmtentries.count:=ppufile.getlongint;
  4449. for i:=0 to vmtentries.count-1 do
  4450. begin
  4451. ppufile.getderef(d);
  4452. new(vmtentry);
  4453. vmtentry^.procdef:=nil;
  4454. vmtentry^.procdefderef:=d;
  4455. vmtentry^.visibility:=tvisibility(ppufile.getbyte);
  4456. vmtentries[i]:=vmtentry;
  4457. end;
  4458. { load implemented interfaces }
  4459. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  4460. begin
  4461. ImplementedInterfaces:=TFPObjectList.Create(true);
  4462. implintfcount:=ppufile.getlongint;
  4463. for i:=0 to implintfcount-1 do
  4464. begin
  4465. ppufile.getderef(d);
  4466. ImplIntf:=TImplementedInterface.Create_deref(d);
  4467. ImplIntf.IOffset:=ppufile.getlongint;
  4468. ImplementedInterfaces.Add(ImplIntf);
  4469. end;
  4470. end
  4471. else
  4472. ImplementedInterfaces:=nil;
  4473. if df_copied_def in defoptions then
  4474. ppufile.getderef(cloneddefderef)
  4475. else
  4476. tObjectSymtable(symtable).ppuload(ppufile);
  4477. { handles the predefined class tobject }
  4478. { the last TOBJECT which is loaded gets }
  4479. { it ! }
  4480. if (childof=nil) and
  4481. (objecttype in [odt_class,odt_javaclass]) and
  4482. (objname^='TOBJECT') then
  4483. class_tobject:=self;
  4484. if (childof=nil) and
  4485. (objecttype=odt_interfacecom) then
  4486. if (objname^='IUNKNOWN') then
  4487. interface_iunknown:=self
  4488. else
  4489. if (objname^='IDISPATCH') then
  4490. interface_idispatch:=self;
  4491. if (childof=nil) and
  4492. (objecttype=odt_objcclass) and
  4493. (objname^='PROTOCOL') then
  4494. objc_protocoltype:=self;
  4495. if (objecttype=odt_javaclass) and
  4496. not(oo_is_formal in objectoptions) then
  4497. begin
  4498. if (objname^='JLOBJECT') then
  4499. java_jlobject:=self
  4500. else if (objname^='JLTHROWABLE') then
  4501. java_jlthrowable:=self
  4502. else if (objname^='FPCBASERECORDTYPE') then
  4503. java_fpcbaserecordtype:=self
  4504. else if (objname^='JLSTRING') then
  4505. java_jlstring:=self
  4506. else if (objname^='ANSISTRINGCLASS') then
  4507. java_ansistring:=self
  4508. else if (objname^='SHORTSTRINGCLASS') then
  4509. java_shortstring:=self
  4510. else if (objname^='JLENUM') then
  4511. java_jlenum:=self
  4512. else if (objname^='JUENUMSET') then
  4513. java_juenumset:=self
  4514. else if (objname^='FPCBITSET') then
  4515. java_jubitset:=self
  4516. else if (objname^='FPCBASEPROCVARTYPE') then
  4517. java_procvarbase:=self;
  4518. end;
  4519. writing_class_record_dbginfo:=false;
  4520. end;
  4521. destructor tobjectdef.destroy;
  4522. begin
  4523. if assigned(symtable) then
  4524. begin
  4525. symtable.free;
  4526. symtable:=nil;
  4527. end;
  4528. stringdispose(objextname);
  4529. stringdispose(iidstr);
  4530. if assigned(ImplementedInterfaces) then
  4531. begin
  4532. ImplementedInterfaces.free;
  4533. ImplementedInterfaces:=nil;
  4534. end;
  4535. if assigned(iidguid) then
  4536. begin
  4537. dispose(iidguid);
  4538. iidguid:=nil;
  4539. end;
  4540. if assigned(vmtentries) then
  4541. begin
  4542. resetvmtentries;
  4543. vmtentries.free;
  4544. vmtentries:=nil;
  4545. end;
  4546. if assigned(vmcallstaticinfo) then
  4547. begin
  4548. freemem(vmcallstaticinfo);
  4549. vmcallstaticinfo:=nil;
  4550. end;
  4551. inherited destroy;
  4552. end;
  4553. function tobjectdef.getcopy : tstoreddef;
  4554. var
  4555. i : longint;
  4556. begin
  4557. result:=tobjectdef.create(objecttype,objrealname^,childof);
  4558. { the constructor allocates a symtable which we release to avoid memory leaks }
  4559. tobjectdef(result).symtable.free;
  4560. tobjectdef(result).symtable:=symtable.getcopy;
  4561. if assigned(objextname) then
  4562. tobjectdef(result).objextname:=stringdup(objextname^);
  4563. if assigned(import_lib) then
  4564. tobjectdef(result).import_lib:=stringdup(import_lib^);
  4565. tobjectdef(result).objectoptions:=objectoptions;
  4566. include(tobjectdef(result).defoptions,df_copied_def);
  4567. tobjectdef(result).extendeddef:=extendeddef;
  4568. if assigned(tcinitcode) then
  4569. tobjectdef(result).tcinitcode:=tcinitcode.getcopy;
  4570. tobjectdef(result).vmt_offset:=vmt_offset;
  4571. if assigned(iidguid) then
  4572. begin
  4573. new(tobjectdef(result).iidguid);
  4574. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  4575. end;
  4576. if assigned(iidstr) then
  4577. tobjectdef(result).iidstr:=stringdup(iidstr^);
  4578. tobjectdef(result).abstractcnt:=abstractcnt;
  4579. if assigned(ImplementedInterfaces) then
  4580. begin
  4581. for i:=0 to ImplementedInterfaces.count-1 do
  4582. tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
  4583. end;
  4584. if assigned(vmtentries) then
  4585. begin
  4586. tobjectdef(result).vmtentries:=TFPList.Create;
  4587. tobjectdef(result).copyvmtentries(self);
  4588. end;
  4589. end;
  4590. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  4591. var
  4592. i : longint;
  4593. vmtentry : pvmtentry;
  4594. ImplIntf : TImplementedInterface;
  4595. old_do_indirect_crc: boolean;
  4596. begin
  4597. { if class1 in unit A changes, and class2 in unit B inherits from it
  4598. (so unit B uses unit A), then unit B with class2 will be recompiled.
  4599. However, if there is also a class3 in unit C that only depends on
  4600. unit B, then unit C will not be recompiled because nothing changed
  4601. to the interface of unit B. Nevertheless, unit C can indirectly
  4602. depend on unit A via derefs, and these must be updated -> the
  4603. indirect crc keeps track of such changes. }
  4604. old_do_indirect_crc:=ppufile.do_indirect_crc;
  4605. ppufile.do_indirect_crc:=true;
  4606. inherited ppuwrite(ppufile);
  4607. ppufile.putbyte(byte(objecttype));
  4608. if assigned(objextname) then
  4609. ppufile.putstring(objextname^)
  4610. else
  4611. ppufile.putstring('');
  4612. ppufile.putasizeint(tObjectSymtable(symtable).datasize);
  4613. ppufile.putword(tObjectSymtable(symtable).paddingsize);
  4614. ppufile.putbyte(byte(tObjectSymtable(symtable).fieldalignment));
  4615. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignment));
  4616. ppufile.putlongint(vmt_offset);
  4617. ppufile.putderef(childofderef);
  4618. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4619. begin
  4620. ppufile.putguid(iidguid^);
  4621. ppufile.putstring(iidstr^);
  4622. end;
  4623. ppufile.putlongint(abstractcnt);
  4624. if objecttype=odt_helper then
  4625. ppufile.putderef(extendeddefderef);
  4626. ppufile.putlongint(vmtentries.count);
  4627. for i:=0 to vmtentries.count-1 do
  4628. begin
  4629. vmtentry:=pvmtentry(vmtentries[i]);
  4630. ppufile.putderef(vmtentry^.procdefderef);
  4631. ppufile.putbyte(byte(vmtentry^.visibility));
  4632. end;
  4633. if assigned(ImplementedInterfaces) then
  4634. begin
  4635. ppufile.putlongint(ImplementedInterfaces.Count);
  4636. for i:=0 to ImplementedInterfaces.Count-1 do
  4637. begin
  4638. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  4639. ppufile.putderef(ImplIntf.intfdefderef);
  4640. ppufile.putlongint(ImplIntf.Ioffset);
  4641. end;
  4642. end;
  4643. if df_copied_def in defoptions then
  4644. ppufile.putderef(cloneddefderef);
  4645. ppufile.writeentry(ibobjectdef);
  4646. if not(df_copied_def in defoptions) then
  4647. tObjectSymtable(symtable).ppuwrite(ppufile);
  4648. ppufile.do_indirect_crc:=old_do_indirect_crc;
  4649. end;
  4650. function tobjectdef.GetTypeName:string;
  4651. begin
  4652. { in this case we will go in endless recursion, because then }
  4653. { there is no tsym associated yet with the def. It can occur }
  4654. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  4655. { instead of the actual type name }
  4656. if not assigned(typesym) then
  4657. result:='<Currently Parsed Class>'
  4658. else
  4659. result:=typesymbolprettyname;
  4660. end;
  4661. procedure tobjectdef.buildderef;
  4662. var
  4663. i : longint;
  4664. vmtentry : pvmtentry;
  4665. begin
  4666. inherited buildderef;
  4667. childofderef.build(childof);
  4668. if df_copied_def in defoptions then
  4669. cloneddefderef.build(symtable.defowner)
  4670. else
  4671. tstoredsymtable(symtable).buildderef;
  4672. if objecttype=odt_helper then
  4673. extendeddefderef.build(extendeddef);
  4674. for i:=0 to vmtentries.count-1 do
  4675. begin
  4676. vmtentry:=pvmtentry(vmtentries[i]);
  4677. vmtentry^.procdefderef.build(vmtentry^.procdef);
  4678. end;
  4679. if assigned(ImplementedInterfaces) then
  4680. begin
  4681. for i:=0 to ImplementedInterfaces.count-1 do
  4682. TImplementedInterface(ImplementedInterfaces[i]).buildderef;
  4683. end;
  4684. end;
  4685. procedure tobjectdef.deref;
  4686. var
  4687. i : longint;
  4688. vmtentry : pvmtentry;
  4689. begin
  4690. inherited deref;
  4691. childof:=tobjectdef(childofderef.resolve);
  4692. if df_copied_def in defoptions then
  4693. begin
  4694. cloneddef:=tobjectdef(cloneddefderef.resolve);
  4695. symtable:=cloneddef.symtable.getcopy;
  4696. end
  4697. else
  4698. tstoredsymtable(symtable).deref;
  4699. if objecttype=odt_helper then
  4700. extendeddef:=tobjectdef(extendeddefderef.resolve);
  4701. for i:=0 to vmtentries.count-1 do
  4702. begin
  4703. vmtentry:=pvmtentry(vmtentries[i]);
  4704. vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve);
  4705. end;
  4706. if assigned(ImplementedInterfaces) then
  4707. begin
  4708. for i:=0 to ImplementedInterfaces.count-1 do
  4709. TImplementedInterface(ImplementedInterfaces[i]).deref;
  4710. end;
  4711. end;
  4712. procedure create_class_helper_for_procdef(def: tobject; arg: pointer);
  4713. var
  4714. pd: tprocdef absolute def;
  4715. st: tsymtable;
  4716. psym: tsym;
  4717. nname: TIDString;
  4718. begin
  4719. if (tdef(def).typ<>procdef) then
  4720. exit;
  4721. { pd.owner = objcclass symtable -> defowner = objcclassdef ->
  4722. owner = symtable in which objcclassdef is defined
  4723. }
  4724. st:=pd.owner.defowner.owner;
  4725. nname:=class_helper_prefix+tprocsym(pd.procsym).name;
  4726. { check for an existing procsym with our special name }
  4727. psym:=tsym(st.find(nname));
  4728. if not assigned(psym) then
  4729. begin
  4730. psym:=tprocsym.create(nname);
  4731. { avoid warning about this symbol being unused }
  4732. psym.IncRefCount;
  4733. { don't check for duplicates:
  4734. a) we checked above
  4735. b) in case we are in the implementation section of a unit, this
  4736. will also check for this symbol in the interface section
  4737. (since you normally cannot have symbols with the same name
  4738. both interface and implementation), and it's possible to
  4739. have class helpers for the same class in the interface and
  4740. in the implementation, and they cannot be merged since only
  4741. the once in the interface must be saved to the ppu/visible
  4742. from other units }
  4743. st.insert(psym,false);
  4744. end
  4745. else if (psym.typ<>procsym) then
  4746. internalerror(2009111501);
  4747. { add ourselves to this special procsym }
  4748. tprocsym(psym).procdeflist.add(def);
  4749. end;
  4750. procedure tobjectdef.buildderefimpl;
  4751. begin
  4752. inherited buildderefimpl;
  4753. if not (df_copied_def in defoptions) then
  4754. tstoredsymtable(symtable).buildderefimpl;
  4755. end;
  4756. procedure tobjectdef.derefimpl;
  4757. begin
  4758. inherited derefimpl;
  4759. if not (df_copied_def in defoptions) then
  4760. tstoredsymtable(symtable).derefimpl;
  4761. { the procdefs are not owned by the class helper procsyms, so they
  4762. are not stored/restored either -> re-add them here }
  4763. if (objecttype=odt_objcclass) or
  4764. (oo_is_classhelper in objectoptions) then
  4765. symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
  4766. end;
  4767. procedure tobjectdef.resetvmtentries;
  4768. var
  4769. i : longint;
  4770. begin
  4771. for i:=0 to vmtentries.Count-1 do
  4772. Dispose(pvmtentry(vmtentries[i]));
  4773. vmtentries.clear;
  4774. end;
  4775. procedure tobjectdef.copyvmtentries(objdef:tobjectdef);
  4776. var
  4777. i : longint;
  4778. vmtentry : pvmtentry;
  4779. begin
  4780. resetvmtentries;
  4781. vmtentries.count:=objdef.vmtentries.count;
  4782. for i:=0 to objdef.vmtentries.count-1 do
  4783. begin
  4784. new(vmtentry);
  4785. vmtentry^:=pvmtentry(objdef.vmtentries[i])^;
  4786. vmtentries[i]:=vmtentry;
  4787. end;
  4788. end;
  4789. function tobjectdef.getparentdef:tdef;
  4790. begin
  4791. { TODO: Remove getparentdef hack}
  4792. { With 2 forward declared classes with the child class before the
  4793. parent class the child class is written earlier to the ppu. Leaving it
  4794. possible to have a reference to the parent class for property overriding,
  4795. but the parent class still has the childof not resolved yet (PFV) }
  4796. if childof=nil then
  4797. childof:=tobjectdef(childofderef.resolve);
  4798. result:=childof;
  4799. end;
  4800. procedure tobjectdef.prepareguid;
  4801. begin
  4802. { set up guid }
  4803. if not assigned(iidguid) then
  4804. begin
  4805. new(iidguid);
  4806. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  4807. end;
  4808. { setup iidstring }
  4809. if not assigned(iidstr) then
  4810. iidstr:=stringdup(''); { default is empty string }
  4811. end;
  4812. procedure tobjectdef.set_parent( c : tobjectdef);
  4813. begin
  4814. if assigned(childof) then
  4815. exit;
  4816. childof:=c;
  4817. if not assigned(c) then
  4818. exit;
  4819. { inherit options and status }
  4820. objectoptions:=objectoptions+(c.objectoptions*inherited_objectoptions);
  4821. { initially has the same number of abstract methods as the parent }
  4822. abstractcnt:=c.abstractcnt;
  4823. { add the data of the anchestor class/object }
  4824. if (objecttype in [odt_class,odt_object,odt_objcclass,odt_javaclass]) then
  4825. begin
  4826. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize+tObjectSymtable(c.symtable).datasize;
  4827. { inherit recordalignment }
  4828. tObjectSymtable(symtable).recordalignment:=tObjectSymtable(c.symtable).recordalignment;
  4829. { if both the parent and this record use C-alignment, also inherit
  4830. the current field alignment }
  4831. if (tObjectSymtable(c.symtable).usefieldalignment=C_alignment) and
  4832. (tObjectSymtable(symtable).usefieldalignment=C_alignment) then
  4833. tObjectSymtable(symtable).fieldalignment:=tObjectSymtable(c.symtable).fieldalignment;
  4834. { the padding is not inherited for Objective-C classes (maybe not
  4835. for cppclass either?) }
  4836. if objecttype=odt_objcclass then
  4837. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-tObjectSymtable(c.symtable).paddingsize;
  4838. if (oo_has_vmt in objectoptions) and
  4839. (oo_has_vmt in c.objectoptions) then
  4840. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-sizeof(pint);
  4841. { if parent has a vmt field then the offset is the same for the child PM }
  4842. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  4843. begin
  4844. vmt_offset:=c.vmt_offset;
  4845. include(objectoptions,oo_has_vmt);
  4846. end;
  4847. end;
  4848. end;
  4849. procedure tobjectdef.insertvmt;
  4850. var
  4851. vs: tfieldvarsym;
  4852. begin
  4853. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  4854. exit;
  4855. if (oo_has_vmt in objectoptions) then
  4856. internalerror(12345)
  4857. else
  4858. begin
  4859. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,
  4860. tObjectSymtable(symtable).fieldalignment);
  4861. if (tf_requires_proper_alignment in target_info.flags) then
  4862. begin
  4863. { Align VMT pointer and whole object instance if target CPU requires alignment. }
  4864. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(pint));
  4865. tObjectSymtable(symtable).alignrecord(tObjectSymtable(symtable).datasize,sizeof(pint));
  4866. end;
  4867. vs:=tfieldvarsym.create('_vptr$'+objname^,vs_value,voidpointertype,[]);
  4868. hidesym(vs);
  4869. tObjectSymtable(symtable).insert(vs);
  4870. tObjectSymtable(symtable).addfield(vs,vis_hidden);
  4871. if (tObjectSymtable(symtable).usefieldalignment<>bit_alignment) then
  4872. vmt_offset:=vs.fieldoffset
  4873. else
  4874. vmt_offset:=vs.fieldoffset div 8;
  4875. include(objectoptions,oo_has_vmt);
  4876. end;
  4877. end;
  4878. procedure tobjectdef.check_forwards;
  4879. begin
  4880. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol,odt_interfacejava]) then
  4881. inherited;
  4882. if (oo_is_forward in objectoptions) then
  4883. begin
  4884. { ok, in future, the forward can be resolved }
  4885. Message1(sym_e_class_forward_not_resolved,objrealname^);
  4886. exclude(objectoptions,oo_is_forward);
  4887. end;
  4888. end;
  4889. { true if prot implements d (or if they are equal) }
  4890. function is_related_interface_multiple(prot: tobjectdef; d : tdef) : boolean;
  4891. var
  4892. i : longint;
  4893. begin
  4894. { objcprotocols have multiple inheritance, all protocols from which
  4895. the current protocol inherits are stored in implementedinterfaces }
  4896. result:=prot=d;
  4897. if result then
  4898. exit;
  4899. for i:=0 to prot.ImplementedInterfaces.count-1 do
  4900. begin
  4901. result:=is_related_interface_multiple(TImplementedInterface(prot.ImplementedInterfaces[i]).intfdef,d);
  4902. if result then
  4903. exit;
  4904. end;
  4905. end;
  4906. { true, if self inherits from d (or if they are equal) }
  4907. function tobjectdef.is_related(d : tdef) : boolean;
  4908. var
  4909. hp : tobjectdef;
  4910. realself: tobjectdef;
  4911. begin
  4912. if (d.typ=objectdef) then
  4913. d:=find_real_class_definition(tobjectdef(d),false);
  4914. realself:=find_real_class_definition(self,false);
  4915. if realself=d then
  4916. begin
  4917. is_related:=true;
  4918. exit;
  4919. end;
  4920. if (d.typ<>objectdef) then
  4921. begin
  4922. is_related:=false;
  4923. exit;
  4924. end;
  4925. { Objective-C protocols and Java interfaces can use multiple
  4926. inheritance }
  4927. if (objecttype in [odt_objcprotocol,odt_interfacejava]) then
  4928. begin
  4929. is_related:=is_related_interface_multiple(realself,d);
  4930. exit
  4931. end;
  4932. { formally declared Objective-C and Java classes match Objective-C/Java
  4933. classes with the same name. In case of Java, the package must also
  4934. match}
  4935. if (objecttype in [odt_objcclass,odt_javaclass]) and
  4936. (tobjectdef(d).objecttype=objecttype) and
  4937. ((oo_is_formal in objectoptions) or
  4938. (oo_is_formal in tobjectdef(d).objectoptions)) and
  4939. (objrealname^=tobjectdef(d).objrealname^) then
  4940. begin
  4941. { check package name for Java }
  4942. if objecttype=odt_objcclass then
  4943. is_related:=true
  4944. else
  4945. begin
  4946. is_related:=
  4947. assigned(import_lib)=assigned(tobjectdef(d).import_lib);
  4948. if is_related and
  4949. assigned(import_lib) then
  4950. is_related:=import_lib^=tobjectdef(d).import_lib^;
  4951. end;
  4952. exit;
  4953. end;
  4954. hp:=realself.childof;
  4955. while assigned(hp) do
  4956. begin
  4957. if hp=d then
  4958. begin
  4959. is_related:=true;
  4960. exit;
  4961. end;
  4962. hp:=hp.childof;
  4963. end;
  4964. is_related:=false;
  4965. end;
  4966. function tobjectdef.find_destructor: tprocdef;
  4967. var
  4968. objdef: tobjectdef;
  4969. begin
  4970. objdef:=self;
  4971. while assigned(objdef) do
  4972. begin
  4973. result:=objdef.find_procdef_bytype(potype_destructor);
  4974. if assigned(result) then
  4975. exit;
  4976. objdef:=objdef.childof;
  4977. end;
  4978. result:=nil;
  4979. end;
  4980. function tobjectdef.implements_any_interfaces: boolean;
  4981. begin
  4982. result := (ImplementedInterfaces.Count > 0) or
  4983. (assigned(childof) and childof.implements_any_interfaces);
  4984. end;
  4985. function tobjectdef.size : asizeint;
  4986. begin
  4987. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  4988. result:=sizeof(pint)
  4989. else
  4990. result:=tObjectSymtable(symtable).datasize;
  4991. end;
  4992. function tobjectdef.alignment:shortint;
  4993. begin
  4994. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  4995. alignment:=sizeof(pint)
  4996. else
  4997. alignment:=tObjectSymtable(symtable).recordalignment;
  4998. end;
  4999. function tobjectdef.vmtmethodoffset(index:longint):longint;
  5000. begin
  5001. { for offset of methods for classes, see rtl/inc/objpash.inc }
  5002. case objecttype of
  5003. odt_class:
  5004. { the +2*sizeof(pint) is size and -size }
  5005. vmtmethodoffset:=(index+10)*sizeof(pint)+2*sizeof(pint);
  5006. odt_helper,
  5007. odt_objcclass,
  5008. odt_objcprotocol:
  5009. vmtmethodoffset:=0;
  5010. odt_interfacecom,odt_interfacecorba,odt_dispinterface:
  5011. vmtmethodoffset:=index*sizeof(pint);
  5012. odt_javaclass,
  5013. odt_interfacejava:
  5014. { invalid }
  5015. vmtmethodoffset:=-1;
  5016. else
  5017. {$ifdef WITHDMT}
  5018. vmtmethodoffset:=(index+4)*sizeof(pint);
  5019. {$else WITHDMT}
  5020. vmtmethodoffset:=(index+3)*sizeof(pint);
  5021. {$endif WITHDMT}
  5022. end;
  5023. end;
  5024. function tobjectdef.vmt_mangledname : TSymStr;
  5025. begin
  5026. if not(oo_has_vmt in objectoptions) then
  5027. Message1(parser_n_object_has_no_vmt,objrealname^);
  5028. vmt_mangledname:=make_mangledname('VMT',owner,objname^);
  5029. end;
  5030. function tobjectdef.needs_inittable : boolean;
  5031. begin
  5032. case objecttype of
  5033. odt_helper,
  5034. odt_class :
  5035. needs_inittable:=false;
  5036. odt_dispinterface,
  5037. odt_interfacecom:
  5038. needs_inittable:=true;
  5039. odt_interfacecorba:
  5040. needs_inittable:=is_related(interface_iunknown);
  5041. odt_object:
  5042. needs_inittable:=tObjectSymtable(symtable).needs_init_final;
  5043. odt_cppclass,
  5044. odt_objcclass,
  5045. odt_objcprotocol,
  5046. odt_javaclass,
  5047. odt_interfacejava:
  5048. needs_inittable:=false;
  5049. else
  5050. internalerror(200108267);
  5051. end;
  5052. end;
  5053. function tobjectdef.rtti_mangledname(rt: trttitype): string;
  5054. begin
  5055. if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
  5056. result:=inherited rtti_mangledname(rt)
  5057. else
  5058. begin
  5059. { necessary in case of a dynamic array of nsobject, or
  5060. if an nsobject field appears in a record that needs
  5061. init/finalisation }
  5062. if rt=initrtti then
  5063. begin
  5064. result:=voidpointertype.rtti_mangledname(rt);
  5065. exit;
  5066. end;
  5067. if not(target_info.system in systems_objc_nfabi) then
  5068. begin
  5069. result:=target_asm.labelprefix;
  5070. case objecttype of
  5071. odt_objcclass:
  5072. begin
  5073. case rt of
  5074. objcclassrtti:
  5075. if not(oo_is_classhelper in objectoptions) then
  5076. result:=result+'_OBJC_CLASS_'
  5077. else
  5078. result:=result+'_OBJC_CATEGORY_';
  5079. objcmetartti:
  5080. if not(oo_is_classhelper in objectoptions) then
  5081. result:=result+'_OBJC_METACLASS_'
  5082. else
  5083. internalerror(2009111511);
  5084. else
  5085. internalerror(2009092302);
  5086. end;
  5087. end;
  5088. odt_objcprotocol:
  5089. result:=result+'_OBJC_PROTOCOL_';
  5090. end;
  5091. end
  5092. else
  5093. begin
  5094. case objecttype of
  5095. odt_objcclass:
  5096. begin
  5097. if (oo_is_classhelper in objectoptions) and
  5098. (rt<>objcclassrtti) then
  5099. internalerror(2009111512);
  5100. case rt of
  5101. objcclassrtti:
  5102. if not(oo_is_classhelper in objectoptions) then
  5103. result:='_OBJC_CLASS_$_'
  5104. else
  5105. result:='_OBJC_$_CATEGORY_';
  5106. objcmetartti:
  5107. result:='_OBJC_METACLASS_$_';
  5108. objcclassrortti:
  5109. result:=lower(target_asm.labelprefix)+'_OBJC_CLASS_RO_$_';
  5110. objcmetarortti:
  5111. result:=lower(target_asm.labelprefix)+'_OBJC_METACLASS_RO_$_';
  5112. else
  5113. internalerror(2009092303);
  5114. end;
  5115. end;
  5116. odt_objcprotocol:
  5117. begin
  5118. result:=lower(target_asm.labelprefix);
  5119. case rt of
  5120. objcclassrtti:
  5121. result:=result+'_OBJC_PROTOCOL_$_';
  5122. objcmetartti:
  5123. result:=result+'_OBJC_LABEL_PROTOCOL_$_';
  5124. else
  5125. internalerror(2009092501);
  5126. end;
  5127. end;
  5128. end;
  5129. end;
  5130. result:=result+objextname^;
  5131. end;
  5132. end;
  5133. function tobjectdef.members_need_inittable : boolean;
  5134. begin
  5135. members_need_inittable:=tObjectSymtable(symtable).needs_init_final;
  5136. end;
  5137. function tobjectdef.find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  5138. var
  5139. ImplIntf : TImplementedInterface;
  5140. i : longint;
  5141. begin
  5142. result:=nil;
  5143. if not assigned(ImplementedInterfaces) then
  5144. exit;
  5145. for i:=0 to ImplementedInterfaces.Count-1 do
  5146. begin
  5147. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  5148. if ImplIntf.intfdef=aintfdef then
  5149. begin
  5150. result:=ImplIntf;
  5151. exit;
  5152. end;
  5153. end;
  5154. end;
  5155. function tobjectdef.is_publishable : boolean;
  5156. begin
  5157. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface];
  5158. end;
  5159. function tobjectdef.get_next_dispid: longint;
  5160. begin
  5161. inc(fcurrent_dispid);
  5162. result:=fcurrent_dispid;
  5163. end;
  5164. function tobjectdef.search_enumerator_get: tprocdef;
  5165. begin
  5166. result:=inherited;
  5167. if not assigned(result) and assigned(childof) then
  5168. result:=childof.search_enumerator_get;
  5169. end;
  5170. function tobjectdef.search_enumerator_move: tprocdef;
  5171. begin
  5172. result:=inherited;
  5173. if not assigned(result) and assigned(childof) then
  5174. result:=childof.search_enumerator_move;
  5175. end;
  5176. function tobjectdef.search_enumerator_current: tsym;
  5177. begin
  5178. result:=inherited;
  5179. if not assigned(result) and assigned(childof) then
  5180. result:=childof.search_enumerator_current;
  5181. end;
  5182. procedure tobjectdef.register_created_classref_type;
  5183. begin
  5184. if not classref_created_in_current_module then
  5185. begin
  5186. classref_created_in_current_module:=true;
  5187. current_module.wpoinfo.addcreatedobjtypeforclassref(self);
  5188. end;
  5189. end;
  5190. procedure tobjectdef.register_created_object_type;
  5191. begin
  5192. if not created_in_current_module then
  5193. begin
  5194. created_in_current_module:=true;
  5195. current_module.wpoinfo.addcreatedobjtype(self);
  5196. end;
  5197. end;
  5198. procedure tobjectdef.register_maybe_created_object_type;
  5199. begin
  5200. { if we know it has been created for sure, no need
  5201. to also record that it maybe can be created in
  5202. this module
  5203. }
  5204. if not (created_in_current_module) and
  5205. not (maybe_created_in_current_module) then
  5206. begin
  5207. maybe_created_in_current_module:=true;
  5208. current_module.wpoinfo.addmaybecreatedbyclassref(self);
  5209. end;
  5210. end;
  5211. procedure tobjectdef.register_vmt_call(index: longint);
  5212. begin
  5213. if (is_object(self) or is_class(self)) then
  5214. current_module.wpoinfo.addcalledvmtentry(self,index);
  5215. end;
  5216. procedure check_and_finish_msg(data: tobject; arg: pointer);
  5217. var
  5218. def: tdef absolute data;
  5219. pd: tprocdef absolute data;
  5220. i,
  5221. paracount: longint;
  5222. begin
  5223. if (def.typ=procdef) then
  5224. begin
  5225. { add all messages also under a dummy name to the symtable in
  5226. which the objcclass/protocol/category is declared, so they can
  5227. be called via id.<name>
  5228. }
  5229. create_class_helper_for_procdef(pd,nil);
  5230. { we have to wait until now to set the mangled name because it
  5231. depends on the (possibly external) class name, which is defined
  5232. at the very end. }
  5233. if not(po_msgstr in pd.procoptions) then
  5234. begin
  5235. CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
  5236. { recover to avoid internalerror later on }
  5237. include(pd.procoptions,po_msgstr);
  5238. pd.messageinf.str:=stringdup('MissingDeclaration');
  5239. end;
  5240. { Mangled name is already set in case this is a copy of
  5241. another type. }
  5242. if not(po_has_mangledname in pd.procoptions) then
  5243. begin
  5244. { check whether the number of formal parameters is correct,
  5245. and whether they have valid Objective-C types }
  5246. paracount:=0;
  5247. for i:=1 to length(pd.messageinf.str^) do
  5248. if pd.messageinf.str^[i]=':' then
  5249. inc(paracount);
  5250. for i:=0 to pd.paras.count-1 do
  5251. if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
  5252. not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
  5253. dec(paracount);
  5254. if (paracount<>0) then
  5255. MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
  5256. pd.setmangledname(pd.objcmangledname);
  5257. end
  5258. else
  5259. { all checks already done }
  5260. exit;
  5261. if not(oo_is_external in pd.struct.objectoptions) then
  5262. begin
  5263. if (po_varargs in pd.procoptions) then
  5264. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external)
  5265. else
  5266. begin
  5267. { check for "array of const" parameters }
  5268. for i:=0 to pd.parast.symlist.count-1 do
  5269. begin
  5270. if (tsym(pd.parast.symlist[i]).typ=paravarsym) and
  5271. is_array_of_const(tparavarsym(pd.parast.symlist[i]).vardef) then
  5272. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external);
  5273. end;
  5274. end;
  5275. end;
  5276. end;
  5277. end;
  5278. procedure mark_private_fields_used(data: tobject; arg: pointer);
  5279. var
  5280. sym: tsym absolute data;
  5281. begin
  5282. if (sym.typ=fieldvarsym) and
  5283. (tfieldvarsym(sym).visibility in [vis_private,vis_strictprivate]) then
  5284. sym.IncRefCount;
  5285. end;
  5286. procedure tobjectdef.finish_objc_data;
  5287. begin
  5288. self.symtable.DefList.foreachcall(@check_and_finish_msg,nil);
  5289. if (oo_is_external in objectoptions) then
  5290. self.symtable.SymList.ForEachCall(@mark_private_fields_used,nil);
  5291. end;
  5292. procedure verify_objc_vardef(data: tobject; arg: pointer);
  5293. var
  5294. sym: tabstractvarsym absolute data;
  5295. res: pboolean absolute arg;
  5296. founderrordef: tdef;
  5297. begin
  5298. if not(tsym(data).typ in [paravarsym,fieldvarsym]) then
  5299. exit;
  5300. if (sym.typ=paravarsym) and
  5301. ((vo_is_hidden_para in tparavarsym(sym).varoptions) or
  5302. is_array_of_const(tparavarsym(sym).vardef)) then
  5303. exit;
  5304. if not objcchecktype(sym.vardef,founderrordef) then
  5305. begin
  5306. MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  5307. res^:=false;
  5308. end;
  5309. end;
  5310. procedure verify_objc_procdef_paras(data: tobject; arg: pointer);
  5311. var
  5312. def: tdef absolute data;
  5313. res: pboolean absolute arg;
  5314. founderrordef: tdef;
  5315. begin
  5316. if (def.typ<>procdef) then
  5317. exit;
  5318. { check parameter types for validity }
  5319. tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg);
  5320. { check the result type for validity }
  5321. if not objcchecktype(tprocdef(def).returndef,founderrordef) then
  5322. begin
  5323. MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  5324. res^:=false;
  5325. end;
  5326. end;
  5327. function tobjectdef.check_objc_types: boolean;
  5328. begin
  5329. { done in separate step from finish_objc_data, because when
  5330. finish_objc_data is called, not all forwarddefs have been resolved
  5331. yet and we need to know all types here }
  5332. result:=true;
  5333. self.symtable.symlist.foreachcall(@verify_objc_vardef,@result);
  5334. self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result);
  5335. end;
  5336. procedure do_cpp_import_info(data: tobject; arg: pointer);
  5337. var
  5338. def: tdef absolute data;
  5339. pd: tprocdef absolute data;
  5340. begin
  5341. if (def.typ=procdef) then
  5342. begin
  5343. pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
  5344. if (oo_is_external in pd.struct.objectoptions) then
  5345. begin
  5346. { copied from psub.read_proc }
  5347. if assigned(tobjectdef(pd.struct).import_lib) then
  5348. current_module.AddExternalImport(tobjectdef(pd.struct).import_lib^,pd.mangledname,pd.mangledname,0,false,false)
  5349. else
  5350. begin
  5351. { add import name to external list for DLL scanning }
  5352. if tf_has_dllscanner in target_info.flags then
  5353. current_module.dllscannerinputlist.Add(pd.mangledname,pd);
  5354. end;
  5355. end;
  5356. end;
  5357. end;
  5358. procedure tobjectdef.finish_cpp_data;
  5359. begin
  5360. self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
  5361. end;
  5362. {****************************************************************************
  5363. TImplementedInterface
  5364. ****************************************************************************}
  5365. constructor TImplementedInterface.create(aintf: tobjectdef);
  5366. begin
  5367. inherited create;
  5368. intfdef:=aintf;
  5369. IOffset:=-1;
  5370. IType:=etStandard;
  5371. NameMappings:=nil;
  5372. procdefs:=nil;
  5373. end;
  5374. constructor TImplementedInterface.create_deref(d:tderef);
  5375. begin
  5376. inherited create;
  5377. intfdef:=nil;
  5378. intfdefderef:=d;
  5379. IOffset:=-1;
  5380. IType:=etStandard;
  5381. NameMappings:=nil;
  5382. procdefs:=nil;
  5383. end;
  5384. destructor TImplementedInterface.destroy;
  5385. var
  5386. i : longint;
  5387. mappedname : pshortstring;
  5388. begin
  5389. if assigned(NameMappings) then
  5390. begin
  5391. for i:=0 to NameMappings.Count-1 do
  5392. begin
  5393. mappedname:=pshortstring(NameMappings[i]);
  5394. stringdispose(mappedname);
  5395. end;
  5396. NameMappings.free;
  5397. NameMappings:=nil;
  5398. end;
  5399. if assigned(procdefs) then
  5400. begin
  5401. procdefs.free;
  5402. procdefs:=nil;
  5403. end;
  5404. inherited destroy;
  5405. end;
  5406. procedure TImplementedInterface.buildderef;
  5407. begin
  5408. intfdefderef.build(intfdef);
  5409. end;
  5410. procedure TImplementedInterface.deref;
  5411. begin
  5412. intfdef:=tobjectdef(intfdefderef.resolve);
  5413. end;
  5414. procedure TImplementedInterface.AddMapping(const origname,newname: string);
  5415. begin
  5416. if not assigned(NameMappings) then
  5417. NameMappings:=TFPHashList.Create;
  5418. NameMappings.Add(origname,stringdup(newname));
  5419. end;
  5420. function TImplementedInterface.GetMapping(const origname: string):string;
  5421. var
  5422. mappedname : pshortstring;
  5423. begin
  5424. result:='';
  5425. if not assigned(NameMappings) then
  5426. exit;
  5427. mappedname:=PShortstring(NameMappings.Find(origname));
  5428. if assigned(mappedname) then
  5429. result:=mappedname^;
  5430. end;
  5431. procedure TImplementedInterface.AddImplProc(pd:tprocdef);
  5432. begin
  5433. if not assigned(procdefs) then
  5434. procdefs:=TFPObjectList.Create(false);
  5435. { duplicate entries must be stored, because multiple }
  5436. { interfaces can declare methods with the same name }
  5437. { and all of these get their own VMT entry }
  5438. procdefs.Add(pd);
  5439. end;
  5440. function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  5441. var
  5442. i : longint;
  5443. begin
  5444. result:=false;
  5445. { interfaces being implemented through delegation are not mergable (FK) }
  5446. if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) or not(assigned(MergingIntf.ProcDefs)) then
  5447. exit;
  5448. weight:=0;
  5449. { empty interface is mergeable }
  5450. if ProcDefs.Count=0 then
  5451. begin
  5452. result:=true;
  5453. exit;
  5454. end;
  5455. { The interface to merge must at least the number of
  5456. procedures of this interface }
  5457. if MergingIntf.ProcDefs.Count<ProcDefs.Count then
  5458. exit;
  5459. for i:=0 to ProcDefs.Count-1 do
  5460. begin
  5461. if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
  5462. exit;
  5463. end;
  5464. weight:=ProcDefs.Count;
  5465. result:=true;
  5466. end;
  5467. function TImplementedInterface.getcopy:TImplementedInterface;
  5468. begin
  5469. Result:=TImplementedInterface.Create(nil);
  5470. { 1) the procdefs list will be freed once for each copy
  5471. 2) since the procdefs list owns its elements, those will also be freed for each copy
  5472. 3) idem for the name mappings
  5473. }
  5474. { warning: this is completely wrong on so many levels...
  5475. Move(pointer(self)^,pointer(result)^,InstanceSize);
  5476. We need to make clean copies of the different fields
  5477. this is not implemented yet, and thus we generate an internal
  5478. error instead PM 2011-06-14 }
  5479. internalerror(2011061401);
  5480. end;
  5481. {****************************************************************************
  5482. TFORWARDDEF
  5483. ****************************************************************************}
  5484. constructor tforwarddef.create(const s:string;const pos:tfileposinfo);
  5485. begin
  5486. inherited create(forwarddef);
  5487. tosymname:=stringdup(s);
  5488. forwardpos:=pos;
  5489. end;
  5490. function tforwarddef.GetTypeName:string;
  5491. begin
  5492. GetTypeName:='unresolved forward to '+tosymname^;
  5493. end;
  5494. destructor tforwarddef.destroy;
  5495. begin
  5496. stringdispose(tosymname);
  5497. inherited destroy;
  5498. end;
  5499. function tforwarddef.getcopy:tstoreddef;
  5500. begin
  5501. result:=tforwarddef.create(tosymname^, forwardpos);
  5502. end;
  5503. {****************************************************************************
  5504. TUNDEFINEDDEF
  5505. ****************************************************************************}
  5506. constructor tundefineddef.create;
  5507. begin
  5508. inherited create(undefineddef);
  5509. end;
  5510. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  5511. begin
  5512. inherited ppuload(undefineddef,ppufile);
  5513. end;
  5514. function tundefineddef.GetTypeName:string;
  5515. begin
  5516. GetTypeName:='<undefined type>';
  5517. end;
  5518. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  5519. begin
  5520. inherited ppuwrite(ppufile);
  5521. ppufile.writeentry(ibundefineddef);
  5522. end;
  5523. {****************************************************************************
  5524. TERRORDEF
  5525. ****************************************************************************}
  5526. constructor terrordef.create;
  5527. begin
  5528. inherited create(errordef);
  5529. { prevent consecutive faults }
  5530. savesize:=1;
  5531. end;
  5532. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  5533. begin
  5534. { Can't write errordefs to ppu }
  5535. internalerror(200411063);
  5536. end;
  5537. function terrordef.GetTypeName:string;
  5538. begin
  5539. GetTypeName:='<erroneous type>';
  5540. end;
  5541. function terrordef.getmangledparaname:TSymStr;
  5542. begin
  5543. getmangledparaname:='error';
  5544. end;
  5545. {****************************************************************************
  5546. Definition Helpers
  5547. ****************************************************************************}
  5548. function is_interfacecom(def: tdef): boolean;
  5549. begin
  5550. is_interfacecom:=
  5551. assigned(def) and
  5552. (def.typ=objectdef) and
  5553. (tobjectdef(def).objecttype=odt_interfacecom);
  5554. end;
  5555. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  5556. begin
  5557. is_interfacecom_or_dispinterface:=
  5558. assigned(def) and
  5559. (def.typ=objectdef) and
  5560. (tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface]);
  5561. end;
  5562. function is_any_interface_kind(def: tdef): boolean;
  5563. begin
  5564. result:=
  5565. assigned(def) and
  5566. (def.typ=objectdef) and
  5567. ((tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface,odt_interfacecorba,odt_interfacejava,odt_objcprotocol]) or
  5568. is_objccategory(def));
  5569. end;
  5570. function is_interfacecorba(def: tdef): boolean;
  5571. begin
  5572. is_interfacecorba:=
  5573. assigned(def) and
  5574. (def.typ=objectdef) and
  5575. (tobjectdef(def).objecttype=odt_interfacecorba);
  5576. end;
  5577. function is_interface(def: tdef): boolean;
  5578. begin
  5579. is_interface:=
  5580. assigned(def) and
  5581. (def.typ=objectdef) and
  5582. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  5583. end;
  5584. function is_dispinterface(def: tdef): boolean;
  5585. begin
  5586. result:=
  5587. assigned(def) and
  5588. (def.typ=objectdef) and
  5589. (tobjectdef(def).objecttype=odt_dispinterface);
  5590. end;
  5591. function is_class(def: tdef): boolean;
  5592. begin
  5593. is_class:=
  5594. assigned(def) and
  5595. (def.typ=objectdef) and
  5596. (tobjectdef(def).objecttype=odt_class);
  5597. end;
  5598. function is_object(def: tdef): boolean;
  5599. begin
  5600. is_object:=
  5601. assigned(def) and
  5602. (def.typ=objectdef) and
  5603. (tobjectdef(def).objecttype=odt_object);
  5604. end;
  5605. function is_cppclass(def: tdef): boolean;
  5606. begin
  5607. is_cppclass:=
  5608. assigned(def) and
  5609. (def.typ=objectdef) and
  5610. (tobjectdef(def).objecttype=odt_cppclass);
  5611. end;
  5612. function is_objcclass(def: tdef): boolean;
  5613. begin
  5614. is_objcclass:=
  5615. assigned(def) and
  5616. (def.typ=objectdef) and
  5617. (tobjectdef(def).objecttype=odt_objcclass);
  5618. end;
  5619. function is_objectpascal_helper(def: tdef): boolean;
  5620. begin
  5621. result:=
  5622. assigned(def) and
  5623. (def.typ=objectdef) and
  5624. (tobjectdef(def).objecttype=odt_helper);
  5625. end;
  5626. function is_objcclassref(def: tdef): boolean;
  5627. begin
  5628. is_objcclassref:=
  5629. assigned(def) and
  5630. (def.typ=classrefdef) and
  5631. is_objcclass(tclassrefdef(def).pointeddef);
  5632. end;
  5633. function is_objcprotocol(def: tdef): boolean;
  5634. begin
  5635. result:=
  5636. assigned(def) and
  5637. (def.typ=objectdef) and
  5638. (tobjectdef(def).objecttype=odt_objcprotocol);
  5639. end;
  5640. function is_objccategory(def: tdef): boolean;
  5641. begin
  5642. result:=
  5643. assigned(def) and
  5644. (def.typ=objectdef) and
  5645. { if used as a forward type }
  5646. ((tobjectdef(def).objecttype=odt_objccategory) or
  5647. { if used as after it has been resolved }
  5648. ((tobjectdef(def).objecttype=odt_objcclass) and
  5649. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5650. end;
  5651. function is_objc_class_or_protocol(def: tdef): boolean;
  5652. begin
  5653. result:=
  5654. assigned(def) and
  5655. (def.typ=objectdef) and
  5656. (tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]);
  5657. end;
  5658. function is_objc_protocol_or_category(def: tdef): boolean;
  5659. begin
  5660. result:=
  5661. assigned(def) and
  5662. (def.typ=objectdef) and
  5663. ((tobjectdef(def).objecttype = odt_objcprotocol) or
  5664. ((tobjectdef(def).objecttype = odt_objcclass) and
  5665. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5666. end;
  5667. function is_classhelper(def: tdef): boolean;
  5668. begin
  5669. result:=
  5670. is_objectpascal_helper(def) or
  5671. is_objccategory(def);
  5672. end;
  5673. function is_class_or_interface(def: tdef): boolean;
  5674. begin
  5675. result:=
  5676. assigned(def) and
  5677. (def.typ=objectdef) and
  5678. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  5679. end;
  5680. function is_class_or_interface_or_objc(def: tdef): boolean;
  5681. begin
  5682. result:=
  5683. assigned(def) and
  5684. (def.typ=objectdef) and
  5685. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]);
  5686. end;
  5687. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  5688. begin
  5689. result:=
  5690. assigned(def) and
  5691. (def.typ=objectdef) and
  5692. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  5693. end;
  5694. function is_class_or_interface_or_object(def: tdef): boolean;
  5695. begin
  5696. result:=
  5697. assigned(def) and
  5698. (def.typ=objectdef) and
  5699. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_object]);
  5700. end;
  5701. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  5702. begin
  5703. result:=
  5704. assigned(def) and
  5705. (def.typ=objectdef) and
  5706. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  5707. end;
  5708. function is_implicit_pointer_object_type(def: tdef): boolean;
  5709. begin
  5710. result:=
  5711. assigned(def) and
  5712. (((def.typ=objectdef) and
  5713. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava])) or
  5714. ((target_info.system=system_jvm_java32) and
  5715. (def.typ=recorddef)));
  5716. end;
  5717. function is_class_or_object(def: tdef): boolean;
  5718. begin
  5719. result:=
  5720. assigned(def) and
  5721. (def.typ=objectdef) and
  5722. (tobjectdef(def).objecttype in [odt_class,odt_object]);
  5723. end;
  5724. function is_record(def: tdef): boolean;
  5725. begin
  5726. result:=
  5727. assigned(def) and
  5728. (def.typ=recorddef);
  5729. end;
  5730. function is_javaclass(def: tdef): boolean;
  5731. begin
  5732. result:=
  5733. assigned(def) and
  5734. (def.typ=objectdef) and
  5735. (tobjectdef(def).objecttype=odt_javaclass);
  5736. end;
  5737. function is_javaclassref(def: tdef): boolean;
  5738. begin
  5739. is_javaclassref:=
  5740. assigned(def) and
  5741. (def.typ=classrefdef) and
  5742. is_javaclass(tclassrefdef(def).pointeddef);
  5743. end;
  5744. function is_javainterface(def: tdef): boolean;
  5745. begin
  5746. result:=
  5747. assigned(def) and
  5748. (def.typ=objectdef) and
  5749. (tobjectdef(def).objecttype=odt_interfacejava);
  5750. end;
  5751. function is_java_class_or_interface(def: tdef): boolean;
  5752. begin
  5753. result:=
  5754. assigned(def) and
  5755. (def.typ=objectdef) and
  5756. (tobjectdef(def).objecttype in [odt_javaclass,odt_interfacejava]);
  5757. end;
  5758. procedure loadobjctypes;
  5759. begin
  5760. objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_CLASS',true).typedef);
  5761. objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER',true).typedef);
  5762. objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID',true).typedef);
  5763. objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL',true).typedef);
  5764. objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT',true).typedef);
  5765. end;
  5766. procedure maybeloadcocoatypes;
  5767. var
  5768. tsym: ttypesym;
  5769. begin
  5770. if assigned(objc_fastenumeration) then
  5771. exit;
  5772. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONPROTOCOL',false);
  5773. if assigned(tsym) then
  5774. objc_fastenumeration:=tobjectdef(tsym.typedef)
  5775. else
  5776. objc_fastenumeration:=nil;
  5777. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONSTATE',false);
  5778. if assigned(tsym) then
  5779. objc_fastenumerationstate:=trecorddef(tsym.typedef)
  5780. else
  5781. objc_fastenumerationstate:=nil;
  5782. end;
  5783. function use_vectorfpu(def : tdef) : boolean;
  5784. begin
  5785. {$ifdef x86}
  5786. {$define use_vectorfpuimplemented}
  5787. use_vectorfpu:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  5788. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  5789. {$endif x86}
  5790. {$ifdef arm}
  5791. {$define use_vectorfpuimplemented}
  5792. use_vectorfpu:=(current_settings.fputype in vfp_scalar);
  5793. {$endif arm}
  5794. {$ifndef use_vectorfpuimplemented}
  5795. use_vectorfpu:=false;
  5796. {$endif}
  5797. end;
  5798. function getpointerdef(def: tdef): tpointerdef;
  5799. var
  5800. res: PHashSetItem;
  5801. begin
  5802. if not assigned(current_module) then
  5803. internalerror(2011071101);
  5804. res:=current_module.ptrdefs.FindOrAdd(@def,sizeof(def));
  5805. if not assigned(res^.Data) then
  5806. begin
  5807. { since these pointerdefs can be reused anywhere in the current
  5808. unit, add them to the global/staticsymtable }
  5809. symtablestack.push(current_module.localsymtable);
  5810. res^.Data:=tpointerdef.create(def);
  5811. symtablestack.pop(current_module.localsymtable);
  5812. end;
  5813. result:=tpointerdef(res^.Data);
  5814. end;
  5815. end.