symdef.pas 333 KB

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