symdef.pas 272 KB

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