symdef.pas 209 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
  4. Symbol table implementation for the definitions
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit symdef;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. { common }
  23. cutils,cclasses,
  24. { global }
  25. globtype,globals,tokens,
  26. { symtable }
  27. symconst,symbase,symtype,
  28. { ppu }
  29. ppu,
  30. { node }
  31. node,
  32. { aasm }
  33. aasmbase,aasmtai,
  34. cpubase,cpuinfo,
  35. cgbase
  36. {$ifdef Delphi}
  37. ,dmisc
  38. {$endif}
  39. ;
  40. type
  41. {************************************************
  42. TDef
  43. ************************************************}
  44. tstoreddef = class(tdef)
  45. protected
  46. typesymderef : tderef;
  47. public
  48. { persistent (available across units) rtti and init tables }
  49. rttitablesym,
  50. inittablesym : tsym; {trttisym}
  51. rttitablesymderef,
  52. inittablesymderef : tderef;
  53. { local (per module) rtti and init tables }
  54. localrttilab : array[trttitype] of tasmlabel;
  55. { linked list of global definitions }
  56. {$ifdef EXTDEBUG}
  57. fileinfo : tfileposinfo;
  58. {$endif}
  59. {$ifdef GDB}
  60. globalnb : word;
  61. is_def_stab_written : tdefstabstatus;
  62. {$endif GDB}
  63. constructor create;
  64. constructor ppuloaddef(ppufile:tcompilerppufile);
  65. procedure reset;
  66. function getcopy : tstoreddef;virtual;
  67. procedure ppuwritedef(ppufile:tcompilerppufile);
  68. procedure ppuwrite(ppufile:tcompilerppufile);virtual;abstract;
  69. procedure buildderef;override;
  70. procedure buildderefimpl;override;
  71. procedure deref;override;
  72. procedure derefimpl;override;
  73. function size:longint;override;
  74. function alignment:longint;override;
  75. function is_publishable : boolean;override;
  76. function needs_inittable : boolean;override;
  77. { debug }
  78. {$ifdef GDB}
  79. function get_var_value(const s:string):string;
  80. function stabstr_evaluate(const s:string;const vars:array of string):Pchar;
  81. function stabstring : pchar;virtual;
  82. procedure concatstabto(asmlist : taasmoutput);virtual;
  83. function NumberString:string;
  84. procedure set_globalnb;virtual;
  85. function allstabstring : pchar;virtual;
  86. {$endif GDB}
  87. { rtti generation }
  88. procedure write_rtti_name;
  89. procedure write_rtti_data(rt:trttitype);virtual;
  90. procedure write_child_rtti_data(rt:trttitype);virtual;
  91. function get_rtti_label(rt:trttitype):tasmsymbol;
  92. { regvars }
  93. function is_intregable : boolean;
  94. function is_fpuregable : boolean;
  95. private
  96. savesize : longint;
  97. end;
  98. tparaitem = class(TLinkedListItem)
  99. paratype : ttype; { required for procvar }
  100. parasym : tsym;
  101. parasymderef : tderef;
  102. defaultvalue : tsym; { tconstsym }
  103. defaultvaluederef : tderef;
  104. paratyp : tvarspez; { required for procvar }
  105. paraloc : array[tcallercallee] of tparalocation;
  106. is_hidden : boolean; { is this a hidden (implicit) parameter }
  107. {$ifdef EXTDEBUG}
  108. eqval : tequaltype;
  109. {$endif EXTDEBUG}
  110. end;
  111. tfiletyp = (ft_text,ft_typed,ft_untyped);
  112. tfiledef = class(tstoreddef)
  113. filetyp : tfiletyp;
  114. typedfiletype : ttype;
  115. constructor createtext;
  116. constructor createuntyped;
  117. constructor createtyped(const tt : ttype);
  118. constructor ppuload(ppufile:tcompilerppufile);
  119. procedure ppuwrite(ppufile:tcompilerppufile);override;
  120. procedure buildderef;override;
  121. procedure deref;override;
  122. function gettypename:string;override;
  123. function getmangledparaname:string;override;
  124. procedure setsize;
  125. { debug }
  126. {$ifdef GDB}
  127. function stabstring : pchar;override;
  128. procedure concatstabto(asmlist : taasmoutput);override;
  129. {$endif GDB}
  130. end;
  131. tvariantdef = class(tstoreddef)
  132. varianttype : tvarianttype;
  133. constructor create(v : tvarianttype);
  134. constructor ppuload(ppufile:tcompilerppufile);
  135. function gettypename:string;override;
  136. procedure ppuwrite(ppufile:tcompilerppufile);override;
  137. procedure setsize;
  138. function needs_inittable : boolean;override;
  139. procedure write_rtti_data(rt:trttitype);override;
  140. {$ifdef GDB}
  141. procedure concatstabto(asmlist : taasmoutput);override;
  142. {$endif GDB}
  143. end;
  144. tformaldef = class(tstoreddef)
  145. constructor create;
  146. constructor ppuload(ppufile:tcompilerppufile);
  147. procedure ppuwrite(ppufile:tcompilerppufile);override;
  148. function gettypename:string;override;
  149. {$ifdef GDB}
  150. function stabstring : pchar;override;
  151. procedure concatstabto(asmlist : taasmoutput);override;
  152. {$endif GDB}
  153. end;
  154. tforwarddef = class(tstoreddef)
  155. tosymname : pstring;
  156. forwardpos : tfileposinfo;
  157. constructor create(const s:string;const pos : tfileposinfo);
  158. destructor destroy;override;
  159. function gettypename:string;override;
  160. end;
  161. terrordef = class(tstoreddef)
  162. constructor create;
  163. function gettypename:string;override;
  164. function getmangledparaname : string;override;
  165. { debug }
  166. {$ifdef GDB}
  167. function stabstring : pchar;override;
  168. procedure concatstabto(asmlist : taasmoutput);override;
  169. {$endif GDB}
  170. end;
  171. { tpointerdef and tclassrefdef should get a common
  172. base class, but I derived tclassrefdef from tpointerdef
  173. to avoid problems with bugs (FK)
  174. }
  175. tpointerdef = class(tstoreddef)
  176. pointertype : ttype;
  177. is_far : boolean;
  178. constructor create(const tt : ttype);
  179. constructor createfar(const tt : ttype);
  180. constructor ppuload(ppufile:tcompilerppufile);
  181. procedure ppuwrite(ppufile:tcompilerppufile);override;
  182. procedure buildderef;override;
  183. procedure deref;override;
  184. function gettypename:string;override;
  185. { debug }
  186. {$ifdef GDB}
  187. function stabstring : pchar;override;
  188. procedure concatstabto(asmlist : taasmoutput);override;
  189. {$endif GDB}
  190. end;
  191. Trecord_stabgen_state=record
  192. stabstring:Pchar;
  193. stabsize,staballoc,recoffset:integer;
  194. end;
  195. tabstractrecorddef = class(tstoreddef)
  196. private
  197. Count : integer;
  198. FRTTIType : trttitype;
  199. {$ifdef GDB}
  200. procedure addname(p:Tnamedindexitem;arg:pointer);
  201. {$endif}
  202. procedure count_field_rtti(sym : tnamedindexitem;arg:pointer);
  203. procedure write_field_rtti(sym : tnamedindexitem;arg:pointer);
  204. procedure generate_field_rtti(sym : tnamedindexitem;arg:pointer);
  205. public
  206. symtable : tsymtable;
  207. function getsymtable(t:tgetsymtable):tsymtable;override;
  208. end;
  209. trecorddef = class(tabstractrecorddef)
  210. public
  211. isunion : boolean;
  212. constructor create(p : tsymtable);
  213. constructor ppuload(ppufile:tcompilerppufile);
  214. destructor destroy;override;
  215. procedure ppuwrite(ppufile:tcompilerppufile);override;
  216. procedure buildderef;override;
  217. procedure deref;override;
  218. function size:longint;override;
  219. function alignment : longint;override;
  220. function gettypename:string;override;
  221. { debug }
  222. {$ifdef GDB}
  223. function stabstring : pchar;override;
  224. procedure concatstabto(asmlist : taasmoutput);override;
  225. {$endif GDB}
  226. function needs_inittable : boolean;override;
  227. { rtti }
  228. procedure write_child_rtti_data(rt:trttitype);override;
  229. procedure write_rtti_data(rt:trttitype);override;
  230. end;
  231. tprocdef = class;
  232. timplementedinterfaces = class;
  233. tobjectdef = class(tabstractrecorddef)
  234. private
  235. {$ifdef GDB}
  236. procedure addprocname(p :tnamedindexitem;arg:pointer);
  237. {$endif GDB}
  238. procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
  239. procedure write_property_info(sym : tnamedindexitem;arg:pointer);
  240. procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
  241. procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
  242. procedure writefields(sym:tnamedindexitem;arg:pointer);
  243. public
  244. childof : tobjectdef;
  245. childofderef : tderef;
  246. objname,
  247. objrealname : pstring;
  248. objectoptions : tobjectoptions;
  249. { to be able to have a variable vmt position }
  250. { and no vmt field for objects without virtuals }
  251. vmt_offset : longint;
  252. {$ifdef GDB}
  253. writing_class_record_stab : boolean;
  254. {$endif GDB}
  255. objecttype : tobjectdeftype;
  256. iidguid: pguid;
  257. iidstr: pstring;
  258. lastvtableindex: longint;
  259. { store implemented interfaces defs and name mappings }
  260. implementedinterfaces: timplementedinterfaces;
  261. constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
  262. constructor ppuload(ppufile:tcompilerppufile);
  263. destructor destroy;override;
  264. procedure ppuwrite(ppufile:tcompilerppufile);override;
  265. function gettypename:string;override;
  266. procedure buildderef;override;
  267. procedure deref;override;
  268. function getparentdef:tdef;override;
  269. function size : longint;override;
  270. function alignment:longint;override;
  271. function vmtmethodoffset(index:longint):longint;
  272. function members_need_inittable : boolean;
  273. { this should be called when this class implements an interface }
  274. procedure prepareguid;
  275. function is_publishable : boolean;override;
  276. function needs_inittable : boolean;override;
  277. function vmt_mangledname : string;
  278. function rtti_name : string;
  279. procedure check_forwards;
  280. function is_related(d : tobjectdef) : boolean;
  281. function next_free_name_index : longint;
  282. procedure insertvmt;
  283. procedure set_parent(c : tobjectdef);
  284. function searchdestructor : tprocdef;
  285. { debug }
  286. {$ifdef GDB}
  287. function stabstring : pchar;override;
  288. procedure set_globalnb;override;
  289. function classnumberstring : string;
  290. procedure concatstabto(asmlist : taasmoutput);override;
  291. function allstabstring : pchar;override;
  292. {$endif GDB}
  293. { rtti }
  294. procedure write_child_rtti_data(rt:trttitype);override;
  295. procedure write_rtti_data(rt:trttitype);override;
  296. function generate_field_table : tasmlabel;
  297. end;
  298. timplementedinterfaces = class
  299. constructor create;
  300. destructor destroy; override;
  301. function count: longint;
  302. function interfaces(intfindex: longint): tobjectdef;
  303. function interfacesderef(intfindex: longint): tderef;
  304. function ioffsets(intfindex: longint): plongint;
  305. function searchintf(def: tdef): longint;
  306. procedure addintf(def: tdef);
  307. procedure buildderef;
  308. procedure deref;
  309. { add interface reference loaded from ppu }
  310. procedure addintf_deref(const d:tderef);
  311. procedure clearmappings;
  312. procedure addmappings(intfindex: longint; const name, newname: string);
  313. function getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
  314. procedure clearimplprocs;
  315. procedure addimplproc(intfindex: longint; procdef: tprocdef);
  316. function implproccount(intfindex: longint): longint;
  317. function implprocs(intfindex: longint; procindex: longint): tprocdef;
  318. function isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
  319. private
  320. finterfaces: tindexarray;
  321. procedure checkindex(intfindex: longint);
  322. end;
  323. tclassrefdef = class(tpointerdef)
  324. constructor create(const t:ttype);
  325. constructor ppuload(ppufile:tcompilerppufile);
  326. procedure ppuwrite(ppufile:tcompilerppufile);override;
  327. function gettypename:string;override;
  328. { debug }
  329. {$ifdef GDB}
  330. function stabstring : pchar;override;
  331. procedure concatstabto(asmlist : taasmoutput);override;
  332. {$endif GDB}
  333. end;
  334. tarraydef = class(tstoreddef)
  335. lowrange,
  336. highrange : longint;
  337. rangetype : ttype;
  338. IsConvertedPointer,
  339. IsDynamicArray,
  340. IsVariant,
  341. IsConstructor,
  342. IsArrayOfConst : boolean;
  343. protected
  344. _elementtype : ttype;
  345. public
  346. function elesize : longint;
  347. constructor create_from_pointer(const elemt : ttype);
  348. constructor create(l,h : longint;const t : ttype);
  349. constructor ppuload(ppufile:tcompilerppufile);
  350. procedure ppuwrite(ppufile:tcompilerppufile);override;
  351. function gettypename:string;override;
  352. function getmangledparaname : string;override;
  353. procedure setelementtype(t: ttype);
  354. {$ifdef GDB}
  355. function stabstring : pchar;override;
  356. procedure concatstabto(asmlist : taasmoutput);override;
  357. {$endif GDB}
  358. procedure buildderef;override;
  359. procedure deref;override;
  360. function size : longint;override;
  361. function alignment : longint;override;
  362. { returns the label of the range check string }
  363. function needs_inittable : boolean;override;
  364. procedure write_child_rtti_data(rt:trttitype);override;
  365. procedure write_rtti_data(rt:trttitype);override;
  366. property elementtype : ttype Read _ElementType;
  367. end;
  368. torddef = class(tstoreddef)
  369. low,high : TConstExprInt;
  370. typ : tbasetype;
  371. constructor create(t : tbasetype;v,b : TConstExprInt);
  372. constructor ppuload(ppufile:tcompilerppufile);
  373. function getcopy : tstoreddef;override;
  374. procedure ppuwrite(ppufile:tcompilerppufile);override;
  375. function is_publishable : boolean;override;
  376. function gettypename:string;override;
  377. procedure setsize;
  378. { debug }
  379. {$ifdef GDB}
  380. function stabstring : pchar;override;
  381. {$endif GDB}
  382. { rtti }
  383. procedure write_rtti_data(rt:trttitype);override;
  384. end;
  385. tfloatdef = class(tstoreddef)
  386. typ : tfloattype;
  387. constructor create(t : tfloattype);
  388. constructor ppuload(ppufile:tcompilerppufile);
  389. function getcopy : tstoreddef;override;
  390. procedure ppuwrite(ppufile:tcompilerppufile);override;
  391. function gettypename:string;override;
  392. function is_publishable : boolean;override;
  393. procedure setsize;
  394. { debug }
  395. {$ifdef GDB}
  396. function stabstring : pchar;override;
  397. {$endif GDB}
  398. { rtti }
  399. procedure write_rtti_data(rt:trttitype);override;
  400. end;
  401. tabstractprocdef = class(tstoreddef)
  402. { saves a definition to the return type }
  403. rettype : ttype;
  404. parast : tsymtable;
  405. para : tlinkedlist;
  406. proctypeoption : tproctypeoption;
  407. proccalloption : tproccalloption;
  408. procoptions : tprocoptions;
  409. requiredargarea : aword;
  410. maxparacount,
  411. minparacount : byte;
  412. {$ifdef i386}
  413. fpu_used : byte; { how many stack fpu must be empty }
  414. {$endif i386}
  415. funcret_paraloc : array[tcallercallee] of tparalocation;
  416. has_paraloc_info : boolean; { paraloc info is available }
  417. constructor create(level:byte);
  418. constructor ppuload(ppufile:tcompilerppufile);
  419. destructor destroy;override;
  420. procedure ppuwrite(ppufile:tcompilerppufile);override;
  421. procedure buildderef;override;
  422. procedure deref;override;
  423. procedure releasemem;
  424. function concatpara(afterpara:tparaitem;const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
  425. function insertpara(const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
  426. procedure removepara(currpara:tparaitem);
  427. function typename_paras(showhidden:boolean): string;
  428. procedure test_if_fpu_result;
  429. function is_methodpointer:boolean;virtual;
  430. function is_addressonly:boolean;virtual;
  431. { debug }
  432. {$ifdef GDB}
  433. function stabstring : pchar;override;
  434. procedure concatstabto(asmlist : taasmoutput);override;
  435. {$endif GDB}
  436. end;
  437. tprocvardef = class(tabstractprocdef)
  438. constructor create(level:byte);
  439. constructor ppuload(ppufile:tcompilerppufile);
  440. procedure ppuwrite(ppufile:tcompilerppufile);override;
  441. procedure buildderef;override;
  442. procedure deref;override;
  443. function getsymtable(t:tgetsymtable):tsymtable;override;
  444. function size : longint;override;
  445. function gettypename:string;override;
  446. function is_publishable : boolean;override;
  447. function is_methodpointer:boolean;override;
  448. function is_addressonly:boolean;override;
  449. { debug }
  450. {$ifdef GDB}
  451. function stabstring : pchar;override;
  452. procedure concatstabto(asmlist : taasmoutput); override;
  453. {$endif GDB}
  454. { rtti }
  455. procedure write_rtti_data(rt:trttitype);override;
  456. end;
  457. tmessageinf = record
  458. case integer of
  459. 0 : (str : pchar);
  460. 1 : (i : longint);
  461. end;
  462. tinlininginfo = record
  463. { node tree }
  464. code : tnode;
  465. flags : tprocinfoflags;
  466. end;
  467. pinlininginfo = ^tinlininginfo;
  468. {$ifdef oldregvars}
  469. { register variables }
  470. pregvarinfo = ^tregvarinfo;
  471. tregvarinfo = record
  472. regvars : array[1..maxvarregs] of tsym;
  473. regvars_para : array[1..maxvarregs] of boolean;
  474. regvars_refs : array[1..maxvarregs] of longint;
  475. fpuregvars : array[1..maxfpuvarregs] of tsym;
  476. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  477. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  478. end;
  479. {$endif oldregvars}
  480. tprocdef = class(tabstractprocdef)
  481. private
  482. _mangledname : pstring;
  483. {$ifdef GDB}
  484. isstabwritten : boolean;
  485. {$endif GDB}
  486. public
  487. extnumber : word;
  488. overloadnumber : word;
  489. messageinf : tmessageinf;
  490. {$ifndef EXTDEBUG}
  491. { where is this function defined and what were the symbol
  492. flags, needed here because there
  493. is only one symbol for all overloaded functions
  494. EXTDEBUG has fileinfo in tdef (PFV) }
  495. fileinfo : tfileposinfo;
  496. {$endif}
  497. symoptions : tsymoptions;
  498. { symbol owning this definition }
  499. procsym : tsym;
  500. procsymderef : tderef;
  501. { alias names }
  502. aliasnames : tstringlist;
  503. { symtables }
  504. localst : tsymtable;
  505. funcretsym : tsym;
  506. funcretsymderef : tderef;
  507. { browser info }
  508. lastref,
  509. defref,
  510. lastwritten : tref;
  511. refcount : longint;
  512. _class : tobjectdef;
  513. _classderef : tderef;
  514. { name of the result variable to insert in the localsymtable }
  515. resultname : stringid;
  516. { true, if the procedure is only declared
  517. (forward procedure) }
  518. forwarddef,
  519. { true if the procedure is declared in the interface }
  520. interfacedef : boolean;
  521. { true if the procedure has a forward declaration }
  522. hasforward : boolean;
  523. { check the problems of manglednames }
  524. has_mangledname : boolean;
  525. { info for inlining the subroutine, if this pointer is nil,
  526. the procedure can't be inlined }
  527. inlininginfo : pinlininginfo;
  528. {$ifdef oldregvars}
  529. regvarinfo: pregvarinfo;
  530. {$endif oldregvars}
  531. constructor create(level:byte);
  532. constructor ppuload(ppufile:tcompilerppufile);
  533. destructor destroy;override;
  534. procedure ppuwrite(ppufile:tcompilerppufile);override;
  535. procedure buildderef;override;
  536. procedure buildderefimpl;override;
  537. procedure deref;override;
  538. procedure derefimpl;override;
  539. function getsymtable(t:tgetsymtable):tsymtable;override;
  540. function gettypename : string;override;
  541. function mangledname : string;
  542. procedure setmangledname(const s : string);
  543. procedure load_references(ppufile:tcompilerppufile;locals:boolean);
  544. function write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  545. { inserts the local symbol table, if this is not
  546. no local symbol table is built. Should be called only
  547. when we are sure that a local symbol table will be required.
  548. }
  549. procedure insert_localst;
  550. function fullprocname(showhidden:boolean):string;
  551. function cplusplusmangledname : string;
  552. function is_methodpointer:boolean;override;
  553. function is_addressonly:boolean;override;
  554. function is_visible_for_object(currobjdef:tobjectdef):boolean;
  555. { debug }
  556. {$ifdef GDB}
  557. function stabstring : pchar;override;
  558. procedure concatstabto(asmlist : taasmoutput);override;
  559. {$endif GDB}
  560. end;
  561. { single linked list of overloaded procs }
  562. pprocdeflist = ^tprocdeflist;
  563. tprocdeflist = record
  564. def : tprocdef;
  565. defderef : tderef;
  566. own : boolean;
  567. next : pprocdeflist;
  568. end;
  569. tstringdef = class(tstoreddef)
  570. string_typ : tstringtype;
  571. len : longint;
  572. constructor createshort(l : byte);
  573. constructor loadshort(ppufile:tcompilerppufile);
  574. constructor createlong(l : longint);
  575. constructor loadlong(ppufile:tcompilerppufile);
  576. constructor createansi(l : longint);
  577. constructor loadansi(ppufile:tcompilerppufile);
  578. constructor createwide(l : longint);
  579. constructor loadwide(ppufile:tcompilerppufile);
  580. function getcopy : tstoreddef;override;
  581. function stringtypname:string;
  582. function size : longint;override;
  583. procedure ppuwrite(ppufile:tcompilerppufile);override;
  584. function gettypename:string;override;
  585. function getmangledparaname:string;override;
  586. function is_publishable : boolean;override;
  587. { debug }
  588. {$ifdef GDB}
  589. function stabstring : pchar;override;
  590. procedure concatstabto(asmlist : taasmoutput);override;
  591. {$endif GDB}
  592. { init/final }
  593. function needs_inittable : boolean;override;
  594. { rtti }
  595. procedure write_rtti_data(rt:trttitype);override;
  596. end;
  597. tenumdef = class(tstoreddef)
  598. minval,
  599. maxval : longint;
  600. has_jumps : boolean;
  601. firstenum : tsym; {tenumsym}
  602. basedef : tenumdef;
  603. basedefderef : tderef;
  604. constructor create;
  605. constructor create_subrange(_basedef:tenumdef;_min,_max:longint);
  606. constructor ppuload(ppufile:tcompilerppufile);
  607. destructor destroy;override;
  608. procedure ppuwrite(ppufile:tcompilerppufile);override;
  609. procedure buildderef;override;
  610. procedure deref;override;
  611. function gettypename:string;override;
  612. function is_publishable : boolean;override;
  613. procedure calcsavesize;
  614. procedure setmax(_max:longint);
  615. procedure setmin(_min:longint);
  616. function min:longint;
  617. function max:longint;
  618. { debug }
  619. {$ifdef GDB}
  620. function stabstring : pchar;override;
  621. {$endif GDB}
  622. { rtti }
  623. procedure write_rtti_data(rt:trttitype);override;
  624. procedure write_child_rtti_data(rt:trttitype);override;
  625. private
  626. procedure correct_owner_symtable;
  627. end;
  628. tsetdef = class(tstoreddef)
  629. elementtype : ttype;
  630. settype : tsettype;
  631. constructor create(const t:ttype;high : longint);
  632. constructor ppuload(ppufile:tcompilerppufile);
  633. destructor destroy;override;
  634. procedure ppuwrite(ppufile:tcompilerppufile);override;
  635. procedure buildderef;override;
  636. procedure deref;override;
  637. function gettypename:string;override;
  638. function is_publishable : boolean;override;
  639. { debug }
  640. {$ifdef GDB}
  641. function stabstring : pchar;override;
  642. procedure concatstabto(asmlist : taasmoutput);override;
  643. {$endif GDB}
  644. { rtti }
  645. procedure write_rtti_data(rt:trttitype);override;
  646. procedure write_child_rtti_data(rt:trttitype);override;
  647. end;
  648. Tdefmatch=(dm_exact,dm_equal,dm_convertl1);
  649. var
  650. aktobjectdef : tobjectdef; { used for private functions check !! }
  651. {$ifdef GDB}
  652. { for STAB debugging }
  653. globaltypecount : word;
  654. pglobaltypecount : pword;
  655. {$endif GDB}
  656. { default types }
  657. generrortype, { error in definition }
  658. voidpointertype, { pointer for Void-Pointerdef }
  659. charpointertype, { pointer for Char-Pointerdef }
  660. voidfarpointertype,
  661. cformaltype, { unique formal definition }
  662. voidtype, { Pointer to Void (procedure) }
  663. cchartype, { Pointer to Char }
  664. cwidechartype, { Pointer to WideChar }
  665. booltype, { pointer to boolean type }
  666. u8inttype, { Pointer to 8-Bit unsigned }
  667. u16inttype, { Pointer to 16-Bit unsigned }
  668. u32inttype, { Pointer to 32-Bit unsigned }
  669. s32inttype, { Pointer to 32-Bit signed }
  670. u64inttype, { pointer to 64 bit unsigned def }
  671. s64inttype, { pointer to 64 bit signed def, }
  672. s32floattype, { pointer for realconstn }
  673. s64floattype, { pointer for realconstn }
  674. s80floattype, { pointer to type of temp. floats }
  675. s64currencytype, { pointer to a currency type }
  676. s32fixedtype, { pointer to type of temp. fixed }
  677. cshortstringtype, { pointer to type of short string const }
  678. clongstringtype, { pointer to type of long string const }
  679. cansistringtype, { pointer to type of ansi string const }
  680. cwidestringtype, { pointer to type of wide string const }
  681. openshortstringtype, { pointer to type of an open shortstring,
  682. needed for readln() }
  683. openchararraytype, { pointer to type of an open array of char,
  684. needed for readln() }
  685. cfiletype, { get the same definition for all file }
  686. { used for stabs }
  687. methodpointertype, { typecasting of methodpointers to extract self }
  688. { we use only one variant def for every variant class }
  689. cvarianttype,
  690. colevarianttype,
  691. ordpointertype,
  692. { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
  693. sinttype,
  694. uinttype,
  695. { unsigned ord type with the same size as a pointer }
  696. ptrinttype,
  697. pvmttype : ttype; { type of classrefs, used for stabs }
  698. { pointer to the anchestor of all classes }
  699. class_tobject : tobjectdef;
  700. { pointer to the ancestor of all COM interfaces }
  701. interface_iunknown : tobjectdef;
  702. { pointer to the TGUID type
  703. of all interfaces }
  704. rec_tguid : trecorddef;
  705. { Pointer to a procdef with no parameters and no return value.
  706. This is used for procedures which are generated automatically
  707. by the compiler.
  708. }
  709. voidprocdef : tprocdef;
  710. const
  711. {$ifdef i386}
  712. pbestrealtype : ^ttype = @s80floattype;
  713. {$endif}
  714. {$ifdef x86_64}
  715. pbestrealtype : ^ttype = @s80floattype;
  716. {$endif}
  717. {$ifdef m68k}
  718. pbestrealtype : ^ttype = @s64floattype;
  719. {$endif}
  720. {$ifdef alpha}
  721. pbestrealtype : ^ttype = @s64floattype;
  722. {$endif}
  723. {$ifdef powerpc}
  724. pbestrealtype : ^ttype = @s64floattype;
  725. {$endif}
  726. {$ifdef ia64}
  727. pbestrealtype : ^ttype = @s64floattype;
  728. {$endif}
  729. {$ifdef SPARC}
  730. pbestrealtype : ^ttype = @s64floattype;
  731. {$endif SPARC}
  732. {$ifdef vis}
  733. pbestrealtype : ^ttype = @s64floattype;
  734. {$endif vis}
  735. {$ifdef ARM}
  736. pbestrealtype : ^ttype = @s64floattype;
  737. {$endif ARM}
  738. function reverseparaitems(p: tparaitem): tparaitem;
  739. function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;
  740. {$ifdef GDB}
  741. { GDB Helpers }
  742. function typeglobalnumber(const s : string) : string;
  743. {$endif GDB}
  744. { should be in the types unit, but the types unit uses the node stuff :( }
  745. function is_interfacecom(def: tdef): boolean;
  746. function is_interfacecorba(def: tdef): boolean;
  747. function is_interface(def: tdef): boolean;
  748. function is_object(def: tdef): boolean;
  749. function is_class(def: tdef): boolean;
  750. function is_cppclass(def: tdef): boolean;
  751. function is_class_or_interface(def: tdef): boolean;
  752. implementation
  753. uses
  754. {$ifdef Delphi}
  755. sysutils,
  756. {$else Delphi}
  757. strings,
  758. {$endif Delphi}
  759. { global }
  760. verbose,
  761. { target }
  762. systems,aasmcpu,paramgr,
  763. { symtable }
  764. symsym,symtable,symutil,defutil,
  765. { module }
  766. {$ifdef GDB}
  767. gdb,
  768. {$endif GDB}
  769. fmodule,
  770. { other }
  771. gendef
  772. ;
  773. {****************************************************************************
  774. Helpers
  775. ****************************************************************************}
  776. function reverseparaitems(p: tparaitem): tparaitem;
  777. var
  778. hp1, hp2: tparaitem;
  779. begin
  780. hp1:=nil;
  781. while assigned(p) do
  782. begin
  783. { pull out }
  784. hp2:=p;
  785. p:=tparaitem(p.next);
  786. { pull in }
  787. hp2.next:=hp1;
  788. hp1:=hp2;
  789. end;
  790. reverseparaitems:=hp1;
  791. end;
  792. function make_mangledname(const typeprefix:string;st:tsymtable;const suffix:string):string;
  793. var
  794. s,
  795. prefix : string;
  796. begin
  797. prefix:='';
  798. if not assigned(st) then
  799. internalerror(200204212);
  800. { sub procedures }
  801. while (st.symtabletype=localsymtable) do
  802. begin
  803. if st.defowner.deftype<>procdef then
  804. internalerror(200204173);
  805. s:=tprocdef(st.defowner).procsym.name;
  806. if tprocdef(st.defowner).overloadnumber>0 then
  807. s:=s+'$'+tostr(tprocdef(st.defowner).overloadnumber);
  808. prefix:=s+'$'+prefix;
  809. st:=st.defowner.owner;
  810. end;
  811. { object/classes symtable }
  812. if (st.symtabletype=objectsymtable) then
  813. begin
  814. if st.defowner.deftype<>objectdef then
  815. internalerror(200204174);
  816. prefix:=tobjectdef(st.defowner).objname^+'_$_'+prefix;
  817. st:=st.defowner.owner;
  818. end;
  819. { symtable must now be static or global }
  820. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  821. internalerror(200204175);
  822. result:='';
  823. if typeprefix<>'' then
  824. result:=result+typeprefix+'_';
  825. { Add P$ for program, which can have the same name as
  826. a unit }
  827. if (tsymtable(main_module.localsymtable)=st) and
  828. (not main_module.is_unit) then
  829. result:=result+'P$'+st.name^
  830. else
  831. result:=result+st.name^;
  832. if prefix<>'' then
  833. result:=result+'_'+prefix;
  834. if suffix<>'' then
  835. result:=result+'_'+suffix;
  836. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  837. if (target_info.system = system_powerpc_darwin) and
  838. (result[1] = 'L') then
  839. result := '_' + result;
  840. end;
  841. {$ifdef GDB}
  842. procedure forcestabto(asmlist : taasmoutput; pd : tdef);
  843. begin
  844. if tstoreddef(pd).is_def_stab_written = not_written then
  845. begin
  846. if assigned(pd.typesym) then
  847. ttypesym(pd.typesym).isusedinstab := true;
  848. tstoreddef(pd).concatstabto(asmlist);
  849. end;
  850. end;
  851. {$endif GDB}
  852. {****************************************************************************
  853. TDEF (base class for definitions)
  854. ****************************************************************************}
  855. constructor tstoreddef.create;
  856. begin
  857. inherited create;
  858. savesize := 0;
  859. {$ifdef EXTDEBUG}
  860. fileinfo := aktfilepos;
  861. {$endif}
  862. if registerdef then
  863. symtablestack.registerdef(self);
  864. {$ifdef GDB}
  865. is_def_stab_written := not_written;
  866. globalnb := 0;
  867. {$endif GDB}
  868. fillchar(localrttilab,sizeof(localrttilab),0);
  869. end;
  870. constructor tstoreddef.ppuloaddef(ppufile:tcompilerppufile);
  871. begin
  872. inherited create;
  873. {$ifdef EXTDEBUG}
  874. fillchar(fileinfo,sizeof(fileinfo),0);
  875. {$endif}
  876. {$ifdef GDB}
  877. is_def_stab_written := not_written;
  878. globalnb := 0;
  879. {$endif GDB}
  880. fillchar(localrttilab,sizeof(localrttilab),0);
  881. { load }
  882. indexnr:=ppufile.getword;
  883. ppufile.getderef(typesymderef);
  884. ppufile.getsmallset(defoptions);
  885. if df_has_rttitable in defoptions then
  886. ppufile.getderef(rttitablesymderef);
  887. if df_has_inittable in defoptions then
  888. ppufile.getderef(inittablesymderef);
  889. end;
  890. procedure Tstoreddef.reset;
  891. begin
  892. {$ifdef GDB}
  893. if assigned(typesym) then
  894. ttypesym(typesym).isusedinstab:=false;
  895. is_def_stab_written:=not_written;
  896. {$endif GDB}
  897. if assigned(rttitablesym) then
  898. trttisym(rttitablesym).lab := nil;
  899. if assigned(inittablesym) then
  900. trttisym(inittablesym).lab := nil;
  901. localrttilab[initrtti]:=nil;
  902. localrttilab[fullrtti]:=nil;
  903. end;
  904. function tstoreddef.getcopy : tstoreddef;
  905. begin
  906. Message(sym_e_cant_create_unique_type);
  907. getcopy:=terrordef.create;
  908. end;
  909. procedure tstoreddef.ppuwritedef(ppufile:tcompilerppufile);
  910. begin
  911. ppufile.putword(indexnr);
  912. ppufile.putderef(typesymderef);
  913. ppufile.putsmallset(defoptions);
  914. if df_has_rttitable in defoptions then
  915. ppufile.putderef(rttitablesymderef);
  916. if df_has_inittable in defoptions then
  917. ppufile.putderef(inittablesymderef);
  918. {$ifdef GDB}
  919. if globalnb = 0 then
  920. begin
  921. if assigned(owner) then
  922. globalnb := owner.getnewtypecount
  923. else
  924. begin
  925. globalnb := PGlobalTypeCount^;
  926. Inc(PGlobalTypeCount^);
  927. end;
  928. end;
  929. {$endif GDB}
  930. end;
  931. procedure tstoreddef.buildderef;
  932. begin
  933. typesymderef.build(typesym);
  934. rttitablesymderef.build(rttitablesym);
  935. inittablesymderef.build(inittablesym);
  936. end;
  937. procedure tstoreddef.buildderefimpl;
  938. begin
  939. end;
  940. procedure tstoreddef.deref;
  941. begin
  942. typesym:=ttypesym(typesymderef.resolve);
  943. if df_has_rttitable in defoptions then
  944. rttitablesym:=trttisym(rttitablesymderef.resolve);
  945. if df_has_inittable in defoptions then
  946. inittablesym:=trttisym(inittablesymderef.resolve);
  947. end;
  948. procedure tstoreddef.derefimpl;
  949. begin
  950. end;
  951. function tstoreddef.size : longint;
  952. begin
  953. size:=savesize;
  954. end;
  955. function tstoreddef.alignment : longint;
  956. begin
  957. { natural alignment by default }
  958. alignment:=size_2_align(savesize);
  959. end;
  960. {$ifdef GDB}
  961. procedure tstoreddef.set_globalnb;
  962. begin
  963. globalnb :=PGlobalTypeCount^;
  964. inc(PglobalTypeCount^);
  965. end;
  966. function Tstoreddef.get_var_value(const s:string):string;
  967. begin
  968. if s='numberstring' then
  969. get_var_value:=numberstring
  970. else if s='sym_line' then
  971. if assigned(typesym) then
  972. get_var_value:=tostr(Ttypesym(typesym).fileinfo.line)
  973. else
  974. get_var_value:='0'
  975. else if s='sym_name' then
  976. if assigned(typesym) then
  977. get_var_value:=Ttypesym(typesym).name
  978. else
  979. get_var_value:=' '
  980. else if s='N_LSYM' then
  981. get_var_value:=tostr(N_LSYM)
  982. else if s='savesize' then
  983. get_var_value:=tostr(savesize);
  984. end;
  985. function Tstoreddef.stabstr_evaluate(const s:string;const vars:array of string):Pchar;
  986. begin
  987. stabstr_evaluate:=string_evaluate(s,@get_var_value,vars);
  988. end;
  989. function tstoreddef.stabstring : pchar;
  990. begin
  991. stabstring:=stabstr_evaluate('t${numberstring};',[]);
  992. end;
  993. function tstoreddef.numberstring : string;
  994. var table : tsymtable;
  995. begin
  996. {formal def have no type !}
  997. if deftype = formaldef then
  998. begin
  999. numberstring := tstoreddef(voidtype.def).numberstring;
  1000. exit;
  1001. end;
  1002. if (not assigned(typesym)) or (not ttypesym(typesym).isusedinstab) then
  1003. begin
  1004. {set even if debuglist is not defined}
  1005. if assigned(typesym) then
  1006. ttypesym(typesym).isusedinstab := true;
  1007. if assigned(debuglist) and (is_def_stab_written = not_written) then
  1008. concatstabto(debuglist);
  1009. end;
  1010. if not (cs_gdb_dbx in aktglobalswitches) then
  1011. begin
  1012. if globalnb = 0 then
  1013. set_globalnb;
  1014. numberstring := tostr(globalnb);
  1015. end
  1016. else
  1017. begin
  1018. if globalnb = 0 then
  1019. begin
  1020. if assigned(owner) then
  1021. globalnb := owner.getnewtypecount
  1022. else
  1023. begin
  1024. globalnb := PGlobalTypeCount^;
  1025. Inc(PGlobalTypeCount^);
  1026. end;
  1027. end;
  1028. if assigned(typesym) then
  1029. begin
  1030. table := ttypesym(typesym).owner;
  1031. if table.unitid > 0 then
  1032. numberstring := '('+tostr(table.unitid)+','+tostr(tstoreddef(ttypesym(typesym).restype.def).globalnb)+')'
  1033. else
  1034. numberstring := tostr(globalnb);
  1035. exit;
  1036. end;
  1037. numberstring := tostr(globalnb);
  1038. end;
  1039. end;
  1040. function tstoreddef.allstabstring : pchar;
  1041. var stabchar : string[2];
  1042. ss,st,su : pchar;
  1043. begin
  1044. ss := stabstring;
  1045. stabchar := 't';
  1046. if deftype in tagtypes then
  1047. stabchar := 'Tt';
  1048. st:=stabstr_evaluate('"${sym_name}:$1$2=',[stabchar,numberstring]);
  1049. reallocmem(st,strlen(ss)+512);
  1050. su:=stabstr_evaluate('",${N_LSYM},0,${sym_line},0',[]);
  1051. strcopy(strecopy(strend(st),ss),su);
  1052. reallocmem(st,strlen(st)+1);
  1053. allstabstring:=st;
  1054. strdispose(ss);
  1055. strdispose(su);
  1056. end;
  1057. procedure tstoreddef.concatstabto(asmlist : taasmoutput);
  1058. var stab_str : pchar;
  1059. begin
  1060. if ((typesym = nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  1061. and (is_def_stab_written = not_written) then
  1062. begin
  1063. If cs_gdb_dbx in aktglobalswitches then
  1064. begin
  1065. { otherwise you get two of each def }
  1066. If assigned(typesym) then
  1067. begin
  1068. if ttypesym(typesym).typ=symconst.typesym then
  1069. ttypesym(typesym).isusedinstab:=true;
  1070. if (ttypesym(typesym).owner = nil) or
  1071. ((ttypesym(typesym).owner.symtabletype = globalsymtable) and
  1072. tglobalsymtable(ttypesym(typesym).owner).dbx_count_ok) then
  1073. begin
  1074. {with DBX we get the definition from the other objects }
  1075. is_def_stab_written := written;
  1076. exit;
  1077. end;
  1078. end;
  1079. end;
  1080. { to avoid infinite loops }
  1081. is_def_stab_written := being_written;
  1082. stab_str := allstabstring;
  1083. asmList.concat(Tai_stabs.Create(stab_str));
  1084. is_def_stab_written := written;
  1085. end;
  1086. end;
  1087. {$endif GDB}
  1088. procedure tstoreddef.write_rtti_name;
  1089. var
  1090. str : string;
  1091. begin
  1092. { name }
  1093. if assigned(typesym) then
  1094. begin
  1095. str:=ttypesym(typesym).realname;
  1096. rttiList.concat(Tai_string.Create(chr(length(str))+str));
  1097. end
  1098. else
  1099. rttiList.concat(Tai_string.Create(#0))
  1100. end;
  1101. procedure tstoreddef.write_rtti_data(rt:trttitype);
  1102. begin
  1103. rttilist.concat(tai_const.create_8bit(tkUnknown));
  1104. write_rtti_name;
  1105. end;
  1106. procedure tstoreddef.write_child_rtti_data(rt:trttitype);
  1107. begin
  1108. end;
  1109. function tstoreddef.get_rtti_label(rt:trttitype) : tasmsymbol;
  1110. begin
  1111. { try to reuse persistent rtti data }
  1112. if (rt=fullrtti) and (df_has_rttitable in defoptions) then
  1113. get_rtti_label:=trttisym(rttitablesym).get_label
  1114. else
  1115. if (rt=initrtti) and (df_has_inittable in defoptions) then
  1116. get_rtti_label:=trttisym(inittablesym).get_label
  1117. else
  1118. begin
  1119. if not assigned(localrttilab[rt]) then
  1120. begin
  1121. objectlibrary.getdatalabel(localrttilab[rt]);
  1122. write_child_rtti_data(rt);
  1123. if (cs_create_smart in aktmoduleswitches) then
  1124. rttiList.concat(Tai_cut.Create);
  1125. rttiList.concat(Tai_align.create(const_align(pointer_size)));
  1126. if (cs_create_smart in aktmoduleswitches) then
  1127. rttiList.concat(Tai_symbol.Create_global(localrttilab[rt],0))
  1128. else
  1129. rttiList.concat(Tai_symbol.Create(localrttilab[rt],0));
  1130. write_rtti_data(rt);
  1131. rttiList.concat(Tai_symbol_end.Create(localrttilab[rt]));
  1132. end;
  1133. get_rtti_label:=localrttilab[rt];
  1134. end;
  1135. end;
  1136. { returns true, if the definition can be published }
  1137. function tstoreddef.is_publishable : boolean;
  1138. begin
  1139. is_publishable:=false;
  1140. end;
  1141. { needs an init table }
  1142. function tstoreddef.needs_inittable : boolean;
  1143. begin
  1144. needs_inittable:=false;
  1145. end;
  1146. function tstoreddef.is_intregable : boolean;
  1147. begin
  1148. is_intregable:=false;
  1149. case deftype of
  1150. pointerdef,
  1151. enumdef:
  1152. is_intregable:=true;
  1153. procvardef :
  1154. is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions);
  1155. orddef :
  1156. case torddef(self).typ of
  1157. bool8bit,bool16bit,bool32bit,
  1158. u8bit,u16bit,u32bit,
  1159. s8bit,s16bit,s32bit,
  1160. uchar, uwidechar:
  1161. is_intregable:=true;
  1162. end;
  1163. objectdef:
  1164. is_intregable:=is_class(self) or is_interface(self);
  1165. setdef:
  1166. is_intregable:=(tsetdef(self).settype=smallset);
  1167. end;
  1168. end;
  1169. function tstoreddef.is_fpuregable : boolean;
  1170. begin
  1171. is_fpuregable:=(deftype=floatdef);
  1172. end;
  1173. {****************************************************************************
  1174. Tstringdef
  1175. ****************************************************************************}
  1176. constructor tstringdef.createshort(l : byte);
  1177. begin
  1178. inherited create;
  1179. string_typ:=st_shortstring;
  1180. deftype:=stringdef;
  1181. len:=l;
  1182. savesize:=len+1;
  1183. end;
  1184. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  1185. begin
  1186. inherited ppuloaddef(ppufile);
  1187. string_typ:=st_shortstring;
  1188. deftype:=stringdef;
  1189. len:=ppufile.getbyte;
  1190. savesize:=len+1;
  1191. end;
  1192. constructor tstringdef.createlong(l : longint);
  1193. begin
  1194. inherited create;
  1195. string_typ:=st_longstring;
  1196. deftype:=stringdef;
  1197. len:=l;
  1198. savesize:=POINTER_SIZE;
  1199. end;
  1200. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1201. begin
  1202. inherited ppuloaddef(ppufile);
  1203. deftype:=stringdef;
  1204. string_typ:=st_longstring;
  1205. len:=ppufile.getlongint;
  1206. savesize:=POINTER_SIZE;
  1207. end;
  1208. constructor tstringdef.createansi(l : longint);
  1209. begin
  1210. inherited create;
  1211. string_typ:=st_ansistring;
  1212. deftype:=stringdef;
  1213. len:=l;
  1214. savesize:=POINTER_SIZE;
  1215. end;
  1216. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1217. begin
  1218. inherited ppuloaddef(ppufile);
  1219. deftype:=stringdef;
  1220. string_typ:=st_ansistring;
  1221. len:=ppufile.getlongint;
  1222. savesize:=POINTER_SIZE;
  1223. end;
  1224. constructor tstringdef.createwide(l : longint);
  1225. begin
  1226. inherited create;
  1227. string_typ:=st_widestring;
  1228. deftype:=stringdef;
  1229. len:=l;
  1230. savesize:=POINTER_SIZE;
  1231. end;
  1232. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1233. begin
  1234. inherited ppuloaddef(ppufile);
  1235. deftype:=stringdef;
  1236. string_typ:=st_widestring;
  1237. len:=ppufile.getlongint;
  1238. savesize:=POINTER_SIZE;
  1239. end;
  1240. function tstringdef.getcopy : tstoreddef;
  1241. begin
  1242. result:=tstringdef.create;
  1243. result.deftype:=stringdef;
  1244. tstringdef(result).string_typ:=string_typ;
  1245. tstringdef(result).len:=len;
  1246. tstringdef(result).savesize:=savesize;
  1247. end;
  1248. function tstringdef.stringtypname:string;
  1249. const
  1250. typname:array[tstringtype] of string[8]=('',
  1251. 'shortstr','longstr','ansistr','widestr'
  1252. );
  1253. begin
  1254. stringtypname:=typname[string_typ];
  1255. end;
  1256. function tstringdef.size : longint;
  1257. begin
  1258. size:=savesize;
  1259. end;
  1260. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  1261. begin
  1262. inherited ppuwritedef(ppufile);
  1263. if string_typ=st_shortstring then
  1264. begin
  1265. {$ifdef extdebug}
  1266. if len > 255 then internalerror(12122002);
  1267. {$endif}
  1268. ppufile.putbyte(byte(len))
  1269. end
  1270. else
  1271. ppufile.putlongint(len);
  1272. case string_typ of
  1273. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1274. st_longstring : ppufile.writeentry(iblongstringdef);
  1275. st_ansistring : ppufile.writeentry(ibansistringdef);
  1276. st_widestring : ppufile.writeentry(ibwidestringdef);
  1277. end;
  1278. end;
  1279. {$ifdef GDB}
  1280. function tstringdef.stabstring : pchar;
  1281. var
  1282. bytest,charst,longst : string;
  1283. begin
  1284. case string_typ of
  1285. st_shortstring:
  1286. begin
  1287. charst := typeglobalnumber('char');
  1288. { this is what I found in stabs.texinfo but
  1289. gdb 4.12 for go32 doesn't understand that !! }
  1290. {$IfDef GDBknowsstrings}
  1291. stabstring:=stabstr_evaluate('n$1;$2',[charst,tostr(len)]);
  1292. {$else}
  1293. bytest := typeglobalnumber('byte');
  1294. stabstring:=stabstr_evaluate('s$1length:$2,0,8;st:ar$2;1;$3;$4,8,$5;;',
  1295. [tostr(len+1),bytest,tostr(len),charst,tostr(len*8)]);
  1296. {$EndIf}
  1297. end;
  1298. st_longstring:
  1299. begin
  1300. charst := typeglobalnumber('char');
  1301. { this is what I found in stabs.texinfo but
  1302. gdb 4.12 for go32 doesn't understand that !! }
  1303. {$IfDef GDBknowsstrings}
  1304. stabstring:=stabstr_evaluate('n$1;$2',[charst,tostr(len)]);
  1305. {$else}
  1306. bytest := typeglobalnumber('byte');
  1307. longst := typeglobalnumber('longint');
  1308. stabstring:=stabstr_evaluate('s$1length:$2,0,32;dummy:$6,32,8;st:ar$2;1;$3;$4,40,$5;;',
  1309. [tostr(len+5),longst,tostr(len),charst,tostr(len*8),bytest]);
  1310. {$EndIf}
  1311. end;
  1312. st_ansistring:
  1313. begin
  1314. { an ansi string looks like a pchar easy !! }
  1315. stabstring:=strpnew('*'+typeglobalnumber('char'));
  1316. end;
  1317. st_widestring:
  1318. begin
  1319. { an ansi string looks like a pwidechar easy !! }
  1320. stabstring:=strpnew('*'+typeglobalnumber('widechar'));
  1321. end;
  1322. end;
  1323. end;
  1324. procedure tstringdef.concatstabto(asmlist : taasmoutput);
  1325. begin
  1326. inherited concatstabto(asmlist);
  1327. end;
  1328. {$endif GDB}
  1329. function tstringdef.needs_inittable : boolean;
  1330. begin
  1331. needs_inittable:=string_typ in [st_ansistring,st_widestring];
  1332. end;
  1333. function tstringdef.gettypename : string;
  1334. const
  1335. names : array[tstringtype] of string[20] = ('',
  1336. 'ShortString','LongString','AnsiString','WideString');
  1337. begin
  1338. gettypename:=names[string_typ];
  1339. end;
  1340. procedure tstringdef.write_rtti_data(rt:trttitype);
  1341. begin
  1342. case string_typ of
  1343. st_ansistring:
  1344. begin
  1345. rttiList.concat(Tai_const.Create_8bit(tkAString));
  1346. write_rtti_name;
  1347. end;
  1348. st_widestring:
  1349. begin
  1350. rttiList.concat(Tai_const.Create_8bit(tkWString));
  1351. write_rtti_name;
  1352. end;
  1353. st_longstring:
  1354. begin
  1355. rttiList.concat(Tai_const.Create_8bit(tkLString));
  1356. write_rtti_name;
  1357. end;
  1358. st_shortstring:
  1359. begin
  1360. rttiList.concat(Tai_const.Create_8bit(tkSString));
  1361. write_rtti_name;
  1362. rttiList.concat(Tai_const.Create_8bit(len));
  1363. end;
  1364. end;
  1365. end;
  1366. function tstringdef.getmangledparaname : string;
  1367. begin
  1368. getmangledparaname:='STRING';
  1369. end;
  1370. function tstringdef.is_publishable : boolean;
  1371. begin
  1372. is_publishable:=true;
  1373. end;
  1374. {****************************************************************************
  1375. TENUMDEF
  1376. ****************************************************************************}
  1377. constructor tenumdef.create;
  1378. begin
  1379. inherited create;
  1380. deftype:=enumdef;
  1381. minval:=0;
  1382. maxval:=0;
  1383. calcsavesize;
  1384. has_jumps:=false;
  1385. basedef:=nil;
  1386. firstenum:=nil;
  1387. correct_owner_symtable;
  1388. end;
  1389. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:longint);
  1390. begin
  1391. inherited create;
  1392. deftype:=enumdef;
  1393. minval:=_min;
  1394. maxval:=_max;
  1395. basedef:=_basedef;
  1396. calcsavesize;
  1397. has_jumps:=false;
  1398. firstenum:=basedef.firstenum;
  1399. while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
  1400. firstenum:=tenumsym(firstenum).nextenum;
  1401. correct_owner_symtable;
  1402. end;
  1403. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  1404. begin
  1405. inherited ppuloaddef(ppufile);
  1406. deftype:=enumdef;
  1407. ppufile.getderef(basedefderef);
  1408. minval:=ppufile.getlongint;
  1409. maxval:=ppufile.getlongint;
  1410. savesize:=ppufile.getlongint;
  1411. has_jumps:=false;
  1412. firstenum:=Nil;
  1413. end;
  1414. procedure tenumdef.calcsavesize;
  1415. begin
  1416. if (aktpackenum=4) or (min<0) or (max>65535) then
  1417. savesize:=4
  1418. else
  1419. if (aktpackenum=2) or (min<0) or (max>255) then
  1420. savesize:=2
  1421. else
  1422. savesize:=1;
  1423. end;
  1424. procedure tenumdef.setmax(_max:longint);
  1425. begin
  1426. maxval:=_max;
  1427. calcsavesize;
  1428. end;
  1429. procedure tenumdef.setmin(_min:longint);
  1430. begin
  1431. minval:=_min;
  1432. calcsavesize;
  1433. end;
  1434. function tenumdef.min:longint;
  1435. begin
  1436. min:=minval;
  1437. end;
  1438. function tenumdef.max:longint;
  1439. begin
  1440. max:=maxval;
  1441. end;
  1442. procedure tenumdef.buildderef;
  1443. begin
  1444. inherited buildderef;
  1445. basedefderef.build(basedef);
  1446. end;
  1447. procedure tenumdef.deref;
  1448. begin
  1449. inherited deref;
  1450. basedef:=tenumdef(basedefderef.resolve);
  1451. end;
  1452. destructor tenumdef.destroy;
  1453. begin
  1454. inherited destroy;
  1455. end;
  1456. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  1457. begin
  1458. inherited ppuwritedef(ppufile);
  1459. ppufile.putderef(basedefderef);
  1460. ppufile.putlongint(min);
  1461. ppufile.putlongint(max);
  1462. ppufile.putlongint(savesize);
  1463. ppufile.writeentry(ibenumdef);
  1464. end;
  1465. { used for enumdef because the symbols are
  1466. inserted in the owner symtable }
  1467. procedure tenumdef.correct_owner_symtable;
  1468. var
  1469. st : tsymtable;
  1470. begin
  1471. if assigned(owner) and
  1472. (owner.symtabletype in [recordsymtable,objectsymtable]) then
  1473. begin
  1474. owner.defindex.deleteindex(self);
  1475. st:=owner;
  1476. while (st.symtabletype in [recordsymtable,objectsymtable]) do
  1477. st:=st.next;
  1478. st.registerdef(self);
  1479. end;
  1480. end;
  1481. {$ifdef GDB}
  1482. function tenumdef.stabstring : pchar;
  1483. var st:Pchar;
  1484. p:Tenumsym;
  1485. s:string;
  1486. memsize,stl:cardinal;
  1487. begin
  1488. memsize:=memsizeinc;
  1489. getmem(st,memsize);
  1490. { we can specify the size with @s<size>; prefix PM }
  1491. if savesize <> std_param_align then
  1492. strpcopy(st,'@s'+tostr(savesize*8)+';e')
  1493. else
  1494. strpcopy(st,'e');
  1495. p := tenumsym(firstenum);
  1496. stl:=strlen(st);
  1497. while assigned(p) do
  1498. begin
  1499. s :=p.name+':'+tostr(p.value)+',';
  1500. { place for the ending ';' also }
  1501. if (stl+length(s)+1>=memsize) then
  1502. begin
  1503. inc(memsize,memsizeinc);
  1504. reallocmem(st,memsize);
  1505. end;
  1506. strpcopy(st+stl,s);
  1507. inc(stl,length(s));
  1508. p:=p.nextenum;
  1509. end;
  1510. st[stl]:=';';
  1511. st[stl+1]:=#0;
  1512. reallocmem(st,stl+2);
  1513. stabstring:=st;
  1514. end;
  1515. {$endif GDB}
  1516. procedure tenumdef.write_child_rtti_data(rt:trttitype);
  1517. begin
  1518. if assigned(basedef) then
  1519. basedef.get_rtti_label(rt);
  1520. end;
  1521. procedure tenumdef.write_rtti_data(rt:trttitype);
  1522. var
  1523. hp : tenumsym;
  1524. begin
  1525. rttiList.concat(Tai_const.Create_8bit(tkEnumeration));
  1526. write_rtti_name;
  1527. case savesize of
  1528. 1:
  1529. rttiList.concat(Tai_const.Create_8bit(otUByte));
  1530. 2:
  1531. rttiList.concat(Tai_const.Create_8bit(otUWord));
  1532. 4:
  1533. rttiList.concat(Tai_const.Create_8bit(otULong));
  1534. end;
  1535. rttiList.concat(Tai_const.Create_32bit(Cardinal(min)));
  1536. rttiList.concat(Tai_const.Create_32bit(Cardinal(max)));
  1537. if assigned(basedef) then
  1538. rttiList.concat(Tai_const_symbol.Create(basedef.get_rtti_label(rt)))
  1539. else
  1540. rttiList.concat(Tai_const.Create_ptr(0));
  1541. hp:=tenumsym(firstenum);
  1542. while assigned(hp) do
  1543. begin
  1544. rttiList.concat(Tai_const.Create_8bit(length(hp.realname)));
  1545. rttiList.concat(Tai_string.Create(hp.realname));
  1546. hp:=hp.nextenum;
  1547. end;
  1548. rttiList.concat(Tai_const.Create_8bit(0));
  1549. end;
  1550. function tenumdef.is_publishable : boolean;
  1551. begin
  1552. is_publishable:=true;
  1553. end;
  1554. function tenumdef.gettypename : string;
  1555. begin
  1556. gettypename:='<enumeration type>';
  1557. end;
  1558. {****************************************************************************
  1559. TORDDEF
  1560. ****************************************************************************}
  1561. constructor torddef.create(t : tbasetype;v,b : TConstExprInt);
  1562. begin
  1563. inherited create;
  1564. deftype:=orddef;
  1565. low:=v;
  1566. high:=b;
  1567. typ:=t;
  1568. setsize;
  1569. end;
  1570. constructor torddef.ppuload(ppufile:tcompilerppufile);
  1571. var
  1572. l1,l2 : longint;
  1573. begin
  1574. inherited ppuloaddef(ppufile);
  1575. deftype:=orddef;
  1576. typ:=tbasetype(ppufile.getbyte);
  1577. if sizeof(TConstExprInt)=8 then
  1578. begin
  1579. l1:=ppufile.getlongint;
  1580. l2:=ppufile.getlongint;
  1581. {$ifopt R+}
  1582. {$define Range_check_on}
  1583. {$endif opt R+}
  1584. {$R- needed here }
  1585. low:=qword(l1)+(int64(l2) shl 32);
  1586. {$ifdef Range_check_on}
  1587. {$R+}
  1588. {$undef Range_check_on}
  1589. {$endif Range_check_on}
  1590. end
  1591. else
  1592. low:=ppufile.getlongint;
  1593. if sizeof(TConstExprInt)=8 then
  1594. begin
  1595. l1:=ppufile.getlongint;
  1596. l2:=ppufile.getlongint;
  1597. {$ifopt R+}
  1598. {$define Range_check_on}
  1599. {$endif opt R+}
  1600. {$R- needed here }
  1601. high:=qword(l1)+(int64(l2) shl 32);
  1602. {$ifdef Range_check_on}
  1603. {$R+}
  1604. {$undef Range_check_on}
  1605. {$endif Range_check_on}
  1606. end
  1607. else
  1608. high:=ppufile.getlongint;
  1609. setsize;
  1610. end;
  1611. function torddef.getcopy : tstoreddef;
  1612. begin
  1613. result:=torddef.create(typ,low,high);
  1614. result.deftype:=orddef;
  1615. torddef(result).low:=low;
  1616. torddef(result).high:=high;
  1617. torddef(result).typ:=typ;
  1618. torddef(result).savesize:=savesize;
  1619. end;
  1620. procedure torddef.setsize;
  1621. const
  1622. sizetbl : array[tbasetype] of longint = (
  1623. 0,
  1624. 1,2,4,8,
  1625. 1,2,4,8,
  1626. 1,2,4,
  1627. 1,2,8
  1628. );
  1629. begin
  1630. savesize:=sizetbl[typ];
  1631. end;
  1632. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  1633. begin
  1634. inherited ppuwritedef(ppufile);
  1635. ppufile.putbyte(byte(typ));
  1636. if sizeof(TConstExprInt)=8 then
  1637. begin
  1638. ppufile.putlongint(longint(lo(low)));
  1639. ppufile.putlongint(longint(hi(low)));
  1640. end
  1641. else
  1642. ppufile.putlongint(low);
  1643. if sizeof(TConstExprInt)=8 then
  1644. begin
  1645. ppufile.putlongint(longint(lo(high)));
  1646. ppufile.putlongint(longint(hi(high)));
  1647. end
  1648. else
  1649. ppufile.putlongint(high);
  1650. ppufile.writeentry(iborddef);
  1651. end;
  1652. {$ifdef GDB}
  1653. function torddef.stabstring : pchar;
  1654. begin
  1655. case typ of
  1656. uvoid : stabstring := strpnew(numberstring+';');
  1657. {GDB 4.12 for go32 doesn't like boolean as range for 0 to 1 !!!}
  1658. {$ifdef Use_integer_types_for_boolean}
  1659. bool8bit,
  1660. bool16bit,
  1661. bool32bit : stabstring := stabstr_evaluate('r${numberstring};0;255;',[]);
  1662. {$else : not Use_integer_types_for_boolean}
  1663. uchar : stabstring := strpnew('-20;');
  1664. uwidechar : stabstring := strpnew('-30;');
  1665. bool8bit : stabstring := strpnew('-21;');
  1666. bool16bit : stabstring := strpnew('-22;');
  1667. bool32bit : stabstring := strpnew('-23;');
  1668. u64bit : stabstring := strpnew('-32;');
  1669. s64bit : stabstring := strpnew('-31;');
  1670. {$endif not Use_integer_types_for_boolean}
  1671. {u32bit : stabstring := tstoreddef(s32inttype.def).numberstring+';0;-1;'); }
  1672. else
  1673. stabstring:=stabstr_evaluate('r$1;$2;$3;',[Tstoreddef(s32inttype.def).numberstring,tostr(longint(low)),tostr(longint(high))]);
  1674. end;
  1675. end;
  1676. {$endif GDB}
  1677. procedure torddef.write_rtti_data(rt:trttitype);
  1678. procedure dointeger;
  1679. const
  1680. trans : array[tbasetype] of byte =
  1681. (otUByte{otNone},
  1682. otUByte,otUWord,otULong,otUByte{otNone},
  1683. otSByte,otSWord,otSLong,otUByte{otNone},
  1684. otUByte,otUWord,otULong,
  1685. otUByte,otUWord,otUByte);
  1686. begin
  1687. write_rtti_name;
  1688. rttiList.concat(Tai_const.Create_8bit(byte(trans[typ])));
  1689. rttiList.concat(Tai_const.Create_32bit(Cardinal(low)));
  1690. rttiList.concat(Tai_const.Create_32bit(Cardinal(high)));
  1691. end;
  1692. begin
  1693. case typ of
  1694. s64bit :
  1695. begin
  1696. rttiList.concat(Tai_const.Create_8bit(tkInt64));
  1697. write_rtti_name;
  1698. {$warning maybe change to create_64bit}
  1699. if target_info.endian=endian_little then
  1700. begin
  1701. { low }
  1702. rttiList.concat(Tai_const.Create_32bit($0));
  1703. rttiList.concat(Tai_const.Create_32bit(cardinal($80000000)));
  1704. { high }
  1705. rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
  1706. rttiList.concat(Tai_const.Create_32bit(cardinal($7fffffff)));
  1707. end
  1708. else
  1709. begin
  1710. { low }
  1711. rttiList.concat(Tai_const.Create_32bit(cardinal($80000000)));
  1712. rttiList.concat(Tai_const.Create_32bit($0));
  1713. { high }
  1714. rttiList.concat(Tai_const.Create_32bit(cardinal($7fffffff)));
  1715. rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
  1716. end;
  1717. end;
  1718. u64bit :
  1719. begin
  1720. rttiList.concat(Tai_const.Create_8bit(tkQWord));
  1721. write_rtti_name;
  1722. { low }
  1723. rttiList.concat(Tai_const.Create_32bit($0));
  1724. rttiList.concat(Tai_const.Create_32bit($0));
  1725. { high }
  1726. rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
  1727. rttiList.concat(Tai_const.Create_32bit(cardinal($ffffffff)));
  1728. end;
  1729. bool8bit:
  1730. begin
  1731. rttiList.concat(Tai_const.Create_8bit(tkBool));
  1732. dointeger;
  1733. end;
  1734. uchar:
  1735. begin
  1736. rttiList.concat(Tai_const.Create_8bit(tkChar));
  1737. dointeger;
  1738. end;
  1739. uwidechar:
  1740. begin
  1741. rttiList.concat(Tai_const.Create_8bit(tkWChar));
  1742. dointeger;
  1743. end;
  1744. else
  1745. begin
  1746. rttiList.concat(Tai_const.Create_8bit(tkInteger));
  1747. dointeger;
  1748. end;
  1749. end;
  1750. end;
  1751. function torddef.is_publishable : boolean;
  1752. begin
  1753. is_publishable:=(typ<>uvoid);
  1754. end;
  1755. function torddef.gettypename : string;
  1756. const
  1757. names : array[tbasetype] of string[20] = (
  1758. 'untyped',
  1759. 'Byte','Word','DWord','QWord',
  1760. 'ShortInt','SmallInt','LongInt','Int64',
  1761. 'Boolean','WordBool','LongBool',
  1762. 'Char','WideChar','Currency');
  1763. begin
  1764. gettypename:=names[typ];
  1765. end;
  1766. {****************************************************************************
  1767. TFLOATDEF
  1768. ****************************************************************************}
  1769. constructor tfloatdef.create(t : tfloattype);
  1770. begin
  1771. inherited create;
  1772. deftype:=floatdef;
  1773. typ:=t;
  1774. setsize;
  1775. end;
  1776. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  1777. begin
  1778. inherited ppuloaddef(ppufile);
  1779. deftype:=floatdef;
  1780. typ:=tfloattype(ppufile.getbyte);
  1781. setsize;
  1782. end;
  1783. function tfloatdef.getcopy : tstoreddef;
  1784. begin
  1785. result:=tfloatdef.create(typ);
  1786. result.deftype:=floatdef;
  1787. tfloatdef(result).savesize:=savesize;
  1788. end;
  1789. procedure tfloatdef.setsize;
  1790. begin
  1791. case typ of
  1792. s32real : savesize:=4;
  1793. s80real : savesize:=extended_size;
  1794. s64real,
  1795. s64currency,
  1796. s64comp : savesize:=8;
  1797. else
  1798. savesize:=0;
  1799. end;
  1800. end;
  1801. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  1802. begin
  1803. inherited ppuwritedef(ppufile);
  1804. ppufile.putbyte(byte(typ));
  1805. ppufile.writeentry(ibfloatdef);
  1806. end;
  1807. {$ifdef GDB}
  1808. function Tfloatdef.stabstring:Pchar;
  1809. begin
  1810. case typ of
  1811. s32real,s64real:
  1812. { found this solution in stabsread.c from GDB v4.16 }
  1813. stabstring:=stabstr_evaluate('r$1;${savesize};0;',[tstoreddef(s32inttype.def).numberstring]);
  1814. s64currency,s64comp:
  1815. stabstring:=stabstr_evaluate('r$1;-${savesize};0;',[tstoreddef(s32inttype.def).numberstring]);
  1816. s80real:
  1817. { under dos at least you must give a size of twelve instead of 10 !! }
  1818. { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
  1819. stabstring:=stabstr_evaluate('r$1;12;0;',[tstoreddef(s32inttype.def).numberstring]);
  1820. else
  1821. internalerror(10005);
  1822. end;
  1823. end;
  1824. {$endif GDB}
  1825. procedure tfloatdef.write_rtti_data(rt:trttitype);
  1826. const
  1827. {tfloattype = (s32real,s64real,s80real,s64bit,s128bit);}
  1828. translate : array[tfloattype] of byte =
  1829. (ftSingle,ftDouble,ftExtended,ftComp,ftCurr,ftFloat128);
  1830. begin
  1831. rttiList.concat(Tai_const.Create_8bit(tkFloat));
  1832. write_rtti_name;
  1833. rttiList.concat(Tai_const.Create_8bit(translate[typ]));
  1834. end;
  1835. function tfloatdef.is_publishable : boolean;
  1836. begin
  1837. is_publishable:=true;
  1838. end;
  1839. function tfloatdef.gettypename : string;
  1840. const
  1841. names : array[tfloattype] of string[20] = (
  1842. 'Single','Double','Extended','Comp','Currency','Float128');
  1843. begin
  1844. gettypename:=names[typ];
  1845. end;
  1846. {****************************************************************************
  1847. TFILEDEF
  1848. ****************************************************************************}
  1849. constructor tfiledef.createtext;
  1850. begin
  1851. inherited create;
  1852. deftype:=filedef;
  1853. filetyp:=ft_text;
  1854. typedfiletype.reset;
  1855. setsize;
  1856. end;
  1857. constructor tfiledef.createuntyped;
  1858. begin
  1859. inherited create;
  1860. deftype:=filedef;
  1861. filetyp:=ft_untyped;
  1862. typedfiletype.reset;
  1863. setsize;
  1864. end;
  1865. constructor tfiledef.createtyped(const tt : ttype);
  1866. begin
  1867. inherited create;
  1868. deftype:=filedef;
  1869. filetyp:=ft_typed;
  1870. typedfiletype:=tt;
  1871. setsize;
  1872. end;
  1873. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  1874. begin
  1875. inherited ppuloaddef(ppufile);
  1876. deftype:=filedef;
  1877. filetyp:=tfiletyp(ppufile.getbyte);
  1878. if filetyp=ft_typed then
  1879. ppufile.gettype(typedfiletype)
  1880. else
  1881. typedfiletype.reset;
  1882. setsize;
  1883. end;
  1884. procedure tfiledef.buildderef;
  1885. begin
  1886. inherited buildderef;
  1887. if filetyp=ft_typed then
  1888. typedfiletype.buildderef;
  1889. end;
  1890. procedure tfiledef.deref;
  1891. begin
  1892. inherited deref;
  1893. if filetyp=ft_typed then
  1894. typedfiletype.resolve;
  1895. end;
  1896. procedure tfiledef.setsize;
  1897. begin
  1898. {$ifdef cpu64bit}
  1899. case filetyp of
  1900. ft_text :
  1901. savesize:=616;
  1902. ft_typed,
  1903. ft_untyped :
  1904. savesize:=324;
  1905. end;
  1906. {$else cpu64bit}
  1907. case filetyp of
  1908. ft_text :
  1909. savesize:=572;
  1910. ft_typed,
  1911. ft_untyped :
  1912. savesize:=316;
  1913. end;
  1914. {$endif cpu64bit}
  1915. end;
  1916. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  1917. begin
  1918. inherited ppuwritedef(ppufile);
  1919. ppufile.putbyte(byte(filetyp));
  1920. if filetyp=ft_typed then
  1921. ppufile.puttype(typedfiletype);
  1922. ppufile.writeentry(ibfiledef);
  1923. end;
  1924. {$ifdef GDB}
  1925. function tfiledef.stabstring : pchar;
  1926. begin
  1927. {$IfDef GDBknowsfiles}
  1928. case filetyp of
  1929. ft_typed :
  1930. stabstring := strpnew('d'+typedfiletype.def.numberstring{+';'});
  1931. ft_untyped :
  1932. stabstring := strpnew('d'+voiddef.numberstring{+';'});
  1933. ft_text :
  1934. stabstring := strpnew('d'+cchartype^.numberstring{+';'});
  1935. end;
  1936. {$Else}
  1937. {based on
  1938. FileRec = Packed Record
  1939. Handle,
  1940. Mode,
  1941. RecSize : longint;
  1942. _private : array[1..32] of byte;
  1943. UserData : array[1..16] of byte;
  1944. name : array[0..255] of char;
  1945. End; }
  1946. { the buffer part is still missing !! (PM) }
  1947. { but the string could become too long !! }
  1948. stabstring:=stabstr_evaluate('s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$1,64,32;'+
  1949. '_PRIVATE:ar$2;1;32;$3,96,256;USERDATA:ar$2;1;16+$3,352,128;'+
  1950. 'NAME:ar$2;0;255;$4,480,2048',[typeglobalnumber('longint'),
  1951. typeglobalnumber('word'),typeglobalnumber('byte'),
  1952. typeglobalnumber('char')]);
  1953. {$EndIf}
  1954. end;
  1955. procedure tfiledef.concatstabto(asmlist : taasmoutput);
  1956. begin
  1957. { most file defs are unnamed !!! }
  1958. if ((typesym = nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  1959. (is_def_stab_written = not_written) then
  1960. begin
  1961. if assigned(typedfiletype.def) then
  1962. forcestabto(asmlist,typedfiletype.def);
  1963. inherited concatstabto(asmlist);
  1964. end;
  1965. end;
  1966. {$endif GDB}
  1967. function tfiledef.gettypename : string;
  1968. begin
  1969. case filetyp of
  1970. ft_untyped:
  1971. gettypename:='File';
  1972. ft_typed:
  1973. gettypename:='File Of '+typedfiletype.def.typename;
  1974. ft_text:
  1975. gettypename:='Text'
  1976. end;
  1977. end;
  1978. function tfiledef.getmangledparaname : string;
  1979. begin
  1980. case filetyp of
  1981. ft_untyped:
  1982. getmangledparaname:='FILE';
  1983. ft_typed:
  1984. getmangledparaname:='FILE$OF$'+typedfiletype.def.mangledparaname;
  1985. ft_text:
  1986. getmangledparaname:='TEXT'
  1987. end;
  1988. end;
  1989. {****************************************************************************
  1990. TVARIANTDEF
  1991. ****************************************************************************}
  1992. constructor tvariantdef.create(v : tvarianttype);
  1993. begin
  1994. inherited create;
  1995. varianttype:=v;
  1996. deftype:=variantdef;
  1997. setsize;
  1998. end;
  1999. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  2000. begin
  2001. inherited ppuloaddef(ppufile);
  2002. varianttype:=tvarianttype(ppufile.getbyte);
  2003. deftype:=variantdef;
  2004. setsize;
  2005. end;
  2006. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  2007. begin
  2008. inherited ppuwritedef(ppufile);
  2009. ppufile.putbyte(byte(varianttype));
  2010. ppufile.writeentry(ibvariantdef);
  2011. end;
  2012. procedure tvariantdef.setsize;
  2013. begin
  2014. savesize:=16;
  2015. end;
  2016. function tvariantdef.gettypename : string;
  2017. begin
  2018. case varianttype of
  2019. vt_normalvariant:
  2020. gettypename:='Variant';
  2021. vt_olevariant:
  2022. gettypename:='OleVariant';
  2023. end;
  2024. end;
  2025. procedure tvariantdef.write_rtti_data(rt:trttitype);
  2026. begin
  2027. rttiList.concat(Tai_const.Create_8bit(tkVariant));
  2028. end;
  2029. function tvariantdef.needs_inittable : boolean;
  2030. begin
  2031. needs_inittable:=true;
  2032. end;
  2033. {$ifdef GDB}
  2034. procedure tvariantdef.concatstabto(asmlist : taasmoutput);
  2035. begin
  2036. { don't know how to handle this }
  2037. end;
  2038. {$endif GDB}
  2039. {****************************************************************************
  2040. TPOINTERDEF
  2041. ****************************************************************************}
  2042. constructor tpointerdef.create(const tt : ttype);
  2043. begin
  2044. inherited create;
  2045. deftype:=pointerdef;
  2046. pointertype:=tt;
  2047. is_far:=false;
  2048. savesize:=POINTER_SIZE;
  2049. end;
  2050. constructor tpointerdef.createfar(const tt : ttype);
  2051. begin
  2052. inherited create;
  2053. deftype:=pointerdef;
  2054. pointertype:=tt;
  2055. is_far:=true;
  2056. savesize:=POINTER_SIZE;
  2057. end;
  2058. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  2059. begin
  2060. inherited ppuloaddef(ppufile);
  2061. deftype:=pointerdef;
  2062. ppufile.gettype(pointertype);
  2063. is_far:=(ppufile.getbyte<>0);
  2064. savesize:=POINTER_SIZE;
  2065. end;
  2066. procedure tpointerdef.buildderef;
  2067. begin
  2068. inherited buildderef;
  2069. pointertype.buildderef;
  2070. end;
  2071. procedure tpointerdef.deref;
  2072. begin
  2073. inherited deref;
  2074. pointertype.resolve;
  2075. end;
  2076. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2077. begin
  2078. inherited ppuwritedef(ppufile);
  2079. ppufile.puttype(pointertype);
  2080. ppufile.putbyte(byte(is_far));
  2081. ppufile.writeentry(ibpointerdef);
  2082. end;
  2083. {$ifdef GDB}
  2084. function tpointerdef.stabstring : pchar;
  2085. begin
  2086. stabstring := strpnew('*'+tstoreddef(pointertype.def).numberstring);
  2087. end;
  2088. procedure tpointerdef.concatstabto(asmlist : taasmoutput);
  2089. var st,nb : string;
  2090. begin
  2091. if assigned(pointertype.def) and
  2092. (pointertype.def.deftype=forwarddef) then
  2093. exit;
  2094. if ( (typesym=nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  2095. (is_def_stab_written = not_written) then
  2096. begin
  2097. is_def_stab_written := being_written;
  2098. if assigned(pointertype.def) and
  2099. (pointertype.def.deftype in [recorddef,objectdef]) then
  2100. begin
  2101. if pointertype.def.deftype=objectdef then
  2102. nb:=tobjectdef(pointertype.def).classnumberstring
  2103. else
  2104. nb:=tstoreddef(pointertype.def).numberstring;
  2105. {to avoid infinite recursion in record with next-like fields }
  2106. if tstoreddef(pointertype.def).is_def_stab_written = being_written then
  2107. begin
  2108. if assigned(pointertype.def.typesym) then
  2109. begin
  2110. if assigned(typesym) then
  2111. st := ttypesym(typesym).name
  2112. else
  2113. st := ' ';
  2114. asmlist.concat(Tai_stabs.create(stabstr_evaluate(
  2115. '"$1:t${numberstring}=*$2=xs$3:",${N_LSYM},0,${sym_line},0',
  2116. [st,nb,pointertype.def.typesym.name])));
  2117. end;
  2118. end
  2119. else
  2120. begin
  2121. is_def_stab_written := not_written;
  2122. inherited concatstabto(asmlist);
  2123. end;
  2124. is_def_stab_written := written;
  2125. end
  2126. else
  2127. begin
  2128. if assigned(pointertype.def) then
  2129. forcestabto(asmlist,pointertype.def);
  2130. is_def_stab_written := not_written;
  2131. inherited concatstabto(asmlist);
  2132. end;
  2133. end;
  2134. end;
  2135. {$endif GDB}
  2136. function tpointerdef.gettypename : string;
  2137. begin
  2138. if is_far then
  2139. gettypename:='^'+pointertype.def.typename+';far'
  2140. else
  2141. gettypename:='^'+pointertype.def.typename;
  2142. end;
  2143. {****************************************************************************
  2144. TCLASSREFDEF
  2145. ****************************************************************************}
  2146. constructor tclassrefdef.create(const t:ttype);
  2147. begin
  2148. inherited create(t);
  2149. deftype:=classrefdef;
  2150. end;
  2151. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  2152. begin
  2153. { be careful, tclassdefref inherits from tpointerdef }
  2154. inherited ppuloaddef(ppufile);
  2155. deftype:=classrefdef;
  2156. ppufile.gettype(pointertype);
  2157. is_far:=false;
  2158. savesize:=POINTER_SIZE;
  2159. end;
  2160. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  2161. begin
  2162. { be careful, tclassdefref inherits from tpointerdef }
  2163. inherited ppuwritedef(ppufile);
  2164. ppufile.puttype(pointertype);
  2165. ppufile.writeentry(ibclassrefdef);
  2166. end;
  2167. {$ifdef GDB}
  2168. function tclassrefdef.stabstring : pchar;
  2169. begin
  2170. stabstring:=strpnew(tstoreddef(pvmttype.def).numberstring+';');
  2171. end;
  2172. procedure tclassrefdef.concatstabto(asmlist : taasmoutput);
  2173. begin
  2174. inherited concatstabto(asmlist);
  2175. end;
  2176. {$endif GDB}
  2177. function tclassrefdef.gettypename : string;
  2178. begin
  2179. gettypename:='Class Of '+pointertype.def.typename;
  2180. end;
  2181. {***************************************************************************
  2182. TSETDEF
  2183. ***************************************************************************}
  2184. constructor tsetdef.create(const t:ttype;high : longint);
  2185. begin
  2186. inherited create;
  2187. deftype:=setdef;
  2188. elementtype:=t;
  2189. if high<32 then
  2190. begin
  2191. settype:=smallset;
  2192. {$ifdef testvarsets}
  2193. if aktsetalloc=0 THEN { $PACKSET Fixed?}
  2194. {$endif}
  2195. savesize:=Sizeof(longint)
  2196. {$ifdef testvarsets}
  2197. else {No, use $PACKSET VALUE for rounding}
  2198. savesize:=aktsetalloc*((high+aktsetalloc*8-1) DIV (aktsetalloc*8))
  2199. {$endif}
  2200. ;
  2201. end
  2202. else
  2203. if high<256 then
  2204. begin
  2205. settype:=normset;
  2206. savesize:=32;
  2207. end
  2208. else
  2209. {$ifdef testvarsets}
  2210. if high<$10000 then
  2211. begin
  2212. settype:=varset;
  2213. savesize:=4*((high+31) div 32);
  2214. end
  2215. else
  2216. {$endif testvarsets}
  2217. Message(sym_e_ill_type_decl_set);
  2218. end;
  2219. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  2220. begin
  2221. inherited ppuloaddef(ppufile);
  2222. deftype:=setdef;
  2223. ppufile.gettype(elementtype);
  2224. settype:=tsettype(ppufile.getbyte);
  2225. case settype of
  2226. normset : savesize:=32;
  2227. varset : savesize:=ppufile.getlongint;
  2228. smallset : savesize:=Sizeof(longint);
  2229. end;
  2230. end;
  2231. destructor tsetdef.destroy;
  2232. begin
  2233. inherited destroy;
  2234. end;
  2235. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  2236. begin
  2237. inherited ppuwritedef(ppufile);
  2238. ppufile.puttype(elementtype);
  2239. ppufile.putbyte(byte(settype));
  2240. if settype=varset then
  2241. ppufile.putlongint(savesize);
  2242. ppufile.writeentry(ibsetdef);
  2243. end;
  2244. {$ifdef GDB}
  2245. function tsetdef.stabstring : pchar;
  2246. begin
  2247. { For small sets write a longint, which can at least be seen
  2248. in the current GDB's (PFV)
  2249. this is obsolete with GDBPAS !!
  2250. and anyhow creates problems with version 4.18!! PM
  2251. if settype=smallset then
  2252. stabstring := strpnew('r'+s32inttype^.numberstring+';0;0xffffffff;')
  2253. else }
  2254. stabstring:=stabstr_evaluate('@s$1;S$2',[tostr(savesize*8),tstoreddef(elementtype.def).numberstring]);
  2255. end;
  2256. procedure tsetdef.concatstabto(asmlist : taasmoutput);
  2257. begin
  2258. if ( not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  2259. (is_def_stab_written = not_written) then
  2260. begin
  2261. if assigned(elementtype.def) then
  2262. forcestabto(asmlist,elementtype.def);
  2263. inherited concatstabto(asmlist);
  2264. end;
  2265. end;
  2266. {$endif GDB}
  2267. procedure tsetdef.buildderef;
  2268. begin
  2269. inherited buildderef;
  2270. elementtype.buildderef;
  2271. end;
  2272. procedure tsetdef.deref;
  2273. begin
  2274. inherited deref;
  2275. elementtype.resolve;
  2276. end;
  2277. procedure tsetdef.write_child_rtti_data(rt:trttitype);
  2278. begin
  2279. tstoreddef(elementtype.def).get_rtti_label(rt);
  2280. end;
  2281. procedure tsetdef.write_rtti_data(rt:trttitype);
  2282. begin
  2283. rttiList.concat(Tai_const.Create_8bit(tkSet));
  2284. write_rtti_name;
  2285. rttiList.concat(Tai_const.Create_8bit(otULong));
  2286. rttiList.concat(Tai_const_symbol.Create(tstoreddef(elementtype.def).get_rtti_label(rt)));
  2287. end;
  2288. function tsetdef.is_publishable : boolean;
  2289. begin
  2290. is_publishable:=(settype=smallset);
  2291. end;
  2292. function tsetdef.gettypename : string;
  2293. begin
  2294. if assigned(elementtype.def) then
  2295. gettypename:='Set Of '+elementtype.def.typename
  2296. else
  2297. gettypename:='Empty Set';
  2298. end;
  2299. {***************************************************************************
  2300. TFORMALDEF
  2301. ***************************************************************************}
  2302. constructor tformaldef.create;
  2303. var
  2304. stregdef : boolean;
  2305. begin
  2306. stregdef:=registerdef;
  2307. registerdef:=false;
  2308. inherited create;
  2309. deftype:=formaldef;
  2310. registerdef:=stregdef;
  2311. { formaldef must be registered at unit level !! }
  2312. if registerdef and assigned(current_module) then
  2313. if assigned(current_module.localsymtable) then
  2314. tsymtable(current_module.localsymtable).registerdef(self)
  2315. else if assigned(current_module.globalsymtable) then
  2316. tsymtable(current_module.globalsymtable).registerdef(self);
  2317. savesize:=0;
  2318. end;
  2319. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  2320. begin
  2321. inherited ppuloaddef(ppufile);
  2322. deftype:=formaldef;
  2323. savesize:=0;
  2324. end;
  2325. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  2326. begin
  2327. inherited ppuwritedef(ppufile);
  2328. ppufile.writeentry(ibformaldef);
  2329. end;
  2330. {$ifdef GDB}
  2331. function tformaldef.stabstring : pchar;
  2332. begin
  2333. stabstring:=stabstr_evaluate('formal${numberstring};',[]);
  2334. end;
  2335. procedure tformaldef.concatstabto(asmlist : taasmoutput);
  2336. begin
  2337. { formaldef can't be stab'ed !}
  2338. end;
  2339. {$endif GDB}
  2340. function tformaldef.gettypename : string;
  2341. begin
  2342. gettypename:='<Formal type>';
  2343. end;
  2344. {***************************************************************************
  2345. TARRAYDEF
  2346. ***************************************************************************}
  2347. constructor tarraydef.create(l,h : longint;const t : ttype);
  2348. begin
  2349. inherited create;
  2350. deftype:=arraydef;
  2351. lowrange:=l;
  2352. highrange:=h;
  2353. rangetype:=t;
  2354. elementtype.reset;
  2355. IsVariant:=false;
  2356. IsConstructor:=false;
  2357. IsArrayOfConst:=false;
  2358. IsDynamicArray:=false;
  2359. IsConvertedPointer:=false;
  2360. end;
  2361. constructor tarraydef.create_from_pointer(const elemt : ttype);
  2362. begin
  2363. self.create(0,$7fffffff,s32inttype);
  2364. IsConvertedPointer:=true;
  2365. setelementtype(elemt);
  2366. end;
  2367. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  2368. begin
  2369. inherited ppuloaddef(ppufile);
  2370. deftype:=arraydef;
  2371. { the addresses are calculated later }
  2372. ppufile.gettype(_elementtype);
  2373. ppufile.gettype(rangetype);
  2374. lowrange:=ppufile.getlongint;
  2375. highrange:=ppufile.getlongint;
  2376. IsArrayOfConst:=boolean(ppufile.getbyte);
  2377. IsDynamicArray:=boolean(ppufile.getbyte);
  2378. IsVariant:=false;
  2379. IsConstructor:=false;
  2380. end;
  2381. procedure tarraydef.buildderef;
  2382. begin
  2383. inherited buildderef;
  2384. _elementtype.buildderef;
  2385. rangetype.buildderef;
  2386. end;
  2387. procedure tarraydef.deref;
  2388. begin
  2389. inherited deref;
  2390. _elementtype.resolve;
  2391. rangetype.resolve;
  2392. end;
  2393. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  2394. begin
  2395. inherited ppuwritedef(ppufile);
  2396. ppufile.puttype(_elementtype);
  2397. ppufile.puttype(rangetype);
  2398. ppufile.putlongint(lowrange);
  2399. ppufile.putlongint(highrange);
  2400. ppufile.putbyte(byte(IsArrayOfConst));
  2401. ppufile.putbyte(byte(IsDynamicArray));
  2402. ppufile.writeentry(ibarraydef);
  2403. end;
  2404. {$ifdef GDB}
  2405. function tarraydef.stabstring : pchar;
  2406. begin
  2407. stabstring:=stabstr_evaluate('ar$1;$2;$3;$4',[Tstoreddef(rangetype.def).numberstring,
  2408. tostr(lowrange),tostr(highrange),Tstoreddef(_elementtype.def).numberstring]);
  2409. end;
  2410. procedure tarraydef.concatstabto(asmlist : taasmoutput);
  2411. begin
  2412. if (not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  2413. and (is_def_stab_written = not_written) then
  2414. begin
  2415. {when array are inserted they have no definition yet !!}
  2416. if assigned(_elementtype.def) then
  2417. inherited concatstabto(asmlist);
  2418. end;
  2419. end;
  2420. {$endif GDB}
  2421. function tarraydef.elesize : longint;
  2422. begin
  2423. elesize:=_elementtype.def.size;
  2424. end;
  2425. function tarraydef.size : longint;
  2426. var
  2427. newsize : TConstExprInt;
  2428. begin
  2429. if IsDynamicArray then
  2430. begin
  2431. size:=POINTER_SIZE;
  2432. exit;
  2433. end;
  2434. {Tarraydef.size may never be called for an open array!}
  2435. if highrange<lowrange then
  2436. internalerror(99080501);
  2437. newsize:=(int64(highrange)-int64(lowrange)+1)*elesize;
  2438. { prevent an overflow }
  2439. if newsize>high(longint) then
  2440. result:=high(longint)
  2441. else
  2442. result:=newsize;
  2443. end;
  2444. procedure tarraydef.setelementtype(t: ttype);
  2445. var
  2446. cachedsize : TConstExprInt;
  2447. begin
  2448. _elementtype:=t;
  2449. if not(IsDynamicArray or
  2450. IsConvertedPointer or
  2451. (highrange<lowrange)) then
  2452. begin
  2453. { cache element size for performance on multidimensional arrays }
  2454. cachedsize := elesize;
  2455. if (cachedsize>0) and
  2456. (
  2457. {$ifdef cpu64bit}
  2458. {$ifdef VER1_0}
  2459. { 1.0.x can't handle this and while bootstrapping with 1.0.x we can forget about it }
  2460. false
  2461. {$else}
  2462. (TConstExprInt(highrange)-TConstExprInt(lowrange) > $7fffffffffffffff) or
  2463. { () are needed around cachedsize-1 to avoid a possible
  2464. integer overflow for cachedsize=1 !! PM }
  2465. (($7fffffffffffffff div cachedsize + (cachedsize -1)) < (int64(highrange) - int64(lowrange)))
  2466. {$endif VER1_0}
  2467. {$else cpu64bit}
  2468. (TConstExprInt(highrange)-TConstExprInt(lowrange) > $7fffffff) or
  2469. { () are needed around cachedsize-1 to avoid a possible
  2470. integer overflow for cachedsize=1 !! PM }
  2471. (($7fffffff div cachedsize + (cachedsize -1)) < (int64(highrange) - int64(lowrange)))
  2472. {$endif cpu64bit}
  2473. ) Then
  2474. Message(sym_e_segment_too_large);
  2475. end;
  2476. end;
  2477. function tarraydef.alignment : longint;
  2478. begin
  2479. { alignment is the size of the elements }
  2480. if elementtype.def.deftype=recorddef then
  2481. alignment:=elementtype.def.alignment
  2482. else
  2483. alignment:=elesize;
  2484. end;
  2485. function tarraydef.needs_inittable : boolean;
  2486. begin
  2487. needs_inittable:=IsDynamicArray or elementtype.def.needs_inittable;
  2488. end;
  2489. procedure tarraydef.write_child_rtti_data(rt:trttitype);
  2490. begin
  2491. tstoreddef(elementtype.def).get_rtti_label(rt);
  2492. end;
  2493. procedure tarraydef.write_rtti_data(rt:trttitype);
  2494. begin
  2495. if IsDynamicArray then
  2496. rttiList.concat(Tai_const.Create_8bit(tkdynarray))
  2497. else
  2498. rttiList.concat(Tai_const.Create_8bit(tkarray));
  2499. write_rtti_name;
  2500. { size of elements }
  2501. rttiList.concat(Tai_const.Create_32bit(elesize));
  2502. { count of elements }
  2503. if not(IsDynamicArray) then
  2504. rttiList.concat(Tai_const.Create_32bit(highrange-lowrange+1));
  2505. { element type }
  2506. rttiList.concat(Tai_const_symbol.Create(tstoreddef(elementtype.def).get_rtti_label(rt)));
  2507. { variant type }
  2508. // !!!!!!!!!!!!!!!!
  2509. end;
  2510. function tarraydef.gettypename : string;
  2511. begin
  2512. if isarrayofconst or isConstructor then
  2513. begin
  2514. if isvariant or ((highrange=-1) and (lowrange=0)) then
  2515. gettypename:='Array Of Const'
  2516. else
  2517. gettypename:='Array Of '+elementtype.def.typename;
  2518. end
  2519. else if ((highrange=-1) and (lowrange=0)) or IsDynamicArray then
  2520. gettypename:='Array Of '+elementtype.def.typename
  2521. else
  2522. begin
  2523. if rangetype.def.deftype=enumdef then
  2524. gettypename:='Array['+rangetype.def.typename+'] Of '+elementtype.def.typename
  2525. else
  2526. gettypename:='Array['+tostr(lowrange)+'..'+
  2527. tostr(highrange)+'] Of '+elementtype.def.typename
  2528. end;
  2529. end;
  2530. function tarraydef.getmangledparaname : string;
  2531. begin
  2532. if isarrayofconst then
  2533. getmangledparaname:='array_of_const'
  2534. else
  2535. if ((highrange=-1) and (lowrange=0)) then
  2536. getmangledparaname:='array_of_'+elementtype.def.mangledparaname
  2537. else
  2538. internalerror(200204176);
  2539. end;
  2540. {***************************************************************************
  2541. tabstractrecorddef
  2542. ***************************************************************************}
  2543. function tabstractrecorddef.getsymtable(t:tgetsymtable):tsymtable;
  2544. begin
  2545. if t=gs_record then
  2546. getsymtable:=symtable
  2547. else
  2548. getsymtable:=nil;
  2549. end;
  2550. {$ifdef GDB}
  2551. procedure tabstractrecorddef.addname(p:Tnamedindexitem;arg:pointer);
  2552. var newrec:Pchar;
  2553. spec:string[3];
  2554. varsize:longint;
  2555. state:^Trecord_stabgen_state;
  2556. begin
  2557. state:=arg;
  2558. { static variables from objects are like global objects }
  2559. if (Tsym(p).typ=varsym) and not (sp_static in Tsym(p).symoptions) then
  2560. begin
  2561. if (sp_protected in tsym(p).symoptions) then
  2562. spec:='/1'
  2563. else if (sp_private in tsym(p).symoptions) then
  2564. spec:='/0'
  2565. else
  2566. spec:='';
  2567. { class fields are pointers PM, obsolete now PM }
  2568. {if (tvarsym(p).vartype.def.deftype=objectdef) and
  2569. tobjectdef(tvarsym(p).vartype.def).is_class then
  2570. spec:=spec+'*'; }
  2571. varsize:=tvarsym(p).vartype.def.size;
  2572. { open arrays made overflows !! }
  2573. if varsize>$fffffff then
  2574. varsize:=$fffffff;
  2575. newrec:=stabstr_evaluate('$1:$2,$3,$4;',[p.name,
  2576. spec+tstoreddef(tvarsym(p).vartype.def).numberstring,
  2577. tostr(tvarsym(p).fieldoffset*8),tostr(varsize*8)]);
  2578. if state^.stabsize+strlen(newrec)>=state^.staballoc-256 then
  2579. begin
  2580. inc(state^.staballoc,memsizeinc);
  2581. reallocmem(state^.stabstring,state^.staballoc);
  2582. end;
  2583. strcopy(state^.stabstring+state^.stabsize,newrec);
  2584. inc(state^.stabsize,strlen(newrec));
  2585. strdispose(newrec);
  2586. {This should be used for case !!}
  2587. inc(state^.recoffset,Tvarsym(p).vartype.def.size);
  2588. end;
  2589. end;
  2590. {$endif GDB}
  2591. procedure tabstractrecorddef.count_field_rtti(sym : tnamedindexitem;arg:pointer);
  2592. begin
  2593. if (FRTTIType=fullrtti) or
  2594. ((tsym(sym).typ=varsym) and
  2595. tvarsym(sym).vartype.def.needs_inittable) then
  2596. inc(Count);
  2597. end;
  2598. procedure tabstractrecorddef.generate_field_rtti(sym:tnamedindexitem;arg:pointer);
  2599. begin
  2600. if (FRTTIType=fullrtti) or
  2601. ((tsym(sym).typ=varsym) and
  2602. tvarsym(sym).vartype.def.needs_inittable) then
  2603. tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(FRTTIType);
  2604. end;
  2605. procedure tabstractrecorddef.write_field_rtti(sym : tnamedindexitem;arg:pointer);
  2606. begin
  2607. if (FRTTIType=fullrtti) or
  2608. ((tsym(sym).typ=varsym) and
  2609. tvarsym(sym).vartype.def.needs_inittable) then
  2610. begin
  2611. rttiList.concat(Tai_const_symbol.Create(tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(FRTTIType)));
  2612. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym).fieldoffset));
  2613. end;
  2614. end;
  2615. {***************************************************************************
  2616. trecorddef
  2617. ***************************************************************************}
  2618. constructor trecorddef.create(p : tsymtable);
  2619. begin
  2620. inherited create;
  2621. deftype:=recorddef;
  2622. symtable:=p;
  2623. symtable.defowner:=self;
  2624. isunion:=false;
  2625. end;
  2626. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  2627. begin
  2628. inherited ppuloaddef(ppufile);
  2629. deftype:=recorddef;
  2630. savesize:=ppufile.getlongint;
  2631. symtable:=trecordsymtable.create(0);
  2632. trecordsymtable(symtable).datasize:=ppufile.getlongint;
  2633. trecordsymtable(symtable).fieldalignment:=ppufile.getbyte;
  2634. trecordsymtable(symtable).recordalignment:=ppufile.getbyte;
  2635. trecordsymtable(symtable).ppuload(ppufile);
  2636. symtable.defowner:=self;
  2637. isunion:=false;
  2638. end;
  2639. destructor trecorddef.destroy;
  2640. begin
  2641. if assigned(symtable) then
  2642. symtable.free;
  2643. inherited destroy;
  2644. end;
  2645. function trecorddef.needs_inittable : boolean;
  2646. begin
  2647. needs_inittable:=trecordsymtable(symtable).needs_init_final
  2648. end;
  2649. procedure trecorddef.buildderef;
  2650. var
  2651. oldrecsyms : tsymtable;
  2652. begin
  2653. inherited buildderef;
  2654. oldrecsyms:=aktrecordsymtable;
  2655. aktrecordsymtable:=symtable;
  2656. { now build the definitions }
  2657. tstoredsymtable(symtable).buildderef;
  2658. aktrecordsymtable:=oldrecsyms;
  2659. end;
  2660. procedure trecorddef.deref;
  2661. var
  2662. oldrecsyms : tsymtable;
  2663. begin
  2664. inherited deref;
  2665. oldrecsyms:=aktrecordsymtable;
  2666. aktrecordsymtable:=symtable;
  2667. { now dereference the definitions }
  2668. tstoredsymtable(symtable).deref;
  2669. aktrecordsymtable:=oldrecsyms;
  2670. { assign TGUID? load only from system unit (unitid=1) }
  2671. if not(assigned(rec_tguid)) and
  2672. (upper(typename)='TGUID') and
  2673. assigned(owner) and
  2674. assigned(owner.name) and
  2675. (owner.name^='SYSTEM') then
  2676. rec_tguid:=self;
  2677. end;
  2678. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  2679. begin
  2680. inherited ppuwritedef(ppufile);
  2681. ppufile.putlongint(savesize);
  2682. ppufile.putlongint(trecordsymtable(symtable).datasize);
  2683. ppufile.putbyte(trecordsymtable(symtable).fieldalignment);
  2684. ppufile.putbyte(trecordsymtable(symtable).recordalignment);
  2685. ppufile.writeentry(ibrecorddef);
  2686. trecordsymtable(symtable).ppuwrite(ppufile);
  2687. end;
  2688. function trecorddef.size:longint;
  2689. begin
  2690. result:=trecordsymtable(symtable).datasize;
  2691. end;
  2692. function trecorddef.alignment:longint;
  2693. begin
  2694. alignment:=trecordsymtable(symtable).recordalignment;
  2695. end;
  2696. {$ifdef GDB}
  2697. function trecorddef.stabstring : pchar;
  2698. var state:Trecord_stabgen_state;
  2699. begin
  2700. getmem(state.stabstring,memsizeinc);
  2701. state.staballoc:=memsizeinc;
  2702. strpcopy(state.stabstring,'s'+tostr(size));
  2703. state.recoffset:=0;
  2704. state.stabsize:=strlen(state.stabstring);
  2705. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,@state);
  2706. { strpcopy(strend(state.stabstring),';');}
  2707. state.stabstring[state.stabsize]:=';';
  2708. state.stabstring[state.stabsize+1]:=#0;
  2709. reallocmem(state.stabstring,state.stabsize+2);
  2710. stabstring:=state.stabstring;
  2711. end;
  2712. procedure trecorddef.concatstabto(asmlist : taasmoutput);
  2713. begin
  2714. if (not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  2715. (is_def_stab_written = not_written) then
  2716. inherited concatstabto(asmlist);
  2717. end;
  2718. {$endif GDB}
  2719. procedure trecorddef.write_child_rtti_data(rt:trttitype);
  2720. begin
  2721. FRTTIType:=rt;
  2722. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
  2723. end;
  2724. procedure trecorddef.write_rtti_data(rt:trttitype);
  2725. begin
  2726. rttiList.concat(Tai_const.Create_8bit(tkrecord));
  2727. write_rtti_name;
  2728. rttiList.concat(Tai_const.Create_32bit(size));
  2729. Count:=0;
  2730. FRTTIType:=rt;
  2731. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
  2732. rttiList.concat(Tai_const.Create_32bit(Count));
  2733. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
  2734. end;
  2735. function trecorddef.gettypename : string;
  2736. begin
  2737. gettypename:='<record type>'
  2738. end;
  2739. {***************************************************************************
  2740. TABSTRACTPROCDEF
  2741. ***************************************************************************}
  2742. constructor tabstractprocdef.create(level:byte);
  2743. begin
  2744. inherited create;
  2745. parast:=tparasymtable.create(level);
  2746. parast.defowner:=self;
  2747. parast.next:=owner;
  2748. para:=TLinkedList.Create;
  2749. minparacount:=0;
  2750. maxparacount:=0;
  2751. proctypeoption:=potype_none;
  2752. proccalloption:=pocall_none;
  2753. procoptions:=[];
  2754. rettype:=voidtype;
  2755. {$ifdef i386}
  2756. fpu_used:=0;
  2757. {$endif i386}
  2758. savesize:=POINTER_SIZE;
  2759. has_paraloc_info:=false;
  2760. end;
  2761. destructor tabstractprocdef.destroy;
  2762. begin
  2763. if assigned(para) then
  2764. begin
  2765. {$ifdef MEMDEBUG}
  2766. memprocpara.start;
  2767. {$endif MEMDEBUG}
  2768. para.free;
  2769. {$ifdef MEMDEBUG}
  2770. memprocpara.stop;
  2771. {$endif MEMDEBUG}
  2772. end;
  2773. if assigned(parast) then
  2774. begin
  2775. {$ifdef MEMDEBUG}
  2776. memprocparast.start;
  2777. {$endif MEMDEBUG}
  2778. parast.free;
  2779. {$ifdef MEMDEBUG}
  2780. memprocparast.stop;
  2781. {$endif MEMDEBUG}
  2782. end;
  2783. inherited destroy;
  2784. end;
  2785. procedure tabstractprocdef.releasemem;
  2786. begin
  2787. para.free;
  2788. para:=nil;
  2789. parast.free;
  2790. parast:=nil;
  2791. end;
  2792. function tabstractprocdef.concatpara(afterpara:tparaitem;const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
  2793. var
  2794. hp : TParaItem;
  2795. begin
  2796. hp:=TParaItem.Create;
  2797. hp.paratyp:=tvarsym(sym).varspez;
  2798. hp.parasym:=sym;
  2799. hp.paratype:=tt;
  2800. hp.is_hidden:=vhidden;
  2801. hp.defaultvalue:=defval;
  2802. { Parameters are stored from left to right }
  2803. if assigned(afterpara) then
  2804. Para.insertafter(hp,afterpara)
  2805. else
  2806. Para.concat(hp);
  2807. { Don't count hidden parameters }
  2808. if not vhidden then
  2809. begin
  2810. if not assigned(defval) then
  2811. inc(minparacount);
  2812. inc(maxparacount);
  2813. end;
  2814. concatpara:=hp;
  2815. end;
  2816. function tabstractprocdef.insertpara(const tt:ttype;sym : tsym;defval:tsym;vhidden:boolean):tparaitem;
  2817. var
  2818. hp : TParaItem;
  2819. begin
  2820. hp:=TParaItem.Create;
  2821. hp.paratyp:=tvarsym(sym).varspez;
  2822. hp.parasym:=sym;
  2823. hp.paratype:=tt;
  2824. hp.is_hidden:=vhidden;
  2825. hp.defaultvalue:=defval;
  2826. { Parameters are stored from left to right }
  2827. Para.insert(hp);
  2828. { Don't count hidden parameters }
  2829. if (not vhidden) then
  2830. begin
  2831. if not assigned(defval) then
  2832. inc(minparacount);
  2833. inc(maxparacount);
  2834. end;
  2835. insertpara:=hp;
  2836. end;
  2837. procedure tabstractprocdef.removepara(currpara:tparaitem);
  2838. begin
  2839. { Don't count hidden parameters }
  2840. if (not currpara.is_hidden) then
  2841. begin
  2842. if not assigned(currpara.defaultvalue) then
  2843. dec(minparacount);
  2844. dec(maxparacount);
  2845. end;
  2846. Para.Remove(currpara);
  2847. currpara.free;
  2848. end;
  2849. { all functions returning in FPU are
  2850. assume to use 2 FPU registers
  2851. until the function implementation
  2852. is processed PM }
  2853. procedure tabstractprocdef.test_if_fpu_result;
  2854. begin
  2855. {$ifdef i386}
  2856. if assigned(rettype.def) and
  2857. (rettype.def.deftype=floatdef) then
  2858. fpu_used:=maxfpuregs;
  2859. {$endif i386}
  2860. end;
  2861. procedure tabstractprocdef.buildderef;
  2862. var
  2863. hp : TParaItem;
  2864. begin
  2865. { released procdef? }
  2866. if not assigned(parast) then
  2867. exit;
  2868. inherited buildderef;
  2869. rettype.buildderef;
  2870. { parast }
  2871. tparasymtable(parast).buildderef;
  2872. { paraitems }
  2873. hp:=TParaItem(Para.first);
  2874. while assigned(hp) do
  2875. begin
  2876. hp.paratype.buildderef;
  2877. hp.defaultvaluederef.build(hp.defaultvalue);
  2878. hp.parasymderef.build(hp.parasym);
  2879. hp:=TParaItem(hp.next);
  2880. end;
  2881. end;
  2882. procedure tabstractprocdef.deref;
  2883. var
  2884. hp : TParaItem;
  2885. begin
  2886. inherited deref;
  2887. rettype.resolve;
  2888. { parast }
  2889. tparasymtable(parast).deref;
  2890. { paraitems }
  2891. minparacount:=0;
  2892. maxparacount:=0;
  2893. hp:=TParaItem(Para.first);
  2894. while assigned(hp) do
  2895. begin
  2896. hp.paratype.resolve;
  2897. hp.defaultvalue:=tsym(hp.defaultvaluederef.resolve);
  2898. hp.parasym:=tvarsym(hp.parasymderef.resolve);
  2899. { connect parasym to paraitem }
  2900. tvarsym(hp.parasym).paraitem:=hp;
  2901. { Don't count hidden parameters }
  2902. if (not hp.is_hidden) then
  2903. begin
  2904. if not assigned(hp.defaultvalue) then
  2905. inc(minparacount);
  2906. inc(maxparacount);
  2907. end;
  2908. hp:=TParaItem(hp.next);
  2909. end;
  2910. end;
  2911. constructor tabstractprocdef.ppuload(ppufile:tcompilerppufile);
  2912. var
  2913. hp : TParaItem;
  2914. count,i : word;
  2915. begin
  2916. inherited ppuloaddef(ppufile);
  2917. parast:=nil;
  2918. Para:=TLinkedList.Create;
  2919. minparacount:=0;
  2920. maxparacount:=0;
  2921. ppufile.gettype(rettype);
  2922. {$ifdef i386}
  2923. fpu_used:=ppufile.getbyte;
  2924. {$else}
  2925. ppufile.getbyte;
  2926. {$endif i386}
  2927. proctypeoption:=tproctypeoption(ppufile.getbyte);
  2928. proccalloption:=tproccalloption(ppufile.getbyte);
  2929. ppufile.getsmallset(procoptions);
  2930. { get the number of parameters }
  2931. count:=ppufile.getbyte;
  2932. savesize:=POINTER_SIZE;
  2933. has_paraloc_info:=false;
  2934. for i:=1 to count do
  2935. begin
  2936. hp:=TParaItem.Create;
  2937. hp.paratyp:=tvarspez(ppufile.getbyte);
  2938. ppufile.gettype(hp.paratype);
  2939. ppufile.getderef(hp.defaultvaluederef);
  2940. hp.defaultvalue:=nil;
  2941. ppufile.getderef(hp.parasymderef);
  2942. hp.parasym:=nil;
  2943. hp.is_hidden:=boolean(ppufile.getbyte);
  2944. { Parameters are stored left to right in both ppu and memory }
  2945. Para.concat(hp);
  2946. end;
  2947. end;
  2948. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  2949. var
  2950. hp : TParaItem;
  2951. oldintfcrc : boolean;
  2952. begin
  2953. { released procdef? }
  2954. if not assigned(parast) then
  2955. exit;
  2956. inherited ppuwritedef(ppufile);
  2957. ppufile.puttype(rettype);
  2958. oldintfcrc:=ppufile.do_interface_crc;
  2959. ppufile.do_interface_crc:=false;
  2960. {$ifdef i386}
  2961. if simplify_ppu then
  2962. fpu_used:=0;
  2963. ppufile.putbyte(fpu_used);
  2964. {$else}
  2965. ppufile.putbyte(0);
  2966. {$endif}
  2967. ppufile.putbyte(ord(proctypeoption));
  2968. ppufile.putbyte(ord(proccalloption));
  2969. ppufile.putsmallset(procoptions);
  2970. ppufile.do_interface_crc:=oldintfcrc;
  2971. { we need to store the count including vs_hidden }
  2972. ppufile.putbyte(para.count);
  2973. hp:=TParaItem(Para.first);
  2974. while assigned(hp) do
  2975. begin
  2976. ppufile.putbyte(byte(hp.paratyp));
  2977. ppufile.puttype(hp.paratype);
  2978. ppufile.putderef(hp.defaultvaluederef);
  2979. ppufile.putderef(hp.parasymderef);
  2980. ppufile.putbyte(byte(hp.is_hidden));
  2981. hp:=TParaItem(hp.next);
  2982. end;
  2983. end;
  2984. function tabstractprocdef.typename_paras(showhidden:boolean) : string;
  2985. var
  2986. hs,s : string;
  2987. hp : TParaItem;
  2988. hpc : tconstsym;
  2989. first : boolean;
  2990. begin
  2991. hp:=TParaItem(Para.first);
  2992. s:='';
  2993. first:=true;
  2994. while assigned(hp) do
  2995. begin
  2996. if (not hp.is_hidden) or
  2997. (showhidden) then
  2998. begin
  2999. if first then
  3000. begin
  3001. s:=s+'(';
  3002. first:=false;
  3003. end
  3004. else
  3005. s:=s+',';
  3006. case hp.paratyp of
  3007. vs_var :
  3008. s:=s+'var';
  3009. vs_const :
  3010. s:=s+'const';
  3011. vs_out :
  3012. s:=s+'out';
  3013. end;
  3014. if assigned(hp.paratype.def.typesym) then
  3015. begin
  3016. if s<>'(' then
  3017. s:=s+' ';
  3018. hs:=hp.paratype.def.typesym.realname;
  3019. if hs[1]<>'$' then
  3020. s:=s+hp.paratype.def.typesym.realname
  3021. else
  3022. s:=s+hp.paratype.def.gettypename;
  3023. end
  3024. else
  3025. s:=s+hp.paratype.def.gettypename;
  3026. { default value }
  3027. if assigned(hp.defaultvalue) then
  3028. begin
  3029. hpc:=tconstsym(hp.defaultvalue);
  3030. hs:='';
  3031. case hpc.consttyp of
  3032. conststring,
  3033. constresourcestring :
  3034. hs:=strpas(pchar(hpc.value.valueptr));
  3035. constreal :
  3036. str(pbestreal(hpc.value.valueptr)^,hs);
  3037. constord :
  3038. hs:=tostr(hpc.value.valueord);
  3039. constpointer :
  3040. hs:=tostr(hpc.value.valueordptr);
  3041. constbool :
  3042. begin
  3043. if hpc.value.valueord<>0 then
  3044. hs:='TRUE'
  3045. else
  3046. hs:='FALSE';
  3047. end;
  3048. constnil :
  3049. hs:='nil';
  3050. constchar :
  3051. hs:=chr(hpc.value.valueord);
  3052. constset :
  3053. hs:='<set>';
  3054. end;
  3055. if hs<>'' then
  3056. s:=s+'="'+hs+'"';
  3057. end;
  3058. end;
  3059. hp:=TParaItem(hp.next);
  3060. end;
  3061. if not first then
  3062. s:=s+')';
  3063. if (po_varargs in procoptions) then
  3064. s:=s+';VarArgs';
  3065. typename_paras:=s;
  3066. end;
  3067. function tabstractprocdef.is_methodpointer:boolean;
  3068. begin
  3069. result:=false;
  3070. end;
  3071. function tabstractprocdef.is_addressonly:boolean;
  3072. begin
  3073. result:=true;
  3074. end;
  3075. {$ifdef GDB}
  3076. function tabstractprocdef.stabstring : pchar;
  3077. begin
  3078. stabstring := strpnew('abstractproc'+numberstring+';');
  3079. end;
  3080. procedure tabstractprocdef.concatstabto(asmlist : taasmoutput);
  3081. begin
  3082. { released procdef? }
  3083. if not assigned(parast) then
  3084. exit;
  3085. if (not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  3086. and (is_def_stab_written = not_written) then
  3087. begin
  3088. if assigned(rettype.def) then forcestabto(asmlist,rettype.def);
  3089. inherited concatstabto(asmlist);
  3090. end;
  3091. end;
  3092. {$endif GDB}
  3093. {***************************************************************************
  3094. TPROCDEF
  3095. ***************************************************************************}
  3096. constructor tprocdef.create(level:byte);
  3097. begin
  3098. inherited create(level);
  3099. deftype:=procdef;
  3100. has_mangledname:=false;
  3101. _mangledname:=nil;
  3102. fileinfo:=aktfilepos;
  3103. extnumber:=$ffff;
  3104. aliasnames:=tstringlist.create;
  3105. funcretsym:=nil;
  3106. localst := nil;
  3107. defref:=nil;
  3108. lastwritten:=nil;
  3109. refcount:=0;
  3110. if (cs_browser in aktmoduleswitches) and make_ref then
  3111. begin
  3112. defref:=tref.create(defref,@akttokenpos);
  3113. inc(refcount);
  3114. end;
  3115. lastref:=defref;
  3116. forwarddef:=true;
  3117. interfacedef:=false;
  3118. hasforward:=false;
  3119. _class := nil;
  3120. new(inlininginfo);
  3121. fillchar(inlininginfo^,sizeof(tinlininginfo),0);
  3122. overloadnumber:=0;
  3123. {$ifdef GDB}
  3124. isstabwritten := false;
  3125. {$endif GDB}
  3126. end;
  3127. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  3128. var
  3129. level : byte;
  3130. begin
  3131. inherited ppuload(ppufile);
  3132. deftype:=procdef;
  3133. has_mangledname:=boolean(ppufile.getbyte);
  3134. if has_mangledname then
  3135. _mangledname:=stringdup(ppufile.getstring)
  3136. else
  3137. _mangledname:=nil;
  3138. overloadnumber:=ppufile.getword;
  3139. extnumber:=ppufile.getword;
  3140. level:=ppufile.getbyte;
  3141. ppufile.getderef(_classderef);
  3142. ppufile.getderef(procsymderef);
  3143. ppufile.getposinfo(fileinfo);
  3144. ppufile.getsmallset(symoptions);
  3145. { inline stuff }
  3146. if proccalloption=pocall_inline then
  3147. begin
  3148. ppufile.getderef(funcretsymderef);
  3149. new(inlininginfo);
  3150. ppufile.getsmallset(inlininginfo^.flags);
  3151. end
  3152. else
  3153. funcretsym:=nil;
  3154. { load para symtable }
  3155. parast:=tparasymtable.create(level);
  3156. tparasymtable(parast).ppuload(ppufile);
  3157. parast.defowner:=self;
  3158. { load local symtable }
  3159. if (proccalloption=pocall_inline) or
  3160. ((current_module.flags and uf_local_browser)<>0) then
  3161. begin
  3162. localst:=tlocalsymtable.create(level);
  3163. tlocalsymtable(localst).ppuload(ppufile);
  3164. localst.defowner:=self;
  3165. end
  3166. else
  3167. localst:=nil;
  3168. { inline stuff }
  3169. if proccalloption=pocall_inline then
  3170. inlininginfo^.code:=ppuloadnodetree(ppufile)
  3171. else
  3172. inlininginfo := nil;
  3173. { default values for no persistent data }
  3174. if (cs_link_deffile in aktglobalswitches) and
  3175. (tf_need_export in target_info.flags) and
  3176. (po_exports in procoptions) then
  3177. deffile.AddExport(mangledname);
  3178. aliasnames:=tstringlist.create;
  3179. forwarddef:=false;
  3180. interfacedef:=false;
  3181. hasforward:=false;
  3182. lastref:=nil;
  3183. lastwritten:=nil;
  3184. defref:=nil;
  3185. refcount:=0;
  3186. {$ifdef GDB}
  3187. isstabwritten := false;
  3188. {$endif GDB}
  3189. end;
  3190. destructor tprocdef.destroy;
  3191. begin
  3192. if assigned(defref) then
  3193. begin
  3194. defref.freechain;
  3195. defref.free;
  3196. end;
  3197. aliasnames.free;
  3198. if assigned(localst) and (localst.symtabletype<>staticsymtable) then
  3199. begin
  3200. {$ifdef MEMDEBUG}
  3201. memproclocalst.start;
  3202. {$endif MEMDEBUG}
  3203. localst.free;
  3204. {$ifdef MEMDEBUG}
  3205. memproclocalst.start;
  3206. {$endif MEMDEBUG}
  3207. end;
  3208. if (proccalloption=pocall_inline) and assigned(inlininginfo) then
  3209. begin
  3210. {$ifdef MEMDEBUG}
  3211. memprocnodetree.start;
  3212. {$endif MEMDEBUG}
  3213. tnode(inlininginfo^.code).free;
  3214. {$ifdef MEMDEBUG}
  3215. memprocnodetree.start;
  3216. {$endif MEMDEBUG}
  3217. end;
  3218. if assigned(inlininginfo) then
  3219. dispose(inlininginfo);
  3220. if (po_msgstr in procoptions) then
  3221. strdispose(messageinf.str);
  3222. if assigned(_mangledname) then
  3223. begin
  3224. {$ifdef MEMDEBUG}
  3225. memmanglednames.start;
  3226. {$endif MEMDEBUG}
  3227. stringdispose(_mangledname);
  3228. {$ifdef MEMDEBUG}
  3229. memmanglednames.stop;
  3230. {$endif MEMDEBUG}
  3231. end;
  3232. inherited destroy;
  3233. end;
  3234. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  3235. var
  3236. oldintfcrc : boolean;
  3237. oldparasymtable,
  3238. oldlocalsymtable : tsymtable;
  3239. begin
  3240. { released procdef? }
  3241. if not assigned(parast) then
  3242. exit;
  3243. oldparasymtable:=aktparasymtable;
  3244. oldlocalsymtable:=aktlocalsymtable;
  3245. aktparasymtable:=parast;
  3246. aktlocalsymtable:=localst;
  3247. inherited ppuwrite(ppufile);
  3248. oldintfcrc:=ppufile.do_interface_crc;
  3249. ppufile.do_interface_crc:=false;
  3250. ppufile.do_interface_crc:=oldintfcrc;
  3251. ppufile.putbyte(byte(has_mangledname));
  3252. if has_mangledname then
  3253. ppufile.putstring(_mangledname^);
  3254. ppufile.putword(overloadnumber);
  3255. ppufile.putword(extnumber);
  3256. ppufile.putbyte(parast.symtablelevel);
  3257. ppufile.putderef(_classderef);
  3258. ppufile.putderef(procsymderef);
  3259. ppufile.putposinfo(fileinfo);
  3260. ppufile.putsmallset(symoptions);
  3261. { inline stuff }
  3262. oldintfcrc:=ppufile.do_crc;
  3263. ppufile.do_crc:=false;
  3264. if proccalloption=pocall_inline then
  3265. begin
  3266. ppufile.putderef(funcretsymderef);
  3267. ppufile.putsmallset(inlininginfo^.flags);
  3268. end;
  3269. ppufile.do_crc:=oldintfcrc;
  3270. { write this entry }
  3271. ppufile.writeentry(ibprocdef);
  3272. { Save the para symtable, this is taken from the interface }
  3273. tparasymtable(parast).ppuwrite(ppufile);
  3274. { save localsymtable for inline procedures or when local
  3275. browser info is requested, this has no influence on the crc }
  3276. if (proccalloption=pocall_inline) or
  3277. ((current_module.flags and uf_local_browser)<>0) then
  3278. begin
  3279. oldintfcrc:=ppufile.do_crc;
  3280. ppufile.do_crc:=false;
  3281. if not assigned(localst) then
  3282. insert_localst;
  3283. tlocalsymtable(localst).ppuwrite(ppufile);
  3284. ppufile.do_crc:=oldintfcrc;
  3285. end;
  3286. { node tree for inlining }
  3287. oldintfcrc:=ppufile.do_crc;
  3288. ppufile.do_crc:=false;
  3289. if proccalloption=pocall_inline then
  3290. ppuwritenodetree(ppufile,inlininginfo^.code);
  3291. ppufile.do_crc:=oldintfcrc;
  3292. aktparasymtable:=oldparasymtable;
  3293. aktlocalsymtable:=oldlocalsymtable;
  3294. end;
  3295. procedure tprocdef.insert_localst;
  3296. begin
  3297. localst:=tlocalsymtable.create(parast.symtablelevel);
  3298. localst.defowner:=self;
  3299. { this is used by insert
  3300. to check same names in parast and localst }
  3301. localst.next:=parast;
  3302. end;
  3303. function tprocdef.fullprocname(showhidden:boolean):string;
  3304. var
  3305. s : string;
  3306. t : ttoken;
  3307. begin
  3308. {$ifdef EXTDEBUG}
  3309. showhidden:=true;
  3310. {$endif EXTDEBUG}
  3311. s:='';
  3312. if assigned(_class) then
  3313. begin
  3314. if po_classmethod in procoptions then
  3315. s:=s+'class ';
  3316. s:=s+_class.objrealname^+'.';
  3317. end;
  3318. if proctypeoption=potype_operator then
  3319. begin
  3320. for t:=NOTOKEN to last_overloaded do
  3321. if procsym.realname='$'+overloaded_names[t] then
  3322. begin
  3323. s:='operator '+arraytokeninfo[t].str+typename_paras(showhidden);
  3324. break;
  3325. end;
  3326. end
  3327. else
  3328. s:=s+procsym.realname+typename_paras(showhidden);
  3329. case proctypeoption of
  3330. potype_constructor:
  3331. s:='constructor '+s;
  3332. potype_destructor:
  3333. s:='destructor '+s;
  3334. else
  3335. if assigned(rettype.def) and
  3336. not(is_void(rettype.def)) then
  3337. s:=s+':'+rettype.def.gettypename;
  3338. end;
  3339. { forced calling convention? }
  3340. if (po_hascallingconvention in procoptions) then
  3341. s:=s+';'+ProcCallOptionStr[proccalloption];
  3342. fullprocname:=s;
  3343. end;
  3344. function tprocdef.is_methodpointer:boolean;
  3345. begin
  3346. result:=assigned(_class);
  3347. end;
  3348. function tprocdef.is_addressonly:boolean;
  3349. begin
  3350. result:=assigned(owner) and
  3351. (owner.symtabletype<>objectsymtable);
  3352. end;
  3353. function tprocdef.is_visible_for_object(currobjdef:tobjectdef):boolean;
  3354. begin
  3355. is_visible_for_object:=false;
  3356. { private symbols are allowed when we are in the same
  3357. module as they are defined }
  3358. if (sp_private in symoptions) and
  3359. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  3360. (owner.defowner.owner.unitid<>0) then
  3361. exit;
  3362. { protected symbols are vissible in the module that defines them and
  3363. also visible to related objects. The related object must be defined
  3364. in the current module }
  3365. if (sp_protected in symoptions) and
  3366. (
  3367. (
  3368. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  3369. (owner.defowner.owner.unitid<>0)
  3370. ) and
  3371. not(
  3372. assigned(currobjdef) and
  3373. (currobjdef.owner.unitid=0) and
  3374. currobjdef.is_related(tobjectdef(owner.defowner))
  3375. )
  3376. ) then
  3377. exit;
  3378. is_visible_for_object:=true;
  3379. end;
  3380. function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
  3381. begin
  3382. case t of
  3383. gs_local :
  3384. getsymtable:=localst;
  3385. gs_para :
  3386. getsymtable:=parast;
  3387. else
  3388. getsymtable:=nil;
  3389. end;
  3390. end;
  3391. procedure tprocdef.load_references(ppufile:tcompilerppufile;locals:boolean);
  3392. var
  3393. pos : tfileposinfo;
  3394. move_last : boolean;
  3395. oldparasymtable,
  3396. oldlocalsymtable : tsymtable;
  3397. begin
  3398. oldparasymtable:=aktparasymtable;
  3399. oldlocalsymtable:=aktlocalsymtable;
  3400. aktparasymtable:=parast;
  3401. aktlocalsymtable:=localst;
  3402. move_last:=lastwritten=lastref;
  3403. while (not ppufile.endofentry) do
  3404. begin
  3405. ppufile.getposinfo(pos);
  3406. inc(refcount);
  3407. lastref:=tref.create(lastref,@pos);
  3408. lastref.is_written:=true;
  3409. if refcount=1 then
  3410. defref:=lastref;
  3411. end;
  3412. if move_last then
  3413. lastwritten:=lastref;
  3414. if ((current_module.flags and uf_local_browser)<>0) and
  3415. locals then
  3416. begin
  3417. tparasymtable(parast).load_references(ppufile,locals);
  3418. tlocalsymtable(localst).load_references(ppufile,locals);
  3419. end;
  3420. aktparasymtable:=oldparasymtable;
  3421. aktlocalsymtable:=oldlocalsymtable;
  3422. end;
  3423. Const
  3424. local_symtable_index : word = $8001;
  3425. function tprocdef.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  3426. var
  3427. ref : tref;
  3428. pdo : tobjectdef;
  3429. move_last : boolean;
  3430. d : tderef;
  3431. oldparasymtable,
  3432. oldlocalsymtable : tsymtable;
  3433. begin
  3434. d.reset;
  3435. move_last:=lastwritten=lastref;
  3436. if move_last and
  3437. (((current_module.flags and uf_local_browser)=0) or
  3438. not locals) then
  3439. exit;
  3440. oldparasymtable:=aktparasymtable;
  3441. oldlocalsymtable:=aktlocalsymtable;
  3442. aktparasymtable:=parast;
  3443. aktlocalsymtable:=localst;
  3444. { write address of this symbol }
  3445. d.build(self);
  3446. ppufile.putderef(d);
  3447. { write refs }
  3448. if assigned(lastwritten) then
  3449. ref:=lastwritten
  3450. else
  3451. ref:=defref;
  3452. while assigned(ref) do
  3453. begin
  3454. if ref.moduleindex=current_module.unit_index then
  3455. begin
  3456. ppufile.putposinfo(ref.posinfo);
  3457. ref.is_written:=true;
  3458. if move_last then
  3459. lastwritten:=ref;
  3460. end
  3461. else if not ref.is_written then
  3462. move_last:=false
  3463. else if move_last then
  3464. lastwritten:=ref;
  3465. ref:=ref.nextref;
  3466. end;
  3467. ppufile.writeentry(ibdefref);
  3468. write_references:=true;
  3469. if ((current_module.flags and uf_local_browser)<>0) and
  3470. locals then
  3471. begin
  3472. pdo:=_class;
  3473. if (owner.symtabletype<>localsymtable) then
  3474. while assigned(pdo) do
  3475. begin
  3476. if pdo.symtable<>aktrecordsymtable then
  3477. begin
  3478. pdo.symtable.unitid:=local_symtable_index;
  3479. inc(local_symtable_index);
  3480. end;
  3481. pdo:=pdo.childof;
  3482. end;
  3483. parast.unitid:=local_symtable_index;
  3484. inc(local_symtable_index);
  3485. localst.unitid:=local_symtable_index;
  3486. inc(local_symtable_index);
  3487. tstoredsymtable(parast).write_references(ppufile,locals);
  3488. tstoredsymtable(localst).write_references(ppufile,locals);
  3489. { decrement for }
  3490. local_symtable_index:=local_symtable_index-2;
  3491. pdo:=_class;
  3492. if (owner.symtabletype<>localsymtable) then
  3493. while assigned(pdo) do
  3494. begin
  3495. if pdo.symtable<>aktrecordsymtable then
  3496. dec(local_symtable_index);
  3497. pdo:=pdo.childof;
  3498. end;
  3499. end;
  3500. aktparasymtable:=oldparasymtable;
  3501. aktlocalsymtable:=oldlocalsymtable;
  3502. end;
  3503. {$ifdef GDB}
  3504. {$ifdef unused}
  3505. { procedure addparaname(p : tsym);
  3506. var vs : char;
  3507. begin
  3508. if tvarsym(p).varspez = vs_value then vs := '1'
  3509. else vs := '0';
  3510. strpcopy(strend(StabRecString),p^.name+':'+tstoreddef(tvarsym(p).vartype.def).numberstring+','+vs+';');
  3511. end; }
  3512. function tprocdef.stabstring : pchar;
  3513. var
  3514. i : longint;
  3515. stabrecstring : pchar;
  3516. begin
  3517. getmem(StabRecString,1024);
  3518. strpcopy(StabRecString,'f'+tstoreddef(rettype.def).numberstring);
  3519. i:=maxparacount;
  3520. if i>0 then
  3521. begin
  3522. strpcopy(strend(StabRecString),','+tostr(i)+';');
  3523. (* confuse gdb !! PM
  3524. if assigned(parast) then
  3525. parast.foreach({$ifdef FPCPROCVAR}@{$endif}addparaname)
  3526. else
  3527. begin
  3528. param := para1;
  3529. i := 0;
  3530. while assigned(param) do
  3531. begin
  3532. inc(i);
  3533. if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
  3534. {Here we have lost the parameter names !!}
  3535. {using lower case parameters }
  3536. strpcopy(strend(stabrecstring),'p'+tostr(i)
  3537. +':'+param^.paratype.def.numberstring+','+vartyp+';');
  3538. param := param^.next;
  3539. end;
  3540. end; *)
  3541. {strpcopy(strend(StabRecString),';');}
  3542. end;
  3543. stabstring := strnew(stabrecstring);
  3544. freemem(stabrecstring,1024);
  3545. end;
  3546. {$endif unused}
  3547. function tprocdef.stabstring: pchar;
  3548. Var RType : Char;
  3549. Obj,Info : String;
  3550. stabsstr : string;
  3551. p : pchar;
  3552. begin
  3553. obj := procsym.name;
  3554. info := '';
  3555. if tprocsym(procsym).is_global then
  3556. RType := 'F'
  3557. else
  3558. RType := 'f';
  3559. if assigned(owner) then
  3560. begin
  3561. if (owner.symtabletype = objectsymtable) then
  3562. obj := owner.name^+'__'+procsym.name;
  3563. { this code was correct only as long as the local symboltable
  3564. of the parent had the same name as the function
  3565. but this is no true anymore !! PM
  3566. if (owner.symtabletype=localsymtable) and assigned(owner.name) then
  3567. info := ','+name+','+owner.name^; }
  3568. if (owner.symtabletype=localsymtable) and
  3569. assigned(owner.defowner) and
  3570. assigned(tprocdef(owner.defowner).procsym) then
  3571. info := ','+procsym.name+','+tprocdef(owner.defowner).procsym.name;
  3572. end;
  3573. stabsstr:=mangledname;
  3574. getmem(p,length(stabsstr)+255);
  3575. strpcopy(p,'"'+obj+':'+RType
  3576. +tstoreddef(rettype.def).numberstring+info+'",'+tostr(n_function)
  3577. +',0,'+
  3578. tostr(fileinfo.line)
  3579. +',');
  3580. strpcopy(strend(p),stabsstr);
  3581. stabstring:=strnew(p);
  3582. freemem(p,length(stabsstr)+255);
  3583. end;
  3584. procedure tprocdef.concatstabto(asmlist : taasmoutput);
  3585. begin
  3586. { released procdef? }
  3587. if not assigned(parast) then
  3588. exit;
  3589. if (proccalloption=pocall_internproc) then
  3590. exit;
  3591. if not isstabwritten then
  3592. asmList.concat(Tai_stabs.Create(stabstring));
  3593. isstabwritten := true;
  3594. if not(po_external in procoptions) then
  3595. begin
  3596. tstoredsymtable(parast).concatstabto(asmlist);
  3597. { local type defs and vars should not be written
  3598. inside the main proc stab }
  3599. if assigned(localst) and
  3600. (localst.symtablelevel>main_program_level) then
  3601. tstoredsymtable(localst).concatstabto(asmlist);
  3602. end;
  3603. is_def_stab_written := written;
  3604. end;
  3605. {$endif GDB}
  3606. procedure tprocdef.buildderef;
  3607. var
  3608. oldparasymtable,
  3609. oldlocalsymtable : tsymtable;
  3610. begin
  3611. oldparasymtable:=aktparasymtable;
  3612. oldlocalsymtable:=aktlocalsymtable;
  3613. aktparasymtable:=parast;
  3614. aktlocalsymtable:=localst;
  3615. inherited buildderef;
  3616. _classderef.build(_class);
  3617. { procsym that originaly defined this definition, should be in the
  3618. same symtable }
  3619. procsymderef.build(procsym);
  3620. aktparasymtable:=oldparasymtable;
  3621. aktlocalsymtable:=oldlocalsymtable;
  3622. end;
  3623. procedure tprocdef.buildderefimpl;
  3624. var
  3625. oldparasymtable,
  3626. oldlocalsymtable : tsymtable;
  3627. begin
  3628. { released procdef? }
  3629. if not assigned(parast) then
  3630. exit;
  3631. oldparasymtable:=aktparasymtable;
  3632. oldlocalsymtable:=aktlocalsymtable;
  3633. aktparasymtable:=parast;
  3634. aktlocalsymtable:=localst;
  3635. inherited buildderefimpl;
  3636. { locals }
  3637. if assigned(localst) then
  3638. begin
  3639. tlocalsymtable(localst).buildderef;
  3640. tlocalsymtable(localst).buildderefimpl;
  3641. funcretsymderef.build(funcretsym);
  3642. end;
  3643. { inline tree }
  3644. if (proccalloption=pocall_inline) then
  3645. inlininginfo^.code.buildderefimpl;
  3646. aktparasymtable:=oldparasymtable;
  3647. aktlocalsymtable:=oldlocalsymtable;
  3648. end;
  3649. procedure tprocdef.deref;
  3650. var
  3651. oldparasymtable,
  3652. oldlocalsymtable : tsymtable;
  3653. begin
  3654. { released procdef? }
  3655. if not assigned(parast) then
  3656. exit;
  3657. oldparasymtable:=aktparasymtable;
  3658. oldlocalsymtable:=aktlocalsymtable;
  3659. aktparasymtable:=parast;
  3660. aktlocalsymtable:=localst;
  3661. inherited deref;
  3662. _class:=tobjectdef(_classderef.resolve);
  3663. { procsym that originaly defined this definition, should be in the
  3664. same symtable }
  3665. procsym:=tprocsym(procsymderef.resolve);
  3666. aktparasymtable:=oldparasymtable;
  3667. aktlocalsymtable:=oldlocalsymtable;
  3668. end;
  3669. procedure tprocdef.derefimpl;
  3670. var
  3671. oldparasymtable,
  3672. oldlocalsymtable : tsymtable;
  3673. begin
  3674. oldparasymtable:=aktparasymtable;
  3675. oldlocalsymtable:=aktlocalsymtable;
  3676. aktparasymtable:=parast;
  3677. aktlocalsymtable:=localst;
  3678. { locals }
  3679. if assigned(localst) then
  3680. begin
  3681. { localst }
  3682. { we can deref both interface and implementation parts }
  3683. tlocalsymtable(localst).deref;
  3684. tlocalsymtable(localst).derefimpl;
  3685. { funcretsym, this is always located in the localst }
  3686. funcretsym:=tsym(funcretsymderef.resolve);
  3687. end
  3688. else
  3689. begin
  3690. { safety }
  3691. funcretsym:=nil;
  3692. end;
  3693. { inline tree }
  3694. if (proccalloption=pocall_inline) then
  3695. inlininginfo^.code.derefimpl;
  3696. aktparasymtable:=oldparasymtable;
  3697. aktlocalsymtable:=oldlocalsymtable;
  3698. end;
  3699. function tprocdef.gettypename : string;
  3700. begin
  3701. gettypename := FullProcName(false);
  3702. end;
  3703. function tprocdef.mangledname : string;
  3704. var
  3705. hp : TParaItem;
  3706. begin
  3707. if assigned(_mangledname) then
  3708. begin
  3709. {$ifdef compress}
  3710. mangledname:=minilzw_decode(_mangledname^);
  3711. {$else}
  3712. mangledname:=_mangledname^;
  3713. {$endif}
  3714. exit;
  3715. end;
  3716. { we need to use the symtable where the procsym is inserted,
  3717. because that is visible to the world }
  3718. mangledname:=make_mangledname('',procsym.owner,procsym.name);
  3719. if overloadnumber>0 then
  3720. mangledname:=mangledname+'$'+tostr(overloadnumber);
  3721. { add parameter types }
  3722. hp:=TParaItem(Para.first);
  3723. while assigned(hp) do
  3724. begin
  3725. if not hp.is_hidden then
  3726. mangledname:=mangledname+'$'+hp.paratype.def.mangledparaname;
  3727. hp:=TParaItem(hp.next);
  3728. end;
  3729. {$ifdef compress}
  3730. _mangledname:=stringdup(minilzw_encode(mangledname));
  3731. {$else}
  3732. _mangledname:=stringdup(mangledname);
  3733. {$endif}
  3734. end;
  3735. function tprocdef.cplusplusmangledname : string;
  3736. function getcppparaname(p : tdef) : string;
  3737. const
  3738. ordtype2str : array[tbasetype] of string[2] = (
  3739. '',
  3740. 'Uc','Us','Ui','Us',
  3741. 'Sc','s','i','x',
  3742. 'b','b','b',
  3743. 'c','w','x');
  3744. var
  3745. s : string;
  3746. begin
  3747. case p.deftype of
  3748. orddef:
  3749. s:=ordtype2str[torddef(p).typ];
  3750. pointerdef:
  3751. s:='P'+getcppparaname(tpointerdef(p).pointertype.def);
  3752. else
  3753. internalerror(2103001);
  3754. end;
  3755. getcppparaname:=s;
  3756. end;
  3757. var
  3758. s,s2 : string;
  3759. param : TParaItem;
  3760. begin
  3761. s := procsym.realname;
  3762. if procsym.owner.symtabletype=objectsymtable then
  3763. begin
  3764. s2:=upper(tobjectdef(procsym.owner.defowner).typesym.realname);
  3765. case proctypeoption of
  3766. potype_destructor:
  3767. s:='_$_'+tostr(length(s2))+s2;
  3768. potype_constructor:
  3769. s:='___'+tostr(length(s2))+s2;
  3770. else
  3771. s:='_'+s+'__'+tostr(length(s2))+s2;
  3772. end;
  3773. end
  3774. else s:=s+'__';
  3775. s:=s+'F';
  3776. { concat modifiers }
  3777. { !!!!! }
  3778. { now we handle the parameters }
  3779. param := TParaItem(Para.first);
  3780. if assigned(param) then
  3781. while assigned(param) do
  3782. begin
  3783. s2:=getcppparaname(param.paratype.def);
  3784. if param.paratyp in [vs_var,vs_out] then
  3785. s2:='R'+s2;
  3786. s:=s+s2;
  3787. param:=TParaItem(param.next);
  3788. end
  3789. else
  3790. s:=s+'v';
  3791. cplusplusmangledname:=s;
  3792. end;
  3793. procedure tprocdef.setmangledname(const s : string);
  3794. begin
  3795. stringdispose(_mangledname);
  3796. {$ifdef compress}
  3797. _mangledname:=stringdup(minilzw_encode(s));
  3798. {$else}
  3799. _mangledname:=stringdup(s);
  3800. {$endif}
  3801. has_mangledname:=true;
  3802. end;
  3803. {***************************************************************************
  3804. TPROCVARDEF
  3805. ***************************************************************************}
  3806. constructor tprocvardef.create(level:byte);
  3807. begin
  3808. inherited create(level);
  3809. deftype:=procvardef;
  3810. end;
  3811. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  3812. begin
  3813. inherited ppuload(ppufile);
  3814. deftype:=procvardef;
  3815. { load para symtable }
  3816. parast:=tparasymtable.create(unknown_level);
  3817. tparasymtable(parast).ppuload(ppufile);
  3818. parast.defowner:=self;
  3819. end;
  3820. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  3821. var
  3822. oldparasymtable,
  3823. oldlocalsymtable : tsymtable;
  3824. begin
  3825. oldparasymtable:=aktparasymtable;
  3826. oldlocalsymtable:=aktlocalsymtable;
  3827. aktparasymtable:=parast;
  3828. aktlocalsymtable:=nil;
  3829. { here we cannot get a real good value so just give something }
  3830. { plausible (PM) }
  3831. { a more secure way would be
  3832. to allways store in a temp }
  3833. {$ifdef i386}
  3834. if is_fpu(rettype.def) then
  3835. fpu_used:={2}maxfpuregs
  3836. else
  3837. fpu_used:=0;
  3838. {$endif i386}
  3839. inherited ppuwrite(ppufile);
  3840. { Write this entry }
  3841. ppufile.writeentry(ibprocvardef);
  3842. { Save the para symtable, this is taken from the interface }
  3843. tparasymtable(parast).ppuwrite(ppufile);
  3844. aktparasymtable:=oldparasymtable;
  3845. aktlocalsymtable:=oldlocalsymtable;
  3846. end;
  3847. procedure tprocvardef.buildderef;
  3848. var
  3849. oldparasymtable,
  3850. oldlocalsymtable : tsymtable;
  3851. begin
  3852. oldparasymtable:=aktparasymtable;
  3853. oldlocalsymtable:=aktlocalsymtable;
  3854. aktparasymtable:=parast;
  3855. aktlocalsymtable:=nil;
  3856. inherited buildderef;
  3857. aktparasymtable:=oldparasymtable;
  3858. aktlocalsymtable:=oldlocalsymtable;
  3859. end;
  3860. procedure tprocvardef.deref;
  3861. var
  3862. oldparasymtable,
  3863. oldlocalsymtable : tsymtable;
  3864. begin
  3865. oldparasymtable:=aktparasymtable;
  3866. oldlocalsymtable:=aktlocalsymtable;
  3867. aktparasymtable:=parast;
  3868. aktlocalsymtable:=nil;
  3869. inherited deref;
  3870. aktparasymtable:=oldparasymtable;
  3871. aktlocalsymtable:=oldlocalsymtable;
  3872. end;
  3873. function tprocvardef.getsymtable(t:tgetsymtable):tsymtable;
  3874. begin
  3875. case t of
  3876. gs_para :
  3877. getsymtable:=parast;
  3878. else
  3879. getsymtable:=nil;
  3880. end;
  3881. end;
  3882. function tprocvardef.size : longint;
  3883. begin
  3884. if (po_methodpointer in procoptions) and
  3885. not(po_addressonly in procoptions) then
  3886. size:=2*POINTER_SIZE
  3887. else
  3888. size:=POINTER_SIZE;
  3889. end;
  3890. function tprocvardef.is_methodpointer:boolean;
  3891. begin
  3892. result:=(po_methodpointer in procoptions);
  3893. end;
  3894. function tprocvardef.is_addressonly:boolean;
  3895. begin
  3896. result:=not(po_methodpointer in procoptions) or
  3897. (po_addressonly in procoptions);
  3898. end;
  3899. {$ifdef GDB}
  3900. function tprocvardef.stabstring : pchar;
  3901. var
  3902. nss : pchar;
  3903. { i : longint; }
  3904. begin
  3905. { i := maxparacount; }
  3906. getmem(nss,1024);
  3907. { it is not a function but a function pointer !! (PM) }
  3908. strpcopy(nss,'*f'+tstoreddef(rettype.def).numberstring{+','+tostr(i)}+';');
  3909. { this confuses gdb !!
  3910. we should use 'F' instead of 'f' but
  3911. as we use c++ language mode
  3912. it does not like that either
  3913. Please do not remove this part
  3914. might be used once
  3915. gdb for pascal is ready PM }
  3916. {$ifdef disabled}
  3917. param := para1;
  3918. i := 0;
  3919. while assigned(param) do
  3920. begin
  3921. inc(i);
  3922. if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
  3923. {Here we have lost the parameter names !!}
  3924. pst := strpnew('p'+tostr(i)+':'+param^.paratype.def.numberstring+','+vartyp+';');
  3925. strcat(nss,pst);
  3926. strdispose(pst);
  3927. param := param^.next;
  3928. end;
  3929. {$endif}
  3930. {strpcopy(strend(nss),';');}
  3931. stabstring := strnew(nss);
  3932. freemem(nss,1024);
  3933. end;
  3934. procedure tprocvardef.concatstabto(asmlist : taasmoutput);
  3935. begin
  3936. if ( not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  3937. and (is_def_stab_written = not_written) then
  3938. inherited concatstabto(asmlist);
  3939. is_def_stab_written:=written;
  3940. end;
  3941. {$endif GDB}
  3942. procedure tprocvardef.write_rtti_data(rt:trttitype);
  3943. var
  3944. pdc : TParaItem;
  3945. methodkind, paraspec : byte;
  3946. begin
  3947. if po_methodpointer in procoptions then
  3948. begin
  3949. { write method id and name }
  3950. rttiList.concat(Tai_const.Create_8bit(tkmethod));
  3951. write_rtti_name;
  3952. { write kind of method (can only be function or procedure)}
  3953. if rettype.def = voidtype.def then
  3954. methodkind := mkProcedure
  3955. else
  3956. methodkind := mkFunction;
  3957. rttiList.concat(Tai_const.Create_8bit(methodkind));
  3958. { get # of parameters }
  3959. rttiList.concat(Tai_const.Create_8bit(maxparacount));
  3960. { write parameter info. The parameters must be written in reverse order
  3961. if this method uses right to left parameter pushing! }
  3962. if proccalloption in pushleftright_pocalls then
  3963. pdc:=TParaItem(Para.first)
  3964. else
  3965. pdc:=TParaItem(Para.last);
  3966. while assigned(pdc) do
  3967. begin
  3968. { only store user visible parameters }
  3969. if not pdc.is_hidden then
  3970. begin
  3971. case pdc.paratyp of
  3972. vs_value: paraspec := 0;
  3973. vs_const: paraspec := pfConst;
  3974. vs_var : paraspec := pfVar;
  3975. vs_out : paraspec := pfOut;
  3976. end;
  3977. { write flags for current parameter }
  3978. rttiList.concat(Tai_const.Create_8bit(paraspec));
  3979. { write name of current parameter }
  3980. if assigned(pdc.parasym) then
  3981. begin
  3982. rttiList.concat(Tai_const.Create_8bit(length(pdc.parasym.realname)));
  3983. rttiList.concat(Tai_string.Create(pdc.parasym.realname));
  3984. end
  3985. else
  3986. rttiList.concat(Tai_const.Create_8bit(0));
  3987. { write name of type of current parameter }
  3988. tstoreddef(pdc.paratype.def).write_rtti_name;
  3989. end;
  3990. if proccalloption in pushleftright_pocalls then
  3991. pdc:=TParaItem(pdc.next)
  3992. else
  3993. pdc:=TParaItem(pdc.previous);
  3994. end;
  3995. { write name of result type }
  3996. tstoreddef(rettype.def).write_rtti_name;
  3997. end;
  3998. end;
  3999. function tprocvardef.is_publishable : boolean;
  4000. begin
  4001. is_publishable:=(po_methodpointer in procoptions);
  4002. end;
  4003. function tprocvardef.gettypename : string;
  4004. var
  4005. s: string;
  4006. showhidden : boolean;
  4007. begin
  4008. {$ifdef EXTDEBUG}
  4009. showhidden:=true;
  4010. {$else EXTDEBUG}
  4011. showhidden:=false;
  4012. {$endif EXTDEBUG}
  4013. s:='<';
  4014. if po_classmethod in procoptions then
  4015. s := s+'class method type of'
  4016. else
  4017. if po_addressonly in procoptions then
  4018. s := s+'address of'
  4019. else
  4020. s := s+'procedure variable type of';
  4021. if assigned(rettype.def) and
  4022. (rettype.def<>voidtype.def) then
  4023. s:=s+' function'+typename_paras(showhidden)+':'+rettype.def.gettypename
  4024. else
  4025. s:=s+' procedure'+typename_paras(showhidden);
  4026. if po_methodpointer in procoptions then
  4027. s := s+' of object';
  4028. gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
  4029. end;
  4030. {***************************************************************************
  4031. TOBJECTDEF
  4032. ***************************************************************************}
  4033. constructor tobjectdef.create(ot : tobjectdeftype;const n : string;c : tobjectdef);
  4034. begin
  4035. inherited create;
  4036. objecttype:=ot;
  4037. deftype:=objectdef;
  4038. objectoptions:=[];
  4039. childof:=nil;
  4040. symtable:=tobjectsymtable.create(n,aktpackrecords);
  4041. { create space for vmt !! }
  4042. vmt_offset:=0;
  4043. symtable.defowner:=self;
  4044. lastvtableindex:=0;
  4045. set_parent(c);
  4046. objname:=stringdup(upper(n));
  4047. objrealname:=stringdup(n);
  4048. if objecttype in [odt_interfacecorba,odt_interfacecom] then
  4049. prepareguid;
  4050. { setup implemented interfaces }
  4051. if objecttype in [odt_class,odt_interfacecorba] then
  4052. implementedinterfaces:=timplementedinterfaces.create
  4053. else
  4054. implementedinterfaces:=nil;
  4055. {$ifdef GDB}
  4056. writing_class_record_stab:=false;
  4057. {$endif GDB}
  4058. end;
  4059. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  4060. var
  4061. i,implintfcount: longint;
  4062. d : tderef;
  4063. begin
  4064. inherited ppuloaddef(ppufile);
  4065. deftype:=objectdef;
  4066. objecttype:=tobjectdeftype(ppufile.getbyte);
  4067. savesize:=ppufile.getlongint;
  4068. vmt_offset:=ppufile.getlongint;
  4069. objrealname:=stringdup(ppufile.getstring);
  4070. objname:=stringdup(upper(objrealname^));
  4071. ppufile.getderef(childofderef);
  4072. ppufile.getsmallset(objectoptions);
  4073. { load guid }
  4074. iidstr:=nil;
  4075. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  4076. begin
  4077. new(iidguid);
  4078. ppufile.getguid(iidguid^);
  4079. iidstr:=stringdup(ppufile.getstring);
  4080. lastvtableindex:=ppufile.getlongint;
  4081. end;
  4082. { load implemented interfaces }
  4083. if objecttype in [odt_class,odt_interfacecorba] then
  4084. begin
  4085. implementedinterfaces:=timplementedinterfaces.create;
  4086. implintfcount:=ppufile.getlongint;
  4087. for i:=1 to implintfcount do
  4088. begin
  4089. ppufile.getderef(d);
  4090. implementedinterfaces.addintf_deref(d);
  4091. implementedinterfaces.ioffsets(i)^:=ppufile.getlongint;
  4092. end;
  4093. end
  4094. else
  4095. implementedinterfaces:=nil;
  4096. symtable:=tobjectsymtable.create(objrealname^,aktpackrecords);
  4097. tobjectsymtable(symtable).datasize:=ppufile.getlongint;
  4098. tobjectsymtable(symtable).fieldalignment:=ppufile.getbyte;
  4099. tobjectsymtable(symtable).recordalignment:=ppufile.getbyte;
  4100. tobjectsymtable(symtable).ppuload(ppufile);
  4101. symtable.defowner:=self;
  4102. { handles the predefined class tobject }
  4103. { the last TOBJECT which is loaded gets }
  4104. { it ! }
  4105. if (childof=nil) and
  4106. (objecttype=odt_class) and
  4107. (objname^='TOBJECT') then
  4108. class_tobject:=self;
  4109. if (childof=nil) and
  4110. (objecttype=odt_interfacecom) and
  4111. (objname^='IUNKNOWN') then
  4112. interface_iunknown:=self;
  4113. {$ifdef GDB}
  4114. writing_class_record_stab:=false;
  4115. {$endif GDB}
  4116. end;
  4117. destructor tobjectdef.destroy;
  4118. begin
  4119. if assigned(symtable) then
  4120. symtable.free;
  4121. stringdispose(objname);
  4122. stringdispose(objrealname);
  4123. if assigned(iidstr) then
  4124. stringdispose(iidstr);
  4125. if assigned(implementedinterfaces) then
  4126. implementedinterfaces.free;
  4127. if assigned(iidguid) then
  4128. dispose(iidguid);
  4129. inherited destroy;
  4130. end;
  4131. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  4132. var
  4133. implintfcount : longint;
  4134. i : longint;
  4135. begin
  4136. inherited ppuwritedef(ppufile);
  4137. ppufile.putbyte(byte(objecttype));
  4138. ppufile.putlongint(size);
  4139. ppufile.putlongint(vmt_offset);
  4140. ppufile.putstring(objrealname^);
  4141. ppufile.putderef(childofderef);
  4142. ppufile.putsmallset(objectoptions);
  4143. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  4144. begin
  4145. ppufile.putguid(iidguid^);
  4146. ppufile.putstring(iidstr^);
  4147. ppufile.putlongint(lastvtableindex);
  4148. end;
  4149. if objecttype in [odt_class,odt_interfacecorba] then
  4150. begin
  4151. implintfcount:=implementedinterfaces.count;
  4152. ppufile.putlongint(implintfcount);
  4153. for i:=1 to implintfcount do
  4154. begin
  4155. ppufile.putderef(implementedinterfaces.interfacesderef(i));
  4156. ppufile.putlongint(implementedinterfaces.ioffsets(i)^);
  4157. end;
  4158. end;
  4159. ppufile.putlongint(tobjectsymtable(symtable).datasize);
  4160. ppufile.putbyte(tobjectsymtable(symtable).fieldalignment);
  4161. ppufile.putbyte(tobjectsymtable(symtable).recordalignment);
  4162. ppufile.writeentry(ibobjectdef);
  4163. tobjectsymtable(symtable).ppuwrite(ppufile);
  4164. end;
  4165. function tobjectdef.gettypename:string;
  4166. begin
  4167. gettypename:=typename;
  4168. end;
  4169. procedure tobjectdef.buildderef;
  4170. var
  4171. oldrecsyms : tsymtable;
  4172. begin
  4173. inherited buildderef;
  4174. childofderef.build(childof);
  4175. oldrecsyms:=aktrecordsymtable;
  4176. aktrecordsymtable:=symtable;
  4177. tstoredsymtable(symtable).buildderef;
  4178. aktrecordsymtable:=oldrecsyms;
  4179. if objecttype in [odt_class,odt_interfacecorba] then
  4180. implementedinterfaces.buildderef;
  4181. end;
  4182. procedure tobjectdef.deref;
  4183. var
  4184. oldrecsyms : tsymtable;
  4185. begin
  4186. inherited deref;
  4187. childof:=tobjectdef(childofderef.resolve);
  4188. oldrecsyms:=aktrecordsymtable;
  4189. aktrecordsymtable:=symtable;
  4190. tstoredsymtable(symtable).deref;
  4191. aktrecordsymtable:=oldrecsyms;
  4192. if objecttype in [odt_class,odt_interfacecorba] then
  4193. implementedinterfaces.deref;
  4194. end;
  4195. function tobjectdef.getparentdef:tdef;
  4196. begin
  4197. result:=childof;
  4198. end;
  4199. procedure tobjectdef.prepareguid;
  4200. begin
  4201. { set up guid }
  4202. if not assigned(iidguid) then
  4203. begin
  4204. new(iidguid);
  4205. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  4206. end;
  4207. { setup iidstring }
  4208. if not assigned(iidstr) then
  4209. iidstr:=stringdup(''); { default is empty string }
  4210. end;
  4211. procedure tobjectdef.set_parent( c : tobjectdef);
  4212. begin
  4213. { nothing to do if the parent was not forward !}
  4214. if assigned(childof) then
  4215. exit;
  4216. childof:=c;
  4217. { some options are inherited !! }
  4218. if assigned(c) then
  4219. begin
  4220. { only important for classes }
  4221. lastvtableindex:=c.lastvtableindex;
  4222. objectoptions:=objectoptions+(c.objectoptions*
  4223. [oo_has_virtual,oo_has_private,oo_has_protected,
  4224. oo_has_constructor,oo_has_destructor]);
  4225. if not (objecttype in [odt_interfacecom,odt_interfacecorba]) then
  4226. begin
  4227. { add the data of the anchestor class }
  4228. inc(tobjectsymtable(symtable).datasize,tobjectsymtable(c.symtable).datasize);
  4229. if (oo_has_vmt in objectoptions) and
  4230. (oo_has_vmt in c.objectoptions) then
  4231. dec(tobjectsymtable(symtable).datasize,POINTER_SIZE);
  4232. { if parent has a vmt field then
  4233. the offset is the same for the child PM }
  4234. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  4235. begin
  4236. vmt_offset:=c.vmt_offset;
  4237. include(objectoptions,oo_has_vmt);
  4238. end;
  4239. end;
  4240. end;
  4241. savesize := tobjectsymtable(symtable).datasize;
  4242. end;
  4243. procedure tobjectdef.insertvmt;
  4244. begin
  4245. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  4246. exit;
  4247. if (oo_has_vmt in objectoptions) then
  4248. internalerror(12345)
  4249. else
  4250. begin
  4251. tobjectsymtable(symtable).datasize:=align(tobjectsymtable(symtable).datasize,
  4252. tobjectsymtable(symtable).fieldalignment);
  4253. vmt_offset:=tobjectsymtable(symtable).datasize;
  4254. inc(tobjectsymtable(symtable).datasize,POINTER_SIZE);
  4255. include(objectoptions,oo_has_vmt);
  4256. end;
  4257. end;
  4258. procedure tobjectdef.check_forwards;
  4259. begin
  4260. if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
  4261. tstoredsymtable(symtable).check_forwards;
  4262. if (oo_is_forward in objectoptions) then
  4263. begin
  4264. { ok, in future, the forward can be resolved }
  4265. Message1(sym_e_class_forward_not_resolved,objrealname^);
  4266. exclude(objectoptions,oo_is_forward);
  4267. end;
  4268. end;
  4269. { true, if self inherits from d (or if they are equal) }
  4270. function tobjectdef.is_related(d : tobjectdef) : boolean;
  4271. var
  4272. hp : tobjectdef;
  4273. begin
  4274. hp:=self;
  4275. while assigned(hp) do
  4276. begin
  4277. if hp=d then
  4278. begin
  4279. is_related:=true;
  4280. exit;
  4281. end;
  4282. hp:=hp.childof;
  4283. end;
  4284. is_related:=false;
  4285. end;
  4286. (* procedure tobjectdef._searchdestructor(sym : tnamedindexitem;arg:pointer);
  4287. var
  4288. p : pprocdeflist;
  4289. begin
  4290. { if we found already a destructor, then we exit }
  4291. if assigned(sd) then
  4292. exit;
  4293. if tsym(sym).typ=procsym then
  4294. begin
  4295. p:=tprocsym(sym).defs;
  4296. while assigned(p) do
  4297. begin
  4298. if p^.def.proctypeoption=potype_destructor then
  4299. begin
  4300. sd:=p^.def;
  4301. exit;
  4302. end;
  4303. p:=p^.next;
  4304. end;
  4305. end;
  4306. end;*)
  4307. procedure _searchdestructor(sym:Tnamedindexitem;sd:pointer);
  4308. begin
  4309. { if we found already a destructor, then we exit }
  4310. if (ppointer(sd)^=nil) and
  4311. (Tsym(sym).typ=procsym) then
  4312. ppointer(sd)^:=Tprocsym(sym).search_procdef_bytype(potype_destructor);
  4313. end;
  4314. function tobjectdef.searchdestructor : tprocdef;
  4315. var
  4316. o : tobjectdef;
  4317. sd : tprocdef;
  4318. begin
  4319. searchdestructor:=nil;
  4320. o:=self;
  4321. sd:=nil;
  4322. while assigned(o) do
  4323. begin
  4324. o.symtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}_searchdestructor,@sd);
  4325. if assigned(sd) then
  4326. begin
  4327. searchdestructor:=sd;
  4328. exit;
  4329. end;
  4330. o:=o.childof;
  4331. end;
  4332. end;
  4333. function tobjectdef.size : longint;
  4334. begin
  4335. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
  4336. result:=POINTER_SIZE
  4337. else
  4338. result:=tobjectsymtable(symtable).datasize;
  4339. end;
  4340. function tobjectdef.alignment:longint;
  4341. begin
  4342. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
  4343. alignment:=POINTER_SIZE
  4344. else
  4345. alignment:=tobjectsymtable(symtable).recordalignment;
  4346. end;
  4347. function tobjectdef.vmtmethodoffset(index:longint):longint;
  4348. begin
  4349. { for offset of methods for classes, see rtl/inc/objpash.inc }
  4350. case objecttype of
  4351. odt_class:
  4352. vmtmethodoffset:=(index+12)*POINTER_SIZE;
  4353. odt_interfacecom,odt_interfacecorba:
  4354. vmtmethodoffset:=index*POINTER_SIZE;
  4355. else
  4356. {$ifdef WITHDMT}
  4357. vmtmethodoffset:=(index+4)*POINTER_SIZE;
  4358. {$else WITHDMT}
  4359. vmtmethodoffset:=(index+3)*POINTER_SIZE;
  4360. {$endif WITHDMT}
  4361. end;
  4362. end;
  4363. function tobjectdef.vmt_mangledname : string;
  4364. begin
  4365. if not(oo_has_vmt in objectoptions) then
  4366. Message1(parser_n_object_has_no_vmt,objrealname^);
  4367. vmt_mangledname:=make_mangledname('VMT',owner,objname^);
  4368. end;
  4369. function tobjectdef.rtti_name : string;
  4370. begin
  4371. rtti_name:=make_mangledname('RTTI',owner,objname^);
  4372. end;
  4373. {$ifdef GDB}
  4374. procedure tobjectdef.addprocname(p :tnamedindexitem;arg:pointer);
  4375. var virtualind,argnames : string;
  4376. newrec : pchar;
  4377. pd,ipd : tprocdef;
  4378. lindex : longint;
  4379. para : TParaItem;
  4380. arglength : byte;
  4381. sp : char;
  4382. state:^Trecord_stabgen_state;
  4383. olds:integer;
  4384. begin
  4385. state:=arg;
  4386. if tsym(p).typ = procsym then
  4387. begin
  4388. pd := tprocsym(p).first_procdef;
  4389. { this will be used for full implementation of object stabs
  4390. not yet done }
  4391. ipd := Tprocsym(p).last_procdef;
  4392. if (po_virtualmethod in pd.procoptions) then
  4393. begin
  4394. lindex := pd.extnumber;
  4395. {doesnt seem to be necessary
  4396. lindex := lindex or $80000000;}
  4397. virtualind := '*'+tostr(lindex)+';'+ipd._class.classnumberstring+';'
  4398. end
  4399. else
  4400. virtualind := '.';
  4401. { used by gdbpas to recognize constructor and destructors }
  4402. if (pd.proctypeoption=potype_constructor) then
  4403. argnames:='__ct__'
  4404. else if (pd.proctypeoption=potype_destructor) then
  4405. argnames:='__dt__'
  4406. else
  4407. argnames := '';
  4408. { arguments are not listed here }
  4409. {we don't need another definition}
  4410. para := TParaItem(pd.Para.first);
  4411. while assigned(para) do
  4412. begin
  4413. if Para.paratype.def.deftype = formaldef then
  4414. begin
  4415. if Para.paratyp=vs_var then
  4416. argnames := argnames+'3var'
  4417. else if Para.paratyp=vs_const then
  4418. argnames:=argnames+'5const'
  4419. else if Para.paratyp=vs_out then
  4420. argnames:=argnames+'3out';
  4421. end
  4422. else
  4423. begin
  4424. { if the arg definition is like (v: ^byte;..
  4425. there is no sym attached to data !!! }
  4426. if assigned(Para.paratype.def.typesym) then
  4427. begin
  4428. arglength := length(Para.paratype.def.typesym.name);
  4429. argnames := argnames + tostr(arglength)+Para.paratype.def.typesym.name;
  4430. end
  4431. else
  4432. begin
  4433. argnames:=argnames+'11unnamedtype';
  4434. end;
  4435. end;
  4436. para := TParaItem(Para.next);
  4437. end;
  4438. ipd.is_def_stab_written := written;
  4439. { here 2A must be changed for private and protected }
  4440. { 0 is private 1 protected and 2 public }
  4441. if (sp_private in tsym(p).symoptions) then sp:='0'
  4442. else if (sp_protected in tsym(p).symoptions) then sp:='1'
  4443. else sp:='2';
  4444. newrec:=stabstr_evaluate('$1::$2=##$3;:$4;$5A$6;',[p.name,ipd.numberstring,
  4445. Tstoreddef(pd.rettype.def).numberstring,argnames,sp,
  4446. virtualind]);
  4447. { get spare place for a string at the end }
  4448. olds:=state^.stabsize;
  4449. inc(state^.stabsize,strlen(newrec));
  4450. if state^.stabsize>=state^.staballoc-256 then
  4451. begin
  4452. inc(state^.staballoc,memsizeinc);
  4453. reallocmem(state^.stabstring,state^.staballoc);
  4454. end;
  4455. strcopy(state^.stabstring+olds,newrec);
  4456. strdispose(newrec);
  4457. {This should be used for case !!
  4458. RecOffset := RecOffset + pd.size;}
  4459. end;
  4460. end;
  4461. function tobjectdef.stabstring : pchar;
  4462. var anc : tobjectdef;
  4463. state:Trecord_stabgen_state;
  4464. ts : string;
  4465. begin
  4466. if not (objecttype=odt_class) or writing_class_record_stab then
  4467. begin
  4468. state.staballoc:=memsizeinc;
  4469. getmem(state.stabstring,state.staballoc);
  4470. strpcopy(state.stabstring,'s'+tostr(tobjectsymtable(symtable).datasize));
  4471. if assigned(childof) then
  4472. begin
  4473. {only one ancestor not virtual, public, at base offset 0 }
  4474. { !1 , 0 2 0 , }
  4475. strpcopy(strend(state.stabstring),'!1,020,'+childof.classnumberstring+';');
  4476. end;
  4477. {virtual table to implement yet}
  4478. state.recoffset:=0;
  4479. state.stabsize:=strlen(state.stabstring);
  4480. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,@state);
  4481. if (oo_has_vmt in objectoptions) then
  4482. if not assigned(childof) or not(oo_has_vmt in childof.objectoptions) then
  4483. begin
  4484. ts:='$vf'+classnumberstring+':'+typeglobalnumber('vtblarray')+','+tostr(vmt_offset*8)+';';
  4485. strpcopy(state.stabstring+state.stabsize,ts);
  4486. inc(state.stabsize,length(ts));
  4487. end;
  4488. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname,@state);
  4489. if (oo_has_vmt in objectoptions) then
  4490. begin
  4491. anc := self;
  4492. while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do
  4493. anc := anc.childof;
  4494. { just in case anc = self }
  4495. ts:=';~%'+anc.classnumberstring+';';
  4496. end
  4497. else
  4498. ts:=';';
  4499. strpcopy(state.stabstring+state.stabsize,ts);
  4500. inc(state.stabsize,length(ts));
  4501. reallocmem(state.stabstring,state.stabsize+1);
  4502. stabstring:=state.stabstring;
  4503. end
  4504. else
  4505. begin
  4506. stabstring:=strpnew('*'+classnumberstring);
  4507. end;
  4508. end;
  4509. procedure tobjectdef.set_globalnb;
  4510. begin
  4511. globalnb:=PglobalTypeCount^;
  4512. inc(PglobalTypeCount^);
  4513. { classes need two type numbers, the globalnb is set to the ptr }
  4514. if objecttype=odt_class then
  4515. begin
  4516. globalnb:=PGlobalTypeCount^;
  4517. inc(PglobalTypeCount^);
  4518. end;
  4519. end;
  4520. function tobjectdef.classnumberstring : string;
  4521. begin
  4522. { write stabs again if needed }
  4523. numberstring;
  4524. if objecttype=odt_class then
  4525. begin
  4526. dec(globalnb);
  4527. classnumberstring:=numberstring;
  4528. inc(globalnb);
  4529. end
  4530. else
  4531. classnumberstring:=numberstring;
  4532. end;
  4533. function tobjectdef.allstabstring : pchar;
  4534. var stabchar : string[2];
  4535. ss,st : pchar;
  4536. sname : string;
  4537. sym_line_no : longint;
  4538. begin
  4539. ss := stabstring;
  4540. getmem(st,strlen(ss)+512);
  4541. stabchar := 't';
  4542. if deftype in tagtypes then
  4543. stabchar := 'Tt';
  4544. if assigned(typesym) then
  4545. begin
  4546. sname := typesym.name;
  4547. sym_line_no:=typesym.fileinfo.line;
  4548. end
  4549. else
  4550. begin
  4551. sname := ' ';
  4552. sym_line_no:=0;
  4553. end;
  4554. if writing_class_record_stab then
  4555. strpcopy(st,'"'+sname+':'+stabchar+classnumberstring+'=')
  4556. else
  4557. strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
  4558. strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
  4559. allstabstring := strnew(st);
  4560. freemem(st,strlen(ss)+512);
  4561. strdispose(ss);
  4562. end;
  4563. procedure tobjectdef.concatstabto(asmlist : taasmoutput);
  4564. var
  4565. oldtypesym : tsym;
  4566. begin
  4567. if objecttype<>odt_class then
  4568. begin
  4569. inherited concatstabto(asmlist);
  4570. exit;
  4571. end;
  4572. if ((typesym=nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  4573. (is_def_stab_written = not_written) then
  4574. begin
  4575. if globalnb=0 then
  4576. set_globalnb;
  4577. { Write the record class itself }
  4578. writing_class_record_stab:=true;
  4579. inherited concatstabto(asmlist);
  4580. writing_class_record_stab:=false;
  4581. { Write the invisible pointer class }
  4582. is_def_stab_written:=not_written;
  4583. oldtypesym:=typesym;
  4584. typesym:=nil;
  4585. inherited concatstabto(asmlist);
  4586. typesym:=oldtypesym;
  4587. end;
  4588. end;
  4589. {$endif GDB}
  4590. function tobjectdef.needs_inittable : boolean;
  4591. begin
  4592. case objecttype of
  4593. odt_class :
  4594. needs_inittable:=false;
  4595. odt_interfacecom:
  4596. needs_inittable:=true;
  4597. odt_interfacecorba:
  4598. needs_inittable:=is_related(interface_iunknown);
  4599. odt_object:
  4600. needs_inittable:=tobjectsymtable(symtable).needs_init_final;
  4601. else
  4602. internalerror(200108267);
  4603. end;
  4604. end;
  4605. function tobjectdef.members_need_inittable : boolean;
  4606. begin
  4607. members_need_inittable:=tobjectsymtable(symtable).needs_init_final;
  4608. end;
  4609. procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer);
  4610. begin
  4611. if needs_prop_entry(tsym(sym)) and
  4612. (tsym(sym).typ<>varsym) then
  4613. inc(count);
  4614. end;
  4615. procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer);
  4616. var
  4617. proctypesinfo : byte;
  4618. procedure writeproc(proc : tsymlist; shiftvalue : byte);
  4619. var
  4620. typvalue : byte;
  4621. hp : psymlistitem;
  4622. address : longint;
  4623. def : tdef;
  4624. begin
  4625. if not(assigned(proc) and assigned(proc.firstsym)) then
  4626. begin
  4627. rttiList.concat(Tai_const.Create_32bit(1));
  4628. typvalue:=3;
  4629. end
  4630. else if proc.firstsym^.sym.typ=varsym then
  4631. begin
  4632. address:=0;
  4633. hp:=proc.firstsym;
  4634. def:=nil;
  4635. while assigned(hp) do
  4636. begin
  4637. case hp^.sltype of
  4638. sl_load :
  4639. begin
  4640. def:=tvarsym(hp^.sym).vartype.def;
  4641. inc(address,tvarsym(hp^.sym).fieldoffset);
  4642. end;
  4643. sl_subscript :
  4644. begin
  4645. if not(assigned(def) and (def.deftype=recorddef)) then
  4646. internalerror(200402171);
  4647. inc(address,tvarsym(hp^.sym).fieldoffset);
  4648. def:=tvarsym(hp^.sym).vartype.def;
  4649. end;
  4650. sl_vec :
  4651. begin
  4652. if not(assigned(def) and (def.deftype=arraydef)) then
  4653. internalerror(200402172);
  4654. def:=tarraydef(def).elementtype.def;
  4655. inc(address,def.size*hp^.value);
  4656. end;
  4657. end;
  4658. hp:=hp^.next;
  4659. end;
  4660. rttiList.concat(Tai_const.Create_32bit(address));
  4661. typvalue:=0;
  4662. end
  4663. else
  4664. begin
  4665. { When there was an error then procdef is not assigned }
  4666. if not assigned(proc.procdef) then
  4667. exit;
  4668. if not(po_virtualmethod in tprocdef(proc.procdef).procoptions) then
  4669. begin
  4670. rttiList.concat(Tai_const_symbol.Createname(tprocdef(proc.procdef).mangledname,AT_FUNCTION,0));
  4671. typvalue:=1;
  4672. end
  4673. else
  4674. begin
  4675. { virtual method, write vmt offset }
  4676. rttiList.concat(Tai_const.Create_32bit(
  4677. tprocdef(proc.procdef)._class.vmtmethodoffset(tprocdef(proc.procdef).extnumber)));
  4678. typvalue:=2;
  4679. end;
  4680. end;
  4681. proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
  4682. end;
  4683. begin
  4684. if needs_prop_entry(tsym(sym)) then
  4685. case tsym(sym).typ of
  4686. varsym:
  4687. begin
  4688. {$ifdef dummy}
  4689. if not(tvarsym(sym).vartype.def.deftype=objectdef) or
  4690. not(tobjectdef(tvarsym(sym).vartype.def).is_class) then
  4691. internalerror(1509992);
  4692. { access to implicit class property as field }
  4693. proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4);
  4694. rttiList.concat(Tai_const_symbol.Createname(tvarsym(sym.vartype.def.get_rtti_label),AT_FUNCTION,0));
  4695. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym.address)));
  4696. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym.address)));
  4697. { per default stored }
  4698. rttiList.concat(Tai_const.Create_32bit(1));
  4699. { index as well as ... }
  4700. rttiList.concat(Tai_const.Create_32bit(0));
  4701. { default value are zero }
  4702. rttiList.concat(Tai_const.Create_32bit(0));
  4703. rttiList.concat(Tai_const.Create_16bit(count));
  4704. inc(count);
  4705. rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
  4706. rttiList.concat(Tai_const.Create_8bit(length(tvarsym(sym.realname))));
  4707. rttiList.concat(Tai_string.Create(tvarsym(sym.realname)));
  4708. {$endif dummy}
  4709. end;
  4710. propertysym:
  4711. begin
  4712. if ppo_indexed in tpropertysym(sym).propoptions then
  4713. proctypesinfo:=$40
  4714. else
  4715. proctypesinfo:=0;
  4716. rttiList.concat(Tai_const_symbol.Create(tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti)));
  4717. writeproc(tpropertysym(sym).readaccess,0);
  4718. writeproc(tpropertysym(sym).writeaccess,2);
  4719. { isn't it stored ? }
  4720. if not(ppo_stored in tpropertysym(sym).propoptions) then
  4721. begin
  4722. rttiList.concat(Tai_const.Create_ptr(0));
  4723. proctypesinfo:=proctypesinfo or (3 shl 4);
  4724. end
  4725. else
  4726. writeproc(tpropertysym(sym).storedaccess,4);
  4727. rttiList.concat(Tai_const.Create_32bit(tpropertysym(sym).index));
  4728. rttiList.concat(Tai_const.Create_32bit(tpropertysym(sym).default));
  4729. rttiList.concat(Tai_const.Create_16bit(count));
  4730. inc(count);
  4731. rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
  4732. rttiList.concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
  4733. rttiList.concat(Tai_string.Create(tpropertysym(sym).realname));
  4734. end;
  4735. else internalerror(1509992);
  4736. end;
  4737. end;
  4738. procedure tobjectdef.generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
  4739. begin
  4740. if needs_prop_entry(tsym(sym)) then
  4741. begin
  4742. case tsym(sym).typ of
  4743. propertysym:
  4744. tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti);
  4745. varsym:
  4746. tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(fullrtti);
  4747. else
  4748. internalerror(1509991);
  4749. end;
  4750. end;
  4751. end;
  4752. procedure tobjectdef.write_child_rtti_data(rt:trttitype);
  4753. begin
  4754. FRTTIType:=rt;
  4755. case rt of
  4756. initrtti :
  4757. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
  4758. fullrtti :
  4759. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_published_child_rtti,nil);
  4760. else
  4761. internalerror(200108301);
  4762. end;
  4763. end;
  4764. type
  4765. tclasslistitem = class(TLinkedListItem)
  4766. index : longint;
  4767. p : tobjectdef;
  4768. end;
  4769. var
  4770. classtablelist : tlinkedlist;
  4771. tablecount : longint;
  4772. function searchclasstablelist(p : tobjectdef) : tclasslistitem;
  4773. var
  4774. hp : tclasslistitem;
  4775. begin
  4776. hp:=tclasslistitem(classtablelist.first);
  4777. while assigned(hp) do
  4778. if hp.p=p then
  4779. begin
  4780. searchclasstablelist:=hp;
  4781. exit;
  4782. end
  4783. else
  4784. hp:=tclasslistitem(hp.next);
  4785. searchclasstablelist:=nil;
  4786. end;
  4787. procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer);
  4788. var
  4789. hp : tclasslistitem;
  4790. begin
  4791. if needs_prop_entry(tsym(sym)) and
  4792. (tsym(sym).typ=varsym) then
  4793. begin
  4794. if tvarsym(sym).vartype.def.deftype<>objectdef then
  4795. internalerror(0206001);
  4796. hp:=searchclasstablelist(tobjectdef(tvarsym(sym).vartype.def));
  4797. if not(assigned(hp)) then
  4798. begin
  4799. hp:=tclasslistitem.create;
  4800. hp.p:=tobjectdef(tvarsym(sym).vartype.def);
  4801. hp.index:=tablecount;
  4802. classtablelist.concat(hp);
  4803. inc(tablecount);
  4804. end;
  4805. inc(count);
  4806. end;
  4807. end;
  4808. procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer);
  4809. var
  4810. hp : tclasslistitem;
  4811. begin
  4812. if needs_prop_entry(tsym(sym)) and
  4813. (tsym(sym).typ=varsym) then
  4814. begin
  4815. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym).fieldoffset));
  4816. hp:=searchclasstablelist(tobjectdef(tvarsym(sym).vartype.def));
  4817. if not(assigned(hp)) then
  4818. internalerror(0206002);
  4819. rttiList.concat(Tai_const.Create_16bit(hp.index));
  4820. rttiList.concat(Tai_const.Create_8bit(length(tvarsym(sym).realname)));
  4821. rttiList.concat(Tai_string.Create(tvarsym(sym).realname));
  4822. end;
  4823. end;
  4824. function tobjectdef.generate_field_table : tasmlabel;
  4825. var
  4826. fieldtable,
  4827. classtable : tasmlabel;
  4828. hp : tclasslistitem;
  4829. begin
  4830. classtablelist:=TLinkedList.Create;
  4831. objectlibrary.getdatalabel(fieldtable);
  4832. objectlibrary.getdatalabel(classtable);
  4833. count:=0;
  4834. tablecount:=0;
  4835. symtable.foreach({$ifdef FPC}@{$endif}count_published_fields,nil);
  4836. if (cs_create_smart in aktmoduleswitches) then
  4837. rttiList.concat(Tai_cut.Create);
  4838. rttilist.concat(tai_align.create(const_align(pointer_size)));
  4839. rttiList.concat(Tai_label.Create(fieldtable));
  4840. rttiList.concat(Tai_const.Create_16bit(count));
  4841. rttiList.concat(Tai_const_symbol.Create(classtable));
  4842. symtable.foreach({$ifdef FPC}@{$endif}writefields,nil);
  4843. { generate the class table }
  4844. rttilist.concat(tai_align.create(const_align(pointer_size)));
  4845. rttiList.concat(Tai_label.Create(classtable));
  4846. rttiList.concat(Tai_const.Create_16bit(tablecount));
  4847. hp:=tclasslistitem(classtablelist.first);
  4848. while assigned(hp) do
  4849. begin
  4850. rttiList.concat(Tai_const_symbol.Createname(tobjectdef(hp.p).vmt_mangledname,AT_FUNCTION,0));
  4851. hp:=tclasslistitem(hp.next);
  4852. end;
  4853. generate_field_table:=fieldtable;
  4854. classtablelist.free;
  4855. end;
  4856. function tobjectdef.next_free_name_index : longint;
  4857. var
  4858. i : longint;
  4859. begin
  4860. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4861. i:=childof.next_free_name_index
  4862. else
  4863. i:=0;
  4864. count:=0;
  4865. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
  4866. next_free_name_index:=i+count;
  4867. end;
  4868. procedure tobjectdef.write_rtti_data(rt:trttitype);
  4869. begin
  4870. case objecttype of
  4871. odt_class:
  4872. rttiList.concat(Tai_const.Create_8bit(tkclass));
  4873. odt_object:
  4874. rttiList.concat(Tai_const.Create_8bit(tkobject));
  4875. odt_interfacecom:
  4876. rttiList.concat(Tai_const.Create_8bit(tkinterface));
  4877. odt_interfacecorba:
  4878. rttiList.concat(Tai_const.Create_8bit(tkinterfaceCorba));
  4879. else
  4880. exit;
  4881. end;
  4882. { generate the name }
  4883. rttiList.concat(Tai_const.Create_8bit(length(objrealname^)));
  4884. rttiList.concat(Tai_string.Create(objrealname^));
  4885. case rt of
  4886. initrtti :
  4887. begin
  4888. rttiList.concat(Tai_const.Create_32bit(size));
  4889. if objecttype in [odt_class,odt_object] then
  4890. begin
  4891. count:=0;
  4892. FRTTIType:=rt;
  4893. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
  4894. rttiList.concat(Tai_const.Create_32bit(count));
  4895. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
  4896. end;
  4897. end;
  4898. fullrtti :
  4899. begin
  4900. if (oo_has_vmt in objectoptions) and
  4901. not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
  4902. rttiList.concat(Tai_const_symbol.Createname(vmt_mangledname,AT_FUNCTION,0))
  4903. else
  4904. rttiList.concat(Tai_const.Create_ptr(0));
  4905. { write owner typeinfo }
  4906. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4907. rttiList.concat(Tai_const_symbol.Create(childof.get_rtti_label(fullrtti)))
  4908. else
  4909. rttiList.concat(Tai_const.Create_ptr(0));
  4910. { count total number of properties }
  4911. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4912. count:=childof.next_free_name_index
  4913. else
  4914. count:=0;
  4915. { write it }
  4916. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
  4917. rttiList.concat(Tai_const.Create_16bit(count));
  4918. { write unit name }
  4919. rttiList.concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
  4920. rttiList.concat(Tai_string.Create(current_module.realmodulename^));
  4921. { write published properties count }
  4922. count:=0;
  4923. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
  4924. rttiList.concat(Tai_const.Create_16bit(count));
  4925. { count is used to write nameindex }
  4926. { but we need an offset of the owner }
  4927. { to give each property an own slot }
  4928. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4929. count:=childof.next_free_name_index
  4930. else
  4931. count:=0;
  4932. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_property_info,nil);
  4933. end;
  4934. end;
  4935. end;
  4936. function tobjectdef.is_publishable : boolean;
  4937. begin
  4938. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
  4939. end;
  4940. {****************************************************************************
  4941. TIMPLEMENTEDINTERFACES
  4942. ****************************************************************************}
  4943. type
  4944. tnamemap = class(TNamedIndexItem)
  4945. newname: pstring;
  4946. constructor create(const aname, anewname: string);
  4947. destructor destroy; override;
  4948. end;
  4949. constructor tnamemap.create(const aname, anewname: string);
  4950. begin
  4951. inherited createname(name);
  4952. newname:=stringdup(anewname);
  4953. end;
  4954. destructor tnamemap.destroy;
  4955. begin
  4956. stringdispose(newname);
  4957. inherited destroy;
  4958. end;
  4959. type
  4960. tprocdefstore = class(TNamedIndexItem)
  4961. procdef: tprocdef;
  4962. constructor create(aprocdef: tprocdef);
  4963. end;
  4964. constructor tprocdefstore.create(aprocdef: tprocdef);
  4965. begin
  4966. inherited create;
  4967. procdef:=aprocdef;
  4968. end;
  4969. type
  4970. timplintfentry = class(TNamedIndexItem)
  4971. intf: tobjectdef;
  4972. intfderef : tderef;
  4973. ioffs: longint;
  4974. namemappings: tdictionary;
  4975. procdefs: TIndexArray;
  4976. constructor create(aintf: tobjectdef);
  4977. constructor create_deref(const d:tderef);
  4978. destructor destroy; override;
  4979. end;
  4980. constructor timplintfentry.create(aintf: tobjectdef);
  4981. begin
  4982. inherited create;
  4983. intf:=aintf;
  4984. ioffs:=-1;
  4985. namemappings:=nil;
  4986. procdefs:=nil;
  4987. end;
  4988. constructor timplintfentry.create_deref(const d:tderef);
  4989. begin
  4990. inherited create;
  4991. intf:=nil;
  4992. intfderef:=d;
  4993. ioffs:=-1;
  4994. namemappings:=nil;
  4995. procdefs:=nil;
  4996. end;
  4997. destructor timplintfentry.destroy;
  4998. begin
  4999. if assigned(namemappings) then
  5000. namemappings.free;
  5001. if assigned(procdefs) then
  5002. procdefs.free;
  5003. inherited destroy;
  5004. end;
  5005. constructor timplementedinterfaces.create;
  5006. begin
  5007. finterfaces:=tindexarray.create(1);
  5008. end;
  5009. destructor timplementedinterfaces.destroy;
  5010. begin
  5011. finterfaces.destroy;
  5012. end;
  5013. function timplementedinterfaces.count: longint;
  5014. begin
  5015. count:=finterfaces.count;
  5016. end;
  5017. procedure timplementedinterfaces.checkindex(intfindex: longint);
  5018. begin
  5019. if (intfindex<1) or (intfindex>count) then
  5020. InternalError(200006123);
  5021. end;
  5022. function timplementedinterfaces.interfaces(intfindex: longint): tobjectdef;
  5023. begin
  5024. checkindex(intfindex);
  5025. interfaces:=timplintfentry(finterfaces.search(intfindex)).intf;
  5026. end;
  5027. function timplementedinterfaces.interfacesderef(intfindex: longint): tderef;
  5028. begin
  5029. checkindex(intfindex);
  5030. interfacesderef:=timplintfentry(finterfaces.search(intfindex)).intfderef;
  5031. end;
  5032. function timplementedinterfaces.ioffsets(intfindex: longint): plongint;
  5033. begin
  5034. checkindex(intfindex);
  5035. ioffsets:=@timplintfentry(finterfaces.search(intfindex)).ioffs;
  5036. end;
  5037. function timplementedinterfaces.searchintf(def: tdef): longint;
  5038. var
  5039. i: longint;
  5040. begin
  5041. i:=1;
  5042. while (i<=count) and (tdef(interfaces(i))<>def) do inc(i);
  5043. if i<=count then
  5044. searchintf:=i
  5045. else
  5046. searchintf:=-1;
  5047. end;
  5048. procedure timplementedinterfaces.buildderef;
  5049. var
  5050. i: longint;
  5051. begin
  5052. for i:=1 to count do
  5053. with timplintfentry(finterfaces.search(i)) do
  5054. intfderef.build(intf);
  5055. end;
  5056. procedure timplementedinterfaces.deref;
  5057. var
  5058. i: longint;
  5059. begin
  5060. for i:=1 to count do
  5061. with timplintfentry(finterfaces.search(i)) do
  5062. intf:=tobjectdef(intfderef.resolve);
  5063. end;
  5064. procedure timplementedinterfaces.addintf_deref(const d:tderef);
  5065. begin
  5066. finterfaces.insert(timplintfentry.create_deref(d));
  5067. end;
  5068. procedure timplementedinterfaces.addintf(def: tdef);
  5069. begin
  5070. if not assigned(def) or (searchintf(def)<>-1) or (def.deftype<>objectdef) or
  5071. not (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]) then
  5072. internalerror(200006124);
  5073. finterfaces.insert(timplintfentry.create(tobjectdef(def)));
  5074. end;
  5075. procedure timplementedinterfaces.clearmappings;
  5076. var
  5077. i: longint;
  5078. begin
  5079. for i:=1 to count do
  5080. with timplintfentry(finterfaces.search(i)) do
  5081. begin
  5082. if assigned(namemappings) then
  5083. namemappings.free;
  5084. namemappings:=nil;
  5085. end;
  5086. end;
  5087. procedure timplementedinterfaces.addmappings(intfindex: longint; const name, newname: string);
  5088. begin
  5089. checkindex(intfindex);
  5090. with timplintfentry(finterfaces.search(intfindex)) do
  5091. begin
  5092. if not assigned(namemappings) then
  5093. namemappings:=tdictionary.create;
  5094. namemappings.insert(tnamemap.create(name,newname));
  5095. end;
  5096. end;
  5097. function timplementedinterfaces.getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
  5098. begin
  5099. checkindex(intfindex);
  5100. if not assigned(nextexist) then
  5101. with timplintfentry(finterfaces.search(intfindex)) do
  5102. begin
  5103. if assigned(namemappings) then
  5104. nextexist:=namemappings.search(name)
  5105. else
  5106. nextexist:=nil;
  5107. end;
  5108. if assigned(nextexist) then
  5109. begin
  5110. getmappings:=tnamemap(nextexist).newname^;
  5111. nextexist:=tnamemap(nextexist).listnext;
  5112. end
  5113. else
  5114. getmappings:='';
  5115. end;
  5116. procedure timplementedinterfaces.clearimplprocs;
  5117. var
  5118. i: longint;
  5119. begin
  5120. for i:=1 to count do
  5121. with timplintfentry(finterfaces.search(i)) do
  5122. begin
  5123. if assigned(procdefs) then
  5124. procdefs.free;
  5125. procdefs:=nil;
  5126. end;
  5127. end;
  5128. procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: tprocdef);
  5129. begin
  5130. checkindex(intfindex);
  5131. with timplintfentry(finterfaces.search(intfindex)) do
  5132. begin
  5133. if not assigned(procdefs) then
  5134. procdefs:=tindexarray.create(4);
  5135. procdefs.insert(tprocdefstore.create(procdef));
  5136. end;
  5137. end;
  5138. function timplementedinterfaces.implproccount(intfindex: longint): longint;
  5139. begin
  5140. checkindex(intfindex);
  5141. with timplintfentry(finterfaces.search(intfindex)) do
  5142. if assigned(procdefs) then
  5143. implproccount:=procdefs.count
  5144. else
  5145. implproccount:=0;
  5146. end;
  5147. function timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): tprocdef;
  5148. begin
  5149. checkindex(intfindex);
  5150. with timplintfentry(finterfaces.search(intfindex)) do
  5151. if assigned(procdefs) then
  5152. implprocs:=tprocdefstore(procdefs.search(procindex)).procdef
  5153. else
  5154. internalerror(200006131);
  5155. end;
  5156. function timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
  5157. var
  5158. possible: boolean;
  5159. i: longint;
  5160. iiep1: TIndexArray;
  5161. iiep2: TIndexArray;
  5162. begin
  5163. checkindex(intfindex);
  5164. checkindex(remainindex);
  5165. iiep1:=timplintfentry(finterfaces.search(intfindex)).procdefs;
  5166. iiep2:=timplintfentry(finterfaces.search(remainindex)).procdefs;
  5167. if not assigned(iiep1) then { empty interface is mergeable :-) }
  5168. begin
  5169. possible:=true;
  5170. weight:=0;
  5171. end
  5172. else
  5173. begin
  5174. possible:=assigned(iiep2) and (iiep1.count<=iiep2.count);
  5175. i:=1;
  5176. while (possible) and (i<=iiep1.count) do
  5177. begin
  5178. possible:=
  5179. (tprocdefstore(iiep1.search(i)).procdef=tprocdefstore(iiep2.search(i)).procdef);
  5180. inc(i);
  5181. end;
  5182. if possible then
  5183. weight:=iiep1.count;
  5184. end;
  5185. isimplmergepossible:=possible;
  5186. end;
  5187. {****************************************************************************
  5188. TFORWARDDEF
  5189. ****************************************************************************}
  5190. constructor tforwarddef.create(const s:string;const pos : tfileposinfo);
  5191. var
  5192. oldregisterdef : boolean;
  5193. begin
  5194. { never register the forwarddefs, they are disposed at the
  5195. end of the type declaration block }
  5196. oldregisterdef:=registerdef;
  5197. registerdef:=false;
  5198. inherited create;
  5199. registerdef:=oldregisterdef;
  5200. deftype:=forwarddef;
  5201. tosymname:=stringdup(s);
  5202. forwardpos:=pos;
  5203. end;
  5204. function tforwarddef.gettypename:string;
  5205. begin
  5206. gettypename:='unresolved forward to '+tosymname^;
  5207. end;
  5208. destructor tforwarddef.destroy;
  5209. begin
  5210. if assigned(tosymname) then
  5211. stringdispose(tosymname);
  5212. inherited destroy;
  5213. end;
  5214. {****************************************************************************
  5215. TERRORDEF
  5216. ****************************************************************************}
  5217. constructor terrordef.create;
  5218. begin
  5219. inherited create;
  5220. deftype:=errordef;
  5221. end;
  5222. {$ifdef GDB}
  5223. function terrordef.stabstring : pchar;
  5224. begin
  5225. stabstring:=strpnew('error'+numberstring);
  5226. end;
  5227. procedure terrordef.concatstabto(asmlist : taasmoutput);
  5228. begin
  5229. { No internal error needed, an normal error is already
  5230. thrown }
  5231. end;
  5232. {$endif GDB}
  5233. function terrordef.gettypename:string;
  5234. begin
  5235. gettypename:='<erroneous type>';
  5236. end;
  5237. function terrordef.getmangledparaname:string;
  5238. begin
  5239. getmangledparaname:='error';
  5240. end;
  5241. {****************************************************************************
  5242. GDB Helpers
  5243. ****************************************************************************}
  5244. {$ifdef GDB}
  5245. function typeglobalnumber(const s : string) : string;
  5246. var st : string;
  5247. symt : tsymtable;
  5248. srsym : tsym;
  5249. srsymtable : tsymtable;
  5250. old_make_ref : boolean;
  5251. begin
  5252. old_make_ref:=make_ref;
  5253. make_ref:=false;
  5254. typeglobalnumber := '0';
  5255. srsym := nil;
  5256. if pos('.',s) > 0 then
  5257. begin
  5258. st := copy(s,1,pos('.',s)-1);
  5259. searchsym(st,srsym,srsymtable);
  5260. st := copy(s,pos('.',s)+1,255);
  5261. if assigned(srsym) then
  5262. begin
  5263. if srsym.typ = unitsym then
  5264. begin
  5265. symt := tunitsym(srsym).unitsymtable;
  5266. srsym := tsym(symt.search(st));
  5267. end else srsym := nil;
  5268. end;
  5269. end else st := s;
  5270. if srsym = nil then
  5271. searchsym(st,srsym,srsymtable);
  5272. if (srsym=nil) or
  5273. (srsym.typ<>typesym) then
  5274. begin
  5275. Message(type_e_type_id_expected);
  5276. exit;
  5277. end;
  5278. typeglobalnumber := tstoreddef(ttypesym(srsym).restype.def).numberstring;
  5279. make_ref:=old_make_ref;
  5280. end;
  5281. {$endif GDB}
  5282. {****************************************************************************
  5283. Definition Helpers
  5284. ****************************************************************************}
  5285. function is_interfacecom(def: tdef): boolean;
  5286. begin
  5287. is_interfacecom:=
  5288. assigned(def) and
  5289. (def.deftype=objectdef) and
  5290. (tobjectdef(def).objecttype=odt_interfacecom);
  5291. end;
  5292. function is_interfacecorba(def: tdef): boolean;
  5293. begin
  5294. is_interfacecorba:=
  5295. assigned(def) and
  5296. (def.deftype=objectdef) and
  5297. (tobjectdef(def).objecttype=odt_interfacecorba);
  5298. end;
  5299. function is_interface(def: tdef): boolean;
  5300. begin
  5301. is_interface:=
  5302. assigned(def) and
  5303. (def.deftype=objectdef) and
  5304. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  5305. end;
  5306. function is_class(def: tdef): boolean;
  5307. begin
  5308. is_class:=
  5309. assigned(def) and
  5310. (def.deftype=objectdef) and
  5311. (tobjectdef(def).objecttype=odt_class);
  5312. end;
  5313. function is_object(def: tdef): boolean;
  5314. begin
  5315. is_object:=
  5316. assigned(def) and
  5317. (def.deftype=objectdef) and
  5318. (tobjectdef(def).objecttype=odt_object);
  5319. end;
  5320. function is_cppclass(def: tdef): boolean;
  5321. begin
  5322. is_cppclass:=
  5323. assigned(def) and
  5324. (def.deftype=objectdef) and
  5325. (tobjectdef(def).objecttype=odt_cppclass);
  5326. end;
  5327. function is_class_or_interface(def: tdef): boolean;
  5328. begin
  5329. is_class_or_interface:=
  5330. assigned(def) and
  5331. (def.deftype=objectdef) and
  5332. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  5333. end;
  5334. end.
  5335. {
  5336. $Log$
  5337. Revision 1.225 2004-03-03 22:01:44 peter
  5338. * fix hidden pointer for stabs
  5339. Revision 1.224 2004/03/02 00:36:33 olle
  5340. * big transformation of Tai_[const_]Symbol.Create[data]name*
  5341. Revision 1.223 2004/02/26 16:16:38 peter
  5342. * tai_const.create_ptr added
  5343. Revision 1.222 2004/02/22 19:55:25 daniel
  5344. * Revert my latest change
  5345. Revision 1.221 2004/02/22 18:49:03 daniel
  5346. * Fixed minor bug in Tenumdef.stabstring
  5347. Revision 1.220 2004/02/19 17:07:42 florian
  5348. * fixed arg. area calculation
  5349. Revision 1.219 2004/02/17 15:57:49 peter
  5350. - fix rtti generation for properties containing sl_vec
  5351. - fix crash when overloaded operator is not available
  5352. - fix record alignment for C style variant records
  5353. Revision 1.218 2004/02/12 15:54:03 peter
  5354. * make extcycle is working again
  5355. Revision 1.217 2004/02/08 18:08:59 jonas
  5356. * fixed regvars support. Needs -doldregvars to activate. Only tested with
  5357. ppc, other processors should however only require maxregvars and
  5358. maxfpuregvars constants in cpubase.pas. Remember to take scratch-
  5359. registers into account when defining that value.
  5360. Revision 1.216 2004/02/06 22:37:00 daniel
  5361. * Removed not very usefull nextglobal & previousglobal fields from
  5362. Tstoreddef, saving 78 kb of memory
  5363. Revision 1.215 2004/02/05 01:24:08 florian
  5364. * several fixes to compile x86-64 system
  5365. Revision 1.214 2004/02/03 22:32:54 peter
  5366. * renamed xNNbittype to xNNinttype
  5367. * renamed registers32 to registersint
  5368. * replace some s32bit,u32bit with torddef([su]inttype).def.typ
  5369. Revision 1.213 2004/01/28 22:16:31 peter
  5370. * more record alignment fixes
  5371. Revision 1.212 2004/01/28 21:05:56 florian
  5372. * fixed alignment of classes
  5373. Revision 1.211 2004/01/28 20:30:18 peter
  5374. * record alignment splitted in fieldalignment and recordalignment,
  5375. the latter is used when this record is inserted in another record.
  5376. Revision 1.210 2004/01/27 10:29:32 daniel
  5377. * Fix string type stab generation. String constant still unsupported.
  5378. Revision 1.209 2004/01/26 19:54:42 daniel
  5379. * Typo
  5380. Revision 1.208 2004/01/26 19:43:49 daniel
  5381. * Try to recude stack usage of Tpointerdef.concatstabsto
  5382. Revision 1.207 2004/01/26 16:12:28 daniel
  5383. * reginfo now also only allocated during register allocation
  5384. * third round of gdb cleanups: kick out most of concatstabto
  5385. Revision 1.206 2004/01/25 20:23:28 daniel
  5386. * More gdb cleanup: make record & object stab generation linear instead
  5387. of quadratic.
  5388. Revision 1.205 2004/01/25 13:18:59 daniel
  5389. * Made varags parameter constant
  5390. Revision 1.204 2004/01/25 12:37:15 daniel
  5391. * Last commit broke debug info for records. Fixed.
  5392. Revision 1.203 2004/01/25 11:33:48 daniel
  5393. * 2nd round of gdb cleanup
  5394. Revision 1.202 2004/01/22 21:33:54 peter
  5395. * procvardef rtti fixed
  5396. Revision 1.201 2004/01/22 16:33:22 peter
  5397. * enum value rtti is now in orginal case
  5398. Revision 1.200 2004/01/20 12:59:37 florian
  5399. * common addnode code for x86-64 and i386
  5400. Revision 1.199 2004/01/15 15:16:18 daniel
  5401. * Some minor stuff
  5402. * Managed to eliminate speed effects of string compression
  5403. Revision 1.198 2004/01/11 23:56:20 daniel
  5404. * Experiment: Compress strings to save memory
  5405. Did not save a single byte of mem; clearly the core size is boosted by
  5406. temporary memory usage...
  5407. Revision 1.197 2004/01/04 21:10:04 jonas
  5408. * Darwin's assembler assumes that all labels starting with 'L' are local
  5409. -> rename symbols starting with 'L'
  5410. Revision 1.196 2003/12/24 20:51:11 peter
  5411. * don't lowercase enumnames
  5412. Revision 1.195 2003/12/24 01:47:22 florian
  5413. * first fixes to compile the x86-64 system unit
  5414. Revision 1.194 2003/12/21 19:42:43 florian
  5415. * fixed ppc inlining stuff
  5416. * fixed wrong unit writing
  5417. + added some sse stuff
  5418. Revision 1.193 2003/12/16 21:29:24 florian
  5419. + inlined procedures inherit procinfo flags
  5420. Revision 1.192 2003/12/12 12:09:40 marco
  5421. * always generate RTTI patch from peter
  5422. Revision 1.191 2003/12/08 22:34:24 peter
  5423. * tai_const.create_32bit changed to cardinal
  5424. Revision 1.190 2003/11/10 22:02:52 peter
  5425. * cross unit inlining fixed
  5426. Revision 1.189 2003/11/08 23:31:27 florian
  5427. * tstoreddef.getcopy returns now an errordef instead of nil; this
  5428. allows easier error recovery
  5429. Revision 1.188 2003/11/05 14:18:03 marco
  5430. * fix from Peter arraysize warning (nav Newsgroup msg)
  5431. Revision 1.187 2003/11/01 15:50:03 peter
  5432. * fix check for valid procdef in property rtti
  5433. Revision 1.186 2003/10/29 21:56:28 peter
  5434. * procsym.deref derefs only own procdefs
  5435. * reset paracount in procdef.deref so a second deref doesn't increase
  5436. the paracounts to invalid values
  5437. Revision 1.185 2003/10/29 19:48:51 peter
  5438. * renamed mangeldname_prefix to make_mangledname and made it more
  5439. generic
  5440. * make_mangledname is now also used for internal threadvar/resstring
  5441. lists
  5442. * Add P$ in front of program modulename to prevent duplicated symbols
  5443. at assembler level, because the main program can have the same name
  5444. as a unit, see webtbs/tw1251b
  5445. Revision 1.184 2003/10/23 14:44:07 peter
  5446. * splitted buildderef and buildderefimpl to fix interface crc
  5447. calculation
  5448. Revision 1.183 2003/10/22 20:40:00 peter
  5449. * write derefdata in a separate ppu entry
  5450. Revision 1.182 2003/10/21 18:14:49 peter
  5451. * fix counting of parameters when loading ppu
  5452. Revision 1.181 2003/10/17 15:08:34 peter
  5453. * commented out more obsolete constants
  5454. Revision 1.180 2003/10/17 14:52:07 peter
  5455. * fixed ppc build
  5456. Revision 1.179 2003/10/17 14:38:32 peter
  5457. * 64k registers supported
  5458. * fixed some memory leaks
  5459. Revision 1.178 2003/10/13 14:05:12 peter
  5460. * removed is_visible_for_proc
  5461. * search also for class overloads when finding interface
  5462. implementations
  5463. Revision 1.177 2003/10/11 16:06:42 florian
  5464. * fixed some MMX<->SSE
  5465. * started to fix ppc, needs an overhaul
  5466. + stabs info improve for spilling, not sure if it works correctly/completly
  5467. - MMX_SUPPORT removed from Makefile.fpc
  5468. Revision 1.176 2003/10/10 17:48:14 peter
  5469. * old trgobj moved to x86/rgcpu and renamed to trgx86fpu
  5470. * tregisteralloctor renamed to trgobj
  5471. * removed rgobj from a lot of units
  5472. * moved location_* and reference_* to cgobj
  5473. * first things for mmx register allocation
  5474. Revision 1.175 2003/10/07 20:43:49 peter
  5475. * Add calling convention in fullprocname when it is specified
  5476. Revision 1.174 2003/10/07 16:06:30 peter
  5477. * tsymlist.def renamed to tsymlist.procdef
  5478. * tsymlist.procdef is now only used to store the procdef
  5479. Revision 1.173 2003/10/06 22:23:41 florian
  5480. + added basic olevariant support
  5481. Revision 1.172 2003/10/05 21:21:52 peter
  5482. * c style array of const generates callparanodes
  5483. * varargs paraloc fixes
  5484. Revision 1.171 2003/10/05 12:56:35 peter
  5485. * don't write procdefs that are released to ppu
  5486. Revision 1.170 2003/10/03 22:00:33 peter
  5487. * parameter alignment fixes
  5488. Revision 1.169 2003/10/02 21:19:42 peter
  5489. * protected visibility fixes
  5490. Revision 1.168 2003/10/01 20:34:49 peter
  5491. * procinfo unit contains tprocinfo
  5492. * cginfo renamed to cgbase
  5493. * moved cgmessage to verbose
  5494. * fixed ppc and sparc compiles
  5495. Revision 1.167 2003/10/01 16:49:05 florian
  5496. * para items are now reversed for pascal calling conventions
  5497. Revision 1.166 2003/10/01 15:32:58 florian
  5498. * fixed FullProcName to handle constructors, destructors and operators correctly
  5499. Revision 1.165 2003/10/01 15:00:02 peter
  5500. * don't write parast,localst debug info for externals
  5501. Revision 1.164 2003/09/23 21:03:35 peter
  5502. * connect parasym to paraitem
  5503. Revision 1.163 2003/09/23 17:56:06 peter
  5504. * locals and paras are allocated in the code generation
  5505. * tvarsym.localloc contains the location of para/local when
  5506. generating code for the current procedure
  5507. Revision 1.162 2003/09/07 22:09:35 peter
  5508. * preparations for different default calling conventions
  5509. * various RA fixes
  5510. Revision 1.161 2003/09/06 22:27:09 florian
  5511. * fixed web bug 2669
  5512. * cosmetic fix in printnode
  5513. * tobjectdef.gettypename implemented
  5514. Revision 1.160 2003/09/03 15:55:01 peter
  5515. * NEWRA branch merged
  5516. Revision 1.159 2003/09/03 11:18:37 florian
  5517. * fixed arm concatcopy
  5518. + arm support in the common compiler sources added
  5519. * moved some generic cg code around
  5520. + tfputype added
  5521. * ...
  5522. Revision 1.158.2.2 2003/08/29 17:28:59 peter
  5523. * next batch of updates
  5524. Revision 1.158.2.1 2003/08/27 19:55:54 peter
  5525. * first tregister patch
  5526. Revision 1.158 2003/08/11 21:18:20 peter
  5527. * start of sparc support for newra
  5528. Revision 1.157 2003/07/08 15:20:56 peter
  5529. * don't allow add/assignments for formaldef
  5530. * formaldef size changed to 0
  5531. Revision 1.156 2003/07/06 21:50:33 jonas
  5532. * fixed ppc compilation problems and changed VOLATILE_REGISTERS for x86
  5533. so that it doesn't include ebp and esp anymore
  5534. Revision 1.155 2003/07/06 15:31:21 daniel
  5535. * Fixed register allocator. *Lots* of fixes.
  5536. Revision 1.154 2003/07/02 22:18:04 peter
  5537. * paraloc splitted in callerparaloc,calleeparaloc
  5538. * sparc calling convention updates
  5539. Revision 1.153 2003/06/25 18:31:23 peter
  5540. * sym,def resolving partly rewritten to support also parent objects
  5541. not directly available through the uses clause
  5542. Revision 1.152 2003/06/17 16:34:44 jonas
  5543. * lots of newra fixes (need getfuncretparaloc implementation for i386)!
  5544. * renamed all_intregisters to paramanager.get_volatile_registers_int(pocall_default) and made it
  5545. processor dependent
  5546. Revision 1.151 2003/06/08 11:41:21 peter
  5547. * set parast.next to the owner of the procdef
  5548. Revision 1.150 2003/06/07 20:26:32 peter
  5549. * re-resolving added instead of reloading from ppu
  5550. * tderef object added to store deref info for resolving
  5551. Revision 1.149 2003/06/05 20:05:55 peter
  5552. * removed changesettype because that will change the definition
  5553. of the setdef forever and can result in a different between
  5554. original interface and current implementation definition
  5555. Revision 1.148 2003/06/03 13:01:59 daniel
  5556. * Register allocator finished
  5557. Revision 1.147 2003/06/02 22:55:28 florian
  5558. * classes and interfaces can be stored in integer registers
  5559. Revision 1.146 2003/05/26 21:17:18 peter
  5560. * procinlinenode removed
  5561. * aktexit2label removed, fast exit removed
  5562. + tcallnode.inlined_pass_2 added
  5563. Revision 1.145 2003/05/25 11:34:17 peter
  5564. * methodpointer self pushing fixed
  5565. Revision 1.144 2003/05/15 18:58:53 peter
  5566. * removed selfpointer_offset, vmtpointer_offset
  5567. * tvarsym.adjusted_address
  5568. * address in localsymtable is now in the real direction
  5569. * removed some obsolete globals
  5570. Revision 1.143 2003/05/13 08:13:16 jonas
  5571. * patch from Peter for rtti symbols
  5572. Revision 1.142 2003/05/11 21:37:03 peter
  5573. * moved implicit exception frame from ncgutil to psub
  5574. * constructor/destructor helpers moved from cobj/ncgutil to psub
  5575. Revision 1.141 2003/05/09 17:47:03 peter
  5576. * self moved to hidden parameter
  5577. * removed hdisposen,hnewn,selfn
  5578. Revision 1.140 2003/05/05 14:53:16 peter
  5579. * vs_hidden replaced by is_hidden boolean
  5580. Revision 1.139 2003/05/01 07:59:43 florian
  5581. * introduced defaultordconsttype to decribe the default size of ordinal constants
  5582. on 64 bit CPUs it's equal to cs64bitdef while on 32 bit CPUs it's equal to s32bitdef
  5583. + added defines CPU32 and CPU64 for 32 bit and 64 bit CPUs
  5584. * int64s/qwords are allowed as for loop counter on 64 bit CPUs
  5585. Revision 1.138 2003/04/27 11:21:34 peter
  5586. * aktprocdef renamed to current_procdef
  5587. * procinfo renamed to current_procinfo
  5588. * procinfo will now be stored in current_module so it can be
  5589. cleaned up properly
  5590. * gen_main_procsym changed to create_main_proc and release_main_proc
  5591. to also generate a tprocinfo structure
  5592. * fixed unit implicit initfinal
  5593. Revision 1.137 2003/04/27 07:29:51 peter
  5594. * current_procdef cleanup, current_procdef is now always nil when parsing
  5595. a new procdef declaration
  5596. * aktprocsym removed
  5597. * lexlevel removed, use symtable.symtablelevel instead
  5598. * implicit init/final code uses the normal genentry/genexit
  5599. * funcret state checking updated for new funcret handling
  5600. Revision 1.136 2003/04/25 20:59:35 peter
  5601. * removed funcretn,funcretsym, function result is now in varsym
  5602. and aliases for result and function name are added using absolutesym
  5603. * vs_hidden parameter for funcret passed in parameter
  5604. * vs_hidden fixes
  5605. * writenode changed to printnode and released from extdebug
  5606. * -vp option added to generate a tree.log with the nodetree
  5607. * nicer printnode for statements, callnode
  5608. Revision 1.135 2003/04/23 20:16:04 peter
  5609. + added currency support based on int64
  5610. + is_64bit for use in cg units instead of is_64bitint
  5611. * removed cgmessage from n386add, replace with internalerrors
  5612. Revision 1.134 2003/04/23 12:35:34 florian
  5613. * fixed several issues with powerpc
  5614. + applied a patch from Jonas for nested function calls (PowerPC only)
  5615. * ...
  5616. Revision 1.133 2003/04/10 17:57:53 peter
  5617. * vs_hidden released
  5618. Revision 1.132 2003/03/18 16:25:50 peter
  5619. * no itnernalerror for errordef.concatstabto()
  5620. Revision 1.131 2003/03/17 16:54:41 peter
  5621. * support DefaultHandler and anonymous inheritance fixed
  5622. for message methods
  5623. Revision 1.130 2003/03/17 15:54:22 peter
  5624. * store symoptions also for procdef
  5625. * check symoptions (private,public) when calculating possible
  5626. overload candidates
  5627. Revision 1.129 2003/02/19 22:00:14 daniel
  5628. * Code generator converted to new register notation
  5629. - Horribily outdated todo.txt removed
  5630. Revision 1.128 2003/02/02 19:25:54 carl
  5631. * Several bugfixes for m68k target (register alloc., opcode emission)
  5632. + VIS target
  5633. + Generic add more complete (still not verified)
  5634. Revision 1.127 2003/01/21 14:36:44 pierre
  5635. * set sizes needs to be passes in bits not bytes to stabs info
  5636. Revision 1.126 2003/01/16 22:11:33 peter
  5637. * fixed tprocdef.is_addressonly
  5638. Revision 1.125 2003/01/15 01:44:33 peter
  5639. * merged methodpointer fixes from 1.0.x
  5640. Revision 1.124 2003/01/09 21:52:37 peter
  5641. * merged some verbosity options.
  5642. * V_LineInfo is a verbosity flag to include line info
  5643. Revision 1.123 2003/01/06 21:16:52 peter
  5644. * po_addressonly added to retrieve the address of a methodpointer
  5645. only, this is used for @tclass.method which has no self pointer
  5646. Revision 1.122 2003/01/05 15:54:15 florian
  5647. + added proper support of type = type <type>; for simple types
  5648. Revision 1.121 2003/01/05 13:36:53 florian
  5649. * x86-64 compiles
  5650. + very basic support for float128 type (x86-64 only)
  5651. Revision 1.120 2003/01/02 19:49:00 peter
  5652. * update self parameter only for methodpointer and methods
  5653. Revision 1.119 2002/12/29 18:25:59 peter
  5654. * tprocdef.gettypename implemented
  5655. Revision 1.118 2002/12/27 15:23:09 peter
  5656. * write class methods in fullname
  5657. Revision 1.117 2002/12/15 19:34:31 florian
  5658. + some front end stuff for vs_hidden added
  5659. Revision 1.116 2002/12/15 11:26:02 peter
  5660. * ignore vs_hidden parameters when choosing overloaded proc
  5661. Revision 1.115 2002/12/07 14:27:09 carl
  5662. * 3% memory optimization
  5663. * changed some types
  5664. + added type checking with different size for call node and for
  5665. parameters
  5666. Revision 1.114 2002/12/01 22:05:27 carl
  5667. * no more warnings for structures over 32K since this is
  5668. handled correctly in this version of the compiler.
  5669. Revision 1.113 2002/11/27 20:04:09 peter
  5670. * tvarsym.get_push_size replaced by paramanager.push_size
  5671. Revision 1.112 2002/11/25 21:05:53 carl
  5672. * several mistakes fixed in message files
  5673. Revision 1.111 2002/11/25 18:43:33 carl
  5674. - removed the invalid if <> checking (Delphi is strange on this)
  5675. + implemented abstract warning on instance creation of class with
  5676. abstract methods.
  5677. * some error message cleanups
  5678. Revision 1.110 2002/11/25 17:43:24 peter
  5679. * splitted defbase in defutil,symutil,defcmp
  5680. * merged isconvertable and is_equal into compare_defs(_ext)
  5681. * made operator search faster by walking the list only once
  5682. Revision 1.109 2002/11/23 22:50:06 carl
  5683. * some small speed optimizations
  5684. + added several new warnings/hints
  5685. Revision 1.108 2002/11/22 22:48:10 carl
  5686. * memory optimization with tconstsym (1.5%)
  5687. Revision 1.107 2002/11/19 16:21:29 pierre
  5688. * correct several stabs generation problems
  5689. Revision 1.106 2002/11/18 17:31:59 peter
  5690. * pass proccalloption to ret_in_xxx and push_xxx functions
  5691. Revision 1.105 2002/11/17 16:31:57 carl
  5692. * memory optimization (3-4%) : cleanup of tai fields,
  5693. cleanup of tdef and tsym fields.
  5694. * make it work for m68k
  5695. Revision 1.104 2002/11/16 19:53:18 carl
  5696. * avoid Range check errors
  5697. Revision 1.103 2002/11/15 16:29:09 peter
  5698. * fixed rtti for int64 (merged)
  5699. Revision 1.102 2002/11/15 01:58:54 peter
  5700. * merged changes from 1.0.7 up to 04-11
  5701. - -V option for generating bug report tracing
  5702. - more tracing for option parsing
  5703. - errors for cdecl and high()
  5704. - win32 import stabs
  5705. - win32 records<=8 are returned in eax:edx (turned off by default)
  5706. - heaptrc update
  5707. - more info for temp management in .s file with EXTDEBUG
  5708. Revision 1.101 2002/11/09 15:31:02 carl
  5709. + align RTTI tables
  5710. Revision 1.100 2002/10/19 15:09:25 peter
  5711. + tobjectdef.members_need_inittable that is used to generate only the
  5712. inittable when it is really used. This saves a lot of useless calls
  5713. to fpc_finalize when destroying classes
  5714. Revision 1.99 2002/10/07 21:30:27 peter
  5715. * removed obsolete rangecheck stuff
  5716. Revision 1.98 2002/10/05 15:14:26 peter
  5717. * getparamangeldname for errordef
  5718. Revision 1.97 2002/10/05 12:43:28 carl
  5719. * fixes for Delphi 6 compilation
  5720. (warning : Some features do not work under Delphi)
  5721. Revision 1.96 2002/09/27 21:13:29 carl
  5722. * low-highval always checked if limit ober 2GB is reached (to avoid overflow)
  5723. Revision 1.95 2002/09/16 09:31:10 florian
  5724. * fixed currency size
  5725. Revision 1.94 2002/09/09 17:34:15 peter
  5726. * tdicationary.replace added to replace and item in a dictionary. This
  5727. is only allowed for the same name
  5728. * varsyms are inserted in symtable before the types are parsed. This
  5729. fixes the long standing "var longint : longint" bug
  5730. - consume_idlist and idstringlist removed. The loops are inserted
  5731. at the callers place and uses the symtable for duplicate id checking
  5732. Revision 1.93 2002/09/07 15:25:07 peter
  5733. * old logs removed and tabs fixed
  5734. Revision 1.92 2002/09/05 19:29:42 peter
  5735. * memdebug enhancements
  5736. Revision 1.91 2002/08/25 19:25:20 peter
  5737. * sym.insert_in_data removed
  5738. * symtable.insertvardata/insertconstdata added
  5739. * removed insert_in_data call from symtable.insert, it needs to be
  5740. called separatly. This allows to deref the address calculation
  5741. * procedures now calculate the parast addresses after the procedure
  5742. directives are parsed. This fixes the cdecl parast problem
  5743. * push_addr_param has an extra argument that specifies if cdecl is used
  5744. or not
  5745. Revision 1.90 2002/08/18 20:06:25 peter
  5746. * inlining is now also allowed in interface
  5747. * renamed write/load to ppuwrite/ppuload
  5748. * tnode storing in ppu
  5749. * nld,ncon,nbas are already updated for storing in ppu
  5750. Revision 1.89 2002/08/11 15:28:00 florian
  5751. + support of explicit type case <any ordinal type>->pointer
  5752. (delphi mode only)
  5753. Revision 1.88 2002/08/11 14:32:28 peter
  5754. * renamed current_library to objectlibrary
  5755. Revision 1.87 2002/08/11 13:24:13 peter
  5756. * saving of asmsymbols in ppu supported
  5757. * asmsymbollist global is removed and moved into a new class
  5758. tasmlibrarydata that will hold the info of a .a file which
  5759. corresponds with a single module. Added librarydata to tmodule
  5760. to keep the library info stored for the module. In the future the
  5761. objectfiles will also be stored to the tasmlibrarydata class
  5762. * all getlabel/newasmsymbol and friends are moved to the new class
  5763. Revision 1.86 2002/08/09 07:33:03 florian
  5764. * a couple of interface related fixes
  5765. Revision 1.85 2002/07/23 09:51:24 daniel
  5766. * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
  5767. are worth comitting.
  5768. Revision 1.84 2002/07/20 11:57:57 florian
  5769. * types.pas renamed to defbase.pas because D6 contains a types
  5770. unit so this would conflicts if D6 programms are compiled
  5771. + Willamette/SSE2 instructions to assembler added
  5772. Revision 1.83 2002/07/11 14:41:30 florian
  5773. * start of the new generic parameter handling
  5774. Revision 1.82 2002/07/07 09:52:32 florian
  5775. * powerpc target fixed, very simple units can be compiled
  5776. * some basic stuff for better callparanode handling, far from being finished
  5777. Revision 1.81 2002/07/01 18:46:26 peter
  5778. * internal linker
  5779. * reorganized aasm layer
  5780. Revision 1.80 2002/07/01 16:23:54 peter
  5781. * cg64 patch
  5782. * basics for currency
  5783. * asnode updates for class and interface (not finished)
  5784. Revision 1.79 2002/05/18 13:34:18 peter
  5785. * readded missing revisions
  5786. Revision 1.78 2002/05/16 19:46:44 carl
  5787. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  5788. + try to fix temp allocation (still in ifdef)
  5789. + generic constructor calls
  5790. + start of tassembler / tmodulebase class cleanup
  5791. Revision 1.76 2002/05/12 16:53:10 peter
  5792. * moved entry and exitcode to ncgutil and cgobj
  5793. * foreach gets extra argument for passing local data to the
  5794. iterator function
  5795. * -CR checks also class typecasts at runtime by changing them
  5796. into as
  5797. * fixed compiler to cycle with the -CR option
  5798. * fixed stabs with elf writer, finally the global variables can
  5799. be watched
  5800. * removed a lot of routines from cga unit and replaced them by
  5801. calls to cgobj
  5802. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  5803. u32bit then the other is typecasted also to u32bit without giving
  5804. a rangecheck warning/error.
  5805. * fixed pascal calling method with reversing also the high tree in
  5806. the parast, detected by tcalcst3 test
  5807. Revision 1.75 2002/04/25 20:16:39 peter
  5808. * moved more routines from cga/n386util
  5809. Revision 1.74 2002/04/23 19:16:35 peter
  5810. * add pinline unit that inserts compiler supported functions using
  5811. one or more statements
  5812. * moved finalize and setlength from ninl to pinline
  5813. Revision 1.73 2002/04/21 19:02:05 peter
  5814. * removed newn and disposen nodes, the code is now directly
  5815. inlined from pexpr
  5816. * -an option that will write the secondpass nodes to the .s file, this
  5817. requires EXTDEBUG define to actually write the info
  5818. * fixed various internal errors and crashes due recent code changes
  5819. Revision 1.72 2002/04/20 21:32:25 carl
  5820. + generic FPC_CHECKPOINTER
  5821. + first parameter offset in stack now portable
  5822. * rename some constants
  5823. + move some cpu stuff to other units
  5824. - remove unused constents
  5825. * fix stacksize for some targets
  5826. * fix generic size problems which depend now on EXTEND_SIZE constant
  5827. }