symdef.pas 172 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600
  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. symppu,ppu,
  30. { node }
  31. node,
  32. { aasm }
  33. aasmbase,aasmtai,cpubase,cpuinfo
  34. ;
  35. type
  36. {************************************************
  37. TDef
  38. ************************************************}
  39. tstoreddef = class(tdef)
  40. { persistent (available across units) rtti and init tables }
  41. rttitablesym,
  42. inittablesym : tsym; {trttisym}
  43. { local (per module) rtti and init tables }
  44. localrttilab : array[trttitype] of tasmlabel;
  45. { linked list of global definitions }
  46. nextglobal,
  47. previousglobal : tstoreddef;
  48. {$ifdef EXTDEBUG}
  49. fileinfo : tfileposinfo;
  50. {$endif}
  51. {$ifdef GDB}
  52. globalnb : word;
  53. is_def_stab_written : tdefstabstatus;
  54. {$endif GDB}
  55. constructor create;
  56. constructor loaddef(ppufile:tcompilerppufile);
  57. destructor destroy;override;
  58. procedure writedef(ppufile:tcompilerppufile);
  59. procedure write(ppufile:tcompilerppufile);virtual;abstract;
  60. procedure deref;override;
  61. procedure derefimpl;override;
  62. function size:longint;override;
  63. function alignment:longint;override;
  64. function is_publishable : boolean;override;
  65. function needs_inittable : boolean;override;
  66. { debug }
  67. {$ifdef GDB}
  68. function stabstring : pchar;virtual;
  69. procedure concatstabto(asmlist : taasmoutput);virtual;
  70. function NumberString:string;
  71. procedure set_globalnb;virtual;
  72. function allstabstring : pchar;virtual;
  73. {$endif GDB}
  74. { rtti generation }
  75. procedure write_rtti_name;
  76. procedure write_rtti_data(rt:trttitype);virtual;
  77. procedure write_child_rtti_data(rt:trttitype);virtual;
  78. function get_rtti_label(rt:trttitype):tasmsymbol;
  79. { regvars }
  80. function is_intregable : boolean;
  81. function is_fpuregable : boolean;
  82. private
  83. savesize : longint;
  84. end;
  85. tparaitem = class(TLinkedListItem)
  86. paratype : ttype;
  87. parasym : tsym;
  88. paratyp : tvarspez;
  89. argconvtyp : targconvtyp;
  90. convertlevel : byte;
  91. defaultvalue : tsym; { tconstsym }
  92. end;
  93. { this is only here to override the count method,
  94. which can't be used }
  95. tparalinkedlist = class(tlinkedlist)
  96. function count:longint;
  97. end;
  98. tfiletyp = (ft_text,ft_typed,ft_untyped);
  99. tfiledef = class(tstoreddef)
  100. filetyp : tfiletyp;
  101. typedfiletype : ttype;
  102. constructor createtext;
  103. constructor createuntyped;
  104. constructor createtyped(const tt : ttype);
  105. constructor load(ppufile:tcompilerppufile);
  106. procedure write(ppufile:tcompilerppufile);override;
  107. procedure deref;override;
  108. function gettypename:string;override;
  109. function getmangledparaname:string;override;
  110. procedure setsize;
  111. { debug }
  112. {$ifdef GDB}
  113. function stabstring : pchar;override;
  114. procedure concatstabto(asmlist : taasmoutput);override;
  115. {$endif GDB}
  116. end;
  117. tvariantdef = class(tstoreddef)
  118. constructor create;
  119. constructor load(ppufile:tcompilerppufile);
  120. function gettypename:string;override;
  121. procedure write(ppufile:tcompilerppufile);override;
  122. procedure setsize;
  123. function needs_inittable : boolean;override;
  124. procedure write_rtti_data(rt:trttitype);override;
  125. end;
  126. tformaldef = class(tstoreddef)
  127. constructor create;
  128. constructor load(ppufile:tcompilerppufile);
  129. procedure write(ppufile:tcompilerppufile);override;
  130. function gettypename:string;override;
  131. {$ifdef GDB}
  132. function stabstring : pchar;override;
  133. procedure concatstabto(asmlist : taasmoutput);override;
  134. {$endif GDB}
  135. end;
  136. tforwarddef = class(tstoreddef)
  137. tosymname : string;
  138. forwardpos : tfileposinfo;
  139. constructor create(const s:string;const pos : tfileposinfo);
  140. function gettypename:string;override;
  141. end;
  142. terrordef = class(tstoreddef)
  143. constructor create;
  144. function gettypename:string;override;
  145. { debug }
  146. {$ifdef GDB}
  147. function stabstring : pchar;override;
  148. {$endif GDB}
  149. end;
  150. { tpointerdef and tclassrefdef should get a common
  151. base class, but I derived tclassrefdef from tpointerdef
  152. to avoid problems with bugs (FK)
  153. }
  154. tpointerdef = class(tstoreddef)
  155. pointertype : ttype;
  156. is_far : boolean;
  157. constructor create(const tt : ttype);
  158. constructor createfar(const tt : ttype);
  159. constructor load(ppufile:tcompilerppufile);
  160. procedure write(ppufile:tcompilerppufile);override;
  161. procedure deref;override;
  162. function gettypename:string;override;
  163. { debug }
  164. {$ifdef GDB}
  165. function stabstring : pchar;override;
  166. procedure concatstabto(asmlist : taasmoutput);override;
  167. {$endif GDB}
  168. end;
  169. tabstractrecorddef = class(tstoreddef)
  170. private
  171. Count : integer;
  172. FRTTIType : trttitype;
  173. {$ifdef GDB}
  174. StabRecString : pchar;
  175. StabRecSize : Integer;
  176. RecOffset : Integer;
  177. procedure addname(p : tnamedindexitem;arg:pointer);
  178. {$endif}
  179. procedure count_field_rtti(sym : tnamedindexitem;arg:pointer);
  180. procedure write_field_rtti(sym : tnamedindexitem;arg:pointer);
  181. procedure generate_field_rtti(sym : tnamedindexitem;arg:pointer);
  182. public
  183. symtable : tsymtable;
  184. function getsymtable(t:tgetsymtable):tsymtable;override;
  185. end;
  186. trecorddef = class(tabstractrecorddef)
  187. public
  188. constructor create(p : tsymtable);
  189. constructor load(ppufile:tcompilerppufile);
  190. destructor destroy;override;
  191. procedure write(ppufile:tcompilerppufile);override;
  192. procedure deref;override;
  193. function size:longint;override;
  194. function alignment : longint;override;
  195. function gettypename:string;override;
  196. { debug }
  197. {$ifdef GDB}
  198. function stabstring : pchar;override;
  199. procedure concatstabto(asmlist : taasmoutput);override;
  200. {$endif GDB}
  201. function needs_inittable : boolean;override;
  202. { rtti }
  203. procedure write_child_rtti_data(rt:trttitype);override;
  204. procedure write_rtti_data(rt:trttitype);override;
  205. end;
  206. tprocdef = class;
  207. timplementedinterfaces = class;
  208. tobjectdef = class(tabstractrecorddef)
  209. private
  210. sd : tprocdef;
  211. procedure _searchdestructor(sym : tnamedindexitem;arg:pointer);
  212. {$ifdef GDB}
  213. procedure addprocname(p :tnamedindexitem;arg:pointer);
  214. {$endif GDB}
  215. procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
  216. procedure write_property_info(sym : tnamedindexitem;arg:pointer);
  217. procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
  218. procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
  219. procedure writefields(sym:tnamedindexitem;arg:pointer);
  220. public
  221. childof : tobjectdef;
  222. objname,
  223. objrealname : pstring;
  224. objectoptions : tobjectoptions;
  225. { to be able to have a variable vmt position }
  226. { and no vmt field for objects without virtuals }
  227. vmt_offset : longint;
  228. {$ifdef GDB}
  229. writing_class_record_stab : boolean;
  230. {$endif GDB}
  231. objecttype : tobjectdeftype;
  232. isiidguidvalid: boolean;
  233. iidguid: TGUID;
  234. iidstr: pstring;
  235. lastvtableindex: longint;
  236. { store implemented interfaces defs and name mappings }
  237. implementedinterfaces: timplementedinterfaces;
  238. constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
  239. constructor load(ppufile:tcompilerppufile);
  240. destructor destroy;override;
  241. procedure write(ppufile:tcompilerppufile);override;
  242. procedure deref;override;
  243. function size : longint;override;
  244. function alignment:longint;override;
  245. function vmtmethodoffset(index:longint):longint;
  246. function is_publishable : boolean;override;
  247. function needs_inittable : boolean;override;
  248. function vmt_mangledname : string;
  249. function rtti_name : string;
  250. procedure check_forwards;
  251. function is_related(d : tobjectdef) : boolean;
  252. function next_free_name_index : longint;
  253. procedure insertvmt;
  254. procedure set_parent(c : tobjectdef);
  255. function searchdestructor : tprocdef;
  256. { debug }
  257. {$ifdef GDB}
  258. function stabstring : pchar;override;
  259. procedure set_globalnb;override;
  260. function classnumberstring : string;
  261. procedure concatstabto(asmlist : taasmoutput);override;
  262. function allstabstring : pchar;override;
  263. {$endif GDB}
  264. { rtti }
  265. procedure write_child_rtti_data(rt:trttitype);override;
  266. procedure write_rtti_data(rt:trttitype);override;
  267. function generate_field_table : tasmlabel;
  268. end;
  269. timplementedinterfaces = class
  270. constructor create;
  271. destructor destroy; override;
  272. function count: longint;
  273. function interfaces(intfindex: longint): tobjectdef;
  274. function ioffsets(intfindex: longint): plongint;
  275. function searchintf(def: tdef): longint;
  276. procedure addintf(def: tdef);
  277. procedure deref;
  278. { add interface reference loaded from ppu }
  279. procedure addintfref(def: pointer);
  280. procedure clearmappings;
  281. procedure addmappings(intfindex: longint; const name, newname: string);
  282. function getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
  283. procedure clearimplprocs;
  284. procedure addimplproc(intfindex: longint; procdef: tprocdef);
  285. function implproccount(intfindex: longint): longint;
  286. function implprocs(intfindex: longint; procindex: longint): tprocdef;
  287. function isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
  288. private
  289. finterfaces: tindexarray;
  290. procedure checkindex(intfindex: longint);
  291. end;
  292. tclassrefdef = class(tpointerdef)
  293. constructor create(const t:ttype);
  294. constructor load(ppufile:tcompilerppufile);
  295. procedure write(ppufile:tcompilerppufile);override;
  296. function gettypename:string;override;
  297. { debug }
  298. {$ifdef GDB}
  299. function stabstring : pchar;override;
  300. procedure concatstabto(asmlist : taasmoutput);override;
  301. {$endif GDB}
  302. end;
  303. tarraydef = class(tstoreddef)
  304. rangenr : longint;
  305. lowrange,
  306. highrange : longint;
  307. elementtype,
  308. rangetype : ttype;
  309. IsDynamicArray,
  310. IsVariant,
  311. IsConstructor,
  312. IsArrayOfConst : boolean;
  313. function elesize : longint;
  314. constructor create(l,h : longint;const t : ttype);
  315. constructor load(ppufile:tcompilerppufile);
  316. procedure write(ppufile:tcompilerppufile);override;
  317. function gettypename:string;override;
  318. function getmangledparaname : string;override;
  319. {$ifdef GDB}
  320. function stabstring : pchar;override;
  321. procedure concatstabto(asmlist : taasmoutput);override;
  322. {$endif GDB}
  323. procedure deref;override;
  324. function size : longint;override;
  325. function alignment : longint;override;
  326. { generates the ranges needed by the asm instruction BOUND (i386)
  327. or CMP2 (Motorola) }
  328. procedure genrangecheck;
  329. { returns the label of the range check string }
  330. function getrangecheckstring : string;
  331. function needs_inittable : boolean;override;
  332. procedure write_child_rtti_data(rt:trttitype);override;
  333. procedure write_rtti_data(rt:trttitype);override;
  334. end;
  335. torddef = class(tstoreddef)
  336. rangenr : longint;
  337. low,high : TConstExprInt;
  338. typ : tbasetype;
  339. constructor create(t : tbasetype;v,b : TConstExprInt);
  340. constructor load(ppufile:tcompilerppufile);
  341. procedure write(ppufile:tcompilerppufile);override;
  342. function is_publishable : boolean;override;
  343. function gettypename:string;override;
  344. procedure setsize;
  345. { generates the ranges needed by the asm instruction BOUND }
  346. { or CMP2 (Motorola) }
  347. procedure genrangecheck;
  348. function getrangecheckstring : string;
  349. { debug }
  350. {$ifdef GDB}
  351. function stabstring : pchar;override;
  352. {$endif GDB}
  353. { rtti }
  354. procedure write_rtti_data(rt:trttitype);override;
  355. end;
  356. tfloatdef = class(tstoreddef)
  357. typ : tfloattype;
  358. constructor create(t : tfloattype);
  359. constructor load(ppufile:tcompilerppufile);
  360. procedure write(ppufile:tcompilerppufile);override;
  361. function gettypename:string;override;
  362. function is_publishable : boolean;override;
  363. procedure setsize;
  364. { debug }
  365. {$ifdef GDB}
  366. function stabstring : pchar;override;
  367. {$endif GDB}
  368. { rtti }
  369. procedure write_rtti_data(rt:trttitype);override;
  370. end;
  371. tabstractprocdef = class(tstoreddef)
  372. { saves a definition to the return type }
  373. rettype : ttype;
  374. proctypeoption : tproctypeoption;
  375. proccalloption : tproccalloption;
  376. procoptions : tprocoptions;
  377. para : tparalinkedlist;
  378. maxparacount,
  379. minparacount : longint;
  380. symtablelevel : byte;
  381. fpu_used : byte; { how many stack fpu must be empty }
  382. constructor create;
  383. constructor load(ppufile:tcompilerppufile);
  384. destructor destroy;override;
  385. procedure write(ppufile:tcompilerppufile);override;
  386. procedure deref;override;
  387. procedure concatpara(const tt:ttype;sym : tsym;vsp : tvarspez;defval:tsym);
  388. function para_size(alignsize:longint) : longint;
  389. function typename_paras : string;
  390. procedure test_if_fpu_result;
  391. { debug }
  392. {$ifdef GDB}
  393. function stabstring : pchar;override;
  394. procedure concatstabto(asmlist : taasmoutput);override;
  395. {$endif GDB}
  396. end;
  397. tprocvardef = class(tabstractprocdef)
  398. constructor create;
  399. constructor load(ppufile:tcompilerppufile);
  400. procedure write(ppufile:tcompilerppufile);override;
  401. function size : longint;override;
  402. function gettypename:string;override;
  403. function is_publishable : boolean;override;
  404. { debug }
  405. {$ifdef GDB}
  406. function stabstring : pchar;override;
  407. procedure concatstabto(asmlist : taasmoutput); override;
  408. {$endif GDB}
  409. { rtti }
  410. procedure write_rtti_data(rt:trttitype);override;
  411. end;
  412. tmessageinf = record
  413. case integer of
  414. 0 : (str : pchar);
  415. 1 : (i : longint);
  416. end;
  417. tprocdef = class(tabstractprocdef)
  418. private
  419. _mangledname : pstring;
  420. {$ifdef GDB}
  421. isstabwritten : boolean;
  422. {$endif GDB}
  423. public
  424. extnumber : word;
  425. overloadnumber : word;
  426. messageinf : tmessageinf;
  427. {$ifndef EXTDEBUG}
  428. { where is this function defined, needed here because there
  429. is only one symbol for all overloaded functions
  430. EXTDEBUG has fileinfo in tdef (PFV) }
  431. fileinfo : tfileposinfo;
  432. {$endif}
  433. { symbol owning this definition }
  434. procsym : tsym;
  435. { alias names }
  436. aliasnames : tstringlist;
  437. { symtables }
  438. parast,
  439. localst : tsymtable;
  440. funcretsym : tsym;
  441. { next is only used to check if RESULT is accessed,
  442. not stored in a tnode }
  443. resultfuncretsym : tsym;
  444. { browser info }
  445. lastref,
  446. defref,
  447. crossref,
  448. lastwritten : tref;
  449. refcount : longint;
  450. _class : tobjectdef;
  451. { it's a tree, but this not easy to handle }
  452. { used for inlined procs }
  453. code : tnode;
  454. { info about register variables (JM) }
  455. regvarinfo: pointer;
  456. { true, if the procedure is only declared }
  457. { (forward procedure) }
  458. forwarddef,
  459. { true if the procedure is declared in the interface }
  460. interfacedef : boolean;
  461. { true if the procedure has a forward declaration }
  462. hasforward : boolean;
  463. { check the problems of manglednames }
  464. has_mangledname : boolean;
  465. { small set which contains the modified registers }
  466. usedregisters : tregisterset;
  467. constructor create;
  468. constructor load(ppufile:tcompilerppufile);
  469. destructor destroy;override;
  470. procedure write(ppufile:tcompilerppufile);override;
  471. procedure deref;override;
  472. procedure derefimpl;override;
  473. function getsymtable(t:tgetsymtable):tsymtable;override;
  474. function haspara:boolean;
  475. function mangledname : string;
  476. procedure setmangledname(const s : string);
  477. procedure load_references(ppufile:tcompilerppufile;locals:boolean);
  478. function write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  479. function fullprocname:string;
  480. function fullprocnamewithret:string;
  481. function cplusplusmangledname : string;
  482. { debug }
  483. {$ifdef GDB}
  484. function stabstring : pchar;override;
  485. procedure concatstabto(asmlist : taasmoutput);override;
  486. {$endif GDB}
  487. end;
  488. { single linked list of overloaded procs }
  489. pprocdeflist = ^tprocdeflist;
  490. tprocdeflist = record
  491. def : tprocdef;
  492. next : pprocdeflist;
  493. end;
  494. tstringdef = class(tstoreddef)
  495. string_typ : tstringtype;
  496. len : longint;
  497. constructor createshort(l : byte);
  498. constructor loadshort(ppufile:tcompilerppufile);
  499. constructor createlong(l : longint);
  500. constructor loadlong(ppufile:tcompilerppufile);
  501. constructor createansi(l : longint);
  502. constructor loadansi(ppufile:tcompilerppufile);
  503. constructor createwide(l : longint);
  504. constructor loadwide(ppufile:tcompilerppufile);
  505. function stringtypname:string;
  506. function size : longint;override;
  507. procedure write(ppufile:tcompilerppufile);override;
  508. function gettypename:string;override;
  509. function getmangledparaname:string;override;
  510. function is_publishable : boolean;override;
  511. { debug }
  512. {$ifdef GDB}
  513. function stabstring : pchar;override;
  514. procedure concatstabto(asmlist : taasmoutput);override;
  515. {$endif GDB}
  516. { init/final }
  517. function needs_inittable : boolean;override;
  518. { rtti }
  519. procedure write_rtti_data(rt:trttitype);override;
  520. end;
  521. tenumdef = class(tstoreddef)
  522. rangenr,
  523. minval,
  524. maxval : longint;
  525. has_jumps : boolean;
  526. firstenum : tsym; {tenumsym}
  527. basedef : tenumdef;
  528. constructor create;
  529. constructor create_subrange(_basedef:tenumdef;_min,_max:longint);
  530. constructor load(ppufile:tcompilerppufile);
  531. destructor destroy;override;
  532. procedure write(ppufile:tcompilerppufile);override;
  533. procedure deref;override;
  534. function gettypename:string;override;
  535. function is_publishable : boolean;override;
  536. procedure calcsavesize;
  537. procedure setmax(_max:longint);
  538. procedure setmin(_min:longint);
  539. function min:longint;
  540. function max:longint;
  541. function getrangecheckstring:string;
  542. procedure genrangecheck;
  543. { debug }
  544. {$ifdef GDB}
  545. function stabstring : pchar;override;
  546. {$endif GDB}
  547. { rtti }
  548. procedure write_rtti_data(rt:trttitype);override;
  549. procedure write_child_rtti_data(rt:trttitype);override;
  550. private
  551. procedure correct_owner_symtable;
  552. end;
  553. tsetdef = class(tstoreddef)
  554. elementtype : ttype;
  555. settype : tsettype;
  556. constructor create(const t:ttype;high : longint);
  557. constructor load(ppufile:tcompilerppufile);
  558. destructor destroy;override;
  559. procedure write(ppufile:tcompilerppufile);override;
  560. procedure deref;override;
  561. function gettypename:string;override;
  562. function is_publishable : boolean;override;
  563. procedure changesettype(s:tsettype);
  564. { debug }
  565. {$ifdef GDB}
  566. function stabstring : pchar;override;
  567. procedure concatstabto(asmlist : taasmoutput);override;
  568. {$endif GDB}
  569. { rtti }
  570. procedure write_rtti_data(rt:trttitype);override;
  571. procedure write_child_rtti_data(rt:trttitype);override;
  572. end;
  573. var
  574. aktobjectdef : tobjectdef; { used for private functions check !! }
  575. firstglobaldef, { linked list of all globals defs }
  576. lastglobaldef : tstoreddef; { used to reset stabs/ranges }
  577. {$ifdef GDB}
  578. { for STAB debugging }
  579. globaltypecount : word;
  580. pglobaltypecount : pword;
  581. {$endif GDB}
  582. { default types }
  583. generrortype, { error in definition }
  584. voidpointertype, { pointer for Void-Pointerdef }
  585. charpointertype, { pointer for Char-Pointerdef }
  586. voidfarpointertype,
  587. cformaltype, { unique formal definition }
  588. voidtype, { Pointer to Void (procedure) }
  589. cchartype, { Pointer to Char }
  590. cwidechartype, { Pointer to WideChar }
  591. booltype, { pointer to boolean type }
  592. u8bittype, { Pointer to 8-Bit unsigned }
  593. u16bittype, { Pointer to 16-Bit unsigned }
  594. u32bittype, { Pointer to 32-Bit unsigned }
  595. s32bittype, { Pointer to 32-Bit signed }
  596. cu64bittype, { pointer to 64 bit unsigned def }
  597. cs64bittype, { pointer to 64 bit signed def, }
  598. s32floattype, { pointer for realconstn }
  599. s64floattype, { pointer for realconstn }
  600. s80floattype, { pointer to type of temp. floats }
  601. s64currencytype, { pointer to a currency type }
  602. s32fixedtype, { pointer to type of temp. fixed }
  603. cshortstringtype, { pointer to type of short string const }
  604. clongstringtype, { pointer to type of long string const }
  605. cansistringtype, { pointer to type of ansi string const }
  606. cwidestringtype, { pointer to type of wide string const }
  607. openshortstringtype, { pointer to type of an open shortstring,
  608. needed for readln() }
  609. openchararraytype, { pointer to type of an open array of char,
  610. needed for readln() }
  611. cfiletype, { get the same definition for all file }
  612. { used for stabs }
  613. cvarianttype, { we use only one variant def }
  614. pvmttype : ttype; { type of classrefs, used for stabs }
  615. class_tobject : tobjectdef; { pointer to the anchestor of all classes }
  616. interface_iunknown : tobjectdef; { KAZ: pointer to the ancestor }
  617. rec_tguid : trecorddef; { KAZ: pointer to the TGUID type }
  618. { of all interfaces }
  619. const
  620. {$ifdef i386}
  621. pbestrealtype : ^ttype = @s80floattype;
  622. {$endif}
  623. {$ifdef m68k}
  624. pbestrealtype : ^ttype = @s64floattype;
  625. {$endif}
  626. {$ifdef alpha}
  627. pbestrealtype : ^ttype = @s64floattype;
  628. {$endif}
  629. {$ifdef powerpc}
  630. pbestrealtype : ^ttype = @s64floattype;
  631. {$endif}
  632. {$ifdef ia64}
  633. pbestrealtype : ^ttype = @s64floattype;
  634. {$endif}
  635. {$ifdef SPARC}
  636. pbestrealtype : ^ttype = @s64floattype;
  637. {$endif SPARC}
  638. function mangledname_prefix(typeprefix:string;st:tsymtable):string;
  639. {$ifdef GDB}
  640. { GDB Helpers }
  641. function typeglobalnumber(const s : string) : string;
  642. {$endif GDB}
  643. { should be in the types unit, but the types unit uses the node stuff :( }
  644. function is_interfacecom(def: tdef): boolean;
  645. function is_interfacecorba(def: tdef): boolean;
  646. function is_interface(def: tdef): boolean;
  647. function is_object(def: tdef): boolean;
  648. function is_class(def: tdef): boolean;
  649. function is_cppclass(def: tdef): boolean;
  650. function is_class_or_interface(def: tdef): boolean;
  651. procedure reset_global_defs;
  652. implementation
  653. uses
  654. {$ifdef Delphi}
  655. sysutils,
  656. {$else Delphi}
  657. strings,
  658. {$endif Delphi}
  659. { global }
  660. verbose,
  661. { target }
  662. systems,
  663. { symtable }
  664. symsym,symtable,
  665. types,
  666. { module }
  667. {$ifdef GDB}
  668. gdb,
  669. {$endif GDB}
  670. fmodule,
  671. { other }
  672. gendef
  673. ;
  674. {****************************************************************************
  675. Helpers
  676. ****************************************************************************}
  677. function mangledname_prefix(typeprefix:string;st:tsymtable):string;
  678. var
  679. s,
  680. prefix : string;
  681. begin
  682. prefix:='';
  683. if not assigned(st) then
  684. internalerror(200204212);
  685. { sub procedures }
  686. while (st.symtabletype=localsymtable) do
  687. begin
  688. if st.defowner.deftype<>procdef then
  689. internalerror(200204173);
  690. s:=tprocdef(st.defowner).procsym.name;
  691. if tprocdef(st.defowner).overloadnumber>0 then
  692. s:=s+'$'+tostr(tprocdef(st.defowner).overloadnumber);
  693. prefix:=s+'$'+prefix;
  694. st:=st.defowner.owner;
  695. end;
  696. { object/classes symtable }
  697. if (st.symtabletype=objectsymtable) then
  698. begin
  699. if st.defowner.deftype<>objectdef then
  700. internalerror(200204174);
  701. prefix:=tobjectdef(st.defowner).objname^+'_$_'+prefix;
  702. st:=st.defowner.owner;
  703. end;
  704. { symtable must now be static or global }
  705. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  706. internalerror(200204175);
  707. mangledname_prefix:=typeprefix+'_'+st.name^+'_'+prefix;
  708. end;
  709. {$ifdef GDB}
  710. procedure forcestabto(asmlist : taasmoutput; pd : tdef);
  711. begin
  712. if tstoreddef(pd).is_def_stab_written = not_written then
  713. begin
  714. if assigned(pd.typesym) then
  715. ttypesym(pd.typesym).isusedinstab := true;
  716. tstoreddef(pd).concatstabto(asmlist);
  717. end;
  718. end;
  719. {$endif GDB}
  720. {****************************************************************************
  721. TDEF (base class for definitions)
  722. ****************************************************************************}
  723. constructor tstoreddef.create;
  724. begin
  725. inherited create;
  726. savesize := 0;
  727. {$ifdef EXTDEBUG}
  728. fileinfo := aktfilepos;
  729. {$endif}
  730. if registerdef then
  731. symtablestack.registerdef(self);
  732. {$ifdef GDB}
  733. is_def_stab_written := not_written;
  734. globalnb := 0;
  735. {$endif GDB}
  736. if assigned(lastglobaldef) then
  737. begin
  738. lastglobaldef.nextglobal := self;
  739. previousglobal:=lastglobaldef;
  740. end
  741. else
  742. begin
  743. firstglobaldef := self;
  744. previousglobal := nil;
  745. end;
  746. lastglobaldef := self;
  747. nextglobal := nil;
  748. fillchar(localrttilab,sizeof(localrttilab),0);
  749. end;
  750. {$ifdef MEMDEBUG}
  751. var
  752. manglenamesize : longint;
  753. {$endif}
  754. constructor tstoreddef.loaddef(ppufile:tcompilerppufile);
  755. begin
  756. inherited create;
  757. {$ifdef EXTDEBUG}
  758. fillchar(fileinfo,sizeof(fileinfo),0);
  759. {$endif}
  760. {$ifdef GDB}
  761. is_def_stab_written := not_written;
  762. globalnb := 0;
  763. {$endif GDB}
  764. if assigned(lastglobaldef) then
  765. begin
  766. lastglobaldef.nextglobal := self;
  767. previousglobal:=lastglobaldef;
  768. end
  769. else
  770. begin
  771. firstglobaldef := self;
  772. previousglobal:=nil;
  773. end;
  774. lastglobaldef := self;
  775. nextglobal := nil;
  776. fillchar(localrttilab,sizeof(localrttilab),0);
  777. { load }
  778. indexnr:=ppufile.getword;
  779. typesym:=ttypesym(pointer(ppufile.getderef));
  780. ppufile.getsmallset(defoptions);
  781. if df_has_rttitable in defoptions then
  782. rttitablesym:=tsym(ppufile.getderef);
  783. if df_has_inittable in defoptions then
  784. inittablesym:=tsym(ppufile.getderef);
  785. end;
  786. destructor tstoreddef.destroy;
  787. begin
  788. { first element ? }
  789. if not(assigned(previousglobal)) then
  790. begin
  791. firstglobaldef := nextglobal;
  792. if assigned(firstglobaldef) then
  793. firstglobaldef.previousglobal:=nil;
  794. end
  795. else
  796. begin
  797. { remove reference in the element before }
  798. previousglobal.nextglobal:=nextglobal;
  799. end;
  800. { last element ? }
  801. if not(assigned(nextglobal)) then
  802. begin
  803. lastglobaldef := previousglobal;
  804. if assigned(lastglobaldef) then
  805. lastglobaldef.nextglobal:=nil;
  806. end
  807. else
  808. nextglobal.previousglobal:=previousglobal;
  809. previousglobal:=nil;
  810. nextglobal:=nil;
  811. end;
  812. procedure tstoreddef.writedef(ppufile:tcompilerppufile);
  813. begin
  814. ppufile.putword(indexnr);
  815. ppufile.putderef(typesym);
  816. ppufile.putsmallset(defoptions);
  817. if df_has_rttitable in defoptions then
  818. ppufile.putderef(rttitablesym);
  819. if df_has_inittable in defoptions then
  820. ppufile.putderef(inittablesym);
  821. {$ifdef GDB}
  822. if globalnb = 0 then
  823. begin
  824. if assigned(owner) then
  825. globalnb := owner.getnewtypecount
  826. else
  827. begin
  828. globalnb := PGlobalTypeCount^;
  829. Inc(PGlobalTypeCount^);
  830. end;
  831. end;
  832. {$endif GDB}
  833. end;
  834. procedure tstoreddef.deref;
  835. begin
  836. resolvesym(pointer(typesym));
  837. resolvesym(pointer(rttitablesym));
  838. resolvesym(pointer(inittablesym));
  839. end;
  840. procedure tstoreddef.derefimpl;
  841. begin
  842. end;
  843. function tstoreddef.size : longint;
  844. begin
  845. size:=savesize;
  846. end;
  847. function tstoreddef.alignment : longint;
  848. begin
  849. { normal alignment by default }
  850. alignment:=0;
  851. end;
  852. {$ifdef GDB}
  853. procedure tstoreddef.set_globalnb;
  854. begin
  855. globalnb :=PGlobalTypeCount^;
  856. inc(PglobalTypeCount^);
  857. end;
  858. function tstoreddef.stabstring : pchar;
  859. begin
  860. stabstring := strpnew('t'+numberstring+';');
  861. end;
  862. function tstoreddef.numberstring : string;
  863. var table : tsymtable;
  864. begin
  865. {formal def have no type !}
  866. if deftype = formaldef then
  867. begin
  868. numberstring := tstoreddef(voidtype.def).numberstring;
  869. exit;
  870. end;
  871. if (not assigned(typesym)) or (not ttypesym(typesym).isusedinstab) then
  872. begin
  873. {set even if debuglist is not defined}
  874. if assigned(typesym) then
  875. ttypesym(typesym).isusedinstab := true;
  876. if assigned(debuglist) and (is_def_stab_written = not_written) then
  877. concatstabto(debuglist);
  878. end;
  879. if not (cs_gdb_dbx in aktglobalswitches) then
  880. begin
  881. if globalnb = 0 then
  882. set_globalnb;
  883. numberstring := tostr(globalnb);
  884. end
  885. else
  886. begin
  887. if globalnb = 0 then
  888. begin
  889. if assigned(owner) then
  890. globalnb := owner.getnewtypecount
  891. else
  892. begin
  893. globalnb := PGlobalTypeCount^;
  894. Inc(PGlobalTypeCount^);
  895. end;
  896. end;
  897. if assigned(typesym) then
  898. begin
  899. table := ttypesym(typesym).owner;
  900. if table.unitid > 0 then
  901. numberstring := '('+tostr(table.unitid)+','+tostr(tstoreddef(ttypesym(typesym).restype.def).globalnb)+')'
  902. else
  903. numberstring := tostr(globalnb);
  904. exit;
  905. end;
  906. numberstring := tostr(globalnb);
  907. end;
  908. end;
  909. function tstoreddef.allstabstring : pchar;
  910. var stabchar : string[2];
  911. ss,st : pchar;
  912. sname : string;
  913. sym_line_no : longint;
  914. begin
  915. ss := stabstring;
  916. getmem(st,strlen(ss)+512);
  917. stabchar := 't';
  918. if deftype in tagtypes then
  919. stabchar := 'Tt';
  920. if assigned(typesym) then
  921. begin
  922. sname := ttypesym(typesym).name;
  923. sym_line_no:=ttypesym(typesym).fileinfo.line;
  924. end
  925. else
  926. begin
  927. sname := ' ';
  928. sym_line_no:=0;
  929. end;
  930. strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
  931. strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
  932. allstabstring := strnew(st);
  933. freemem(st,strlen(ss)+512);
  934. strdispose(ss);
  935. end;
  936. procedure tstoreddef.concatstabto(asmlist : taasmoutput);
  937. var stab_str : pchar;
  938. begin
  939. if ((typesym = nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  940. and (is_def_stab_written = not_written) then
  941. begin
  942. If cs_gdb_dbx in aktglobalswitches then
  943. begin
  944. { otherwise you get two of each def }
  945. If assigned(typesym) then
  946. begin
  947. if ttypesym(typesym).typ=symconst.typesym then
  948. ttypesym(typesym).isusedinstab:=true;
  949. if (ttypesym(typesym).owner = nil) or
  950. ((ttypesym(typesym).owner.symtabletype = globalsymtable) and
  951. tglobalsymtable(ttypesym(typesym).owner).dbx_count_ok) then
  952. begin
  953. {with DBX we get the definition from the other objects }
  954. is_def_stab_written := written;
  955. exit;
  956. end;
  957. end;
  958. end;
  959. { to avoid infinite loops }
  960. is_def_stab_written := being_written;
  961. stab_str := allstabstring;
  962. asmList.concat(Tai_stabs.Create(stab_str));
  963. is_def_stab_written := written;
  964. end;
  965. end;
  966. {$endif GDB}
  967. procedure tstoreddef.write_rtti_name;
  968. var
  969. str : string;
  970. begin
  971. { name }
  972. if assigned(typesym) then
  973. begin
  974. str:=ttypesym(typesym).realname;
  975. rttiList.concat(Tai_string.Create(chr(length(str))+str));
  976. end
  977. else
  978. rttiList.concat(Tai_string.Create(#0))
  979. end;
  980. procedure tstoreddef.write_rtti_data(rt:trttitype);
  981. begin
  982. end;
  983. procedure tstoreddef.write_child_rtti_data(rt:trttitype);
  984. begin
  985. end;
  986. function tstoreddef.get_rtti_label(rt:trttitype) : tasmsymbol;
  987. begin
  988. { try to reuse persistent rtti data }
  989. if (rt=fullrtti) and (df_has_rttitable in defoptions) then
  990. get_rtti_label:=trttisym(rttitablesym).get_label
  991. else
  992. if (rt=initrtti) and (df_has_inittable in defoptions) then
  993. get_rtti_label:=trttisym(inittablesym).get_label
  994. else
  995. begin
  996. if not assigned(localrttilab[rt]) then
  997. begin
  998. getdatalabel(localrttilab[rt]);
  999. write_child_rtti_data(rt);
  1000. if (cs_create_smart in aktmoduleswitches) then
  1001. rttiList.concat(Tai_cut.Create);
  1002. rttiList.concat(Tai_symbol.Create(localrttilab[rt],0));
  1003. write_rtti_data(rt);
  1004. rttiList.concat(Tai_symbol_end.Create(localrttilab[rt]));
  1005. end;
  1006. get_rtti_label:=localrttilab[rt];
  1007. end;
  1008. end;
  1009. { returns true, if the definition can be published }
  1010. function tstoreddef.is_publishable : boolean;
  1011. begin
  1012. is_publishable:=false;
  1013. end;
  1014. { needs an init table }
  1015. function tstoreddef.needs_inittable : boolean;
  1016. begin
  1017. needs_inittable:=false;
  1018. end;
  1019. function tstoreddef.is_intregable : boolean;
  1020. begin
  1021. is_intregable:=false;
  1022. case deftype of
  1023. pointerdef,
  1024. enumdef:
  1025. is_intregable:=true;
  1026. procvardef :
  1027. is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions);
  1028. orddef :
  1029. case torddef(self).typ of
  1030. bool8bit,bool16bit,bool32bit,
  1031. u8bit,u16bit,u32bit,
  1032. s8bit,s16bit,s32bit:
  1033. is_intregable:=true;
  1034. end;
  1035. setdef:
  1036. is_intregable:=(tsetdef(self).settype=smallset);
  1037. end;
  1038. end;
  1039. function tstoreddef.is_fpuregable : boolean;
  1040. begin
  1041. is_fpuregable:=(deftype=floatdef);
  1042. end;
  1043. {****************************************************************************
  1044. TPARALINKEDLIST
  1045. ****************************************************************************}
  1046. function tparalinkedlist.count:longint;
  1047. begin
  1048. { You must use tabstractprocdef.minparacount and .maxparacount instead }
  1049. internalerror(432432978);
  1050. count:=0;
  1051. end;
  1052. {****************************************************************************
  1053. Tstringdef
  1054. ****************************************************************************}
  1055. constructor tstringdef.createshort(l : byte);
  1056. begin
  1057. inherited create;
  1058. string_typ:=st_shortstring;
  1059. deftype:=stringdef;
  1060. len:=l;
  1061. savesize:=len+1;
  1062. end;
  1063. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  1064. begin
  1065. inherited loaddef(ppufile);
  1066. string_typ:=st_shortstring;
  1067. deftype:=stringdef;
  1068. len:=ppufile.getbyte;
  1069. savesize:=len+1;
  1070. end;
  1071. constructor tstringdef.createlong(l : longint);
  1072. begin
  1073. inherited create;
  1074. string_typ:=st_longstring;
  1075. deftype:=stringdef;
  1076. len:=l;
  1077. savesize:=POINTER_SIZE;
  1078. end;
  1079. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1080. begin
  1081. inherited loaddef(ppufile);
  1082. deftype:=stringdef;
  1083. string_typ:=st_longstring;
  1084. len:=ppufile.getlongint;
  1085. savesize:=POINTER_SIZE;
  1086. end;
  1087. constructor tstringdef.createansi(l : longint);
  1088. begin
  1089. inherited create;
  1090. string_typ:=st_ansistring;
  1091. deftype:=stringdef;
  1092. len:=l;
  1093. savesize:=POINTER_SIZE;
  1094. end;
  1095. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1096. begin
  1097. inherited loaddef(ppufile);
  1098. deftype:=stringdef;
  1099. string_typ:=st_ansistring;
  1100. len:=ppufile.getlongint;
  1101. savesize:=POINTER_SIZE;
  1102. end;
  1103. constructor tstringdef.createwide(l : longint);
  1104. begin
  1105. inherited create;
  1106. string_typ:=st_widestring;
  1107. deftype:=stringdef;
  1108. len:=l;
  1109. savesize:=POINTER_SIZE;
  1110. end;
  1111. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1112. begin
  1113. inherited loaddef(ppufile);
  1114. deftype:=stringdef;
  1115. string_typ:=st_widestring;
  1116. len:=ppufile.getlongint;
  1117. savesize:=POINTER_SIZE;
  1118. end;
  1119. function tstringdef.stringtypname:string;
  1120. const
  1121. typname:array[tstringtype] of string[8]=('',
  1122. 'shortstr','longstr','ansistr','widestr'
  1123. );
  1124. begin
  1125. stringtypname:=typname[string_typ];
  1126. end;
  1127. function tstringdef.size : longint;
  1128. begin
  1129. size:=savesize;
  1130. end;
  1131. procedure tstringdef.write(ppufile:tcompilerppufile);
  1132. begin
  1133. inherited writedef(ppufile);
  1134. if string_typ=st_shortstring then
  1135. ppufile.putbyte(len)
  1136. else
  1137. ppufile.putlongint(len);
  1138. case string_typ of
  1139. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1140. st_longstring : ppufile.writeentry(iblongstringdef);
  1141. st_ansistring : ppufile.writeentry(ibansistringdef);
  1142. st_widestring : ppufile.writeentry(ibwidestringdef);
  1143. end;
  1144. end;
  1145. {$ifdef GDB}
  1146. function tstringdef.stabstring : pchar;
  1147. var
  1148. bytest,charst,longst : string;
  1149. begin
  1150. case string_typ of
  1151. st_shortstring:
  1152. begin
  1153. charst := typeglobalnumber('char');
  1154. { this is what I found in stabs.texinfo but
  1155. gdb 4.12 for go32 doesn't understand that !! }
  1156. {$IfDef GDBknowsstrings}
  1157. stabstring := strpnew('n'+charst+';'+tostr(len));
  1158. {$else}
  1159. bytest := typeglobalnumber('byte');
  1160. stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
  1161. +',0,8;st:ar'+bytest
  1162. +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
  1163. {$EndIf}
  1164. end;
  1165. st_longstring:
  1166. begin
  1167. charst := typeglobalnumber('char');
  1168. { this is what I found in stabs.texinfo but
  1169. gdb 4.12 for go32 doesn't understand that !! }
  1170. {$IfDef GDBknowsstrings}
  1171. stabstring := strpnew('n'+charst+';'+tostr(len));
  1172. {$else}
  1173. bytest := typeglobalnumber('byte');
  1174. longst := typeglobalnumber('longint');
  1175. stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
  1176. +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
  1177. +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
  1178. {$EndIf}
  1179. end;
  1180. st_ansistring:
  1181. begin
  1182. { an ansi string looks like a pchar easy !! }
  1183. stabstring:=strpnew('*'+typeglobalnumber('char'));
  1184. end;
  1185. st_widestring:
  1186. begin
  1187. { an ansi string looks like a pwidechar easy !! }
  1188. stabstring:=strpnew('*'+typeglobalnumber('widechar'));
  1189. end;
  1190. end;
  1191. end;
  1192. procedure tstringdef.concatstabto(asmlist : taasmoutput);
  1193. begin
  1194. inherited concatstabto(asmlist);
  1195. end;
  1196. {$endif GDB}
  1197. function tstringdef.needs_inittable : boolean;
  1198. begin
  1199. needs_inittable:=string_typ in [st_ansistring,st_widestring];
  1200. end;
  1201. function tstringdef.gettypename : string;
  1202. const
  1203. names : array[tstringtype] of string[20] = ('',
  1204. 'ShortString','LongString','AnsiString','WideString');
  1205. begin
  1206. gettypename:=names[string_typ];
  1207. end;
  1208. procedure tstringdef.write_rtti_data(rt:trttitype);
  1209. begin
  1210. case string_typ of
  1211. st_ansistring:
  1212. begin
  1213. rttiList.concat(Tai_const.Create_8bit(tkAString));
  1214. write_rtti_name;
  1215. end;
  1216. st_widestring:
  1217. begin
  1218. rttiList.concat(Tai_const.Create_8bit(tkWString));
  1219. write_rtti_name;
  1220. end;
  1221. st_longstring:
  1222. begin
  1223. rttiList.concat(Tai_const.Create_8bit(tkLString));
  1224. write_rtti_name;
  1225. end;
  1226. st_shortstring:
  1227. begin
  1228. rttiList.concat(Tai_const.Create_8bit(tkSString));
  1229. write_rtti_name;
  1230. rttiList.concat(Tai_const.Create_8bit(len));
  1231. end;
  1232. end;
  1233. end;
  1234. function tstringdef.getmangledparaname : string;
  1235. begin
  1236. getmangledparaname:='STRING';
  1237. end;
  1238. function tstringdef.is_publishable : boolean;
  1239. begin
  1240. is_publishable:=true;
  1241. end;
  1242. {****************************************************************************
  1243. TENUMDEF
  1244. ****************************************************************************}
  1245. constructor tenumdef.create;
  1246. begin
  1247. inherited create;
  1248. deftype:=enumdef;
  1249. minval:=0;
  1250. maxval:=0;
  1251. calcsavesize;
  1252. has_jumps:=false;
  1253. basedef:=nil;
  1254. rangenr:=0;
  1255. firstenum:=nil;
  1256. correct_owner_symtable;
  1257. end;
  1258. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:longint);
  1259. begin
  1260. inherited create;
  1261. deftype:=enumdef;
  1262. minval:=_min;
  1263. maxval:=_max;
  1264. basedef:=_basedef;
  1265. calcsavesize;
  1266. has_jumps:=false;
  1267. rangenr:=0;
  1268. firstenum:=basedef.firstenum;
  1269. while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
  1270. firstenum:=tenumsym(firstenum).nextenum;
  1271. correct_owner_symtable;
  1272. end;
  1273. constructor tenumdef.load(ppufile:tcompilerppufile);
  1274. begin
  1275. inherited loaddef(ppufile);
  1276. deftype:=enumdef;
  1277. basedef:=tenumdef(ppufile.getderef);
  1278. minval:=ppufile.getlongint;
  1279. maxval:=ppufile.getlongint;
  1280. savesize:=ppufile.getlongint;
  1281. has_jumps:=false;
  1282. firstenum:=Nil;
  1283. end;
  1284. procedure tenumdef.calcsavesize;
  1285. begin
  1286. if (aktpackenum=4) or (min<0) or (max>65535) then
  1287. savesize:=4
  1288. else
  1289. if (aktpackenum=2) or (min<0) or (max>255) then
  1290. savesize:=2
  1291. else
  1292. savesize:=1;
  1293. end;
  1294. procedure tenumdef.setmax(_max:longint);
  1295. begin
  1296. maxval:=_max;
  1297. calcsavesize;
  1298. end;
  1299. procedure tenumdef.setmin(_min:longint);
  1300. begin
  1301. minval:=_min;
  1302. calcsavesize;
  1303. end;
  1304. function tenumdef.min:longint;
  1305. begin
  1306. min:=minval;
  1307. end;
  1308. function tenumdef.max:longint;
  1309. begin
  1310. max:=maxval;
  1311. end;
  1312. procedure tenumdef.deref;
  1313. begin
  1314. inherited deref;
  1315. resolvedef(pointer(basedef));
  1316. end;
  1317. destructor tenumdef.destroy;
  1318. begin
  1319. inherited destroy;
  1320. end;
  1321. procedure tenumdef.write(ppufile:tcompilerppufile);
  1322. begin
  1323. inherited writedef(ppufile);
  1324. ppufile.putderef(basedef);
  1325. ppufile.putlongint(min);
  1326. ppufile.putlongint(max);
  1327. ppufile.putlongint(savesize);
  1328. ppufile.writeentry(ibenumdef);
  1329. end;
  1330. function tenumdef.getrangecheckstring : string;
  1331. begin
  1332. if (cs_create_smart in aktmoduleswitches) then
  1333. getrangecheckstring:='R_'+current_module.modulename^+tostr(rangenr)
  1334. else
  1335. getrangecheckstring:='R_'+tostr(rangenr);
  1336. end;
  1337. procedure tenumdef.genrangecheck;
  1338. begin
  1339. if rangenr=0 then
  1340. begin
  1341. { generate two constant for bounds }
  1342. getlabelnr(rangenr);
  1343. if (cs_create_smart in aktmoduleswitches) then
  1344. dataSegment.concat(Tai_symbol.Createname_global(getrangecheckstring,8))
  1345. else
  1346. dataSegment.concat(Tai_symbol.Createname(getrangecheckstring,8));
  1347. dataSegment.concat(Tai_const.Create_32bit(min));
  1348. dataSegment.concat(Tai_const.Create_32bit(max));
  1349. end;
  1350. end;
  1351. { used for enumdef because the symbols are
  1352. inserted in the owner symtable }
  1353. procedure tenumdef.correct_owner_symtable;
  1354. var
  1355. st : tsymtable;
  1356. begin
  1357. if assigned(owner) and
  1358. (owner.symtabletype in [recordsymtable,objectsymtable]) then
  1359. begin
  1360. owner.defindex.deleteindex(self);
  1361. st:=owner;
  1362. while (st.symtabletype in [recordsymtable,objectsymtable]) do
  1363. st:=st.next;
  1364. st.registerdef(self);
  1365. end;
  1366. end;
  1367. {$ifdef GDB}
  1368. function tenumdef.stabstring : pchar;
  1369. var st,st2 : pchar;
  1370. p : tenumsym;
  1371. s : string;
  1372. memsize : word;
  1373. begin
  1374. memsize := memsizeinc;
  1375. getmem(st,memsize);
  1376. { we can specify the size with @s<size>; prefix PM }
  1377. if savesize <> std_param_align then
  1378. strpcopy(st,'@s'+tostr(savesize*8)+';e')
  1379. else
  1380. strpcopy(st,'e');
  1381. p := tenumsym(firstenum);
  1382. while assigned(p) do
  1383. begin
  1384. s :=p.name+':'+tostr(p.value)+',';
  1385. { place for the ending ';' also }
  1386. if (strlen(st)+length(s)+1<memsize) then
  1387. strpcopy(strend(st),s)
  1388. else
  1389. begin
  1390. getmem(st2,memsize+memsizeinc);
  1391. strcopy(st2,st);
  1392. freemem(st,memsize);
  1393. st := st2;
  1394. memsize := memsize+memsizeinc;
  1395. strpcopy(strend(st),s);
  1396. end;
  1397. p := p.nextenum;
  1398. end;
  1399. strpcopy(strend(st),';');
  1400. stabstring := strnew(st);
  1401. freemem(st,memsize);
  1402. end;
  1403. {$endif GDB}
  1404. procedure tenumdef.write_child_rtti_data(rt:trttitype);
  1405. begin
  1406. if assigned(basedef) then
  1407. basedef.get_rtti_label(rt);
  1408. end;
  1409. procedure tenumdef.write_rtti_data(rt:trttitype);
  1410. var
  1411. hp : tenumsym;
  1412. begin
  1413. rttiList.concat(Tai_const.Create_8bit(tkEnumeration));
  1414. write_rtti_name;
  1415. case savesize of
  1416. 1:
  1417. rttiList.concat(Tai_const.Create_8bit(otUByte));
  1418. 2:
  1419. rttiList.concat(Tai_const.Create_8bit(otUWord));
  1420. 4:
  1421. rttiList.concat(Tai_const.Create_8bit(otULong));
  1422. end;
  1423. rttiList.concat(Tai_const.Create_32bit(min));
  1424. rttiList.concat(Tai_const.Create_32bit(max));
  1425. if assigned(basedef) then
  1426. rttiList.concat(Tai_const_symbol.Create(basedef.get_rtti_label(rt)))
  1427. else
  1428. rttiList.concat(Tai_const.Create_32bit(0));
  1429. hp:=tenumsym(firstenum);
  1430. while assigned(hp) do
  1431. begin
  1432. rttiList.concat(Tai_const.Create_8bit(length(hp.name)));
  1433. rttiList.concat(Tai_string.Create(lower(hp.name)));
  1434. hp:=hp.nextenum;
  1435. end;
  1436. rttiList.concat(Tai_const.Create_8bit(0));
  1437. end;
  1438. function tenumdef.is_publishable : boolean;
  1439. begin
  1440. is_publishable:=true;
  1441. end;
  1442. function tenumdef.gettypename : string;
  1443. begin
  1444. gettypename:='<enumeration type>';
  1445. end;
  1446. {****************************************************************************
  1447. TORDDEF
  1448. ****************************************************************************}
  1449. constructor torddef.create(t : tbasetype;v,b : TConstExprInt);
  1450. begin
  1451. inherited create;
  1452. deftype:=orddef;
  1453. low:=v;
  1454. high:=b;
  1455. typ:=t;
  1456. rangenr:=0;
  1457. setsize;
  1458. end;
  1459. constructor torddef.load(ppufile:tcompilerppufile);
  1460. var
  1461. l1,l2 : longint;
  1462. begin
  1463. inherited loaddef(ppufile);
  1464. deftype:=orddef;
  1465. typ:=tbasetype(ppufile.getbyte);
  1466. if sizeof(TConstExprInt)=8 then
  1467. begin
  1468. l1:=ppufile.getlongint;
  1469. l2:=ppufile.getlongint;
  1470. {$ifopt R+}
  1471. {$define Range_check_on}
  1472. {$endif opt R+}
  1473. {$R- needed here }
  1474. low:=qword(l1)+(int64(l2) shl 32);
  1475. {$ifdef Range_check_on}
  1476. {$R+}
  1477. {$undef Range_check_on}
  1478. {$endif Range_check_on}
  1479. end
  1480. else
  1481. low:=ppufile.getlongint;
  1482. if sizeof(TConstExprInt)=8 then
  1483. begin
  1484. l1:=ppufile.getlongint;
  1485. l2:=ppufile.getlongint;
  1486. {$ifopt R+}
  1487. {$define Range_check_on}
  1488. {$endif opt R+}
  1489. {$R- needed here }
  1490. high:=qword(l1)+(int64(l2) shl 32);
  1491. {$ifdef Range_check_on}
  1492. {$R+}
  1493. {$undef Range_check_on}
  1494. {$endif Range_check_on}
  1495. end
  1496. else
  1497. high:=ppufile.getlongint;
  1498. rangenr:=0;
  1499. setsize;
  1500. end;
  1501. procedure torddef.setsize;
  1502. begin
  1503. case typ of
  1504. u8bit,s8bit,
  1505. uchar,bool8bit:
  1506. savesize:=1;
  1507. u16bit,s16bit,
  1508. bool16bit,uwidechar:
  1509. savesize:=2;
  1510. s32bit,u32bit,
  1511. bool32bit:
  1512. savesize:=4;
  1513. u64bit,s64bit:
  1514. savesize:=8;
  1515. else
  1516. savesize:=0;
  1517. end;
  1518. { there are no entrys for range checking }
  1519. rangenr:=0;
  1520. end;
  1521. function torddef.getrangecheckstring : string;
  1522. begin
  1523. if (cs_create_smart in aktmoduleswitches) then
  1524. getrangecheckstring:='R_'+current_module.modulename^+tostr(rangenr)
  1525. else
  1526. getrangecheckstring:='R_'+tostr(rangenr);
  1527. end;
  1528. procedure torddef.genrangecheck;
  1529. var
  1530. rangechecksize : longint;
  1531. begin
  1532. if rangenr=0 then
  1533. begin
  1534. if low<=high then
  1535. rangechecksize:=8
  1536. else
  1537. rangechecksize:=16;
  1538. { generate two constant for bounds }
  1539. getlabelnr(rangenr);
  1540. if (cs_create_smart in aktmoduleswitches) then
  1541. dataSegment.concat(Tai_symbol.Createname_global(getrangecheckstring,rangechecksize))
  1542. else
  1543. dataSegment.concat(Tai_symbol.Createname(getrangecheckstring,rangechecksize));
  1544. if low<=high then
  1545. begin
  1546. dataSegment.concat(Tai_const.Create_32bit(low));
  1547. dataSegment.concat(Tai_const.Create_32bit(high));
  1548. end
  1549. { for u32bit we need two bounds }
  1550. else
  1551. begin
  1552. dataSegment.concat(Tai_const.Create_32bit(low));
  1553. dataSegment.concat(Tai_const.Create_32bit($7fffffff));
  1554. dataSegment.concat(Tai_const.Create_32bit(longint($80000000)));
  1555. dataSegment.concat(Tai_const.Create_32bit(high));
  1556. end;
  1557. end;
  1558. end;
  1559. procedure torddef.write(ppufile:tcompilerppufile);
  1560. begin
  1561. inherited writedef(ppufile);
  1562. ppufile.putbyte(byte(typ));
  1563. if sizeof(TConstExprInt)=8 then
  1564. begin
  1565. ppufile.putlongint(longint(lo(low)));
  1566. ppufile.putlongint(longint(hi(low)));
  1567. end
  1568. else
  1569. ppufile.putlongint(low);
  1570. if sizeof(TConstExprInt)=8 then
  1571. begin
  1572. ppufile.putlongint(longint(lo(high)));
  1573. ppufile.putlongint(longint(hi(high)));
  1574. end
  1575. else
  1576. ppufile.putlongint(high);
  1577. ppufile.writeentry(iborddef);
  1578. end;
  1579. {$ifdef GDB}
  1580. function torddef.stabstring : pchar;
  1581. begin
  1582. case typ of
  1583. uvoid : stabstring := strpnew(numberstring+';');
  1584. {GDB 4.12 for go32 doesn't like boolean as range for 0 to 1 !!!}
  1585. {$ifdef Use_integer_types_for_boolean}
  1586. bool8bit,
  1587. bool16bit,
  1588. bool32bit : stabstring := strpnew('r'+numberstring+';0;255;');
  1589. {$else : not Use_integer_types_for_boolean}
  1590. bool8bit : stabstring := strpnew('-21;');
  1591. bool16bit : stabstring := strpnew('-22;');
  1592. bool32bit : stabstring := strpnew('-23;');
  1593. u64bit : stabstring := strpnew('-32;');
  1594. s64bit : stabstring := strpnew('-31;');
  1595. {$endif not Use_integer_types_for_boolean}
  1596. {u32bit : stabstring := tstoreddef(s32bittype.def).numberstring+';0;-1;'); }
  1597. else
  1598. stabstring := strpnew('r'+tstoreddef(s32bittype.def).numberstring+';'+tostr(longint(low))+';'+tostr(longint(high))+';');
  1599. end;
  1600. end;
  1601. {$endif GDB}
  1602. procedure torddef.write_rtti_data(rt:trttitype);
  1603. procedure dointeger;
  1604. const
  1605. trans : array[tbasetype] of byte =
  1606. (otUByte{otNone},
  1607. otUByte,otUWord,otULong,otUByte{otNone},
  1608. otSByte,otSWord,otSLong,otUByte{otNone},
  1609. otUByte,otUWord,otULong,
  1610. otUByte,otUWord);
  1611. begin
  1612. write_rtti_name;
  1613. rttiList.concat(Tai_const.Create_8bit(byte(trans[typ])));
  1614. rttiList.concat(Tai_const.Create_32bit(longint(low)));
  1615. rttiList.concat(Tai_const.Create_32bit(longint(high)));
  1616. end;
  1617. begin
  1618. case typ of
  1619. s64bit :
  1620. begin
  1621. rttiList.concat(Tai_const.Create_8bit(tkInt64));
  1622. write_rtti_name;
  1623. { low }
  1624. rttiList.concat(Tai_const.Create_32bit($0));
  1625. rttiList.concat(Tai_const.Create_32bit($8000));
  1626. { high }
  1627. rttiList.concat(Tai_const.Create_32bit($ffff));
  1628. rttiList.concat(Tai_const.Create_32bit($7fff));
  1629. end;
  1630. u64bit :
  1631. begin
  1632. rttiList.concat(Tai_const.Create_8bit(tkQWord));
  1633. write_rtti_name;
  1634. { low }
  1635. rttiList.concat(Tai_const.Create_32bit($0));
  1636. rttiList.concat(Tai_const.Create_32bit($0));
  1637. { high }
  1638. rttiList.concat(Tai_const.Create_32bit($0));
  1639. rttiList.concat(Tai_const.Create_32bit($8000));
  1640. end;
  1641. bool8bit:
  1642. begin
  1643. rttiList.concat(Tai_const.Create_8bit(tkBool));
  1644. dointeger;
  1645. end;
  1646. uchar:
  1647. begin
  1648. rttiList.concat(Tai_const.Create_8bit(tkChar));
  1649. dointeger;
  1650. end;
  1651. uwidechar:
  1652. begin
  1653. rttiList.concat(Tai_const.Create_8bit(tkWChar));
  1654. dointeger;
  1655. end;
  1656. else
  1657. begin
  1658. rttiList.concat(Tai_const.Create_8bit(tkInteger));
  1659. dointeger;
  1660. end;
  1661. end;
  1662. end;
  1663. function torddef.is_publishable : boolean;
  1664. begin
  1665. is_publishable:=(typ<>uvoid);
  1666. end;
  1667. function torddef.gettypename : string;
  1668. const
  1669. names : array[tbasetype] of string[20] = (
  1670. 'untyped',
  1671. 'Byte','Word','DWord','QWord',
  1672. 'ShortInt','SmallInt','LongInt','Int64',
  1673. 'Boolean','WordBool','LongBool',
  1674. 'Char','WideChar');
  1675. begin
  1676. gettypename:=names[typ];
  1677. end;
  1678. {****************************************************************************
  1679. TFLOATDEF
  1680. ****************************************************************************}
  1681. constructor tfloatdef.create(t : tfloattype);
  1682. begin
  1683. inherited create;
  1684. deftype:=floatdef;
  1685. typ:=t;
  1686. setsize;
  1687. end;
  1688. constructor tfloatdef.load(ppufile:tcompilerppufile);
  1689. begin
  1690. inherited loaddef(ppufile);
  1691. deftype:=floatdef;
  1692. typ:=tfloattype(ppufile.getbyte);
  1693. setsize;
  1694. end;
  1695. procedure tfloatdef.setsize;
  1696. begin
  1697. case typ of
  1698. s32real : savesize:=4;
  1699. s64real : savesize:=8;
  1700. s80real : savesize:=extended_size;
  1701. s64comp : savesize:=8;
  1702. else
  1703. savesize:=0;
  1704. end;
  1705. end;
  1706. procedure tfloatdef.write(ppufile:tcompilerppufile);
  1707. begin
  1708. inherited writedef(ppufile);
  1709. ppufile.putbyte(byte(typ));
  1710. ppufile.writeentry(ibfloatdef);
  1711. end;
  1712. {$ifdef GDB}
  1713. function tfloatdef.stabstring : pchar;
  1714. begin
  1715. case typ of
  1716. s32real,
  1717. s64real : stabstring := strpnew('r'+
  1718. tstoreddef(s32bittype.def).numberstring+';'+tostr(savesize)+';0;');
  1719. { found this solution in stabsread.c from GDB v4.16 }
  1720. s64currency,
  1721. s64comp : stabstring := strpnew('r'+
  1722. tstoreddef(s32bittype.def).numberstring+';-'+tostr(savesize)+';0;');
  1723. { under dos at least you must give a size of twelve instead of 10 !! }
  1724. { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
  1725. s80real : stabstring := strpnew('r'+tstoreddef(s32bittype.def).numberstring+';12;0;');
  1726. else
  1727. internalerror(10005);
  1728. end;
  1729. end;
  1730. {$endif GDB}
  1731. procedure tfloatdef.write_rtti_data(rt:trttitype);
  1732. const
  1733. {tfloattype = (s32real,s64real,s80real,s64bit);}
  1734. translate : array[tfloattype] of byte =
  1735. (ftSingle,ftDouble,ftExtended,ftComp,ftCurr);
  1736. begin
  1737. rttiList.concat(Tai_const.Create_8bit(tkFloat));
  1738. write_rtti_name;
  1739. rttiList.concat(Tai_const.Create_8bit(translate[typ]));
  1740. end;
  1741. function tfloatdef.is_publishable : boolean;
  1742. begin
  1743. is_publishable:=true;
  1744. end;
  1745. function tfloatdef.gettypename : string;
  1746. const
  1747. names : array[tfloattype] of string[20] = (
  1748. 'Single','Double','Extended','Comp','Currency');
  1749. begin
  1750. gettypename:=names[typ];
  1751. end;
  1752. {****************************************************************************
  1753. TFILEDEF
  1754. ****************************************************************************}
  1755. constructor tfiledef.createtext;
  1756. begin
  1757. inherited create;
  1758. deftype:=filedef;
  1759. filetyp:=ft_text;
  1760. typedfiletype.reset;
  1761. setsize;
  1762. end;
  1763. constructor tfiledef.createuntyped;
  1764. begin
  1765. inherited create;
  1766. deftype:=filedef;
  1767. filetyp:=ft_untyped;
  1768. typedfiletype.reset;
  1769. setsize;
  1770. end;
  1771. constructor tfiledef.createtyped(const tt : ttype);
  1772. begin
  1773. inherited create;
  1774. deftype:=filedef;
  1775. filetyp:=ft_typed;
  1776. typedfiletype:=tt;
  1777. setsize;
  1778. end;
  1779. constructor tfiledef.load(ppufile:tcompilerppufile);
  1780. begin
  1781. inherited loaddef(ppufile);
  1782. deftype:=filedef;
  1783. filetyp:=tfiletyp(ppufile.getbyte);
  1784. if filetyp=ft_typed then
  1785. ppufile.gettype(typedfiletype)
  1786. else
  1787. typedfiletype.reset;
  1788. setsize;
  1789. end;
  1790. procedure tfiledef.deref;
  1791. begin
  1792. inherited deref;
  1793. if filetyp=ft_typed then
  1794. typedfiletype.resolve;
  1795. end;
  1796. procedure tfiledef.setsize;
  1797. begin
  1798. case filetyp of
  1799. ft_text :
  1800. savesize:=572;
  1801. ft_typed,
  1802. ft_untyped :
  1803. savesize:=316;
  1804. end;
  1805. end;
  1806. procedure tfiledef.write(ppufile:tcompilerppufile);
  1807. begin
  1808. inherited writedef(ppufile);
  1809. ppufile.putbyte(byte(filetyp));
  1810. if filetyp=ft_typed then
  1811. ppufile.puttype(typedfiletype);
  1812. ppufile.writeentry(ibfiledef);
  1813. end;
  1814. {$ifdef GDB}
  1815. function tfiledef.stabstring : pchar;
  1816. begin
  1817. {$IfDef GDBknowsfiles}
  1818. case filetyp of
  1819. ft_typed :
  1820. stabstring := strpnew('d'+typedfiletype.def.numberstring{+';'});
  1821. ft_untyped :
  1822. stabstring := strpnew('d'+voiddef.numberstring{+';'});
  1823. ft_text :
  1824. stabstring := strpnew('d'+cchartype^.numberstring{+';'});
  1825. end;
  1826. {$Else}
  1827. {based on
  1828. FileRec = Packed Record
  1829. Handle,
  1830. Mode,
  1831. RecSize : longint;
  1832. _private : array[1..32] of byte;
  1833. UserData : array[1..16] of byte;
  1834. name : array[0..255] of char;
  1835. End; }
  1836. { the buffer part is still missing !! (PM) }
  1837. { but the string could become too long !! }
  1838. stabstring := strpnew('s'+tostr(savesize)+
  1839. 'HANDLE:'+typeglobalnumber('longint')+',0,32;'+
  1840. 'MODE:'+typeglobalnumber('longint')+',32,32;'+
  1841. 'RECSIZE:'+typeglobalnumber('longint')+',64,32;'+
  1842. '_PRIVATE:ar'+typeglobalnumber('word')+';1;32;'+typeglobalnumber('byte')
  1843. +',96,256;'+
  1844. 'USERDATA:ar'+typeglobalnumber('word')+';1;16;'+typeglobalnumber('byte')
  1845. +',352,128;'+
  1846. 'NAME:ar'+typeglobalnumber('word')+';0;255;'+typeglobalnumber('char')
  1847. +',480,2048;;');
  1848. {$EndIf}
  1849. end;
  1850. procedure tfiledef.concatstabto(asmlist : taasmoutput);
  1851. begin
  1852. { most file defs are unnamed !!! }
  1853. if ((typesym = nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  1854. (is_def_stab_written = not_written) then
  1855. begin
  1856. if assigned(typedfiletype.def) then
  1857. forcestabto(asmlist,typedfiletype.def);
  1858. inherited concatstabto(asmlist);
  1859. end;
  1860. end;
  1861. {$endif GDB}
  1862. function tfiledef.gettypename : string;
  1863. begin
  1864. case filetyp of
  1865. ft_untyped:
  1866. gettypename:='File';
  1867. ft_typed:
  1868. gettypename:='File Of '+typedfiletype.def.typename;
  1869. ft_text:
  1870. gettypename:='Text'
  1871. end;
  1872. end;
  1873. function tfiledef.getmangledparaname : string;
  1874. begin
  1875. case filetyp of
  1876. ft_untyped:
  1877. getmangledparaname:='FILE';
  1878. ft_typed:
  1879. getmangledparaname:='FILE$OF$'+typedfiletype.def.mangledparaname;
  1880. ft_text:
  1881. getmangledparaname:='TEXT'
  1882. end;
  1883. end;
  1884. {****************************************************************************
  1885. TVARIANTDEF
  1886. ****************************************************************************}
  1887. constructor tvariantdef.create;
  1888. begin
  1889. inherited create;
  1890. deftype:=variantdef;
  1891. setsize;
  1892. end;
  1893. constructor tvariantdef.load(ppufile:tcompilerppufile);
  1894. begin
  1895. inherited loaddef(ppufile);
  1896. deftype:=variantdef;
  1897. setsize;
  1898. end;
  1899. procedure tvariantdef.write(ppufile:tcompilerppufile);
  1900. begin
  1901. inherited writedef(ppufile);
  1902. ppufile.writeentry(ibvariantdef);
  1903. end;
  1904. procedure tvariantdef.setsize;
  1905. begin
  1906. savesize:=16;
  1907. end;
  1908. function tvariantdef.gettypename : string;
  1909. begin
  1910. gettypename:='Variant';
  1911. end;
  1912. procedure tvariantdef.write_rtti_data(rt:trttitype);
  1913. begin
  1914. rttiList.concat(Tai_const.Create_8bit(tkVariant));
  1915. end;
  1916. function tvariantdef.needs_inittable : boolean;
  1917. begin
  1918. needs_inittable:=true;
  1919. end;
  1920. {****************************************************************************
  1921. TPOINTERDEF
  1922. ****************************************************************************}
  1923. constructor tpointerdef.create(const tt : ttype);
  1924. begin
  1925. inherited create;
  1926. deftype:=pointerdef;
  1927. pointertype:=tt;
  1928. is_far:=false;
  1929. savesize:=POINTER_SIZE;
  1930. end;
  1931. constructor tpointerdef.createfar(const tt : ttype);
  1932. begin
  1933. inherited create;
  1934. deftype:=pointerdef;
  1935. pointertype:=tt;
  1936. is_far:=true;
  1937. savesize:=POINTER_SIZE;
  1938. end;
  1939. constructor tpointerdef.load(ppufile:tcompilerppufile);
  1940. begin
  1941. inherited loaddef(ppufile);
  1942. deftype:=pointerdef;
  1943. ppufile.gettype(pointertype);
  1944. is_far:=(ppufile.getbyte<>0);
  1945. savesize:=POINTER_SIZE;
  1946. end;
  1947. procedure tpointerdef.deref;
  1948. begin
  1949. inherited deref;
  1950. pointertype.resolve;
  1951. end;
  1952. procedure tpointerdef.write(ppufile:tcompilerppufile);
  1953. begin
  1954. inherited writedef(ppufile);
  1955. ppufile.puttype(pointertype);
  1956. ppufile.putbyte(byte(is_far));
  1957. ppufile.writeentry(ibpointerdef);
  1958. end;
  1959. {$ifdef GDB}
  1960. function tpointerdef.stabstring : pchar;
  1961. begin
  1962. stabstring := strpnew('*'+tstoreddef(pointertype.def).numberstring);
  1963. end;
  1964. procedure tpointerdef.concatstabto(asmlist : taasmoutput);
  1965. var st,nb : string;
  1966. sym_line_no : longint;
  1967. begin
  1968. if assigned(pointertype.def) and
  1969. (pointertype.def.deftype=forwarddef) then
  1970. exit;
  1971. if ( (typesym=nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  1972. (is_def_stab_written = not_written) then
  1973. begin
  1974. is_def_stab_written := being_written;
  1975. if assigned(pointertype.def) and
  1976. (pointertype.def.deftype in [recorddef,objectdef]) then
  1977. begin
  1978. nb:=tstoreddef(pointertype.def).numberstring;
  1979. {to avoid infinite recursion in record with next-like fields }
  1980. if tstoreddef(pointertype.def).is_def_stab_written = being_written then
  1981. begin
  1982. if assigned(pointertype.def.typesym) then
  1983. begin
  1984. if assigned(typesym) then
  1985. begin
  1986. st := ttypesym(typesym).name;
  1987. sym_line_no:=ttypesym(typesym).fileinfo.line;
  1988. end
  1989. else
  1990. begin
  1991. st := ' ';
  1992. sym_line_no:=0;
  1993. end;
  1994. st := '"'+st+':t'+numberstring+'=*'+nb
  1995. +'=xs'+pointertype.def.typesym.name+':",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0';
  1996. asmList.concat(Tai_stabs.Create(strpnew(st)));
  1997. end;
  1998. end
  1999. else
  2000. begin
  2001. is_def_stab_written := not_written;
  2002. inherited concatstabto(asmlist);
  2003. end;
  2004. is_def_stab_written := written;
  2005. end
  2006. else
  2007. begin
  2008. if assigned(pointertype.def) then
  2009. forcestabto(asmlist,pointertype.def);
  2010. is_def_stab_written := not_written;
  2011. inherited concatstabto(asmlist);
  2012. end;
  2013. end;
  2014. end;
  2015. {$endif GDB}
  2016. function tpointerdef.gettypename : string;
  2017. begin
  2018. if is_far then
  2019. gettypename:='^'+pointertype.def.typename+';far'
  2020. else
  2021. gettypename:='^'+pointertype.def.typename;
  2022. end;
  2023. {****************************************************************************
  2024. TCLASSREFDEF
  2025. ****************************************************************************}
  2026. constructor tclassrefdef.create(const t:ttype);
  2027. begin
  2028. inherited create(t);
  2029. deftype:=classrefdef;
  2030. end;
  2031. constructor tclassrefdef.load(ppufile:tcompilerppufile);
  2032. begin
  2033. { be careful, tclassdefref inherits from tpointerdef }
  2034. inherited loaddef(ppufile);
  2035. deftype:=classrefdef;
  2036. ppufile.gettype(pointertype);
  2037. is_far:=false;
  2038. savesize:=POINTER_SIZE;
  2039. end;
  2040. procedure tclassrefdef.write(ppufile:tcompilerppufile);
  2041. begin
  2042. { be careful, tclassdefref inherits from tpointerdef }
  2043. inherited writedef(ppufile);
  2044. ppufile.puttype(pointertype);
  2045. ppufile.writeentry(ibclassrefdef);
  2046. end;
  2047. {$ifdef GDB}
  2048. function tclassrefdef.stabstring : pchar;
  2049. begin
  2050. stabstring:=strpnew(tstoreddef(pvmttype.def).numberstring+';');
  2051. end;
  2052. procedure tclassrefdef.concatstabto(asmlist : taasmoutput);
  2053. begin
  2054. inherited concatstabto(asmlist);
  2055. end;
  2056. {$endif GDB}
  2057. function tclassrefdef.gettypename : string;
  2058. begin
  2059. gettypename:='Class Of '+pointertype.def.typename;
  2060. end;
  2061. {***************************************************************************
  2062. TSETDEF
  2063. ***************************************************************************}
  2064. constructor tsetdef.create(const t:ttype;high : longint);
  2065. begin
  2066. inherited create;
  2067. deftype:=setdef;
  2068. elementtype:=t;
  2069. if high<32 then
  2070. begin
  2071. settype:=smallset;
  2072. {$ifdef testvarsets}
  2073. if aktsetalloc=0 THEN { $PACKSET Fixed?}
  2074. {$endif}
  2075. savesize:=Sizeof(longint)
  2076. {$ifdef testvarsets}
  2077. else {No, use $PACKSET VALUE for rounding}
  2078. savesize:=aktsetalloc*((high+aktsetalloc*8-1) DIV (aktsetalloc*8))
  2079. {$endif}
  2080. ;
  2081. end
  2082. else
  2083. if high<256 then
  2084. begin
  2085. settype:=normset;
  2086. savesize:=32;
  2087. end
  2088. else
  2089. {$ifdef testvarsets}
  2090. if high<$10000 then
  2091. begin
  2092. settype:=varset;
  2093. savesize:=4*((high+31) div 32);
  2094. end
  2095. else
  2096. {$endif testvarsets}
  2097. Message(sym_e_ill_type_decl_set);
  2098. end;
  2099. constructor tsetdef.load(ppufile:tcompilerppufile);
  2100. begin
  2101. inherited loaddef(ppufile);
  2102. deftype:=setdef;
  2103. ppufile.gettype(elementtype);
  2104. settype:=tsettype(ppufile.getbyte);
  2105. case settype of
  2106. normset : savesize:=32;
  2107. varset : savesize:=ppufile.getlongint;
  2108. smallset : savesize:=Sizeof(longint);
  2109. end;
  2110. end;
  2111. destructor tsetdef.destroy;
  2112. begin
  2113. inherited destroy;
  2114. end;
  2115. procedure tsetdef.write(ppufile:tcompilerppufile);
  2116. begin
  2117. inherited writedef(ppufile);
  2118. ppufile.puttype(elementtype);
  2119. ppufile.putbyte(byte(settype));
  2120. if settype=varset then
  2121. ppufile.putlongint(savesize);
  2122. ppufile.writeentry(ibsetdef);
  2123. end;
  2124. procedure tsetdef.changesettype(s:tsettype);
  2125. begin
  2126. case s of
  2127. smallset :
  2128. savesize:=sizeof(longint);
  2129. normset :
  2130. savesize:=32;
  2131. varset :
  2132. internalerror(200110201);
  2133. end;
  2134. settype:=s;
  2135. end;
  2136. {$ifdef GDB}
  2137. function tsetdef.stabstring : pchar;
  2138. begin
  2139. { For small sets write a longint, which can at least be seen
  2140. in the current GDB's (PFV)
  2141. this is obsolete with GDBPAS !!
  2142. and anyhow creates problems with version 4.18!! PM
  2143. if settype=smallset then
  2144. stabstring := strpnew('r'+s32bittype^.numberstring+';0;0xffffffff;')
  2145. else }
  2146. stabstring := strpnew('S'+tstoreddef(elementtype.def).numberstring);
  2147. end;
  2148. procedure tsetdef.concatstabto(asmlist : taasmoutput);
  2149. begin
  2150. if ( not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  2151. (is_def_stab_written = not_written) then
  2152. begin
  2153. if assigned(elementtype.def) then
  2154. forcestabto(asmlist,elementtype.def);
  2155. inherited concatstabto(asmlist);
  2156. end;
  2157. end;
  2158. {$endif GDB}
  2159. procedure tsetdef.deref;
  2160. begin
  2161. inherited deref;
  2162. elementtype.resolve;
  2163. end;
  2164. procedure tsetdef.write_child_rtti_data(rt:trttitype);
  2165. begin
  2166. tstoreddef(elementtype.def).get_rtti_label(rt);
  2167. end;
  2168. procedure tsetdef.write_rtti_data(rt:trttitype);
  2169. begin
  2170. rttiList.concat(Tai_const.Create_8bit(tkSet));
  2171. write_rtti_name;
  2172. rttiList.concat(Tai_const.Create_8bit(otULong));
  2173. rttiList.concat(Tai_const_symbol.Create(tstoreddef(elementtype.def).get_rtti_label(rt)));
  2174. end;
  2175. function tsetdef.is_publishable : boolean;
  2176. begin
  2177. is_publishable:=(settype=smallset);
  2178. end;
  2179. function tsetdef.gettypename : string;
  2180. begin
  2181. if assigned(elementtype.def) then
  2182. gettypename:='Set Of '+elementtype.def.typename
  2183. else
  2184. gettypename:='Empty Set';
  2185. end;
  2186. {***************************************************************************
  2187. TFORMALDEF
  2188. ***************************************************************************}
  2189. constructor tformaldef.create;
  2190. var
  2191. stregdef : boolean;
  2192. begin
  2193. stregdef:=registerdef;
  2194. registerdef:=false;
  2195. inherited create;
  2196. deftype:=formaldef;
  2197. registerdef:=stregdef;
  2198. { formaldef must be registered at unit level !! }
  2199. if registerdef and assigned(current_module) then
  2200. if assigned(current_module.localsymtable) then
  2201. tsymtable(current_module.localsymtable).registerdef(self)
  2202. else if assigned(current_module.globalsymtable) then
  2203. tsymtable(current_module.globalsymtable).registerdef(self);
  2204. savesize:=POINTER_SIZE;
  2205. end;
  2206. constructor tformaldef.load(ppufile:tcompilerppufile);
  2207. begin
  2208. inherited loaddef(ppufile);
  2209. deftype:=formaldef;
  2210. savesize:=POINTER_SIZE;
  2211. end;
  2212. procedure tformaldef.write(ppufile:tcompilerppufile);
  2213. begin
  2214. inherited writedef(ppufile);
  2215. ppufile.writeentry(ibformaldef);
  2216. end;
  2217. {$ifdef GDB}
  2218. function tformaldef.stabstring : pchar;
  2219. begin
  2220. stabstring := strpnew('formal'+numberstring+';');
  2221. end;
  2222. procedure tformaldef.concatstabto(asmlist : taasmoutput);
  2223. begin
  2224. { formaldef can't be stab'ed !}
  2225. end;
  2226. {$endif GDB}
  2227. function tformaldef.gettypename : string;
  2228. begin
  2229. gettypename:='Var';
  2230. end;
  2231. {***************************************************************************
  2232. TARRAYDEF
  2233. ***************************************************************************}
  2234. constructor tarraydef.create(l,h : longint;const t : ttype);
  2235. begin
  2236. inherited create;
  2237. deftype:=arraydef;
  2238. lowrange:=l;
  2239. highrange:=h;
  2240. rangetype:=t;
  2241. elementtype.reset;
  2242. IsVariant:=false;
  2243. IsConstructor:=false;
  2244. IsArrayOfConst:=false;
  2245. IsDynamicArray:=false;
  2246. rangenr:=0;
  2247. end;
  2248. constructor tarraydef.load(ppufile:tcompilerppufile);
  2249. begin
  2250. inherited loaddef(ppufile);
  2251. deftype:=arraydef;
  2252. { the addresses are calculated later }
  2253. ppufile.gettype(elementtype);
  2254. ppufile.gettype(rangetype);
  2255. lowrange:=ppufile.getlongint;
  2256. highrange:=ppufile.getlongint;
  2257. IsArrayOfConst:=boolean(ppufile.getbyte);
  2258. IsDynamicArray:=boolean(ppufile.getbyte);
  2259. IsVariant:=false;
  2260. IsConstructor:=false;
  2261. rangenr:=0;
  2262. end;
  2263. function tarraydef.getrangecheckstring : string;
  2264. begin
  2265. if (cs_create_smart in aktmoduleswitches) then
  2266. getrangecheckstring:='R_'+current_module.modulename^+tostr(rangenr)
  2267. else
  2268. getrangecheckstring:='R_'+tostr(rangenr);
  2269. end;
  2270. procedure tarraydef.genrangecheck;
  2271. begin
  2272. if rangenr=0 then
  2273. begin
  2274. { generates the data for range checking }
  2275. getlabelnr(rangenr);
  2276. if (cs_create_smart in aktmoduleswitches) then
  2277. dataSegment.concat(Tai_symbol.Createname_global(getrangecheckstring,8))
  2278. else
  2279. dataSegment.concat(Tai_symbol.Createname(getrangecheckstring,8));
  2280. if lowrange<=highrange then
  2281. begin
  2282. dataSegment.concat(Tai_const.Create_32bit(lowrange));
  2283. dataSegment.concat(Tai_const.Create_32bit(highrange));
  2284. end
  2285. { for big arrays we need two bounds }
  2286. else
  2287. begin
  2288. dataSegment.concat(Tai_const.Create_32bit(lowrange));
  2289. dataSegment.concat(Tai_const.Create_32bit($7fffffff));
  2290. dataSegment.concat(Tai_const.Create_32bit(longint($80000000)));
  2291. dataSegment.concat(Tai_const.Create_32bit(highrange));
  2292. end;
  2293. end;
  2294. end;
  2295. procedure tarraydef.deref;
  2296. begin
  2297. inherited deref;
  2298. elementtype.resolve;
  2299. rangetype.resolve;
  2300. end;
  2301. procedure tarraydef.write(ppufile:tcompilerppufile);
  2302. begin
  2303. inherited writedef(ppufile);
  2304. ppufile.puttype(elementtype);
  2305. ppufile.puttype(rangetype);
  2306. ppufile.putlongint(lowrange);
  2307. ppufile.putlongint(highrange);
  2308. ppufile.putbyte(byte(IsArrayOfConst));
  2309. ppufile.putbyte(byte(IsDynamicArray));
  2310. ppufile.writeentry(ibarraydef);
  2311. end;
  2312. {$ifdef GDB}
  2313. function tarraydef.stabstring : pchar;
  2314. begin
  2315. stabstring := strpnew('ar'+tstoreddef(rangetype.def).numberstring+';'
  2316. +tostr(lowrange)+';'+tostr(highrange)+';'+tstoreddef(elementtype.def).numberstring);
  2317. end;
  2318. procedure tarraydef.concatstabto(asmlist : taasmoutput);
  2319. begin
  2320. if (not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  2321. and (is_def_stab_written = not_written) then
  2322. begin
  2323. {when array are inserted they have no definition yet !!}
  2324. if assigned(elementtype.def) then
  2325. inherited concatstabto(asmlist);
  2326. end;
  2327. end;
  2328. {$endif GDB}
  2329. function tarraydef.elesize : longint;
  2330. begin
  2331. elesize:=elementtype.def.size;
  2332. end;
  2333. function tarraydef.size : longint;
  2334. var
  2335. newsize,
  2336. cachedsize: TConstExprInt;
  2337. begin
  2338. if IsDynamicArray then
  2339. begin
  2340. size:=POINTER_SIZE;
  2341. exit;
  2342. end;
  2343. {Tarraydef.size may never be called for an open array!}
  2344. if highrange<lowrange then
  2345. internalerror(99080501);
  2346. cachedsize := elesize;
  2347. If (cachedsize>0) and
  2348. (
  2349. (TConstExprInt(highrange)-TConstExprInt(lowrange) > $7fffffff) or
  2350. { () are needed around elesize-1 to avoid a possible
  2351. integer overflow for elesize=1 !! PM }
  2352. (($7fffffff div cachedsize + (cachedsize -1)) < (int64(highrange) - int64(lowrange)))
  2353. ) Then
  2354. Begin
  2355. Message(sym_e_segment_too_large);
  2356. size := 4
  2357. End
  2358. Else
  2359. begin
  2360. newsize:=(int64(highrange)-int64(lowrange)+1)*cachedsize;
  2361. { prevent an overflow }
  2362. if newsize>high(longint) then
  2363. size:=high(longint)
  2364. else
  2365. size:=newsize;
  2366. end
  2367. end;
  2368. function tarraydef.alignment : longint;
  2369. begin
  2370. { alignment is the size of the elements }
  2371. if elementtype.def.deftype=recorddef then
  2372. alignment:=elementtype.def.alignment
  2373. else
  2374. alignment:=elesize;
  2375. end;
  2376. function tarraydef.needs_inittable : boolean;
  2377. begin
  2378. needs_inittable:=IsDynamicArray or elementtype.def.needs_inittable;
  2379. end;
  2380. procedure tarraydef.write_child_rtti_data(rt:trttitype);
  2381. begin
  2382. tstoreddef(elementtype.def).get_rtti_label(rt);
  2383. end;
  2384. procedure tarraydef.write_rtti_data(rt:trttitype);
  2385. begin
  2386. if IsDynamicArray then
  2387. rttiList.concat(Tai_const.Create_8bit(tkdynarray))
  2388. else
  2389. rttiList.concat(Tai_const.Create_8bit(tkarray));
  2390. write_rtti_name;
  2391. { size of elements }
  2392. rttiList.concat(Tai_const.Create_32bit(elesize));
  2393. { count of elements }
  2394. if not(IsDynamicArray) then
  2395. rttiList.concat(Tai_const.Create_32bit(highrange-lowrange+1));
  2396. { element type }
  2397. rttiList.concat(Tai_const_symbol.Create(tstoreddef(elementtype.def).get_rtti_label(rt)));
  2398. { variant type }
  2399. // !!!!!!!!!!!!!!!!
  2400. end;
  2401. function tarraydef.gettypename : string;
  2402. begin
  2403. if isarrayofconst or isConstructor then
  2404. begin
  2405. if isvariant or ((highrange=-1) and (lowrange=0)) then
  2406. gettypename:='Array Of Const'
  2407. else
  2408. gettypename:='Array Of '+elementtype.def.typename;
  2409. end
  2410. else if ((highrange=-1) and (lowrange=0)) or IsDynamicArray then
  2411. gettypename:='Array Of '+elementtype.def.typename
  2412. else
  2413. begin
  2414. if rangetype.def.deftype=enumdef then
  2415. gettypename:='Array['+rangetype.def.typename+'] Of '+elementtype.def.typename
  2416. else
  2417. gettypename:='Array['+tostr(lowrange)+'..'+
  2418. tostr(highrange)+'] Of '+elementtype.def.typename
  2419. end;
  2420. end;
  2421. function tarraydef.getmangledparaname : string;
  2422. begin
  2423. if isarrayofconst then
  2424. getmangledparaname:='array_of_const'
  2425. else
  2426. if ((highrange=-1) and (lowrange=0)) then
  2427. getmangledparaname:='array_of_'+elementtype.def.mangledparaname
  2428. else
  2429. internalerror(200204176);
  2430. end;
  2431. {***************************************************************************
  2432. tabstractrecorddef
  2433. ***************************************************************************}
  2434. function tabstractrecorddef.getsymtable(t:tgetsymtable):tsymtable;
  2435. begin
  2436. if t=gs_record then
  2437. getsymtable:=symtable
  2438. else
  2439. getsymtable:=nil;
  2440. end;
  2441. {$ifdef GDB}
  2442. procedure tabstractrecorddef.addname(p : tnamedindexitem;arg:pointer);
  2443. var
  2444. news, newrec : pchar;
  2445. spec : string[3];
  2446. varsize : longint;
  2447. begin
  2448. { static variables from objects are like global objects }
  2449. if (sp_static in tsym(p).symoptions) then
  2450. exit;
  2451. If tsym(p).typ = varsym then
  2452. begin
  2453. if (sp_protected in tsym(p).symoptions) then
  2454. spec:='/1'
  2455. else if (sp_private in tsym(p).symoptions) then
  2456. spec:='/0'
  2457. else
  2458. spec:='';
  2459. if not assigned(tvarsym(p).vartype.def) then
  2460. writeln(tvarsym(p).name);
  2461. { class fields are pointers PM, obsolete now PM }
  2462. {if (tvarsym(p).vartype.def.deftype=objectdef) and
  2463. tobjectdef(tvarsym(p).vartype.def).is_class then
  2464. spec:=spec+'*'; }
  2465. varsize:=tvarsym(p).vartype.def.size;
  2466. { open arrays made overflows !! }
  2467. if varsize>$fffffff then
  2468. varsize:=$fffffff;
  2469. newrec := strpnew(p.name+':'+spec+tstoreddef(tvarsym(p).vartype.def).numberstring
  2470. +','+tostr(tvarsym(p).address*8)+','
  2471. +tostr(varsize*8)+';');
  2472. if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
  2473. begin
  2474. getmem(news,stabrecsize+memsizeinc);
  2475. strcopy(news,stabrecstring);
  2476. freemem(stabrecstring,stabrecsize);
  2477. stabrecsize:=stabrecsize+memsizeinc;
  2478. stabrecstring:=news;
  2479. end;
  2480. strcat(StabRecstring,newrec);
  2481. strdispose(newrec);
  2482. {This should be used for case !!}
  2483. inc(RecOffset,tvarsym(p).vartype.def.size);
  2484. end;
  2485. end;
  2486. {$endif GDB}
  2487. procedure tabstractrecorddef.count_field_rtti(sym : tnamedindexitem;arg:pointer);
  2488. begin
  2489. if (FRTTIType=fullrtti) or
  2490. ((tsym(sym).typ=varsym) and
  2491. tvarsym(sym).vartype.def.needs_inittable) then
  2492. inc(Count);
  2493. end;
  2494. procedure tabstractrecorddef.generate_field_rtti(sym:tnamedindexitem;arg:pointer);
  2495. begin
  2496. if (FRTTIType=fullrtti) or
  2497. ((tsym(sym).typ=varsym) and
  2498. tvarsym(sym).vartype.def.needs_inittable) then
  2499. tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(FRTTIType);
  2500. end;
  2501. procedure tabstractrecorddef.write_field_rtti(sym : tnamedindexitem;arg:pointer);
  2502. begin
  2503. if (FRTTIType=fullrtti) or
  2504. ((tsym(sym).typ=varsym) and
  2505. tvarsym(sym).vartype.def.needs_inittable) then
  2506. begin
  2507. rttiList.concat(Tai_const_symbol.Create(tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(FRTTIType)));
  2508. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym).address));
  2509. end;
  2510. end;
  2511. {***************************************************************************
  2512. trecorddef
  2513. ***************************************************************************}
  2514. constructor trecorddef.create(p : tsymtable);
  2515. begin
  2516. inherited create;
  2517. deftype:=recorddef;
  2518. symtable:=p;
  2519. symtable.defowner:=self;
  2520. { recordalign -1 means C record packing, that starts
  2521. with an alignment of 1 }
  2522. if aktalignment.recordalignmax=-1 then
  2523. symtable.dataalignment:=1
  2524. else
  2525. symtable.dataalignment:=aktalignment.recordalignmax;
  2526. end;
  2527. constructor trecorddef.load(ppufile:tcompilerppufile);
  2528. var
  2529. oldread_member : boolean;
  2530. begin
  2531. inherited loaddef(ppufile);
  2532. deftype:=recorddef;
  2533. savesize:=ppufile.getlongint;
  2534. oldread_member:=read_member;
  2535. read_member:=true;
  2536. symtable:=trecordsymtable.create;
  2537. trecordsymtable(symtable).load(ppufile);
  2538. read_member:=oldread_member;
  2539. symtable.defowner:=self;
  2540. end;
  2541. destructor trecorddef.destroy;
  2542. begin
  2543. if assigned(symtable) then
  2544. symtable.free;
  2545. inherited destroy;
  2546. end;
  2547. function trecorddef.needs_inittable : boolean;
  2548. begin
  2549. needs_inittable:=trecordsymtable(symtable).needs_init_final
  2550. end;
  2551. procedure trecorddef.deref;
  2552. var
  2553. oldrecsyms : tsymtable;
  2554. begin
  2555. inherited deref;
  2556. oldrecsyms:=aktrecordsymtable;
  2557. aktrecordsymtable:=symtable;
  2558. { now dereference the definitions }
  2559. tstoredsymtable(symtable).deref;
  2560. aktrecordsymtable:=oldrecsyms;
  2561. { assign TGUID? load only from system unit (unitid=1) }
  2562. if not(assigned(rec_tguid)) and
  2563. (upper(typename)='TGUID') and
  2564. assigned(owner) and
  2565. assigned(owner.name) and
  2566. (owner.name^='SYSTEM') then
  2567. rec_tguid:=self;
  2568. end;
  2569. procedure trecorddef.write(ppufile:tcompilerppufile);
  2570. var
  2571. oldread_member : boolean;
  2572. begin
  2573. oldread_member:=read_member;
  2574. read_member:=true;
  2575. inherited writedef(ppufile);
  2576. ppufile.putlongint(savesize);
  2577. ppufile.writeentry(ibrecorddef);
  2578. trecordsymtable(symtable).write(ppufile);
  2579. read_member:=oldread_member;
  2580. end;
  2581. function trecorddef.size:longint;
  2582. begin
  2583. size:=symtable.datasize;
  2584. end;
  2585. function trecorddef.alignment:longint;
  2586. var
  2587. l : longint;
  2588. hp : tvarsym;
  2589. begin
  2590. { also check the first symbol for it's size, because a
  2591. packed record has dataalignment of 1, but the first
  2592. sym could be a longint which should be aligned on 4 bytes,
  2593. this is compatible with C record packing (PFV) }
  2594. hp:=tvarsym(symtable.symindex.first);
  2595. if assigned(hp) then
  2596. begin
  2597. if hp.vartype.def.deftype in [recorddef,arraydef] then
  2598. l:=hp.vartype.def.alignment
  2599. else
  2600. l:=hp.vartype.def.size;
  2601. if l>symtable.dataalignment then
  2602. begin
  2603. if l>=4 then
  2604. alignment:=4
  2605. else
  2606. if l>=2 then
  2607. alignment:=2
  2608. else
  2609. alignment:=1;
  2610. end
  2611. else
  2612. alignment:=symtable.dataalignment;
  2613. end
  2614. else
  2615. alignment:=symtable.dataalignment;
  2616. end;
  2617. {$ifdef GDB}
  2618. function trecorddef.stabstring : pchar;
  2619. begin
  2620. GetMem(stabrecstring,memsizeinc);
  2621. stabrecsize:=memsizeinc;
  2622. strpcopy(stabRecString,'s'+tostr(size));
  2623. RecOffset := 0;
  2624. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,nil);
  2625. strpcopy(strend(StabRecString),';');
  2626. stabstring := strnew(StabRecString);
  2627. Freemem(stabrecstring,stabrecsize);
  2628. end;
  2629. procedure trecorddef.concatstabto(asmlist : taasmoutput);
  2630. begin
  2631. if (not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  2632. (is_def_stab_written = not_written) then
  2633. inherited concatstabto(asmlist);
  2634. end;
  2635. {$endif GDB}
  2636. procedure trecorddef.write_child_rtti_data(rt:trttitype);
  2637. begin
  2638. FRTTIType:=rt;
  2639. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
  2640. end;
  2641. procedure trecorddef.write_rtti_data(rt:trttitype);
  2642. begin
  2643. rttiList.concat(Tai_const.Create_8bit(tkrecord));
  2644. write_rtti_name;
  2645. rttiList.concat(Tai_const.Create_32bit(size));
  2646. Count:=0;
  2647. FRTTIType:=rt;
  2648. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
  2649. rttiList.concat(Tai_const.Create_32bit(Count));
  2650. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
  2651. end;
  2652. function trecorddef.gettypename : string;
  2653. begin
  2654. gettypename:='<record type>'
  2655. end;
  2656. {***************************************************************************
  2657. TABSTRACTPROCDEF
  2658. ***************************************************************************}
  2659. constructor tabstractprocdef.create;
  2660. begin
  2661. inherited create;
  2662. para:=TParaLinkedList.Create;
  2663. minparacount:=0;
  2664. maxparacount:=0;
  2665. proctypeoption:=potype_none;
  2666. proccalloption:=pocall_none;
  2667. procoptions:=[];
  2668. rettype:=voidtype;
  2669. symtablelevel:=0;
  2670. fpu_used:=0;
  2671. savesize:=POINTER_SIZE;
  2672. end;
  2673. destructor tabstractprocdef.destroy;
  2674. begin
  2675. Para.Free;
  2676. inherited destroy;
  2677. end;
  2678. procedure tabstractprocdef.concatpara(const tt:ttype;sym : tsym;vsp : tvarspez;defval:tsym);
  2679. var
  2680. hp : TParaItem;
  2681. begin
  2682. hp:=TParaItem.Create;
  2683. hp.paratyp:=vsp;
  2684. hp.parasym:=sym;
  2685. hp.paratype:=tt;
  2686. hp.defaultvalue:=defval;
  2687. Para.insert(hp);
  2688. if not assigned(defval) then
  2689. inc(minparacount);
  2690. inc(maxparacount);
  2691. end;
  2692. { all functions returning in FPU are
  2693. assume to use 2 FPU registers
  2694. until the function implementation
  2695. is processed PM }
  2696. procedure tabstractprocdef.test_if_fpu_result;
  2697. begin
  2698. if assigned(rettype.def) and
  2699. (rettype.def.deftype=floatdef) then
  2700. {$ifdef FAST_FPU}
  2701. fpu_used:=3;
  2702. {$else : not FAST_FPU, i.e. SAFE_FPU}
  2703. fpu_used:={2}maxfpuregs;
  2704. {$endif FAST_FPU}
  2705. end;
  2706. procedure tabstractprocdef.deref;
  2707. var
  2708. hp : TParaItem;
  2709. begin
  2710. inherited deref;
  2711. rettype.resolve;
  2712. hp:=TParaItem(Para.first);
  2713. while assigned(hp) do
  2714. begin
  2715. hp.paratype.resolve;
  2716. resolvesym(pointer(hp.defaultvalue));
  2717. resolvesym(pointer(hp.parasym));
  2718. hp:=TParaItem(hp.next);
  2719. end;
  2720. end;
  2721. constructor tabstractprocdef.load(ppufile:tcompilerppufile);
  2722. var
  2723. hp : TParaItem;
  2724. count,i : word;
  2725. begin
  2726. inherited loaddef(ppufile);
  2727. Para:=TParaLinkedList.Create;
  2728. minparacount:=0;
  2729. maxparacount:=0;
  2730. ppufile.gettype(rettype);
  2731. fpu_used:=ppufile.getbyte;
  2732. proctypeoption:=tproctypeoption(ppufile.getbyte);
  2733. proccalloption:=tproccalloption(ppufile.getbyte);
  2734. ppufile.getsmallset(procoptions);
  2735. count:=ppufile.getword;
  2736. savesize:=POINTER_SIZE;
  2737. for i:=1 to count do
  2738. begin
  2739. hp:=TParaItem.Create;
  2740. hp.paratyp:=tvarspez(ppufile.getbyte);
  2741. { hp.register:=tregister(ppufile.getbyte); }
  2742. ppufile.gettype(hp.paratype);
  2743. hp.defaultvalue:=tsym(ppufile.getderef);
  2744. hp.parasym:=tsym(ppufile.getderef);
  2745. if not assigned(hp.defaultvalue) then
  2746. inc(minparacount);
  2747. inc(maxparacount);
  2748. Para.concat(hp);
  2749. end;
  2750. end;
  2751. procedure tabstractprocdef.write(ppufile:tcompilerppufile);
  2752. var
  2753. hp : TParaItem;
  2754. oldintfcrc : boolean;
  2755. begin
  2756. inherited writedef(ppufile);
  2757. ppufile.puttype(rettype);
  2758. oldintfcrc:=ppufile.do_interface_crc;
  2759. ppufile.do_interface_crc:=false;
  2760. if simplify_ppu then
  2761. fpu_used:=0;
  2762. ppufile.putbyte(fpu_used);
  2763. ppufile.putbyte(ord(proctypeoption));
  2764. ppufile.putbyte(ord(proccalloption));
  2765. ppufile.putsmallset(procoptions);
  2766. ppufile.do_interface_crc:=oldintfcrc;
  2767. ppufile.putword(maxparacount);
  2768. hp:=TParaItem(Para.first);
  2769. while assigned(hp) do
  2770. begin
  2771. ppufile.putbyte(byte(hp.paratyp));
  2772. { ppufile.putbyte(byte(hp.register)); }
  2773. ppufile.puttype(hp.paratype);
  2774. ppufile.putderef(hp.defaultvalue);
  2775. ppufile.putderef(hp.parasym);
  2776. hp:=TParaItem(hp.next);
  2777. end;
  2778. end;
  2779. function tabstractprocdef.para_size(alignsize:longint) : longint;
  2780. var
  2781. pdc : TParaItem;
  2782. l : longint;
  2783. begin
  2784. l:=0;
  2785. pdc:=TParaItem(Para.first);
  2786. while assigned(pdc) do
  2787. begin
  2788. case pdc.paratyp of
  2789. vs_out,
  2790. vs_var : inc(l,POINTER_SIZE);
  2791. vs_value,
  2792. vs_const : if push_addr_param(pdc.paratype.def) then
  2793. inc(l,POINTER_SIZE)
  2794. else
  2795. inc(l,pdc.paratype.def.size);
  2796. end;
  2797. l:=align(l,alignsize);
  2798. pdc:=TParaItem(pdc.next);
  2799. end;
  2800. para_size:=l;
  2801. end;
  2802. function tabstractprocdef.typename_paras : string;
  2803. var
  2804. hs,s : string;
  2805. hp : TParaItem;
  2806. hpc : tconstsym;
  2807. begin
  2808. hp:=TParaItem(Para.last);
  2809. if not(assigned(hp)) then
  2810. begin
  2811. typename_paras:='';
  2812. exit;
  2813. end;
  2814. s:='(';
  2815. while assigned(hp) do
  2816. begin
  2817. if hp.paratyp=vs_var then
  2818. s:=s+'var'
  2819. else if hp.paratyp=vs_const then
  2820. s:=s+'const'
  2821. else if hp.paratyp=vs_out then
  2822. s:=s+'out';
  2823. if assigned(hp.paratype.def.typesym) then
  2824. begin
  2825. if hp.paratyp in [vs_var,vs_const,vs_out] then
  2826. s := s + ' ';
  2827. s:=s+hp.paratype.def.typesym.realname;
  2828. end;
  2829. { default value }
  2830. if assigned(hp.defaultvalue) then
  2831. begin
  2832. hpc:=tconstsym(hp.defaultvalue);
  2833. hs:='';
  2834. case hpc.consttyp of
  2835. conststring,
  2836. constresourcestring :
  2837. hs:=strpas(pchar(hpc.valueptr));
  2838. constreal :
  2839. str(pbestreal(hpc.valueptr)^,hs);
  2840. constord :
  2841. hs:=tostr(hpc.valueord);
  2842. constpointer :
  2843. hs:=tostr(hpc.valueordptr);
  2844. constbool :
  2845. begin
  2846. if hpc.valueord<>0 then
  2847. hs:='TRUE'
  2848. else
  2849. hs:='FALSE';
  2850. end;
  2851. constnil :
  2852. hs:='nil';
  2853. constchar :
  2854. hs:=chr(hpc.valueord);
  2855. constset :
  2856. hs:='<set>';
  2857. end;
  2858. if hs<>'' then
  2859. s:=s+'="'+hs+'"';
  2860. end;
  2861. hp:=TParaItem(hp.previous);
  2862. if assigned(hp) then
  2863. s:=s+',';
  2864. end;
  2865. s:=s+')';
  2866. if (po_varargs in procoptions) then
  2867. s:=s+';VarArgs';
  2868. typename_paras:=s;
  2869. end;
  2870. {$ifdef GDB}
  2871. function tabstractprocdef.stabstring : pchar;
  2872. begin
  2873. stabstring := strpnew('abstractproc'+numberstring+';');
  2874. end;
  2875. procedure tabstractprocdef.concatstabto(asmlist : taasmoutput);
  2876. begin
  2877. if (not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  2878. and (is_def_stab_written = not_written) then
  2879. begin
  2880. if assigned(rettype.def) then forcestabto(asmlist,rettype.def);
  2881. inherited concatstabto(asmlist);
  2882. end;
  2883. end;
  2884. {$endif GDB}
  2885. {***************************************************************************
  2886. TPROCDEF
  2887. ***************************************************************************}
  2888. constructor tprocdef.create;
  2889. begin
  2890. inherited create;
  2891. deftype:=procdef;
  2892. has_mangledname:=false;
  2893. _mangledname:=nil;
  2894. fileinfo:=aktfilepos;
  2895. extnumber:=$ffff;
  2896. aliasnames:=tstringlist.create;
  2897. localst:=tlocalsymtable.create;
  2898. parast:=tparasymtable.create;
  2899. funcretsym:=nil;
  2900. localst.defowner:=self;
  2901. parast.defowner:=self;
  2902. { this is used by insert
  2903. to check same names in parast and localst }
  2904. localst.next:=parast;
  2905. defref:=nil;
  2906. crossref:=nil;
  2907. lastwritten:=nil;
  2908. refcount:=0;
  2909. if (cs_browser in aktmoduleswitches) and make_ref then
  2910. begin
  2911. defref:=tref.create(defref,@akttokenpos);
  2912. inc(refcount);
  2913. end;
  2914. lastref:=defref;
  2915. { first, we assume that all registers are used }
  2916. usedregisters:=ALL_REGISTERS;
  2917. forwarddef:=true;
  2918. interfacedef:=false;
  2919. hasforward:=false;
  2920. _class := nil;
  2921. code:=nil;
  2922. regvarinfo := nil;
  2923. overloadnumber:=0;
  2924. {$ifdef GDB}
  2925. isstabwritten := false;
  2926. {$endif GDB}
  2927. end;
  2928. constructor tprocdef.load(ppufile:tcompilerppufile);
  2929. begin
  2930. inherited load(ppufile);
  2931. deftype:=procdef;
  2932. ppufile.getnormalset(usedregisters);
  2933. has_mangledname:=boolean(ppufile.getbyte);
  2934. if has_mangledname then
  2935. _mangledname:=stringdup(ppufile.getstring)
  2936. else
  2937. _mangledname:=nil;
  2938. overloadnumber:=ppufile.getword;
  2939. extnumber:=ppufile.getword;
  2940. _class := tobjectdef(ppufile.getderef);
  2941. procsym := tsym(ppufile.getderef);
  2942. ppufile.getposinfo(fileinfo);
  2943. { inline stuff }
  2944. if proccalloption=pocall_inline then
  2945. funcretsym:=tsym(ppufile.getderef)
  2946. else
  2947. funcretsym:=nil;
  2948. { load para and local symtables }
  2949. parast:=tparasymtable.create;
  2950. tparasymtable(parast).load(ppufile);
  2951. parast.defowner:=self;
  2952. if (proccalloption=pocall_inline) or
  2953. ((current_module.flags and uf_local_browser)<>0) then
  2954. begin
  2955. localst:=tlocalsymtable.create;
  2956. tlocalsymtable(localst).load(ppufile);
  2957. localst.defowner:=self;
  2958. end
  2959. else
  2960. localst:=nil;
  2961. { default values for no persistent data }
  2962. if (cs_link_deffile in aktglobalswitches) and
  2963. (tf_need_export in target_info.flags) and
  2964. (po_exports in procoptions) then
  2965. deffile.AddExport(mangledname);
  2966. aliasnames:=tstringlist.create;
  2967. forwarddef:=false;
  2968. interfacedef:=false;
  2969. hasforward:=false;
  2970. code := nil;
  2971. regvarinfo := nil;
  2972. lastref:=nil;
  2973. lastwritten:=nil;
  2974. defref:=nil;
  2975. refcount:=0;
  2976. {$ifdef GDB}
  2977. isstabwritten := false;
  2978. {$endif GDB}
  2979. end;
  2980. destructor tprocdef.destroy;
  2981. begin
  2982. if assigned(defref) then
  2983. begin
  2984. defref.freechain;
  2985. defref.free;
  2986. end;
  2987. aliasnames.free;
  2988. if assigned(parast) then
  2989. parast.free;
  2990. if assigned(localst) and (localst.symtabletype<>staticsymtable) then
  2991. localst.free;
  2992. if (proccalloption=pocall_inline) and assigned(code) then
  2993. tnode(code).free;
  2994. if assigned(regvarinfo) then
  2995. dispose(pregvarinfo(regvarinfo));
  2996. if (po_msgstr in procoptions) then
  2997. strdispose(messageinf.str);
  2998. if assigned(_mangledname) then
  2999. stringdispose(_mangledname);
  3000. inherited destroy;
  3001. end;
  3002. procedure tprocdef.write(ppufile:tcompilerppufile);
  3003. var
  3004. oldintfcrc : boolean;
  3005. begin
  3006. inherited write(ppufile);
  3007. oldintfcrc:=ppufile.do_interface_crc;
  3008. ppufile.do_interface_crc:=false;
  3009. { set all registers to used for simplified compilation PM }
  3010. if simplify_ppu then
  3011. begin
  3012. usedregisters:=ALL_REGISTERS;
  3013. end;
  3014. ppufile.putnormalset(usedregisters);
  3015. ppufile.do_interface_crc:=oldintfcrc;
  3016. ppufile.putbyte(byte(has_mangledname));
  3017. if has_mangledname then
  3018. ppufile.putstring(mangledname);
  3019. ppufile.putword(overloadnumber);
  3020. ppufile.putword(extnumber);
  3021. ppufile.putderef(_class);
  3022. ppufile.putderef(procsym);
  3023. ppufile.putposinfo(fileinfo);
  3024. { inline stuff references to localsymtable, no influence
  3025. on the crc }
  3026. oldintfcrc:=ppufile.do_crc;
  3027. ppufile.do_crc:=false;
  3028. if (proccalloption=pocall_inline) then
  3029. ppufile.putderef(funcretsym);
  3030. ppufile.do_crc:=oldintfcrc;
  3031. { write this entry }
  3032. ppufile.writeentry(ibprocdef);
  3033. { Save the para symtable, this is taken from the interface }
  3034. if not assigned(parast) then
  3035. begin
  3036. parast:=tparasymtable.create;
  3037. parast.defowner:=self;
  3038. end;
  3039. tparasymtable(parast).write(ppufile);
  3040. { save localsymtable for inline procedures or when local
  3041. browser info is requested, this has no influence on the crc }
  3042. if (proccalloption=pocall_inline) or
  3043. ((current_module.flags and uf_local_browser)<>0) then
  3044. begin
  3045. oldintfcrc:=ppufile.do_crc;
  3046. ppufile.do_crc:=false;
  3047. if not assigned(localst) then
  3048. begin
  3049. localst:=tlocalsymtable.create;
  3050. localst.defowner:=self;
  3051. end;
  3052. tlocalsymtable(localst).write(ppufile);
  3053. ppufile.do_crc:=oldintfcrc;
  3054. end;
  3055. end;
  3056. function tprocdef.fullprocname:string;
  3057. var
  3058. s : string;
  3059. begin
  3060. s:='';
  3061. if assigned(_class) then
  3062. s:=_class.objrealname^+'.';
  3063. s:=s+procsym.realname+typename_paras;
  3064. fullprocname:=s;
  3065. end;
  3066. function tprocdef.fullprocnamewithret:string;
  3067. var
  3068. s : string;
  3069. begin
  3070. s:=fullprocname;
  3071. if assigned(rettype.def) and
  3072. not(is_equal(rettype.def,voidtype.def)) then
  3073. s:=s+' : '+rettype.def.gettypename;
  3074. fullprocnamewithret:=s;
  3075. end;
  3076. function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
  3077. begin
  3078. case t of
  3079. gs_local :
  3080. getsymtable:=localst;
  3081. gs_para :
  3082. getsymtable:=parast;
  3083. else
  3084. getsymtable:=nil;
  3085. end;
  3086. end;
  3087. procedure tprocdef.load_references(ppufile:tcompilerppufile;locals:boolean);
  3088. var
  3089. pos : tfileposinfo;
  3090. move_last : boolean;
  3091. begin
  3092. move_last:=lastwritten=lastref;
  3093. while (not ppufile.endofentry) do
  3094. begin
  3095. ppufile.getposinfo(pos);
  3096. inc(refcount);
  3097. lastref:=tref.create(lastref,@pos);
  3098. lastref.is_written:=true;
  3099. if refcount=1 then
  3100. defref:=lastref;
  3101. end;
  3102. if move_last then
  3103. lastwritten:=lastref;
  3104. if ((current_module.flags and uf_local_browser)<>0) and
  3105. locals then
  3106. begin
  3107. tparasymtable(parast).load_references(ppufile,locals);
  3108. tlocalsymtable(localst).load_references(ppufile,locals);
  3109. end;
  3110. end;
  3111. Const
  3112. local_symtable_index : longint = $8001;
  3113. function tprocdef.write_references(ppufile:tcompilerppufile;locals:boolean):boolean;
  3114. var
  3115. ref : tref;
  3116. pdo : tobjectdef;
  3117. move_last : boolean;
  3118. begin
  3119. move_last:=lastwritten=lastref;
  3120. if move_last and
  3121. (((current_module.flags and uf_local_browser)=0) or
  3122. not locals) then
  3123. exit;
  3124. { write address of this symbol }
  3125. ppufile.putderef(self);
  3126. { write refs }
  3127. if assigned(lastwritten) then
  3128. ref:=lastwritten
  3129. else
  3130. ref:=defref;
  3131. while assigned(ref) do
  3132. begin
  3133. if ref.moduleindex=current_module.unit_index then
  3134. begin
  3135. ppufile.putposinfo(ref.posinfo);
  3136. ref.is_written:=true;
  3137. if move_last then
  3138. lastwritten:=ref;
  3139. end
  3140. else if not ref.is_written then
  3141. move_last:=false
  3142. else if move_last then
  3143. lastwritten:=ref;
  3144. ref:=ref.nextref;
  3145. end;
  3146. ppufile.writeentry(ibdefref);
  3147. write_references:=true;
  3148. if ((current_module.flags and uf_local_browser)<>0) and
  3149. locals then
  3150. begin
  3151. pdo:=_class;
  3152. if (owner.symtabletype<>localsymtable) then
  3153. while assigned(pdo) do
  3154. begin
  3155. if pdo.symtable<>aktrecordsymtable then
  3156. begin
  3157. pdo.symtable.unitid:=local_symtable_index;
  3158. inc(local_symtable_index);
  3159. end;
  3160. pdo:=pdo.childof;
  3161. end;
  3162. parast.unitid:=local_symtable_index;
  3163. inc(local_symtable_index);
  3164. localst.unitid:=local_symtable_index;
  3165. inc(local_symtable_index);
  3166. tstoredsymtable(parast).write_references(ppufile,locals);
  3167. tstoredsymtable(localst).write_references(ppufile,locals);
  3168. { decrement for }
  3169. local_symtable_index:=local_symtable_index-2;
  3170. pdo:=_class;
  3171. if (owner.symtabletype<>localsymtable) then
  3172. while assigned(pdo) do
  3173. begin
  3174. if pdo.symtable<>aktrecordsymtable then
  3175. dec(local_symtable_index);
  3176. pdo:=pdo.childof;
  3177. end;
  3178. end;
  3179. end;
  3180. function tprocdef.haspara:boolean;
  3181. begin
  3182. haspara:=assigned(parast.symindex.first);
  3183. end;
  3184. {$ifdef GDB}
  3185. {$ifdef unused}
  3186. { procedure addparaname(p : tsym);
  3187. var vs : char;
  3188. begin
  3189. if tvarsym(p).varspez = vs_value then vs := '1'
  3190. else vs := '0';
  3191. strpcopy(strend(StabRecString),p^.name+':'+tstoreddef(tvarsym(p).vartype.def).numberstring+','+vs+';');
  3192. end; }
  3193. function tprocdef.stabstring : pchar;
  3194. var
  3195. i : longint;
  3196. stabrecstring : pchar;
  3197. begin
  3198. getmem(StabRecString,1024);
  3199. strpcopy(StabRecString,'f'+tstoreddef(rettype.def).numberstring);
  3200. i:=maxparacount;
  3201. if i>0 then
  3202. begin
  3203. strpcopy(strend(StabRecString),','+tostr(i)+';');
  3204. (* confuse gdb !! PM
  3205. if assigned(parast) then
  3206. parast.foreach({$ifdef FPCPROCVAR}@{$endif}addparaname)
  3207. else
  3208. begin
  3209. param := para1;
  3210. i := 0;
  3211. while assigned(param) do
  3212. begin
  3213. inc(i);
  3214. if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
  3215. {Here we have lost the parameter names !!}
  3216. {using lower case parameters }
  3217. strpcopy(strend(stabrecstring),'p'+tostr(i)
  3218. +':'+param^.paratype.def.numberstring+','+vartyp+';');
  3219. param := param^.next;
  3220. end;
  3221. end; *)
  3222. {strpcopy(strend(StabRecString),';');}
  3223. end;
  3224. stabstring := strnew(stabrecstring);
  3225. freemem(stabrecstring,1024);
  3226. end;
  3227. {$endif unused}
  3228. function tprocdef.stabstring: pchar;
  3229. Var RType : Char;
  3230. Obj,Info : String;
  3231. stabsstr : string;
  3232. p : pchar;
  3233. begin
  3234. obj := procsym.name;
  3235. info := '';
  3236. if tprocsym(procsym).is_global then
  3237. RType := 'F'
  3238. else
  3239. RType := 'f';
  3240. if assigned(owner) then
  3241. begin
  3242. if (owner.symtabletype = objectsymtable) then
  3243. obj := upper(owner.name^)+'__'+procsym.name;
  3244. { this code was correct only as long as the local symboltable
  3245. of the parent had the same name as the function
  3246. but this is no true anymore !! PM
  3247. if (owner.symtabletype=localsymtable) and assigned(owner.name) then
  3248. info := ','+name+','+owner.name^; }
  3249. if (owner.symtabletype=localsymtable) and
  3250. assigned(owner.defowner) and
  3251. assigned(tprocdef(owner.defowner).procsym) then
  3252. info := ','+procsym.name+','+tprocdef(owner.defowner).procsym.name;
  3253. end;
  3254. stabsstr:=mangledname;
  3255. getmem(p,length(stabsstr)+255);
  3256. strpcopy(p,'"'+obj+':'+RType
  3257. +tstoreddef(rettype.def).numberstring+info+'",'+tostr(n_function)
  3258. +',0,'+
  3259. tostr(fileinfo.line)
  3260. +',');
  3261. strpcopy(strend(p),stabsstr);
  3262. stabstring:=strnew(p);
  3263. freemem(p,length(stabsstr)+255);
  3264. end;
  3265. procedure tprocdef.concatstabto(asmlist : taasmoutput);
  3266. begin
  3267. if (proccalloption=pocall_internproc) then
  3268. exit;
  3269. if not isstabwritten then
  3270. asmList.concat(Tai_stabs.Create(stabstring));
  3271. isstabwritten := true;
  3272. if assigned(parast) then
  3273. tstoredsymtable(parast).concatstabto(asmlist);
  3274. { local type defs and vars should not be written
  3275. inside the main proc stab }
  3276. if assigned(localst) and
  3277. (lexlevel>main_program_level) then
  3278. tstoredsymtable(localst).concatstabto(asmlist);
  3279. is_def_stab_written := written;
  3280. end;
  3281. {$endif GDB}
  3282. procedure tprocdef.deref;
  3283. var
  3284. oldlocalsymtable : tsymtable;
  3285. begin
  3286. inherited deref;
  3287. resolvedef(pointer(_class));
  3288. { parast }
  3289. oldlocalsymtable:=aktlocalsymtable;
  3290. aktlocalsymtable:=parast;
  3291. tparasymtable(parast).deref;
  3292. aktlocalsymtable:=oldlocalsymtable;
  3293. { procsym that originaly defined this definition, should be in the
  3294. same symtable }
  3295. resolvesym(pointer(procsym));
  3296. end;
  3297. procedure tprocdef.derefimpl;
  3298. var
  3299. oldlocalsymtable : tsymtable;
  3300. begin
  3301. { locals }
  3302. if assigned(localst) then
  3303. begin
  3304. { localst }
  3305. oldlocalsymtable:=aktlocalsymtable;
  3306. aktlocalsymtable:=localst;
  3307. { we can deref both interface and implementation parts }
  3308. tlocalsymtable(localst).deref;
  3309. tlocalsymtable(localst).derefimpl;
  3310. aktlocalsymtable:=oldlocalsymtable;
  3311. { funcretsym, this is always located in the localst }
  3312. resolvesym(pointer(funcretsym));
  3313. end
  3314. else
  3315. begin
  3316. { safety }
  3317. funcretsym:=nil;
  3318. end;
  3319. end;
  3320. function tprocdef.mangledname : string;
  3321. var
  3322. s : string;
  3323. hp : TParaItem;
  3324. begin
  3325. if assigned(_mangledname) then
  3326. begin
  3327. mangledname:=_mangledname^;
  3328. exit;
  3329. end;
  3330. { we need to use the symtable where the procsym is inserted,
  3331. because that is visible to the world }
  3332. s:=mangledname_prefix('',procsym.owner)+procsym.name+'$';
  3333. if overloadnumber>0 then
  3334. s:=s+tostr(overloadnumber)+'$';
  3335. { add parameter types }
  3336. hp:=TParaItem(Para.last);
  3337. while assigned(hp) do
  3338. begin
  3339. s:=s+hp.paratype.def.mangledparaname;
  3340. hp:=TParaItem(hp.previous);
  3341. if assigned(hp) then
  3342. s:=s+'$';
  3343. end;
  3344. _mangledname:=stringdup(s);
  3345. mangledname:=_mangledname^;
  3346. end;
  3347. function tprocdef.cplusplusmangledname : string;
  3348. function getcppparaname(p : tdef) : string;
  3349. const
  3350. ordtype2str : array[tbasetype] of string[2] = (
  3351. '',
  3352. 'Uc','Us','Ui','Us',
  3353. 'Sc','s','i','x',
  3354. 'b','b','b',
  3355. 'c','w');
  3356. var
  3357. s : string;
  3358. begin
  3359. case p.deftype of
  3360. orddef:
  3361. s:=ordtype2str[torddef(p).typ];
  3362. pointerdef:
  3363. s:='P'+getcppparaname(tpointerdef(p).pointertype.def);
  3364. else
  3365. internalerror(2103001);
  3366. end;
  3367. getcppparaname:=s;
  3368. end;
  3369. var
  3370. s,s2 : string;
  3371. param : TParaItem;
  3372. begin
  3373. s := procsym.realname;
  3374. if procsym.owner.symtabletype=objectsymtable then
  3375. begin
  3376. s2:=upper(tobjectdef(procsym.owner.defowner).typesym.realname);
  3377. case proctypeoption of
  3378. potype_destructor:
  3379. s:='_$_'+tostr(length(s2))+s2;
  3380. potype_constructor:
  3381. s:='___'+tostr(length(s2))+s2;
  3382. else
  3383. s:='_'+s+'__'+tostr(length(s2))+s2;
  3384. end;
  3385. end
  3386. else s:=s+'__';
  3387. s:=s+'F';
  3388. { concat modifiers }
  3389. { !!!!! }
  3390. { now we handle the parameters }
  3391. param := TParaItem(Para.first);
  3392. if assigned(param) then
  3393. while assigned(param) do
  3394. begin
  3395. s2:=getcppparaname(param.paratype.def);
  3396. if param.paratyp in [vs_var,vs_out] then
  3397. s2:='R'+s2;
  3398. s:=s+s2;
  3399. param:=TParaItem(param.next);
  3400. end
  3401. else
  3402. s:=s+'v';
  3403. cplusplusmangledname:=s;
  3404. end;
  3405. procedure tprocdef.setmangledname(const s : string);
  3406. begin
  3407. stringdispose(_mangledname);
  3408. _mangledname:=stringdup(s);
  3409. has_mangledname:=true;
  3410. end;
  3411. {***************************************************************************
  3412. TPROCVARDEF
  3413. ***************************************************************************}
  3414. constructor tprocvardef.create;
  3415. begin
  3416. inherited create;
  3417. deftype:=procvardef;
  3418. end;
  3419. constructor tprocvardef.load(ppufile:tcompilerppufile);
  3420. begin
  3421. inherited load(ppufile);
  3422. deftype:=procvardef;
  3423. end;
  3424. procedure tprocvardef.write(ppufile:tcompilerppufile);
  3425. begin
  3426. { here we cannot get a real good value so just give something }
  3427. { plausible (PM) }
  3428. { a more secure way would be
  3429. to allways store in a temp }
  3430. if is_fpu(rettype.def) then
  3431. {$ifdef FAST_FPU}
  3432. fpu_used:=3
  3433. {$else : not FAST_FPU, i.e. SAFE_FPU}
  3434. fpu_used:={2}maxfpuregs
  3435. {$endif FAST_FPU}
  3436. else
  3437. fpu_used:=0;
  3438. inherited write(ppufile);
  3439. ppufile.writeentry(ibprocvardef);
  3440. end;
  3441. function tprocvardef.size : longint;
  3442. begin
  3443. if (po_methodpointer in procoptions) then
  3444. size:=2*POINTER_SIZE
  3445. else
  3446. size:=POINTER_SIZE;
  3447. end;
  3448. {$ifdef GDB}
  3449. function tprocvardef.stabstring : pchar;
  3450. var
  3451. nss : pchar;
  3452. { i : longint; }
  3453. begin
  3454. { i := maxparacount; }
  3455. getmem(nss,1024);
  3456. { it is not a function but a function pointer !! (PM) }
  3457. strpcopy(nss,'*f'+tstoreddef(rettype.def).numberstring{+','+tostr(i)}+';');
  3458. { this confuses gdb !!
  3459. we should use 'F' instead of 'f' but
  3460. as we use c++ language mode
  3461. it does not like that either
  3462. Please do not remove this part
  3463. might be used once
  3464. gdb for pascal is ready PM }
  3465. (*
  3466. param := para1;
  3467. i := 0;
  3468. while assigned(param) do
  3469. begin
  3470. inc(i);
  3471. if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
  3472. {Here we have lost the parameter names !!}
  3473. pst := strpnew('p'+tostr(i)+':'+param^.paratype.def.numberstring+','+vartyp+';');
  3474. strcat(nss,pst);
  3475. strdispose(pst);
  3476. param := param^.next;
  3477. end; *)
  3478. {strpcopy(strend(nss),';');}
  3479. stabstring := strnew(nss);
  3480. freemem(nss,1024);
  3481. end;
  3482. procedure tprocvardef.concatstabto(asmlist : taasmoutput);
  3483. begin
  3484. if ( not assigned(typesym) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  3485. and (is_def_stab_written = not_written) then
  3486. inherited concatstabto(asmlist);
  3487. is_def_stab_written:=written;
  3488. end;
  3489. {$endif GDB}
  3490. procedure tprocvardef.write_rtti_data(rt:trttitype);
  3491. var
  3492. pdc : TParaItem;
  3493. methodkind, paraspec : byte;
  3494. begin
  3495. if po_methodpointer in procoptions then
  3496. begin
  3497. { write method id and name }
  3498. rttiList.concat(Tai_const.Create_8bit(tkmethod));
  3499. write_rtti_name;
  3500. { write kind of method (can only be function or procedure)}
  3501. if rettype.def = voidtype.def then
  3502. methodkind := mkProcedure
  3503. else
  3504. methodkind := mkFunction;
  3505. rttiList.concat(Tai_const.Create_8bit(methodkind));
  3506. { get # of parameters }
  3507. rttiList.concat(Tai_const.Create_8bit(maxparacount));
  3508. { write parameter info. The parameters must be written in reverse order
  3509. if this method uses right to left parameter pushing! }
  3510. if (po_leftright in procoptions) then
  3511. pdc:=TParaItem(Para.last)
  3512. else
  3513. pdc:=TParaItem(Para.first);
  3514. while assigned(pdc) do
  3515. begin
  3516. case pdc.paratyp of
  3517. vs_value: paraspec := 0;
  3518. vs_const: paraspec := pfConst;
  3519. vs_var : paraspec := pfVar;
  3520. vs_out : paraspec := pfOut;
  3521. end;
  3522. { write flags for current parameter }
  3523. rttiList.concat(Tai_const.Create_8bit(paraspec));
  3524. { write name of current parameter ### how can I get this??? (sg)}
  3525. rttiList.concat(Tai_const.Create_8bit(0));
  3526. { write name of type of current parameter }
  3527. tstoreddef(pdc.paratype.def).write_rtti_name;
  3528. if (po_leftright in procoptions) then
  3529. pdc:=TParaItem(pdc.previous)
  3530. else
  3531. pdc:=TParaItem(pdc.next);
  3532. end;
  3533. { write name of result type }
  3534. tstoreddef(rettype.def).write_rtti_name;
  3535. end;
  3536. end;
  3537. function tprocvardef.is_publishable : boolean;
  3538. begin
  3539. is_publishable:=(po_methodpointer in procoptions);
  3540. end;
  3541. function tprocvardef.gettypename : string;
  3542. var
  3543. s: string;
  3544. begin
  3545. if assigned(rettype.def) and
  3546. (rettype.def<>voidtype.def) then
  3547. s:='<procedure variable type of function'+typename_paras+
  3548. ':'+rettype.def.gettypename
  3549. else
  3550. s:='<procedure variable type of procedure'+typename_paras;
  3551. if po_methodpointer in procoptions then
  3552. s := s+' of object';
  3553. gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
  3554. end;
  3555. {***************************************************************************
  3556. TOBJECTDEF
  3557. ***************************************************************************}
  3558. {$ifdef GDB}
  3559. const
  3560. vtabletype : word = 0;
  3561. vtableassigned : boolean = false;
  3562. {$endif GDB}
  3563. constructor tobjectdef.create(ot : tobjectdeftype;const n : string;c : tobjectdef);
  3564. begin
  3565. inherited create;
  3566. objecttype:=ot;
  3567. deftype:=objectdef;
  3568. objectoptions:=[];
  3569. childof:=nil;
  3570. symtable:=tobjectsymtable.create(n);
  3571. { create space for vmt !! }
  3572. vmt_offset:=0;
  3573. symtable.datasize:=0;
  3574. symtable.defowner:=self;
  3575. { recordalign -1 means C record packing, that starts
  3576. with an alignment of 1 }
  3577. if aktalignment.recordalignmax=-1 then
  3578. symtable.dataalignment:=1
  3579. else
  3580. symtable.dataalignment:=aktalignment.recordalignmax;
  3581. lastvtableindex:=0;
  3582. set_parent(c);
  3583. objname:=stringdup(upper(n));
  3584. objrealname:=stringdup(n);
  3585. { set up guid }
  3586. isiidguidvalid:=true; { default null guid }
  3587. fillchar(iidguid,sizeof(iidguid),0); { default null guid }
  3588. iidstr:=stringdup(''); { default is empty string }
  3589. { setup implemented interfaces }
  3590. if objecttype in [odt_class,odt_interfacecorba] then
  3591. implementedinterfaces:=timplementedinterfaces.create
  3592. else
  3593. implementedinterfaces:=nil;
  3594. {$ifdef GDB}
  3595. writing_class_record_stab:=false;
  3596. {$endif GDB}
  3597. end;
  3598. constructor tobjectdef.load(ppufile:tcompilerppufile);
  3599. var
  3600. oldread_member : boolean;
  3601. i,implintfcount: longint;
  3602. begin
  3603. inherited loaddef(ppufile);
  3604. deftype:=objectdef;
  3605. objecttype:=tobjectdeftype(ppufile.getbyte);
  3606. savesize:=ppufile.getlongint;
  3607. vmt_offset:=ppufile.getlongint;
  3608. objrealname:=stringdup(ppufile.getstring);
  3609. objname:=stringdup(upper(objrealname^));
  3610. childof:=tobjectdef(ppufile.getderef);
  3611. ppufile.getsmallset(objectoptions);
  3612. { load guid }
  3613. iidstr:=nil;
  3614. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  3615. begin
  3616. isiidguidvalid:=boolean(ppufile.getbyte);
  3617. ppufile.putguid(iidguid);
  3618. iidstr:=stringdup(ppufile.getstring);
  3619. lastvtableindex:=ppufile.getlongint;
  3620. end;
  3621. { load implemented interfaces }
  3622. if objecttype in [odt_class,odt_interfacecorba] then
  3623. begin
  3624. implementedinterfaces:=timplementedinterfaces.create;
  3625. implintfcount:=ppufile.getlongint;
  3626. for i:=1 to implintfcount do
  3627. begin
  3628. implementedinterfaces.addintfref(ppufile.getderef);
  3629. implementedinterfaces.ioffsets(i)^:=ppufile.getlongint;
  3630. end;
  3631. end
  3632. else
  3633. implementedinterfaces:=nil;
  3634. oldread_member:=read_member;
  3635. read_member:=true;
  3636. symtable:=tobjectsymtable.create(objrealname^);
  3637. tobjectsymtable(symtable).load(ppufile);
  3638. read_member:=oldread_member;
  3639. symtable.defowner:=self;
  3640. { handles the predefined class tobject }
  3641. { the last TOBJECT which is loaded gets }
  3642. { it ! }
  3643. if (childof=nil) and
  3644. (objecttype=odt_class) and
  3645. (objname^='TOBJECT') then
  3646. class_tobject:=self;
  3647. if (childof=nil) and
  3648. (objecttype=odt_interfacecom) and
  3649. (objname^='IUNKNOWN') then
  3650. interface_iunknown:=self;
  3651. {$ifdef GDB}
  3652. writing_class_record_stab:=false;
  3653. {$endif GDB}
  3654. end;
  3655. destructor tobjectdef.destroy;
  3656. begin
  3657. if assigned(symtable) then
  3658. symtable.free;
  3659. stringdispose(objname);
  3660. stringdispose(objrealname);
  3661. stringdispose(iidstr);
  3662. if assigned(implementedinterfaces) then
  3663. implementedinterfaces.free;
  3664. inherited destroy;
  3665. end;
  3666. procedure tobjectdef.write(ppufile:tcompilerppufile);
  3667. var
  3668. oldread_member : boolean;
  3669. implintfcount : longint;
  3670. i : longint;
  3671. begin
  3672. inherited writedef(ppufile);
  3673. ppufile.putbyte(byte(objecttype));
  3674. ppufile.putlongint(size);
  3675. ppufile.putlongint(vmt_offset);
  3676. ppufile.putstring(objrealname^);
  3677. ppufile.putderef(childof);
  3678. ppufile.putsmallset(objectoptions);
  3679. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  3680. begin
  3681. ppufile.putbyte(byte(isiidguidvalid));
  3682. ppufile.putguid(iidguid);
  3683. ppufile.putstring(iidstr^);
  3684. ppufile.putlongint(lastvtableindex);
  3685. end;
  3686. if objecttype in [odt_class,odt_interfacecorba] then
  3687. begin
  3688. implintfcount:=implementedinterfaces.count;
  3689. ppufile.putlongint(implintfcount);
  3690. for i:=1 to implintfcount do
  3691. begin
  3692. ppufile.putderef(implementedinterfaces.interfaces(i));
  3693. ppufile.putlongint(implementedinterfaces.ioffsets(i)^);
  3694. end;
  3695. end;
  3696. ppufile.writeentry(ibobjectdef);
  3697. oldread_member:=read_member;
  3698. read_member:=true;
  3699. tobjectsymtable(symtable).write(ppufile);
  3700. read_member:=oldread_member;
  3701. end;
  3702. procedure tobjectdef.deref;
  3703. var
  3704. oldrecsyms : tsymtable;
  3705. begin
  3706. inherited deref;
  3707. resolvedef(pointer(childof));
  3708. oldrecsyms:=aktrecordsymtable;
  3709. aktrecordsymtable:=symtable;
  3710. tstoredsymtable(symtable).deref;
  3711. aktrecordsymtable:=oldrecsyms;
  3712. if objecttype in [odt_class,odt_interfacecorba] then
  3713. implementedinterfaces.deref;
  3714. end;
  3715. procedure tobjectdef.set_parent( c : tobjectdef);
  3716. begin
  3717. { nothing to do if the parent was not forward !}
  3718. if assigned(childof) then
  3719. exit;
  3720. childof:=c;
  3721. { some options are inherited !! }
  3722. if assigned(c) then
  3723. begin
  3724. { only important for classes }
  3725. lastvtableindex:=c.lastvtableindex;
  3726. objectoptions:=objectoptions+(c.objectoptions*
  3727. [oo_has_virtual,oo_has_private,oo_has_protected,
  3728. oo_has_constructor,oo_has_destructor]);
  3729. if not (objecttype in [odt_interfacecom,odt_interfacecorba]) then
  3730. begin
  3731. { add the data of the anchestor class }
  3732. inc(symtable.datasize,c.symtable.datasize);
  3733. if (oo_has_vmt in objectoptions) and
  3734. (oo_has_vmt in c.objectoptions) then
  3735. dec(symtable.datasize,POINTER_SIZE);
  3736. { if parent has a vmt field then
  3737. the offset is the same for the child PM }
  3738. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  3739. begin
  3740. vmt_offset:=c.vmt_offset;
  3741. include(objectoptions,oo_has_vmt);
  3742. end;
  3743. end;
  3744. end;
  3745. savesize := symtable.datasize;
  3746. end;
  3747. procedure tobjectdef.insertvmt;
  3748. begin
  3749. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  3750. exit;
  3751. if (oo_has_vmt in objectoptions) then
  3752. internalerror(12345)
  3753. else
  3754. begin
  3755. symtable.datasize:=align(symtable.datasize,symtable.dataalignment);
  3756. vmt_offset:=symtable.datasize;
  3757. inc(symtable.datasize,POINTER_SIZE);
  3758. include(objectoptions,oo_has_vmt);
  3759. end;
  3760. end;
  3761. procedure tobjectdef.check_forwards;
  3762. begin
  3763. if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
  3764. tstoredsymtable(symtable).check_forwards;
  3765. if (oo_is_forward in objectoptions) then
  3766. begin
  3767. { ok, in future, the forward can be resolved }
  3768. Message1(sym_e_class_forward_not_resolved,objrealname^);
  3769. exclude(objectoptions,oo_is_forward);
  3770. end;
  3771. end;
  3772. { true, if self inherits from d (or if they are equal) }
  3773. function tobjectdef.is_related(d : tobjectdef) : boolean;
  3774. var
  3775. hp : tobjectdef;
  3776. begin
  3777. hp:=self;
  3778. while assigned(hp) do
  3779. begin
  3780. if hp=d then
  3781. begin
  3782. is_related:=true;
  3783. exit;
  3784. end;
  3785. hp:=hp.childof;
  3786. end;
  3787. is_related:=false;
  3788. end;
  3789. procedure tobjectdef._searchdestructor(sym : tnamedindexitem;arg:pointer);
  3790. var
  3791. p : pprocdeflist;
  3792. begin
  3793. { if we found already a destructor, then we exit }
  3794. if assigned(sd) then
  3795. exit;
  3796. if tsym(sym).typ=procsym then
  3797. begin
  3798. p:=tprocsym(sym).defs;
  3799. while assigned(p) do
  3800. begin
  3801. if p^.def.proctypeoption=potype_destructor then
  3802. begin
  3803. sd:=p^.def;
  3804. exit;
  3805. end;
  3806. p:=p^.next;
  3807. end;
  3808. end;
  3809. end;
  3810. function tobjectdef.searchdestructor : tprocdef;
  3811. var
  3812. o : tobjectdef;
  3813. begin
  3814. searchdestructor:=nil;
  3815. o:=self;
  3816. sd:=nil;
  3817. while assigned(o) do
  3818. begin
  3819. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}_searchdestructor,nil);
  3820. if assigned(sd) then
  3821. begin
  3822. searchdestructor:=sd;
  3823. exit;
  3824. end;
  3825. o:=o.childof;
  3826. end;
  3827. end;
  3828. function tobjectdef.size : longint;
  3829. begin
  3830. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
  3831. size:=POINTER_SIZE
  3832. else
  3833. size:=symtable.datasize;
  3834. end;
  3835. function tobjectdef.alignment:longint;
  3836. begin
  3837. alignment:=symtable.dataalignment;
  3838. end;
  3839. function tobjectdef.vmtmethodoffset(index:longint):longint;
  3840. begin
  3841. { for offset of methods for classes, see rtl/inc/objpash.inc }
  3842. case objecttype of
  3843. odt_class:
  3844. vmtmethodoffset:=(index+12)*POINTER_SIZE;
  3845. odt_interfacecom,odt_interfacecorba:
  3846. vmtmethodoffset:=index*POINTER_SIZE;
  3847. else
  3848. {$ifdef WITHDMT}
  3849. vmtmethodoffset:=(index+4)*POINTER_SIZE;
  3850. {$else WITHDMT}
  3851. vmtmethodoffset:=(index+3)*POINTER_SIZE;
  3852. {$endif WITHDMT}
  3853. end;
  3854. end;
  3855. function tobjectdef.vmt_mangledname : string;
  3856. begin
  3857. if not(oo_has_vmt in objectoptions) then
  3858. Message1(parser_object_has_no_vmt,objrealname^);
  3859. vmt_mangledname:=mangledname_prefix('VMT',owner)+objname^;
  3860. end;
  3861. function tobjectdef.rtti_name : string;
  3862. begin
  3863. rtti_name:=mangledname_prefix('RTTI',owner)+objname^;
  3864. end;
  3865. {$ifdef GDB}
  3866. procedure tobjectdef.addprocname(p :tnamedindexitem;arg:pointer);
  3867. var virtualind,argnames : string;
  3868. news, newrec : pchar;
  3869. pd,ipd : tprocdef;
  3870. lindex : longint;
  3871. para : TParaItem;
  3872. arglength : byte;
  3873. sp : char;
  3874. pdl : pprocdeflist;
  3875. begin
  3876. If tsym(p).typ = procsym then
  3877. begin
  3878. pd := tprocsym(p).defs^.def;
  3879. { this will be used for full implementation of object stabs
  3880. not yet done }
  3881. pdl:=tprocsym(p).defs;
  3882. while assigned(pdl) do
  3883. begin
  3884. ipd:=pdl^.def;
  3885. pdl:=pdl^.next;
  3886. end;
  3887. if (po_virtualmethod in pd.procoptions) then
  3888. begin
  3889. lindex := pd.extnumber;
  3890. {doesnt seem to be necessary
  3891. lindex := lindex or $80000000;}
  3892. virtualind := '*'+tostr(lindex)+';'+ipd._class.classnumberstring+';'
  3893. end
  3894. else
  3895. virtualind := '.';
  3896. { used by gdbpas to recognize constructor and destructors }
  3897. if (pd.proctypeoption=potype_constructor) then
  3898. argnames:='__ct__'
  3899. else if (pd.proctypeoption=potype_destructor) then
  3900. argnames:='__dt__'
  3901. else
  3902. argnames := '';
  3903. { arguments are not listed here }
  3904. {we don't need another definition}
  3905. para := TParaItem(pd.Para.first);
  3906. while assigned(para) do
  3907. begin
  3908. if Para.paratype.def.deftype = formaldef then
  3909. begin
  3910. if Para.paratyp=vs_var then
  3911. argnames := argnames+'3var'
  3912. else if Para.paratyp=vs_const then
  3913. argnames:=argnames+'5const'
  3914. else if Para.paratyp=vs_out then
  3915. argnames:=argnames+'3out';
  3916. end
  3917. else
  3918. begin
  3919. { if the arg definition is like (v: ^byte;..
  3920. there is no sym attached to data !!! }
  3921. if assigned(Para.paratype.def.typesym) then
  3922. begin
  3923. arglength := length(Para.paratype.def.typesym.name);
  3924. argnames := argnames + tostr(arglength)+Para.paratype.def.typesym.name;
  3925. end
  3926. else
  3927. begin
  3928. argnames:=argnames+'11unnamedtype';
  3929. end;
  3930. end;
  3931. para := TParaItem(Para.next);
  3932. end;
  3933. ipd.is_def_stab_written := written;
  3934. { here 2A must be changed for private and protected }
  3935. { 0 is private 1 protected and 2 public }
  3936. if (sp_private in tsym(p).symoptions) then sp:='0'
  3937. else if (sp_protected in tsym(p).symoptions) then sp:='1'
  3938. else sp:='2';
  3939. newrec := strpnew(p.name+'::'+ipd.numberstring
  3940. +'=##'+tstoreddef(pd.rettype.def).numberstring+';:'+argnames+';'+sp+'A'
  3941. +virtualind+';');
  3942. { get spare place for a string at the end }
  3943. if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
  3944. begin
  3945. getmem(news,stabrecsize+memsizeinc);
  3946. strcopy(news,stabrecstring);
  3947. freemem(stabrecstring,stabrecsize);
  3948. stabrecsize:=stabrecsize+memsizeinc;
  3949. stabrecstring:=news;
  3950. end;
  3951. strcat(StabRecstring,newrec);
  3952. {freemem(newrec,memsizeinc); }
  3953. strdispose(newrec);
  3954. {This should be used for case !!
  3955. RecOffset := RecOffset + pd.size;}
  3956. end;
  3957. end;
  3958. function tobjectdef.stabstring : pchar;
  3959. var anc : tobjectdef;
  3960. oldrec : pchar;
  3961. oldrecsize,oldrecoffset : longint;
  3962. str_end : string;
  3963. begin
  3964. if not (objecttype=odt_class) or writing_class_record_stab then
  3965. begin
  3966. oldrec := stabrecstring;
  3967. oldrecsize:=stabrecsize;
  3968. stabrecsize:=memsizeinc;
  3969. GetMem(stabrecstring,stabrecsize);
  3970. strpcopy(stabRecString,'s'+tostr(symtable.datasize));
  3971. if assigned(childof) then
  3972. begin
  3973. {only one ancestor not virtual, public, at base offset 0 }
  3974. { !1 , 0 2 0 , }
  3975. strpcopy(strend(stabrecstring),'!1,020,'+childof.classnumberstring+';');
  3976. end;
  3977. {virtual table to implement yet}
  3978. OldRecOffset:=RecOffset;
  3979. RecOffset := 0;
  3980. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addname,nil);
  3981. RecOffset:=OldRecOffset;
  3982. if (oo_has_vmt in objectoptions) then
  3983. if not assigned(childof) or not(oo_has_vmt in childof.objectoptions) then
  3984. begin
  3985. strpcopy(strend(stabrecstring),'$vf'+classnumberstring+':'+typeglobalnumber('vtblarray')
  3986. +','+tostr(vmt_offset*8)+';');
  3987. end;
  3988. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname,nil);
  3989. if (oo_has_vmt in objectoptions) then
  3990. begin
  3991. anc := self;
  3992. while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do
  3993. anc := anc.childof;
  3994. { just in case anc = self }
  3995. str_end:=';~%'+anc.classnumberstring+';';
  3996. end
  3997. else
  3998. str_end:=';';
  3999. strpcopy(strend(stabrecstring),str_end);
  4000. stabstring := strnew(StabRecString);
  4001. freemem(stabrecstring,stabrecsize);
  4002. stabrecstring := oldrec;
  4003. stabrecsize:=oldrecsize;
  4004. end
  4005. else
  4006. begin
  4007. stabstring:=strpnew('*'+classnumberstring);
  4008. end;
  4009. end;
  4010. procedure tobjectdef.set_globalnb;
  4011. begin
  4012. globalnb:=PglobalTypeCount^;
  4013. inc(PglobalTypeCount^);
  4014. { classes need two type numbers, the globalnb is set to the ptr }
  4015. if objecttype=odt_class then
  4016. begin
  4017. globalnb:=PGlobalTypeCount^;
  4018. inc(PglobalTypeCount^);
  4019. end;
  4020. end;
  4021. function tobjectdef.classnumberstring : string;
  4022. begin
  4023. { write stabs again if needed }
  4024. numberstring;
  4025. if objecttype=odt_class then
  4026. begin
  4027. dec(globalnb);
  4028. classnumberstring:=numberstring;
  4029. inc(globalnb);
  4030. end
  4031. else
  4032. classnumberstring:=numberstring;
  4033. end;
  4034. function tobjectdef.allstabstring : pchar;
  4035. var stabchar : string[2];
  4036. ss,st : pchar;
  4037. sname : string;
  4038. sym_line_no : longint;
  4039. begin
  4040. ss := stabstring;
  4041. getmem(st,strlen(ss)+512);
  4042. stabchar := 't';
  4043. if deftype in tagtypes then
  4044. stabchar := 'Tt';
  4045. if assigned(typesym) then
  4046. begin
  4047. sname := typesym.name;
  4048. sym_line_no:=typesym.fileinfo.line;
  4049. end
  4050. else
  4051. begin
  4052. sname := ' ';
  4053. sym_line_no:=0;
  4054. end;
  4055. if writing_class_record_stab then
  4056. strpcopy(st,'"'+sname+':'+stabchar+classnumberstring+'=')
  4057. else
  4058. strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
  4059. strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
  4060. allstabstring := strnew(st);
  4061. freemem(st,strlen(ss)+512);
  4062. strdispose(ss);
  4063. end;
  4064. procedure tobjectdef.concatstabto(asmlist : taasmoutput);
  4065. var st : pstring;
  4066. begin
  4067. if objecttype<>odt_class then
  4068. begin
  4069. inherited concatstabto(asmlist);
  4070. exit;
  4071. end;
  4072. if ((typesym=nil) or ttypesym(typesym).isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
  4073. (is_def_stab_written = not_written) then
  4074. begin
  4075. if globalnb=0 then
  4076. set_globalnb;
  4077. { Write the record class itself }
  4078. writing_class_record_stab:=true;
  4079. inherited concatstabto(asmlist);
  4080. writing_class_record_stab:=false;
  4081. { Write the invisible pointer class }
  4082. is_def_stab_written:=not_written;
  4083. if assigned(typesym) then
  4084. begin
  4085. st:=typesym.FName;
  4086. typesym.FName:=stringdup(' ');
  4087. end;
  4088. inherited concatstabto(asmlist);
  4089. if assigned(typesym) then
  4090. begin
  4091. stringdispose(typesym.FName);
  4092. typesym.FName:=st;
  4093. end;
  4094. end;
  4095. end;
  4096. {$endif GDB}
  4097. function tobjectdef.needs_inittable : boolean;
  4098. begin
  4099. case objecttype of
  4100. odt_class :
  4101. needs_inittable:=false;
  4102. odt_interfacecom:
  4103. needs_inittable:=true;
  4104. odt_interfacecorba:
  4105. needs_inittable:=is_related(interface_iunknown);
  4106. odt_object:
  4107. needs_inittable:=tobjectsymtable(symtable).needs_init_final;
  4108. else
  4109. internalerror(200108267);
  4110. end;
  4111. end;
  4112. procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer);
  4113. begin
  4114. if needs_prop_entry(tsym(sym)) and
  4115. (tsym(sym).typ<>varsym) then
  4116. inc(count);
  4117. end;
  4118. procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer);
  4119. var
  4120. proctypesinfo : byte;
  4121. procedure writeproc(proc : tsymlist; shiftvalue : byte);
  4122. var
  4123. typvalue : byte;
  4124. hp : psymlistitem;
  4125. address : longint;
  4126. begin
  4127. if not(assigned(proc) and assigned(proc.firstsym)) then
  4128. begin
  4129. rttiList.concat(Tai_const.Create_32bit(1));
  4130. typvalue:=3;
  4131. end
  4132. else if proc.firstsym^.sym.typ=varsym then
  4133. begin
  4134. address:=0;
  4135. hp:=proc.firstsym;
  4136. while assigned(hp) do
  4137. begin
  4138. inc(address,tvarsym(hp^.sym).address);
  4139. hp:=hp^.next;
  4140. end;
  4141. rttiList.concat(Tai_const.Create_32bit(address));
  4142. typvalue:=0;
  4143. end
  4144. else
  4145. begin
  4146. if not(po_virtualmethod in tprocdef(proc.def).procoptions) then
  4147. begin
  4148. rttiList.concat(Tai_const_symbol.Createname(tprocdef(proc.def).mangledname));
  4149. typvalue:=1;
  4150. end
  4151. else
  4152. begin
  4153. { virtual method, write vmt offset }
  4154. rttiList.concat(Tai_const.Create_32bit(
  4155. tprocdef(proc.def)._class.vmtmethodoffset(tprocdef(proc.def).extnumber)));
  4156. typvalue:=2;
  4157. end;
  4158. end;
  4159. proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
  4160. end;
  4161. begin
  4162. if needs_prop_entry(tsym(sym)) then
  4163. case tsym(sym).typ of
  4164. varsym:
  4165. begin
  4166. {$ifdef dummy}
  4167. if not(tvarsym(sym).vartype.def.deftype=objectdef) or
  4168. not(tobjectdef(tvarsym(sym).vartype.def).is_class) then
  4169. internalerror(1509992);
  4170. { access to implicit class property as field }
  4171. proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4);
  4172. rttiList.concat(Tai_const_symbol.Createname(tvarsym(sym.vartype.def.get_rtti_label)));
  4173. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym.address)));
  4174. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym.address)));
  4175. { per default stored }
  4176. rttiList.concat(Tai_const.Create_32bit(1));
  4177. { index as well as ... }
  4178. rttiList.concat(Tai_const.Create_32bit(0));
  4179. { default value are zero }
  4180. rttiList.concat(Tai_const.Create_32bit(0));
  4181. rttiList.concat(Tai_const.Create_16bit(count));
  4182. inc(count);
  4183. rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
  4184. rttiList.concat(Tai_const.Create_8bit(length(tvarsym(sym.realname))));
  4185. rttiList.concat(Tai_string.Create(tvarsym(sym.realname)));
  4186. {$endif dummy}
  4187. end;
  4188. propertysym:
  4189. begin
  4190. if ppo_indexed in tpropertysym(sym).propoptions then
  4191. proctypesinfo:=$40
  4192. else
  4193. proctypesinfo:=0;
  4194. rttiList.concat(Tai_const_symbol.Create(tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti)));
  4195. writeproc(tpropertysym(sym).readaccess,0);
  4196. writeproc(tpropertysym(sym).writeaccess,2);
  4197. { isn't it stored ? }
  4198. if not(ppo_stored in tpropertysym(sym).propoptions) then
  4199. begin
  4200. rttiList.concat(Tai_const.Create_32bit(0));
  4201. proctypesinfo:=proctypesinfo or (3 shl 4);
  4202. end
  4203. else
  4204. writeproc(tpropertysym(sym).storedaccess,4);
  4205. rttiList.concat(Tai_const.Create_32bit(tpropertysym(sym).index));
  4206. rttiList.concat(Tai_const.Create_32bit(tpropertysym(sym).default));
  4207. rttiList.concat(Tai_const.Create_16bit(count));
  4208. inc(count);
  4209. rttiList.concat(Tai_const.Create_8bit(proctypesinfo));
  4210. rttiList.concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
  4211. rttiList.concat(Tai_string.Create(tpropertysym(sym).realname));
  4212. end;
  4213. else internalerror(1509992);
  4214. end;
  4215. end;
  4216. procedure tobjectdef.generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
  4217. begin
  4218. if needs_prop_entry(tsym(sym)) then
  4219. begin
  4220. case tsym(sym).typ of
  4221. propertysym:
  4222. tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti);
  4223. varsym:
  4224. tstoreddef(tvarsym(sym).vartype.def).get_rtti_label(fullrtti);
  4225. else
  4226. internalerror(1509991);
  4227. end;
  4228. end;
  4229. end;
  4230. procedure tobjectdef.write_child_rtti_data(rt:trttitype);
  4231. begin
  4232. FRTTIType:=rt;
  4233. case rt of
  4234. initrtti :
  4235. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_field_rtti,nil);
  4236. fullrtti :
  4237. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}generate_published_child_rtti,nil);
  4238. else
  4239. internalerror(200108301);
  4240. end;
  4241. end;
  4242. type
  4243. tclasslistitem = class(TLinkedListItem)
  4244. index : longint;
  4245. p : tobjectdef;
  4246. end;
  4247. var
  4248. classtablelist : tlinkedlist;
  4249. tablecount : longint;
  4250. function searchclasstablelist(p : tobjectdef) : tclasslistitem;
  4251. var
  4252. hp : tclasslistitem;
  4253. begin
  4254. hp:=tclasslistitem(classtablelist.first);
  4255. while assigned(hp) do
  4256. if hp.p=p then
  4257. begin
  4258. searchclasstablelist:=hp;
  4259. exit;
  4260. end
  4261. else
  4262. hp:=tclasslistitem(hp.next);
  4263. searchclasstablelist:=nil;
  4264. end;
  4265. procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer);
  4266. var
  4267. hp : tclasslistitem;
  4268. begin
  4269. if needs_prop_entry(tsym(sym)) and
  4270. (tsym(sym).typ=varsym) then
  4271. begin
  4272. if tvarsym(sym).vartype.def.deftype<>objectdef then
  4273. internalerror(0206001);
  4274. hp:=searchclasstablelist(tobjectdef(tvarsym(sym).vartype.def));
  4275. if not(assigned(hp)) then
  4276. begin
  4277. hp:=tclasslistitem.create;
  4278. hp.p:=tobjectdef(tvarsym(sym).vartype.def);
  4279. hp.index:=tablecount;
  4280. classtablelist.concat(hp);
  4281. inc(tablecount);
  4282. end;
  4283. inc(count);
  4284. end;
  4285. end;
  4286. procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer);
  4287. var
  4288. hp : tclasslistitem;
  4289. begin
  4290. if needs_prop_entry(tsym(sym)) and
  4291. (tsym(sym).typ=varsym) then
  4292. begin
  4293. rttiList.concat(Tai_const.Create_32bit(tvarsym(sym).address));
  4294. hp:=searchclasstablelist(tobjectdef(tvarsym(sym).vartype.def));
  4295. if not(assigned(hp)) then
  4296. internalerror(0206002);
  4297. rttiList.concat(Tai_const.Create_16bit(hp.index));
  4298. rttiList.concat(Tai_const.Create_8bit(length(tvarsym(sym).realname)));
  4299. rttiList.concat(Tai_string.Create(tvarsym(sym).realname));
  4300. end;
  4301. end;
  4302. function tobjectdef.generate_field_table : tasmlabel;
  4303. var
  4304. fieldtable,
  4305. classtable : tasmlabel;
  4306. hp : tclasslistitem;
  4307. begin
  4308. classtablelist:=TLinkedList.Create;
  4309. getdatalabel(fieldtable);
  4310. getdatalabel(classtable);
  4311. count:=0;
  4312. tablecount:=0;
  4313. symtable.foreach({$ifdef FPC}@{$endif}count_published_fields,nil);
  4314. if (cs_create_smart in aktmoduleswitches) then
  4315. rttiList.concat(Tai_cut.Create);
  4316. rttiList.concat(Tai_label.Create(fieldtable));
  4317. rttiList.concat(Tai_const.Create_16bit(count));
  4318. rttiList.concat(Tai_const_symbol.Create(classtable));
  4319. symtable.foreach({$ifdef FPC}@{$endif}writefields,nil);
  4320. { generate the class table }
  4321. rttiList.concat(Tai_label.Create(classtable));
  4322. rttiList.concat(Tai_const.Create_16bit(tablecount));
  4323. hp:=tclasslistitem(classtablelist.first);
  4324. while assigned(hp) do
  4325. begin
  4326. rttiList.concat(Tai_const_symbol.Createname(tobjectdef(hp.p).vmt_mangledname));
  4327. hp:=tclasslistitem(hp.next);
  4328. end;
  4329. generate_field_table:=fieldtable;
  4330. classtablelist.free;
  4331. end;
  4332. function tobjectdef.next_free_name_index : longint;
  4333. var
  4334. i : longint;
  4335. begin
  4336. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4337. i:=childof.next_free_name_index
  4338. else
  4339. i:=0;
  4340. count:=0;
  4341. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
  4342. next_free_name_index:=i+count;
  4343. end;
  4344. procedure tobjectdef.write_rtti_data(rt:trttitype);
  4345. begin
  4346. case objecttype of
  4347. odt_class:
  4348. rttiList.concat(Tai_const.Create_8bit(tkclass));
  4349. odt_object:
  4350. rttiList.concat(Tai_const.Create_8bit(tkobject));
  4351. odt_interfacecom:
  4352. rttiList.concat(Tai_const.Create_8bit(tkinterface));
  4353. odt_interfacecorba:
  4354. rttiList.concat(Tai_const.Create_8bit(tkinterfaceCorba));
  4355. else
  4356. exit;
  4357. end;
  4358. { generate the name }
  4359. rttiList.concat(Tai_const.Create_8bit(length(objrealname^)));
  4360. rttiList.concat(Tai_string.Create(objrealname^));
  4361. case rt of
  4362. initrtti :
  4363. begin
  4364. rttiList.concat(Tai_const.Create_32bit(size));
  4365. if objecttype in [odt_class,odt_object] then
  4366. begin
  4367. count:=0;
  4368. FRTTIType:=rt;
  4369. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_field_rtti,nil);
  4370. rttiList.concat(Tai_const.Create_32bit(count));
  4371. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti,nil);
  4372. end;
  4373. end;
  4374. fullrtti :
  4375. begin
  4376. if objecttype in [odt_interfacecom,odt_interfacecorba] then
  4377. rttiList.concat(Tai_const.Create_32bit(0))
  4378. else
  4379. rttiList.concat(Tai_const_symbol.Createname(vmt_mangledname));
  4380. { write owner typeinfo }
  4381. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4382. rttiList.concat(Tai_const_symbol.Create(childof.get_rtti_label(fullrtti)))
  4383. else
  4384. rttiList.concat(Tai_const.Create_32bit(0));
  4385. { count total number of properties }
  4386. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4387. count:=childof.next_free_name_index
  4388. else
  4389. count:=0;
  4390. { write it }
  4391. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
  4392. rttiList.concat(Tai_const.Create_16bit(count));
  4393. { write unit name }
  4394. rttiList.concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
  4395. rttiList.concat(Tai_string.Create(current_module.realmodulename^));
  4396. { write published properties count }
  4397. count:=0;
  4398. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties,nil);
  4399. rttiList.concat(Tai_const.Create_16bit(count));
  4400. { count is used to write nameindex }
  4401. { but we need an offset of the owner }
  4402. { to give each property an own slot }
  4403. if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
  4404. count:=childof.next_free_name_index
  4405. else
  4406. count:=0;
  4407. symtable.foreach({$ifdef FPCPROCVAR}@{$endif}write_property_info,nil);
  4408. end;
  4409. end;
  4410. end;
  4411. function tobjectdef.is_publishable : boolean;
  4412. begin
  4413. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
  4414. end;
  4415. {****************************************************************************
  4416. TIMPLEMENTEDINTERFACES
  4417. ****************************************************************************}
  4418. type
  4419. tnamemap = class(TNamedIndexItem)
  4420. newname: pstring;
  4421. constructor create(const aname, anewname: string);
  4422. destructor destroy; override;
  4423. end;
  4424. constructor tnamemap.create(const aname, anewname: string);
  4425. begin
  4426. inherited createname(name);
  4427. newname:=stringdup(anewname);
  4428. end;
  4429. destructor tnamemap.destroy;
  4430. begin
  4431. stringdispose(newname);
  4432. inherited destroy;
  4433. end;
  4434. type
  4435. tprocdefstore = class(TNamedIndexItem)
  4436. procdef: tprocdef;
  4437. constructor create(aprocdef: tprocdef);
  4438. end;
  4439. constructor tprocdefstore.create(aprocdef: tprocdef);
  4440. begin
  4441. inherited create;
  4442. procdef:=aprocdef;
  4443. end;
  4444. type
  4445. timplintfentry = class(TNamedIndexItem)
  4446. intf: tobjectdef;
  4447. ioffs: longint;
  4448. namemappings: tdictionary;
  4449. procdefs: TIndexArray;
  4450. constructor create(aintf: tobjectdef);
  4451. destructor destroy; override;
  4452. end;
  4453. constructor timplintfentry.create(aintf: tobjectdef);
  4454. begin
  4455. inherited create;
  4456. intf:=aintf;
  4457. ioffs:=-1;
  4458. namemappings:=nil;
  4459. procdefs:=nil;
  4460. end;
  4461. destructor timplintfentry.destroy;
  4462. begin
  4463. if assigned(namemappings) then
  4464. namemappings.free;
  4465. if assigned(procdefs) then
  4466. procdefs.free;
  4467. inherited destroy;
  4468. end;
  4469. constructor timplementedinterfaces.create;
  4470. begin
  4471. finterfaces:=tindexarray.create(1);
  4472. end;
  4473. destructor timplementedinterfaces.destroy;
  4474. begin
  4475. finterfaces.destroy;
  4476. end;
  4477. function timplementedinterfaces.count: longint;
  4478. begin
  4479. count:=finterfaces.count;
  4480. end;
  4481. procedure timplementedinterfaces.checkindex(intfindex: longint);
  4482. begin
  4483. if (intfindex<1) or (intfindex>count) then
  4484. InternalError(200006123);
  4485. end;
  4486. function timplementedinterfaces.interfaces(intfindex: longint): tobjectdef;
  4487. begin
  4488. checkindex(intfindex);
  4489. interfaces:=timplintfentry(finterfaces.search(intfindex)).intf;
  4490. end;
  4491. function timplementedinterfaces.ioffsets(intfindex: longint): plongint;
  4492. begin
  4493. checkindex(intfindex);
  4494. ioffsets:=@timplintfentry(finterfaces.search(intfindex)).ioffs;
  4495. end;
  4496. function timplementedinterfaces.searchintf(def: tdef): longint;
  4497. var
  4498. i: longint;
  4499. begin
  4500. i:=1;
  4501. while (i<=count) and (tdef(interfaces(i))<>def) do inc(i);
  4502. if i<=count then
  4503. searchintf:=i
  4504. else
  4505. searchintf:=-1;
  4506. end;
  4507. procedure timplementedinterfaces.deref;
  4508. var
  4509. i: longint;
  4510. begin
  4511. for i:=1 to count do
  4512. with timplintfentry(finterfaces.search(i)) do
  4513. resolvedef(pointer(intf));
  4514. end;
  4515. procedure timplementedinterfaces.addintfref(def: pointer);
  4516. begin
  4517. finterfaces.insert(timplintfentry.create(tobjectdef(def)));
  4518. end;
  4519. procedure timplementedinterfaces.addintf(def: tdef);
  4520. begin
  4521. if not assigned(def) or (searchintf(def)<>-1) or (def.deftype<>objectdef) or
  4522. not (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]) then
  4523. internalerror(200006124);
  4524. finterfaces.insert(timplintfentry.create(tobjectdef(def)));
  4525. end;
  4526. procedure timplementedinterfaces.clearmappings;
  4527. var
  4528. i: longint;
  4529. begin
  4530. for i:=1 to count do
  4531. with timplintfentry(finterfaces.search(i)) do
  4532. begin
  4533. if assigned(namemappings) then
  4534. namemappings.free;
  4535. namemappings:=nil;
  4536. end;
  4537. end;
  4538. procedure timplementedinterfaces.addmappings(intfindex: longint; const name, newname: string);
  4539. begin
  4540. checkindex(intfindex);
  4541. with timplintfentry(finterfaces.search(intfindex)) do
  4542. begin
  4543. if not assigned(namemappings) then
  4544. namemappings:=tdictionary.create;
  4545. namemappings.insert(tnamemap.create(name,newname));
  4546. end;
  4547. end;
  4548. function timplementedinterfaces.getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
  4549. begin
  4550. checkindex(intfindex);
  4551. if not assigned(nextexist) then
  4552. with timplintfentry(finterfaces.search(intfindex)) do
  4553. begin
  4554. if assigned(namemappings) then
  4555. nextexist:=namemappings.search(name)
  4556. else
  4557. nextexist:=nil;
  4558. end;
  4559. if assigned(nextexist) then
  4560. begin
  4561. getmappings:=tnamemap(nextexist).newname^;
  4562. nextexist:=tnamemap(nextexist).listnext;
  4563. end
  4564. else
  4565. getmappings:='';
  4566. end;
  4567. procedure timplementedinterfaces.clearimplprocs;
  4568. var
  4569. i: longint;
  4570. begin
  4571. for i:=1 to count do
  4572. with timplintfentry(finterfaces.search(i)) do
  4573. begin
  4574. if assigned(procdefs) then
  4575. procdefs.free;
  4576. procdefs:=nil;
  4577. end;
  4578. end;
  4579. procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: tprocdef);
  4580. begin
  4581. checkindex(intfindex);
  4582. with timplintfentry(finterfaces.search(intfindex)) do
  4583. begin
  4584. if not assigned(procdefs) then
  4585. procdefs:=tindexarray.create(4);
  4586. procdefs.insert(tprocdefstore.create(procdef));
  4587. end;
  4588. end;
  4589. function timplementedinterfaces.implproccount(intfindex: longint): longint;
  4590. begin
  4591. checkindex(intfindex);
  4592. with timplintfentry(finterfaces.search(intfindex)) do
  4593. if assigned(procdefs) then
  4594. implproccount:=procdefs.count
  4595. else
  4596. implproccount:=0;
  4597. end;
  4598. function timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): tprocdef;
  4599. begin
  4600. checkindex(intfindex);
  4601. with timplintfentry(finterfaces.search(intfindex)) do
  4602. if assigned(procdefs) then
  4603. implprocs:=tprocdefstore(procdefs.search(procindex)).procdef
  4604. else
  4605. internalerror(200006131);
  4606. end;
  4607. function timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
  4608. var
  4609. possible: boolean;
  4610. i: longint;
  4611. iiep1: TIndexArray;
  4612. iiep2: TIndexArray;
  4613. begin
  4614. checkindex(intfindex);
  4615. checkindex(remainindex);
  4616. iiep1:=timplintfentry(finterfaces.search(intfindex)).procdefs;
  4617. iiep2:=timplintfentry(finterfaces.search(remainindex)).procdefs;
  4618. if not assigned(iiep1) then { empty interface is mergeable :-) }
  4619. begin
  4620. possible:=true;
  4621. weight:=0;
  4622. end
  4623. else
  4624. begin
  4625. possible:=assigned(iiep2) and (iiep1.count<=iiep2.count);
  4626. i:=1;
  4627. while (possible) and (i<=iiep1.count) do
  4628. begin
  4629. possible:=
  4630. (tprocdefstore(iiep1.search(i)).procdef=tprocdefstore(iiep2.search(i)).procdef);
  4631. inc(i);
  4632. end;
  4633. if possible then
  4634. weight:=iiep1.count;
  4635. end;
  4636. isimplmergepossible:=possible;
  4637. end;
  4638. {****************************************************************************
  4639. TFORWARDDEF
  4640. ****************************************************************************}
  4641. constructor tforwarddef.create(const s:string;const pos : tfileposinfo);
  4642. var
  4643. oldregisterdef : boolean;
  4644. begin
  4645. { never register the forwarddefs, they are disposed at the
  4646. end of the type declaration block }
  4647. oldregisterdef:=registerdef;
  4648. registerdef:=false;
  4649. inherited create;
  4650. registerdef:=oldregisterdef;
  4651. deftype:=forwarddef;
  4652. tosymname:=s;
  4653. forwardpos:=pos;
  4654. end;
  4655. function tforwarddef.gettypename:string;
  4656. begin
  4657. gettypename:='unresolved forward to '+tosymname;
  4658. end;
  4659. {****************************************************************************
  4660. TERRORDEF
  4661. ****************************************************************************}
  4662. constructor terrordef.create;
  4663. begin
  4664. inherited create;
  4665. deftype:=errordef;
  4666. end;
  4667. {$ifdef GDB}
  4668. function terrordef.stabstring : pchar;
  4669. begin
  4670. stabstring:=strpnew('error'+numberstring);
  4671. end;
  4672. {$endif GDB}
  4673. function terrordef.gettypename:string;
  4674. begin
  4675. gettypename:='<erroneous type>';
  4676. end;
  4677. {****************************************************************************
  4678. GDB Helpers
  4679. ****************************************************************************}
  4680. {$ifdef GDB}
  4681. function typeglobalnumber(const s : string) : string;
  4682. var st : string;
  4683. symt : tsymtable;
  4684. srsym : tsym;
  4685. srsymtable : tsymtable;
  4686. old_make_ref : boolean;
  4687. begin
  4688. old_make_ref:=make_ref;
  4689. make_ref:=false;
  4690. typeglobalnumber := '0';
  4691. srsym := nil;
  4692. if pos('.',s) > 0 then
  4693. begin
  4694. st := copy(s,1,pos('.',s)-1);
  4695. searchsym(st,srsym,srsymtable);
  4696. st := copy(s,pos('.',s)+1,255);
  4697. if assigned(srsym) then
  4698. begin
  4699. if srsym.typ = unitsym then
  4700. begin
  4701. symt := tunitsym(srsym).unitsymtable;
  4702. srsym := tsym(symt.search(st));
  4703. end else srsym := nil;
  4704. end;
  4705. end else st := s;
  4706. if srsym = nil then
  4707. searchsym(st,srsym,srsymtable);
  4708. if (srsym=nil) or
  4709. (srsym.typ<>typesym) then
  4710. begin
  4711. Message(type_e_type_id_expected);
  4712. exit;
  4713. end;
  4714. typeglobalnumber := tstoreddef(ttypesym(srsym).restype.def).numberstring;
  4715. make_ref:=old_make_ref;
  4716. end;
  4717. {$endif GDB}
  4718. {****************************************************************************
  4719. Definition Helpers
  4720. ****************************************************************************}
  4721. procedure reset_global_defs;
  4722. var
  4723. def : tstoreddef;
  4724. {$ifdef debug}
  4725. prevdef : tstoreddef;
  4726. {$endif debug}
  4727. begin
  4728. {$ifdef debug}
  4729. prevdef:=nil;
  4730. {$endif debug}
  4731. {$ifdef GDB}
  4732. pglobaltypecount:=@globaltypecount;
  4733. {$endif GDB}
  4734. def:=firstglobaldef;
  4735. while assigned(def) do
  4736. begin
  4737. {$ifdef GDB}
  4738. if assigned(def.typesym) then
  4739. ttypesym(def.typesym).isusedinstab:=false;
  4740. def.is_def_stab_written:=not_written;
  4741. {$endif GDB}
  4742. { reset rangenr's }
  4743. case def.deftype of
  4744. orddef : torddef(def).rangenr:=0;
  4745. enumdef : tenumdef(def).rangenr:=0;
  4746. arraydef : tarraydef(def).rangenr:=0;
  4747. end;
  4748. if assigned(def.rttitablesym) then
  4749. trttisym(def.rttitablesym).lab := nil;
  4750. if assigned(def.inittablesym) then
  4751. trttisym(def.inittablesym).lab := nil;
  4752. def.localrttilab[initrtti]:=nil;
  4753. def.localrttilab[fullrtti]:=nil;
  4754. {$ifdef debug}
  4755. prevdef:=def;
  4756. {$endif debug}
  4757. def:=def.nextglobal;
  4758. end;
  4759. end;
  4760. function is_interfacecom(def: tdef): boolean;
  4761. begin
  4762. is_interfacecom:=
  4763. assigned(def) and
  4764. (def.deftype=objectdef) and
  4765. (tobjectdef(def).objecttype=odt_interfacecom);
  4766. end;
  4767. function is_interfacecorba(def: tdef): boolean;
  4768. begin
  4769. is_interfacecorba:=
  4770. assigned(def) and
  4771. (def.deftype=objectdef) and
  4772. (tobjectdef(def).objecttype=odt_interfacecorba);
  4773. end;
  4774. function is_interface(def: tdef): boolean;
  4775. begin
  4776. is_interface:=
  4777. assigned(def) and
  4778. (def.deftype=objectdef) and
  4779. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  4780. end;
  4781. function is_class(def: tdef): boolean;
  4782. begin
  4783. is_class:=
  4784. assigned(def) and
  4785. (def.deftype=objectdef) and
  4786. (tobjectdef(def).objecttype=odt_class);
  4787. end;
  4788. function is_object(def: tdef): boolean;
  4789. begin
  4790. is_object:=
  4791. assigned(def) and
  4792. (def.deftype=objectdef) and
  4793. (tobjectdef(def).objecttype=odt_object);
  4794. end;
  4795. function is_cppclass(def: tdef): boolean;
  4796. begin
  4797. is_cppclass:=
  4798. assigned(def) and
  4799. (def.deftype=objectdef) and
  4800. (tobjectdef(def).objecttype=odt_cppclass);
  4801. end;
  4802. function is_class_or_interface(def: tdef): boolean;
  4803. begin
  4804. is_class_or_interface:=
  4805. assigned(def) and
  4806. (def.deftype=objectdef) and
  4807. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  4808. end;
  4809. end.
  4810. {
  4811. $Log$
  4812. Revision 1.81 2002-07-01 18:46:26 peter
  4813. * internal linker
  4814. * reorganized aasm layer
  4815. Revision 1.80 2002/07/01 16:23:54 peter
  4816. * cg64 patch
  4817. * basics for currency
  4818. * asnode updates for class and interface (not finished)
  4819. Revision 1.79 2002/05/18 13:34:18 peter
  4820. * readded missing revisions
  4821. Revision 1.78 2002/05/16 19:46:44 carl
  4822. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  4823. + try to fix temp allocation (still in ifdef)
  4824. + generic constructor calls
  4825. + start of tassembler / tmodulebase class cleanup
  4826. Revision 1.76 2002/05/12 16:53:10 peter
  4827. * moved entry and exitcode to ncgutil and cgobj
  4828. * foreach gets extra argument for passing local data to the
  4829. iterator function
  4830. * -CR checks also class typecasts at runtime by changing them
  4831. into as
  4832. * fixed compiler to cycle with the -CR option
  4833. * fixed stabs with elf writer, finally the global variables can
  4834. be watched
  4835. * removed a lot of routines from cga unit and replaced them by
  4836. calls to cgobj
  4837. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  4838. u32bit then the other is typecasted also to u32bit without giving
  4839. a rangecheck warning/error.
  4840. * fixed pascal calling method with reversing also the high tree in
  4841. the parast, detected by tcalcst3 test
  4842. Revision 1.75 2002/04/25 20:16:39 peter
  4843. * moved more routines from cga/n386util
  4844. Revision 1.74 2002/04/23 19:16:35 peter
  4845. * add pinline unit that inserts compiler supported functions using
  4846. one or more statements
  4847. * moved finalize and setlength from ninl to pinline
  4848. Revision 1.73 2002/04/21 19:02:05 peter
  4849. * removed newn and disposen nodes, the code is now directly
  4850. inlined from pexpr
  4851. * -an option that will write the secondpass nodes to the .s file, this
  4852. requires EXTDEBUG define to actually write the info
  4853. * fixed various internal errors and crashes due recent code changes
  4854. Revision 1.72 2002/04/20 21:32:25 carl
  4855. + generic FPC_CHECKPOINTER
  4856. + first parameter offset in stack now portable
  4857. * rename some constants
  4858. + move some cpu stuff to other units
  4859. - remove unused constents
  4860. * fix stacksize for some targets
  4861. * fix generic size problems which depend now on EXTEND_SIZE constant
  4862. Revision 1.71 2002/04/19 15:46:03 peter
  4863. * mangledname rewrite, tprocdef.mangledname is now created dynamicly
  4864. in most cases and not written to the ppu
  4865. * add mangeledname_prefix() routine to generate the prefix of
  4866. manglednames depending on the current procedure, object and module
  4867. * removed static procprefix since the mangledname is now build only
  4868. on demand from tprocdef.mangledname
  4869. Revision 1.70 2002/04/15 19:06:34 carl
  4870. + target_info.size_of_pointer -> pointer_Size
  4871. Revision 1.69 2002/04/14 16:55:43 carl
  4872. + replace some stuff by ALL_REGISTERS
  4873. Revision 1.68 2002/04/02 17:11:29 peter
  4874. * tlocation,treference update
  4875. * LOC_CONSTANT added for better constant handling
  4876. * secondadd splitted in multiple routines
  4877. * location_force_reg added for loading a location to a register
  4878. of a specified size
  4879. * secondassignment parses now first the right and then the left node
  4880. (this is compatible with Kylix). This saves a lot of push/pop especially
  4881. with string operations
  4882. * adapted some routines to use the new cg methods
  4883. Revision 1.67 2002/03/31 20:26:36 jonas
  4884. + a_loadfpu_* and a_loadmm_* methods in tcg
  4885. * register allocation is now handled by a class and is mostly processor
  4886. independent (+rgobj.pas and i386/rgcpu.pas)
  4887. * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
  4888. * some small improvements and fixes to the optimizer
  4889. * some register allocation fixes
  4890. * some fpuvaroffset fixes in the unary minus node
  4891. * push/popusedregisters is now called rg.save/restoreusedregisters and
  4892. (for i386) uses temps instead of push/pop's when using -Op3 (that code is
  4893. also better optimizable)
  4894. * fixed and optimized register saving/restoring for new/dispose nodes
  4895. * LOC_FPU locations now also require their "register" field to be set to
  4896. R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
  4897. - list field removed of the tnode class because it's not used currently
  4898. and can cause hard-to-find bugs
  4899. Revision 1.66 2002/03/24 19:10:14 carl
  4900. + patch for SPARC from Mazen NEIFER
  4901. Revision 1.65 2002/02/04 08:16:07 jonas
  4902. * fixed severe slowdown when compiling a program with arrays that have
  4903. a lot (15+) dimensions ("merged")
  4904. Revision 1.64 2002/01/19 15:12:34 peter
  4905. * check for unresolved forward classes in the interface
  4906. Revision 1.63 2002/01/06 21:52:30 peter
  4907. * fixed previous commit
  4908. Revision 1.62 2002/01/06 12:08:15 peter
  4909. * removed uauto from orddef, use new range_to_basetype generating
  4910. the correct ordinal type for a range
  4911. }