symdef.pas 168 KB

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