symdef.pas 184 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864
  1. {
  2. Symbol table implementation for the definitions
  3. Copyright (c) 1998-2005 by Florian Klaempfl, Pierre Muller
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit symdef;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cclasses,
  23. { global }
  24. globtype,globals,tokens,constexp,
  25. { symtable }
  26. symconst,symbase,symtype,
  27. { ppu }
  28. ppu,
  29. { node }
  30. node,
  31. { aasm }
  32. aasmbase,aasmtai,aasmdata,
  33. cpubase,cpuinfo,
  34. cgbase,cgutils,
  35. parabase
  36. ;
  37. type
  38. {************************************************
  39. TDef
  40. ************************************************}
  41. { tstoreddef }
  42. tstoreddef = class(tdef)
  43. protected
  44. typesymderef : tderef;
  45. public
  46. {$ifdef EXTDEBUG}
  47. fileinfo : tfileposinfo;
  48. {$endif}
  49. { generic support }
  50. genericdef : tstoreddef;
  51. genericdefderef : tderef;
  52. generictokenbuf : tdynamicarray;
  53. constructor create(dt:tdeftyp);
  54. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  55. destructor destroy;override;
  56. function getcopy : tstoreddef;virtual;
  57. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  58. procedure buildderef;override;
  59. procedure buildderefimpl;override;
  60. procedure deref;override;
  61. procedure derefimpl;override;
  62. function size:asizeint;override;
  63. function getvardef:longint;override;
  64. function alignment:shortint;override;
  65. function is_publishable : boolean;override;
  66. function needs_inittable : boolean;override;
  67. function rtti_mangledname(rt:trttitype):string;override;
  68. function OwnerHierarchyName: string; override;
  69. function in_currentunit: boolean;
  70. { regvars }
  71. function is_intregable : boolean;
  72. function is_fpuregable : boolean;
  73. { generics }
  74. procedure initgeneric;
  75. private
  76. savesize : asizeuint;
  77. end;
  78. tfiletyp = (ft_text,ft_typed,ft_untyped);
  79. tfiledef = class(tstoreddef)
  80. filetyp : tfiletyp;
  81. typedfiledef : tdef;
  82. typedfiledefderef : tderef;
  83. constructor createtext;
  84. constructor createuntyped;
  85. constructor createtyped(def : tdef);
  86. constructor ppuload(ppufile:tcompilerppufile);
  87. function getcopy : tstoreddef;override;
  88. procedure ppuwrite(ppufile:tcompilerppufile);override;
  89. procedure buildderef;override;
  90. procedure deref;override;
  91. function GetTypeName:string;override;
  92. function getmangledparaname:string;override;
  93. procedure setsize;
  94. end;
  95. tvariantdef = class(tstoreddef)
  96. varianttype : tvarianttype;
  97. constructor create(v : tvarianttype);
  98. constructor ppuload(ppufile:tcompilerppufile);
  99. function getcopy : tstoreddef;override;
  100. function GetTypeName:string;override;
  101. procedure ppuwrite(ppufile:tcompilerppufile);override;
  102. function getvardef:longint;override;
  103. procedure setsize;
  104. function is_publishable : boolean;override;
  105. function needs_inittable : boolean;override;
  106. end;
  107. tformaldef = class(tstoreddef)
  108. typed:boolean;
  109. constructor create(Atyped:boolean);
  110. constructor ppuload(ppufile:tcompilerppufile);
  111. procedure ppuwrite(ppufile:tcompilerppufile);override;
  112. function GetTypeName:string;override;
  113. end;
  114. tforwarddef = class(tstoreddef)
  115. tosymname : pshortstring;
  116. forwardpos : tfileposinfo;
  117. constructor create(const s:string;const pos:tfileposinfo);
  118. destructor destroy;override;
  119. function getcopy:tstoreddef;override;
  120. function GetTypeName:string;override;
  121. end;
  122. tundefineddef = class(tstoreddef)
  123. constructor create;
  124. constructor ppuload(ppufile:tcompilerppufile);
  125. procedure ppuwrite(ppufile:tcompilerppufile);override;
  126. function GetTypeName:string;override;
  127. end;
  128. terrordef = class(tstoreddef)
  129. constructor create;
  130. procedure ppuwrite(ppufile:tcompilerppufile);override;
  131. function GetTypeName:string;override;
  132. function getmangledparaname : string;override;
  133. end;
  134. tabstractpointerdef = class(tstoreddef)
  135. pointeddef : tdef;
  136. pointeddefderef : tderef;
  137. constructor create(dt:tdeftyp;def:tdef);
  138. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  139. procedure ppuwrite(ppufile:tcompilerppufile);override;
  140. procedure buildderef;override;
  141. procedure deref;override;
  142. end;
  143. tpointerdef = class(tabstractpointerdef)
  144. is_far : boolean;
  145. has_pointer_math : boolean;
  146. constructor create(def:tdef);
  147. constructor createfar(def:tdef);
  148. function getcopy:tstoreddef;override;
  149. constructor ppuload(ppufile:tcompilerppufile);
  150. procedure ppuwrite(ppufile:tcompilerppufile);override;
  151. function GetTypeName:string;override;
  152. end;
  153. tprocdef = class;
  154. { tabstractrecorddef }
  155. tabstractrecorddef= class(tstoreddef)
  156. objname,
  157. objrealname : PShortString;
  158. symtable : TSymtable;
  159. cloneddef : tabstractrecorddef;
  160. cloneddefderef : tderef;
  161. objectoptions : tobjectoptions;
  162. constructor create(const n:string; dt:tdeftyp);
  163. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  164. procedure ppuwrite(ppufile:tcompilerppufile);override;
  165. destructor destroy; override;
  166. procedure check_forwards; virtual;
  167. function find_procdef_bytype(pt:tproctypeoption): tprocdef;
  168. function GetSymtable(t:tGetSymtable):TSymtable;override;
  169. function is_packed:boolean;
  170. function RttiName: string;
  171. { enumerator support }
  172. function search_enumerator_get: tprocdef; virtual;
  173. function search_enumerator_move: tprocdef; virtual;
  174. function search_enumerator_current: tsym; virtual;
  175. end;
  176. trecorddef = class(tabstractrecorddef)
  177. public
  178. isunion : boolean;
  179. constructor create(const n:string; p:TSymtable);
  180. constructor ppuload(ppufile:tcompilerppufile);
  181. destructor destroy;override;
  182. function getcopy : tstoreddef;override;
  183. procedure ppuwrite(ppufile:tcompilerppufile);override;
  184. procedure buildderef;override;
  185. procedure deref;override;
  186. function size:asizeint;override;
  187. function alignment : shortint;override;
  188. function padalignment: shortint;
  189. function GetTypeName:string;override;
  190. { debug }
  191. function needs_inittable : boolean;override;
  192. end;
  193. tobjectdef = class;
  194. { TImplementedInterface }
  195. TImplementedInterface = class
  196. IntfDef : tobjectdef;
  197. IntfDefDeref : tderef;
  198. IType : tinterfaceentrytype;
  199. IOffset : longint;
  200. VtblImplIntf : TImplementedInterface;
  201. NameMappings : TFPHashList;
  202. ProcDefs : TFPObjectList;
  203. ImplementsGetter : tsym;
  204. constructor create(aintf: tobjectdef);
  205. constructor create_deref(d:tderef);
  206. destructor destroy; override;
  207. function getcopy:TImplementedInterface;
  208. procedure buildderef;
  209. procedure deref;
  210. procedure AddMapping(const origname, newname: string);
  211. function GetMapping(const origname: string):string;
  212. procedure AddImplProc(pd:tprocdef);
  213. function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  214. end;
  215. { tvmtentry }
  216. tvmtentry = record
  217. procdef : tprocdef;
  218. procdefderef : tderef;
  219. visibility : tvisibility;
  220. end;
  221. pvmtentry = ^tvmtentry;
  222. { tobjectdef }
  223. tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
  224. pmvcallstaticinfo = ^tmvcallstaticinfo;
  225. tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
  226. tobjectdef = class(tabstractrecorddef)
  227. private
  228. fcurrent_dispid: longint;
  229. public
  230. dwarf_struct_lab : tasmsymbol;
  231. childof : tobjectdef;
  232. childofderef : tderef;
  233. { for Object Pascal helpers }
  234. extendeddef : tdef;
  235. extendeddefderef: tderef;
  236. { for C++ classes: name of the library this class is imported from }
  237. import_lib,
  238. { for Objective-C: protocols and classes can have the same name there }
  239. objextname : pshortstring;
  240. { to be able to have a variable vmt position }
  241. { and no vmt field for objects without virtuals }
  242. vmtentries : TFPList;
  243. vmcallstaticinfo : pmvcallstaticinfo;
  244. vmt_offset : longint;
  245. objecttype : tobjecttyp;
  246. iidguid : pguid;
  247. iidstr : pshortstring;
  248. writing_class_record_dbginfo,
  249. { a class of this type has been created in this module }
  250. created_in_current_module,
  251. { a loadvmtnode for this class has been created in this
  252. module, so if a classrefdef variable of this or a parent
  253. class is used somewhere to instantiate a class, then this
  254. class may be instantiated
  255. }
  256. maybe_created_in_current_module,
  257. { a "class of" this particular class has been created in
  258. this module
  259. }
  260. classref_created_in_current_module : boolean;
  261. { store implemented interfaces defs and name mappings }
  262. ImplementedInterfaces : TFPObjectList;
  263. constructor create(ot:tobjecttyp;const n:string;c:tobjectdef);
  264. constructor ppuload(ppufile:tcompilerppufile);
  265. destructor destroy;override;
  266. function getcopy : tstoreddef;override;
  267. procedure ppuwrite(ppufile:tcompilerppufile);override;
  268. function GetTypeName:string;override;
  269. procedure buildderef;override;
  270. procedure deref;override;
  271. procedure buildderefimpl;override;
  272. procedure derefimpl;override;
  273. procedure resetvmtentries;
  274. procedure copyvmtentries(objdef:tobjectdef);
  275. function getparentdef:tdef;override;
  276. function size : asizeint;override;
  277. function alignment:shortint;override;
  278. function vmtmethodoffset(index:longint):longint;
  279. function members_need_inittable : boolean;
  280. function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  281. { this should be called when this class implements an interface }
  282. procedure prepareguid;
  283. function is_publishable : boolean;override;
  284. function is_related(d : tdef) : boolean;override;
  285. function needs_inittable : boolean;override;
  286. function rtti_mangledname(rt:trttitype):string;override;
  287. function vmt_mangledname : string;
  288. procedure check_forwards; override;
  289. procedure insertvmt;
  290. procedure set_parent(c : tobjectdef);
  291. function find_destructor: tprocdef;
  292. function implements_any_interfaces: boolean;
  293. { dispinterface support }
  294. function get_next_dispid: longint;
  295. { enumerator support }
  296. function search_enumerator_get: tprocdef; override;
  297. function search_enumerator_move: tprocdef; override;
  298. function search_enumerator_current: tsym; override;
  299. { WPO }
  300. procedure register_created_object_type;override;
  301. procedure register_maybe_created_object_type;
  302. procedure register_created_classref_type;
  303. procedure register_vmt_call(index:longint);
  304. { ObjC }
  305. procedure finish_objc_data;
  306. function check_objc_types: boolean;
  307. { C++ }
  308. procedure finish_cpp_data;
  309. end;
  310. tclassrefdef = class(tabstractpointerdef)
  311. constructor create(def:tdef);
  312. constructor ppuload(ppufile:tcompilerppufile);
  313. procedure ppuwrite(ppufile:tcompilerppufile);override;
  314. function getcopy:tstoreddef;override;
  315. function GetTypeName:string;override;
  316. function is_publishable : boolean;override;
  317. function rtti_mangledname(rt:trttitype):string;override;
  318. procedure register_created_object_type;override;
  319. end;
  320. tarraydef = class(tstoreddef)
  321. lowrange,
  322. highrange : asizeint;
  323. rangedef : tdef;
  324. rangedefderef : tderef;
  325. arrayoptions : tarraydefoptions;
  326. symtable : TSymtable;
  327. protected
  328. _elementdef : tdef;
  329. _elementdefderef : tderef;
  330. procedure setelementdef(def:tdef);
  331. public
  332. function elesize : asizeint;
  333. function elepackedbitsize : asizeint;
  334. function elecount : asizeuint;
  335. constructor create_from_pointer(def:tdef);
  336. constructor create(l,h:asizeint;def:tdef);
  337. constructor ppuload(ppufile:tcompilerppufile);
  338. destructor destroy; override;
  339. function getcopy : tstoreddef;override;
  340. procedure ppuwrite(ppufile:tcompilerppufile);override;
  341. function GetTypeName:string;override;
  342. function getmangledparaname : string;override;
  343. procedure buildderef;override;
  344. procedure deref;override;
  345. function size : asizeint;override;
  346. function alignment : shortint;override;
  347. { returns the label of the range check string }
  348. function needs_inittable : boolean;override;
  349. property elementdef : tdef read _elementdef write setelementdef;
  350. function is_publishable : boolean;override;
  351. end;
  352. torddef = class(tstoreddef)
  353. low,high : TConstExprInt;
  354. ordtype : tordtype;
  355. constructor create(t : tordtype;v,b : TConstExprInt);
  356. constructor ppuload(ppufile:tcompilerppufile);
  357. function getcopy : tstoreddef;override;
  358. procedure ppuwrite(ppufile:tcompilerppufile);override;
  359. function is_publishable : boolean;override;
  360. function GetTypeName:string;override;
  361. function alignment:shortint;override;
  362. procedure setsize;
  363. function packedbitsize: asizeint; override;
  364. function getvardef : longint;override;
  365. end;
  366. tfloatdef = class(tstoreddef)
  367. floattype : tfloattype;
  368. constructor create(t : tfloattype);
  369. constructor ppuload(ppufile:tcompilerppufile);
  370. function getcopy : tstoreddef;override;
  371. procedure ppuwrite(ppufile:tcompilerppufile);override;
  372. function GetTypeName:string;override;
  373. function is_publishable : boolean;override;
  374. function alignment:shortint;override;
  375. procedure setsize;
  376. function getvardef:longint;override;
  377. end;
  378. { tabstractprocdef }
  379. tabstractprocdef = class(tstoreddef)
  380. { saves a definition to the return type }
  381. returndef : tdef;
  382. returndefderef : tderef;
  383. parast : TSymtable;
  384. paras : tparalist;
  385. proctypeoption : tproctypeoption;
  386. proccalloption : tproccalloption;
  387. procoptions : tprocoptions;
  388. callerargareasize,
  389. calleeargareasize: pint;
  390. { number of user visibile parameters }
  391. maxparacount,
  392. minparacount : byte;
  393. {$ifdef m68k}
  394. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  395. {$endif}
  396. funcretloc : array[tcallercallee] of TCGPara;
  397. has_paraloc_info : tcallercallee; { paraloc info is available }
  398. constructor create(dt:tdeftyp;level:byte);
  399. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  400. destructor destroy;override;
  401. procedure ppuwrite(ppufile:tcompilerppufile);override;
  402. procedure buildderef;override;
  403. procedure deref;override;
  404. procedure calcparas;
  405. function typename_paras(showhidden:boolean): string;
  406. function is_methodpointer:boolean;virtual;
  407. function is_addressonly:boolean;virtual;
  408. function no_self_node:boolean;
  409. procedure check_mark_as_nested;
  410. procedure init_paraloc_info(side: tcallercallee);
  411. function stack_tainting_parameter(side: tcallercallee): boolean;
  412. private
  413. procedure count_para(p:TObject;arg:pointer);
  414. procedure insert_para(p:TObject;arg:pointer);
  415. end;
  416. tprocvardef = class(tabstractprocdef)
  417. constructor create(level:byte);
  418. constructor ppuload(ppufile:tcompilerppufile);
  419. function getcopy : tstoreddef;override;
  420. procedure ppuwrite(ppufile:tcompilerppufile);override;
  421. function GetSymtable(t:tGetSymtable):TSymtable;override;
  422. function size : asizeint;override;
  423. function GetTypeName:string;override;
  424. function is_publishable : boolean;override;
  425. function is_methodpointer:boolean;override;
  426. function is_addressonly:boolean;override;
  427. function getmangledparaname:string;override;
  428. end;
  429. tmessageinf = record
  430. case integer of
  431. 0 : (str : pshortstring);
  432. 1 : (i : longint);
  433. end;
  434. tinlininginfo = record
  435. { node tree }
  436. code : tnode;
  437. flags : tprocinfoflags;
  438. end;
  439. pinlininginfo = ^tinlininginfo;
  440. {$ifdef oldregvars}
  441. { register variables }
  442. pregvarinfo = ^tregvarinfo;
  443. tregvarinfo = record
  444. regvars : array[1..maxvarregs] of tsym;
  445. regvars_para : array[1..maxvarregs] of boolean;
  446. regvars_refs : array[1..maxvarregs] of longint;
  447. fpuregvars : array[1..maxfpuvarregs] of tsym;
  448. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  449. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  450. end;
  451. {$endif oldregvars}
  452. { tprocdef }
  453. tprocdef = class(tabstractprocdef)
  454. private
  455. _mangledname : pshortstring;
  456. public
  457. messageinf : tmessageinf;
  458. dispid : longint;
  459. {$ifndef EXTDEBUG}
  460. { where is this function defined and what were the symbol
  461. flags, needed here because there
  462. is only one symbol for all overloaded functions
  463. EXTDEBUG has fileinfo in tdef (PFV) }
  464. fileinfo : tfileposinfo;
  465. {$endif}
  466. symoptions : tsymoptions;
  467. deprecatedmsg : pshortstring;
  468. { symbol owning this definition }
  469. procsym : tsym;
  470. procsymderef : tderef;
  471. { alias names }
  472. aliasnames : TCmdStrList;
  473. { symtables }
  474. localst : TSymtable;
  475. funcretsym : tsym;
  476. funcretsymderef : tderef;
  477. struct : tabstractrecorddef;
  478. structderef : tderef;
  479. {$if defined(powerpc) or defined(m68k)}
  480. { library symbol for AmigaOS/MorphOS }
  481. libsym : tsym;
  482. libsymderef : tderef;
  483. {$endif powerpc or m68k}
  484. { name of the result variable to insert in the localsymtable }
  485. resultname : pshortstring;
  486. { import info }
  487. import_dll,
  488. import_name : pshortstring;
  489. { info for inlining the subroutine, if this pointer is nil,
  490. the procedure can't be inlined }
  491. inlininginfo : pinlininginfo;
  492. {$ifdef oldregvars}
  493. regvarinfo: pregvarinfo;
  494. {$endif oldregvars}
  495. { First/last assembler symbol/instruction in aasmoutput list.
  496. Note: initialised after compiling the code for the procdef, but
  497. not saved to/restored from ppu. Used when inserting debug info }
  498. procstarttai,
  499. procendtai : tai;
  500. import_nr : word;
  501. extnumber : word;
  502. {$ifdef i386}
  503. fpu_used : byte;
  504. {$endif i386}
  505. visibility : tvisibility;
  506. { true, if the procedure is only declared
  507. (forward procedure) }
  508. forwarddef,
  509. { true if the procedure is declared in the interface }
  510. interfacedef : boolean;
  511. { true if the procedure has a forward declaration }
  512. hasforward : boolean;
  513. { interrupt vector }
  514. interruptvector : longint;
  515. constructor create(level:byte);
  516. constructor ppuload(ppufile:tcompilerppufile);
  517. destructor destroy;override;
  518. procedure ppuwrite(ppufile:tcompilerppufile);override;
  519. procedure buildderef;override;
  520. procedure buildderefimpl;override;
  521. procedure deref;override;
  522. procedure derefimpl;override;
  523. function GetSymtable(t:tGetSymtable):TSymtable;override;
  524. function GetTypeName : string;override;
  525. function mangledname : string;
  526. procedure setmangledname(const s : string);
  527. function fullprocname(showhidden:boolean):string;
  528. function cplusplusmangledname : string;
  529. function objcmangledname : string;
  530. function is_methodpointer:boolean;override;
  531. function is_addressonly:boolean;override;
  532. procedure make_external;
  533. end;
  534. { single linked list of overloaded procs }
  535. pprocdeflist = ^tprocdeflist;
  536. tprocdeflist = record
  537. def : tprocdef;
  538. defderef : tderef;
  539. next : pprocdeflist;
  540. end;
  541. tstringdef = class(tstoreddef)
  542. stringtype : tstringtype;
  543. len : asizeint;
  544. constructor createshort(l : byte);
  545. constructor loadshort(ppufile:tcompilerppufile);
  546. constructor createlong(l : asizeint);
  547. constructor loadlong(ppufile:tcompilerppufile);
  548. constructor createansi;
  549. constructor loadansi(ppufile:tcompilerppufile);
  550. constructor createwide;
  551. constructor loadwide(ppufile:tcompilerppufile);
  552. constructor createunicode;
  553. constructor loadunicode(ppufile:tcompilerppufile);
  554. function getcopy : tstoreddef;override;
  555. function stringtypname:string;
  556. procedure ppuwrite(ppufile:tcompilerppufile);override;
  557. function GetTypeName:string;override;
  558. function getmangledparaname:string;override;
  559. function is_publishable : boolean;override;
  560. function alignment : shortint;override;
  561. function needs_inittable : boolean;override;
  562. function getvardef:longint;override;
  563. end;
  564. { tenumdef }
  565. tenumdef = class(tstoreddef)
  566. minval,
  567. maxval : asizeint;
  568. has_jumps : boolean;
  569. basedef : tenumdef;
  570. basedefderef : tderef;
  571. symtable : TSymtable;
  572. constructor create;
  573. constructor create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  574. constructor ppuload(ppufile:tcompilerppufile);
  575. destructor destroy;override;
  576. function getcopy : tstoreddef;override;
  577. procedure ppuwrite(ppufile:tcompilerppufile);override;
  578. procedure buildderef;override;
  579. procedure deref;override;
  580. function GetTypeName:string;override;
  581. function is_publishable : boolean;override;
  582. procedure calcsavesize;
  583. function packedbitsize: asizeint; override;
  584. procedure setmax(_max:asizeint);
  585. procedure setmin(_min:asizeint);
  586. function min:asizeint;
  587. function max:asizeint;
  588. function getfirstsym:tsym;
  589. end;
  590. tsetdef = class(tstoreddef)
  591. elementdef : tdef;
  592. elementdefderef : tderef;
  593. setbase,
  594. setmax : aword;
  595. constructor create(def:tdef;low, high : asizeint);
  596. constructor ppuload(ppufile:tcompilerppufile);
  597. function getcopy : tstoreddef;override;
  598. procedure ppuwrite(ppufile:tcompilerppufile);override;
  599. procedure buildderef;override;
  600. procedure deref;override;
  601. function GetTypeName:string;override;
  602. function is_publishable : boolean;override;
  603. end;
  604. tdefawaresymtablestack = class(TSymtablestack)
  605. private
  606. procedure addhelpers(st: TSymtable);
  607. procedure removehelpers(st: TSymtable);
  608. public
  609. procedure push(st: TSymtable); override;
  610. procedure pop(st: TSymtable); override;
  611. end;
  612. var
  613. current_structdef: tabstractrecorddef; { used for private functions check !! }
  614. current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class }
  615. current_specializedef: tstoreddef; { used to implement usage of generic class in itself }
  616. { default types }
  617. generrordef, { error in definition }
  618. voidpointertype, { pointer for Void-pointeddef }
  619. charpointertype, { pointer for Char-pointeddef }
  620. widecharpointertype, { pointer for WideChar-pointeddef }
  621. voidfarpointertype,
  622. cundefinedtype,
  623. cformaltype, { unique formal definition }
  624. ctypedformaltype, { unique typed formal definition }
  625. voidtype, { Void (procedure) }
  626. cchartype, { Char }
  627. cwidechartype, { WideChar }
  628. pasbool8type, { boolean type }
  629. pasbool16type,
  630. pasbool32type,
  631. pasbool64type,
  632. bool8type,
  633. bool16type,
  634. bool32type,
  635. bool64type, { implement me }
  636. u8inttype, { 8-Bit unsigned integer }
  637. s8inttype, { 8-Bit signed integer }
  638. u16inttype, { 16-Bit unsigned integer }
  639. s16inttype, { 16-Bit signed integer }
  640. u32inttype, { 32-Bit unsigned integer }
  641. s32inttype, { 32-Bit signed integer }
  642. u64inttype, { 64-bit unsigned integer }
  643. s64inttype, { 64-bit signed integer }
  644. s32floattype, { 32 bit floating point number }
  645. s64floattype, { 64 bit floating point number }
  646. s80floattype, { 80 bit floating point number }
  647. sc80floattype, { 80 bit floating point number but stored like in C }
  648. s64currencytype, { pointer to a currency type }
  649. cshortstringtype, { pointer to type of short string const }
  650. clongstringtype, { pointer to type of long string const }
  651. cansistringtype, { pointer to type of ansi string const }
  652. cwidestringtype, { pointer to type of wide string const }
  653. cunicodestringtype,
  654. openshortstringtype, { pointer to type of an open shortstring,
  655. needed for readln() }
  656. openchararraytype, { pointer to type of an open array of char,
  657. needed for readln() }
  658. cfiletype, { get the same definition for all file }
  659. { used for stabs }
  660. methodpointertype, { typecasting of methodpointers to extract self }
  661. hresultdef,
  662. { we use only one variant def for every variant class }
  663. cvarianttype,
  664. colevarianttype,
  665. { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
  666. sinttype,
  667. uinttype,
  668. { unsigned and signed ord type with the same size as a pointer }
  669. ptruinttype,
  670. ptrsinttype,
  671. { several types to simulate more or less C++ objects for GDB }
  672. vmttype,
  673. vmtarraytype,
  674. pvmttype : tdef; { type of classrefs, used for stabs }
  675. { pointer to the anchestor of all classes }
  676. class_tobject : tobjectdef;
  677. { pointer to the ancestor of all COM interfaces }
  678. interface_iunknown : tobjectdef;
  679. { pointer to the ancestor of all dispinterfaces }
  680. interface_idispatch : tobjectdef;
  681. { pointer to the TGUID type
  682. of all interfaces }
  683. rec_tguid : trecorddef;
  684. { pointer to jump buffer }
  685. rec_jmp_buf : trecorddef;
  686. { Objective-C base types }
  687. objc_metaclasstype,
  688. objc_superclasstype,
  689. objc_idtype,
  690. objc_seltype : tpointerdef;
  691. objc_objecttype : trecorddef;
  692. { base type of @protocol(protocolname) Objective-C statements }
  693. objc_protocoltype : tobjectdef;
  694. { helper types for for-in "fast enumeration" support in Objective-C 2.0 }
  695. objc_fastenumeration : tobjectdef;
  696. objc_fastenumerationstate : trecorddef;
  697. const
  698. {$ifdef i386}
  699. pbestrealtype : ^tdef = @s80floattype;
  700. {$endif}
  701. {$ifdef x86_64}
  702. pbestrealtype : ^tdef = @s80floattype;
  703. {$endif}
  704. {$ifdef m68k}
  705. pbestrealtype : ^tdef = @s64floattype;
  706. {$endif}
  707. {$ifdef alpha}
  708. pbestrealtype : ^tdef = @s64floattype;
  709. {$endif}
  710. {$ifdef powerpc}
  711. pbestrealtype : ^tdef = @s64floattype;
  712. {$endif}
  713. {$ifdef POWERPC64}
  714. pbestrealtype : ^tdef = @s64floattype;
  715. {$endif}
  716. {$ifdef ia64}
  717. pbestrealtype : ^tdef = @s64floattype;
  718. {$endif}
  719. {$ifdef SPARC}
  720. pbestrealtype : ^tdef = @s64floattype;
  721. {$endif SPARC}
  722. {$ifdef vis}
  723. pbestrealtype : ^tdef = @s64floattype;
  724. {$endif vis}
  725. {$ifdef ARM}
  726. pbestrealtype : ^tdef = @s64floattype;
  727. {$endif ARM}
  728. {$ifdef MIPS}
  729. pbestrealtype : ^tdef = @s64floattype;
  730. {$endif MIPS}
  731. {$ifdef AVR}
  732. pbestrealtype : ^tdef = @s64floattype;
  733. {$endif AVR}
  734. function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string;
  735. function make_dllmangledname(const dllname,importname:string;
  736. import_nr : word; pco : tproccalloption):string;
  737. { should be in the types unit, but the types unit uses the node stuff :( }
  738. function is_interfacecom(def: tdef): boolean;
  739. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  740. function is_interfacecorba(def: tdef): boolean;
  741. function is_interface(def: tdef): boolean;
  742. function is_dispinterface(def: tdef): boolean;
  743. function is_object(def: tdef): boolean;
  744. function is_class(def: tdef): boolean;
  745. function is_cppclass(def: tdef): boolean;
  746. function is_objectpascal_helper(def: tdef): boolean;
  747. function is_objcclass(def: tdef): boolean;
  748. function is_objcclassref(def: tdef): boolean;
  749. function is_objcprotocol(def: tdef): boolean;
  750. function is_objccategory(def: tdef): boolean;
  751. function is_objc_class_or_protocol(def: tdef): boolean;
  752. function is_objc_protocol_or_category(def: tdef): boolean;
  753. function is_classhelper(def: tdef): boolean;
  754. function is_class_or_interface(def: tdef): boolean;
  755. function is_class_or_interface_or_objc(def: tdef): boolean;
  756. function is_class_or_interface_or_object(def: tdef): boolean;
  757. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  758. function is_implicit_pointer_object_type(def: tdef): boolean;
  759. function is_class_or_object(def: tdef): boolean;
  760. function is_record(def: tdef): boolean;
  761. procedure loadobjctypes;
  762. procedure maybeloadcocoatypes;
  763. function use_vectorfpu(def : tdef) : boolean;
  764. implementation
  765. uses
  766. SysUtils,
  767. cutils,
  768. { global }
  769. verbose,
  770. { target }
  771. systems,aasmcpu,paramgr,
  772. { symtable }
  773. symsym,symtable,symutil,defutil,objcdef,
  774. { module }
  775. fmodule,
  776. { other }
  777. gendef,
  778. fpccrc
  779. ;
  780. {****************************************************************************
  781. Helpers
  782. ****************************************************************************}
  783. function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string;
  784. var
  785. s,hs,
  786. prefix : string;
  787. oldlen,
  788. newlen,
  789. i : longint;
  790. crc : dword;
  791. hp : tparavarsym;
  792. begin
  793. prefix:='';
  794. if not assigned(st) then
  795. internalerror(200204212);
  796. { sub procedures }
  797. while (st.symtabletype=localsymtable) do
  798. begin
  799. if st.defowner.typ<>procdef then
  800. internalerror(200204173);
  801. { Add the full mangledname of procedure to prevent
  802. conflicts with 2 overloads having both a nested procedure
  803. with the same name, see tb0314 (PFV) }
  804. s:=tprocdef(st.defowner).procsym.name;
  805. oldlen:=length(s);
  806. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  807. begin
  808. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  809. if not(vo_is_hidden_para in hp.varoptions) then
  810. s:=s+'$'+hp.vardef.mangledparaname;
  811. end;
  812. if not is_void(tprocdef(st.defowner).returndef) then
  813. s:=s+'$$'+tprocdef(st.defowner).returndef.mangledparaname;
  814. newlen:=length(s);
  815. { Replace with CRC if the parameter line is very long }
  816. if (newlen-oldlen>12) and
  817. ((newlen+length(prefix)>100) or (newlen-oldlen>32)) then
  818. begin
  819. crc:=0;
  820. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  821. begin
  822. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  823. if not(vo_is_hidden_para in hp.varoptions) then
  824. begin
  825. hs:=hp.vardef.mangledparaname;
  826. crc:=UpdateCrc32(crc,hs[1],length(hs));
  827. end;
  828. end;
  829. hs:=hp.vardef.mangledparaname;
  830. crc:=UpdateCrc32(crc,hs[1],length(hs));
  831. s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
  832. end;
  833. if prefix<>'' then
  834. prefix:=s+'_'+prefix
  835. else
  836. prefix:=s;
  837. if length(prefix)>100 then
  838. begin
  839. crc:=0;
  840. crc:=UpdateCrc32(crc,prefix[1],length(prefix));
  841. prefix:='$CRC'+hexstr(crc,8);
  842. end;
  843. st:=st.defowner.owner;
  844. end;
  845. { object/classes symtable, nested type definitions in classes require the while loop }
  846. while st.symtabletype in [ObjectSymtable,recordsymtable] do
  847. begin
  848. if not (st.defowner.typ in [objectdef,recorddef]) then
  849. internalerror(200204174);
  850. prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
  851. st:=st.defowner.owner;
  852. end;
  853. { symtable must now be static or global }
  854. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  855. internalerror(200204175);
  856. result:='';
  857. if typeprefix<>'' then
  858. result:=result+typeprefix+'_';
  859. { Add P$ for program, which can have the same name as
  860. a unit }
  861. if (TSymtable(main_module.localsymtable)=st) and
  862. (not main_module.is_unit) then
  863. result:=result+'P$'+st.name^
  864. else
  865. result:=result+st.name^;
  866. if prefix<>'' then
  867. result:=result+'_'+prefix;
  868. if suffix<>'' then
  869. result:=result+'_'+suffix;
  870. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  871. { Further, the Mac OS X 10.5 linker does not consider symbols which do not }
  872. { start with '_' as regular symbols (it does not generate N_GSYM entries }
  873. { those in the debug map, leading to troubles with dsymutil). So always }
  874. { add an underscore on darwin. }
  875. if (target_info.system in systems_darwin) then
  876. result := '_' + result;
  877. end;
  878. function make_dllmangledname(const dllname,importname:string;import_nr : word; pco : tproccalloption):string;
  879. var
  880. crc : cardinal;
  881. i : longint;
  882. use_crc : boolean;
  883. dllprefix : string;
  884. begin
  885. if (target_info.system in (systems_all_windows + systems_nativent +
  886. [system_i386_emx, system_i386_os2]))
  887. and (dllname <> '') then
  888. begin
  889. dllprefix:=lower(ExtractFileName(dllname));
  890. { Remove .dll suffix if present }
  891. if copy(dllprefix,length(dllprefix)-3,length(dllprefix))='.dll' then
  892. dllprefix:=copy(dllprefix,1,length(dllprefix)-4);
  893. use_crc:=false;
  894. for i:=1 to length(dllprefix) do
  895. if not (dllprefix[i] in ['a'..'z','A'..'Z','_','0'..'9']) then
  896. begin
  897. use_crc:=true;
  898. break;
  899. end;
  900. if use_crc then
  901. begin
  902. crc:=0;
  903. crc:=UpdateCrc32(crc,dllprefix[1],length(dllprefix));
  904. dllprefix:='_$dll$crc$'+hexstr(crc,8)+'$';
  905. end
  906. else
  907. dllprefix:='_$dll$'+dllprefix+'$';
  908. if importname<>'' then
  909. result:=dllprefix+importname
  910. else
  911. result:=dllprefix+'_index_'+tostr(import_nr);
  912. { Replace ? and @ in import name, since GNU AS does not allow these characters in symbol names. }
  913. { This allows to import VC++ mangled names from DLLs. }
  914. { Do not perform replacement, if external symbol is not imported from DLL. }
  915. if (dllname<>'') then
  916. begin
  917. Replace(result,'?','__q$$');
  918. {$ifdef arm}
  919. { @ symbol is not allowed in ARM assembler only }
  920. Replace(result,'@','__a$$');
  921. {$endif arm}
  922. end;
  923. end
  924. else
  925. begin
  926. if importname<>'' then
  927. begin
  928. if not(pco in [pocall_cdecl,pocall_cppdecl]) then
  929. result:=importname
  930. else
  931. result:=target_info.Cprefix+importname;
  932. end
  933. else
  934. result:='_index_'+tostr(import_nr);
  935. end;
  936. end;
  937. {****************************************************************************
  938. TDEFAWARESYMTABLESTACK
  939. (symtablestack descendant that does some special actions on
  940. the pushed/popped symtables)
  941. ****************************************************************************}
  942. procedure tdefawaresymtablestack.addhelpers(st: TSymtable);
  943. var
  944. i: integer;
  945. s: string;
  946. list: TFPObjectList;
  947. def: tdef;
  948. begin
  949. { search the symtable from first to last; the helper to use will be the
  950. last one in the list }
  951. for i:=0 to st.symlist.count-1 do
  952. begin
  953. if not (st.symlist[i] is ttypesym) then
  954. continue;
  955. def:=ttypesym(st.SymList[i]).typedef;
  956. if is_objectpascal_helper(def) and
  957. (tobjectdef(def).extendeddef.typ in [recorddef,objectdef]) then
  958. begin
  959. s:=make_mangledname('',tabstractrecorddef(tobjectdef(def).extendeddef).symtable,'');
  960. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  961. if not assigned(list) then
  962. begin
  963. list:=TFPObjectList.Create(false);
  964. current_module.extendeddefs.Add(s,list);
  965. end;
  966. list.Add(def);
  967. end
  968. else
  969. { add nested helpers as well }
  970. if def.typ in [recorddef,objectdef] then
  971. addhelpers(tabstractrecorddef(def).symtable);
  972. end;
  973. end;
  974. procedure tdefawaresymtablestack.removehelpers(st: TSymtable);
  975. var
  976. i, j: integer;
  977. tmpst: TSymtable;
  978. list: TFPObjectList;
  979. begin
  980. for i:=current_module.extendeddefs.count-1 downto 0 do
  981. begin
  982. list:=TFPObjectList(current_module.extendeddefs[i]);
  983. for j:=list.count-1 downto 0 do
  984. begin
  985. if not (list[j] is tobjectdef) then
  986. Internalerror(2011031501);
  987. tmpst:=tobjectdef(list[j]).owner;
  988. repeat
  989. if tmpst=st then
  990. begin
  991. list.delete(j);
  992. break;
  993. end
  994. else
  995. begin
  996. if assigned(tmpst.defowner) then
  997. tmpst:=tmpst.defowner.owner
  998. else
  999. tmpst:=nil;
  1000. end;
  1001. until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]);
  1002. end;
  1003. if list.count=0 then
  1004. current_module.extendeddefs.delete(i);
  1005. end;
  1006. end;
  1007. procedure tdefawaresymtablestack.push(st: TSymtable);
  1008. begin
  1009. { nested helpers will be added as well }
  1010. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1011. (sto_has_helper in st.tableoptions) then
  1012. addhelpers(st);
  1013. inherited push(st);
  1014. end;
  1015. procedure tdefawaresymtablestack.pop(st: TSymtable);
  1016. begin
  1017. inherited pop(st);
  1018. { nested helpers will be removed as well }
  1019. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1020. (sto_has_helper in st.tableoptions) then
  1021. removehelpers(st);
  1022. end;
  1023. {****************************************************************************
  1024. TDEF (base class for definitions)
  1025. ****************************************************************************}
  1026. constructor tstoreddef.create(dt:tdeftyp);
  1027. var
  1028. insertstack : psymtablestackitem;
  1029. begin
  1030. inherited create(dt);
  1031. savesize := 0;
  1032. {$ifdef EXTDEBUG}
  1033. fileinfo := current_filepos;
  1034. {$endif}
  1035. generictokenbuf:=nil;
  1036. genericdef:=nil;
  1037. { Don't register forwarddefs, they are disposed at the
  1038. end of an type block }
  1039. if (dt=forwarddef) then
  1040. exit;
  1041. { Register in current_module }
  1042. if assigned(current_module) then
  1043. begin
  1044. current_module.deflist.Add(self);
  1045. DefId:=current_module.deflist.Count-1;
  1046. end;
  1047. { Register in symtable stack }
  1048. if assigned(symtablestack) then
  1049. begin
  1050. insertstack:=symtablestack.stack;
  1051. while assigned(insertstack) and
  1052. (insertstack^.symtable.symtabletype=withsymtable) do
  1053. insertstack:=insertstack^.next;
  1054. if not assigned(insertstack) then
  1055. internalerror(200602044);
  1056. insertstack^.symtable.insertdef(self);
  1057. end;
  1058. end;
  1059. destructor tstoreddef.destroy;
  1060. begin
  1061. { Direct calls are not allowed, use symtable.deletedef() }
  1062. if assigned(owner) then
  1063. internalerror(200612311);
  1064. if assigned(generictokenbuf) then
  1065. begin
  1066. generictokenbuf.free;
  1067. generictokenbuf:=nil;
  1068. end;
  1069. inherited destroy;
  1070. end;
  1071. constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1072. var
  1073. sizeleft,i : longint;
  1074. buf : array[0..255] of byte;
  1075. begin
  1076. inherited create(dt);
  1077. DefId:=ppufile.getlongint;
  1078. current_module.deflist[DefId]:=self;
  1079. {$ifdef EXTDEBUG}
  1080. fillchar(fileinfo,sizeof(fileinfo),0);
  1081. {$endif}
  1082. { load }
  1083. ppufile.getderef(typesymderef);
  1084. ppufile.getsmallset(defoptions);
  1085. ppufile.getsmallset(defstates);
  1086. if df_generic in defoptions then
  1087. begin
  1088. sizeleft:=ppufile.getlongint;
  1089. initgeneric;
  1090. while sizeleft>0 do
  1091. begin
  1092. if sizeleft>sizeof(buf) then
  1093. i:=sizeof(buf)
  1094. else
  1095. i:=sizeleft;
  1096. ppufile.getdata(buf,i);
  1097. generictokenbuf.write(buf,i);
  1098. dec(sizeleft,i);
  1099. end;
  1100. end;
  1101. if df_specialization in defoptions then
  1102. ppufile.getderef(genericdefderef);
  1103. end;
  1104. function Tstoreddef.rtti_mangledname(rt:trttitype):string;
  1105. var
  1106. prefix : string[4];
  1107. begin
  1108. if rt=fullrtti then
  1109. begin
  1110. prefix:='RTTI';
  1111. include(defstates,ds_rtti_table_used);
  1112. end
  1113. else
  1114. begin
  1115. prefix:='INIT';
  1116. include(defstates,ds_init_table_used);
  1117. end;
  1118. if assigned(typesym) and
  1119. (owner.symtabletype in [staticsymtable,globalsymtable]) then
  1120. result:=make_mangledname(prefix,owner,typesym.name)
  1121. else
  1122. result:=make_mangledname(prefix,findunitsymtable(owner),'DEF'+tostr(DefId))
  1123. end;
  1124. function tstoreddef.OwnerHierarchyName: string;
  1125. var
  1126. tmp: tdef;
  1127. begin
  1128. tmp:=self;
  1129. result:='';
  1130. repeat
  1131. if tmp.owner.symtabletype in [ObjectSymtable,recordsymtable] then
  1132. tmp:=tdef(tmp.owner.defowner)
  1133. else
  1134. break;
  1135. result:=tabstractrecorddef(tmp).objrealname^+'.'+result;
  1136. until tmp=nil;
  1137. end;
  1138. function tstoreddef.in_currentunit: boolean;
  1139. var
  1140. st: tsymtable;
  1141. begin
  1142. st:=owner;
  1143. while not(st.symtabletype in [globalsymtable,staticsymtable]) do
  1144. st:=st.defowner.owner;
  1145. result:=st.iscurrentunit;
  1146. end;
  1147. function tstoreddef.getcopy : tstoreddef;
  1148. begin
  1149. Message(sym_e_cant_create_unique_type);
  1150. getcopy:=terrordef.create;
  1151. end;
  1152. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  1153. var
  1154. sizeleft,i : longint;
  1155. buf : array[0..255] of byte;
  1156. oldintfcrc : boolean;
  1157. begin
  1158. ppufile.putlongint(DefId);
  1159. ppufile.putderef(typesymderef);
  1160. ppufile.putsmallset(defoptions);
  1161. oldintfcrc:=ppufile.do_crc;
  1162. ppufile.do_crc:=false;
  1163. ppufile.putsmallset(defstates);
  1164. if df_generic in defoptions then
  1165. begin
  1166. if assigned(generictokenbuf) then
  1167. begin
  1168. sizeleft:=generictokenbuf.size;
  1169. generictokenbuf.seek(0);
  1170. end
  1171. else
  1172. sizeleft:=0;
  1173. ppufile.putlongint(sizeleft);
  1174. while sizeleft>0 do
  1175. begin
  1176. if sizeleft>sizeof(buf) then
  1177. i:=sizeof(buf)
  1178. else
  1179. i:=sizeleft;
  1180. generictokenbuf.read(buf,i);
  1181. ppufile.putdata(buf,i);
  1182. dec(sizeleft,i);
  1183. end;
  1184. end;
  1185. ppufile.do_crc:=oldintfcrc;
  1186. if df_specialization in defoptions then
  1187. ppufile.putderef(genericdefderef);
  1188. end;
  1189. procedure tstoreddef.buildderef;
  1190. begin
  1191. typesymderef.build(typesym);
  1192. genericdefderef.build(genericdef);
  1193. end;
  1194. procedure tstoreddef.buildderefimpl;
  1195. begin
  1196. end;
  1197. procedure tstoreddef.deref;
  1198. begin
  1199. typesym:=ttypesym(typesymderef.resolve);
  1200. if df_specialization in defoptions then
  1201. genericdef:=tstoreddef(genericdefderef.resolve);
  1202. end;
  1203. procedure tstoreddef.derefimpl;
  1204. begin
  1205. end;
  1206. function tstoreddef.size : asizeint;
  1207. begin
  1208. size:=savesize;
  1209. end;
  1210. function tstoreddef.getvardef:longint;
  1211. begin
  1212. result:=varUndefined;
  1213. end;
  1214. function tstoreddef.alignment : shortint;
  1215. begin
  1216. { natural alignment by default }
  1217. alignment:=size_2_align(savesize);
  1218. { can happen if savesize = 0, e.g. for voiddef or
  1219. an empty record
  1220. }
  1221. if (alignment=0) then
  1222. alignment:=1;
  1223. end;
  1224. { returns true, if the definition can be published }
  1225. function tstoreddef.is_publishable : boolean;
  1226. begin
  1227. is_publishable:=false;
  1228. end;
  1229. { needs an init table }
  1230. function tstoreddef.needs_inittable : boolean;
  1231. begin
  1232. needs_inittable:=false;
  1233. end;
  1234. function tstoreddef.is_intregable : boolean;
  1235. var
  1236. recsize,temp: longint;
  1237. begin
  1238. is_intregable:=false;
  1239. case typ of
  1240. orddef,
  1241. pointerdef,
  1242. enumdef,
  1243. classrefdef:
  1244. is_intregable:=true;
  1245. procvardef :
  1246. is_intregable:=tprocvardef(self).is_addressonly;
  1247. objectdef:
  1248. is_intregable:=(is_implicit_pointer_object_type(self)) and not needs_inittable;
  1249. setdef:
  1250. is_intregable:=is_smallset(self);
  1251. recorddef:
  1252. begin
  1253. recsize:=size;
  1254. is_intregable:=
  1255. ispowerof2(recsize,temp) and
  1256. (recsize <= sizeof(asizeint));
  1257. end;
  1258. end;
  1259. end;
  1260. function tstoreddef.is_fpuregable : boolean;
  1261. begin
  1262. {$ifdef x86}
  1263. result:=use_vectorfpu(self);
  1264. {$else x86}
  1265. result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches);
  1266. {$endif x86}
  1267. end;
  1268. procedure tstoreddef.initgeneric;
  1269. begin
  1270. if assigned(generictokenbuf) then
  1271. internalerror(200512131);
  1272. generictokenbuf:=tdynamicarray.create(256);
  1273. end;
  1274. {****************************************************************************
  1275. Tstringdef
  1276. ****************************************************************************}
  1277. constructor tstringdef.createshort(l : byte);
  1278. begin
  1279. inherited create(stringdef);
  1280. stringtype:=st_shortstring;
  1281. len:=l;
  1282. savesize:=len+1;
  1283. end;
  1284. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  1285. begin
  1286. inherited ppuload(stringdef,ppufile);
  1287. stringtype:=st_shortstring;
  1288. len:=ppufile.getbyte;
  1289. savesize:=len+1;
  1290. end;
  1291. constructor tstringdef.createlong(l : asizeint);
  1292. begin
  1293. inherited create(stringdef);
  1294. stringtype:=st_longstring;
  1295. len:=l;
  1296. savesize:=sizeof(pint);
  1297. end;
  1298. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1299. begin
  1300. inherited ppuload(stringdef,ppufile);
  1301. stringtype:=st_longstring;
  1302. len:=ppufile.getasizeint;
  1303. savesize:=sizeof(pint);
  1304. end;
  1305. constructor tstringdef.createansi;
  1306. begin
  1307. inherited create(stringdef);
  1308. stringtype:=st_ansistring;
  1309. len:=-1;
  1310. savesize:=sizeof(pint);
  1311. end;
  1312. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1313. begin
  1314. inherited ppuload(stringdef,ppufile);
  1315. stringtype:=st_ansistring;
  1316. len:=ppufile.getaint;
  1317. savesize:=sizeof(pint);
  1318. end;
  1319. constructor tstringdef.createwide;
  1320. begin
  1321. inherited create(stringdef);
  1322. stringtype:=st_widestring;
  1323. len:=-1;
  1324. savesize:=sizeof(pint);
  1325. end;
  1326. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1327. begin
  1328. inherited ppuload(stringdef,ppufile);
  1329. stringtype:=st_widestring;
  1330. len:=ppufile.getaint;
  1331. savesize:=sizeof(pint);
  1332. end;
  1333. constructor tstringdef.createunicode;
  1334. begin
  1335. inherited create(stringdef);
  1336. stringtype:=st_unicodestring;
  1337. len:=-1;
  1338. savesize:=sizeof(pint);
  1339. end;
  1340. constructor tstringdef.loadunicode(ppufile:tcompilerppufile);
  1341. begin
  1342. inherited ppuload(stringdef,ppufile);
  1343. stringtype:=st_unicodestring;
  1344. len:=ppufile.getaint;
  1345. savesize:=sizeof(pint);
  1346. end;
  1347. function tstringdef.getcopy : tstoreddef;
  1348. begin
  1349. result:=tstringdef.create(typ);
  1350. result.typ:=stringdef;
  1351. tstringdef(result).stringtype:=stringtype;
  1352. tstringdef(result).len:=len;
  1353. tstringdef(result).savesize:=savesize;
  1354. end;
  1355. function tstringdef.stringtypname:string;
  1356. const
  1357. typname:array[tstringtype] of string[10]=(
  1358. 'shortstr','longstr','ansistr','widestr','unicodestr'
  1359. );
  1360. begin
  1361. stringtypname:=typname[stringtype];
  1362. end;
  1363. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  1364. begin
  1365. inherited ppuwrite(ppufile);
  1366. if stringtype=st_shortstring then
  1367. begin
  1368. {$ifdef extdebug}
  1369. if len > 255 then internalerror(12122002);
  1370. {$endif}
  1371. ppufile.putbyte(byte(len))
  1372. end
  1373. else
  1374. ppufile.putaint(len);
  1375. case stringtype of
  1376. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1377. st_longstring : ppufile.writeentry(iblongstringdef);
  1378. st_ansistring : ppufile.writeentry(ibansistringdef);
  1379. st_widestring : ppufile.writeentry(ibwidestringdef);
  1380. st_unicodestring : ppufile.writeentry(ibunicodestringdef);
  1381. end;
  1382. end;
  1383. function tstringdef.needs_inittable : boolean;
  1384. begin
  1385. needs_inittable:=stringtype in [st_ansistring,st_widestring,st_unicodestring];
  1386. end;
  1387. function tstringdef.GetTypeName : string;
  1388. const
  1389. names : array[tstringtype] of string[15] = (
  1390. 'ShortString','LongString','AnsiString','WideString','UnicodeString');
  1391. begin
  1392. GetTypeName:=names[stringtype];
  1393. end;
  1394. function tstringdef.getvardef : longint;
  1395. const
  1396. vardef : array[tstringtype] of longint = (
  1397. varUndefined,varUndefined,varString,varOleStr,varUString);
  1398. begin
  1399. result:=vardef[stringtype];
  1400. end;
  1401. function tstringdef.alignment : shortint;
  1402. begin
  1403. case stringtype of
  1404. st_unicodestring,
  1405. st_widestring,
  1406. st_ansistring:
  1407. alignment:=size_2_align(savesize);
  1408. st_longstring,
  1409. st_shortstring:
  1410. { char to string accesses byte 0 and 1 with one word access }
  1411. if (tf_requires_proper_alignment in target_info.flags) or
  1412. { macpas needs an alignment of 2 (MetroWerks compatible) }
  1413. (m_mac in current_settings.modeswitches) then
  1414. alignment:=size_2_align(2)
  1415. else
  1416. alignment:=size_2_align(1);
  1417. else
  1418. internalerror(200412301);
  1419. end;
  1420. end;
  1421. function tstringdef.getmangledparaname : string;
  1422. begin
  1423. getmangledparaname:='STRING';
  1424. end;
  1425. function tstringdef.is_publishable : boolean;
  1426. begin
  1427. is_publishable:=true;
  1428. end;
  1429. {****************************************************************************
  1430. TENUMDEF
  1431. ****************************************************************************}
  1432. constructor tenumdef.create;
  1433. begin
  1434. inherited create(enumdef);
  1435. minval:=0;
  1436. maxval:=0;
  1437. calcsavesize;
  1438. has_jumps:=false;
  1439. basedef:=nil;
  1440. symtable:=tenumsymtable.create(self);
  1441. end;
  1442. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  1443. begin
  1444. inherited create(enumdef);
  1445. minval:=_min;
  1446. maxval:=_max;
  1447. basedef:=_basedef;
  1448. calcsavesize;
  1449. has_jumps:=false;
  1450. symtable:=basedef.symtable.getcopy;
  1451. include(defoptions, df_copied_def);
  1452. end;
  1453. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  1454. begin
  1455. inherited ppuload(enumdef,ppufile);
  1456. minval:=ppufile.getaint;
  1457. maxval:=ppufile.getaint;
  1458. savesize:=ppufile.getaint;
  1459. has_jumps:=false;
  1460. if df_copied_def in defoptions then
  1461. begin
  1462. symtable:=nil;
  1463. ppufile.getderef(basedefderef);
  1464. end
  1465. else
  1466. begin
  1467. // create with nil defowner first to prevent values changes on insert
  1468. symtable:=tenumsymtable.create(nil);
  1469. tenumsymtable(symtable).ppuload(ppufile);
  1470. symtable.defowner:=self;
  1471. end;
  1472. end;
  1473. destructor tenumdef.destroy;
  1474. begin
  1475. symtable.free;
  1476. symtable:=nil;
  1477. inherited destroy;
  1478. end;
  1479. function tenumdef.getcopy : tstoreddef;
  1480. begin
  1481. if assigned(basedef) then
  1482. result:=tenumdef.create_subrange(basedef,minval,maxval)
  1483. else
  1484. begin
  1485. result:=tenumdef.create;
  1486. tenumdef(result).minval:=minval;
  1487. tenumdef(result).maxval:=maxval;
  1488. tenumdef(result).symtable.free;
  1489. tenumdef(result).symtable:=symtable.getcopy;
  1490. tenumdef(result).basedef:=self;
  1491. end;
  1492. tenumdef(result).has_jumps:=has_jumps;
  1493. tenumdef(result).basedefderef:=basedefderef;
  1494. include(tenumdef(result).defoptions,df_copied_def);
  1495. end;
  1496. procedure tenumdef.calcsavesize;
  1497. begin
  1498. if (current_settings.packenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
  1499. savesize:=8
  1500. else
  1501. if (current_settings.packenum=4) or (min<low(smallint)) or (max>high(word)) then
  1502. savesize:=4
  1503. else
  1504. if (current_settings.packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  1505. savesize:=2
  1506. else
  1507. savesize:=1;
  1508. end;
  1509. function tenumdef.packedbitsize: asizeint;
  1510. var
  1511. sizeval: tconstexprint;
  1512. power: longint;
  1513. begin
  1514. result := 0;
  1515. if (minval >= 0) and
  1516. (maxval <= 1) then
  1517. result := 1
  1518. else
  1519. begin
  1520. if (minval>=0) then
  1521. sizeval:=maxval
  1522. else
  1523. { don't count 0 twice }
  1524. sizeval:=(cutils.max(-minval,maxval)*2)-1;
  1525. { 256 must become 512 etc. }
  1526. nextpowerof2(sizeval+1,power);
  1527. result := power;
  1528. end;
  1529. end;
  1530. procedure tenumdef.setmax(_max:asizeint);
  1531. begin
  1532. maxval:=_max;
  1533. calcsavesize;
  1534. end;
  1535. procedure tenumdef.setmin(_min:asizeint);
  1536. begin
  1537. minval:=_min;
  1538. calcsavesize;
  1539. end;
  1540. function tenumdef.min:asizeint;
  1541. begin
  1542. min:=minval;
  1543. end;
  1544. function tenumdef.max:asizeint;
  1545. begin
  1546. max:=maxval;
  1547. end;
  1548. function tenumdef.getfirstsym: tsym;
  1549. var
  1550. i:integer;
  1551. begin
  1552. for i := 0 to symtable.SymList.Count - 1 do
  1553. begin
  1554. result:=tsym(symtable.SymList[i]);
  1555. if tenumsym(result).value=minval then
  1556. exit;
  1557. end;
  1558. result:=nil;
  1559. end;
  1560. procedure tenumdef.buildderef;
  1561. begin
  1562. inherited buildderef;
  1563. if df_copied_def in defoptions then
  1564. basedefderef.build(basedef)
  1565. else
  1566. tenumsymtable(symtable).buildderef;
  1567. end;
  1568. procedure tenumdef.deref;
  1569. begin
  1570. inherited deref;
  1571. if df_copied_def in defoptions then
  1572. begin
  1573. basedef:=tenumdef(basedefderef.resolve);
  1574. symtable:=basedef.symtable.getcopy;
  1575. end
  1576. else
  1577. tenumsymtable(symtable).deref;
  1578. end;
  1579. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  1580. begin
  1581. inherited ppuwrite(ppufile);
  1582. ppufile.putaint(min);
  1583. ppufile.putaint(max);
  1584. ppufile.putaint(savesize);
  1585. if df_copied_def in defoptions then
  1586. ppufile.putderef(basedefderef);
  1587. ppufile.writeentry(ibenumdef);
  1588. if not (df_copied_def in defoptions) then
  1589. tenumsymtable(symtable).ppuwrite(ppufile);
  1590. end;
  1591. function tenumdef.is_publishable : boolean;
  1592. begin
  1593. is_publishable:=true;
  1594. end;
  1595. function tenumdef.GetTypeName : string;
  1596. begin
  1597. GetTypeName:='<enumeration type>';
  1598. end;
  1599. {****************************************************************************
  1600. TORDDEF
  1601. ****************************************************************************}
  1602. constructor torddef.create(t : tordtype;v,b : TConstExprInt);
  1603. begin
  1604. inherited create(orddef);
  1605. low:=v;
  1606. high:=b;
  1607. ordtype:=t;
  1608. setsize;
  1609. end;
  1610. constructor torddef.ppuload(ppufile:tcompilerppufile);
  1611. begin
  1612. inherited ppuload(orddef,ppufile);
  1613. ordtype:=tordtype(ppufile.getbyte);
  1614. low:=ppufile.getexprint;
  1615. high:=ppufile.getexprint;
  1616. setsize;
  1617. end;
  1618. function torddef.getcopy : tstoreddef;
  1619. begin
  1620. result:=torddef.create(ordtype,low,high);
  1621. result.typ:=orddef;
  1622. torddef(result).low:=low;
  1623. torddef(result).high:=high;
  1624. torddef(result).ordtype:=ordtype;
  1625. torddef(result).savesize:=savesize;
  1626. end;
  1627. function torddef.alignment:shortint;
  1628. begin
  1629. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) and
  1630. (ordtype in [s64bit,u64bit]) then
  1631. result := 4
  1632. else
  1633. result := inherited alignment;
  1634. end;
  1635. procedure torddef.setsize;
  1636. const
  1637. sizetbl : array[tordtype] of longint = (
  1638. 0,
  1639. 1,2,4,8,
  1640. 1,2,4,8,
  1641. 1,2,4,8,
  1642. 1,2,4,8,
  1643. 1,2,8
  1644. );
  1645. begin
  1646. savesize:=sizetbl[ordtype];
  1647. end;
  1648. function torddef.packedbitsize: asizeint;
  1649. var
  1650. sizeval: tconstexprint;
  1651. power: longint;
  1652. begin
  1653. result := 0;
  1654. if ordtype = uvoid then
  1655. exit;
  1656. {$ifndef cpu64bitalu}
  1657. if (ordtype in [s64bit,u64bit]) then
  1658. {$else not cpu64bitalu}
  1659. if (ordtype = u64bit) or
  1660. ((ordtype = s64bit) and
  1661. ((low <= (system.low(int64) div 2)) or
  1662. (high > (system.high(int64) div 2)))) then
  1663. {$endif cpu64bitalu}
  1664. result := 64
  1665. else if (low >= 0) and
  1666. (high <= 1) then
  1667. result := 1
  1668. else
  1669. begin
  1670. if (low>=0) then
  1671. sizeval:=high
  1672. else
  1673. { don't count 0 twice }
  1674. sizeval:=(cutils.max(-low,high)*2)-1;
  1675. { 256 must become 512 etc. }
  1676. nextpowerof2(sizeval+1,power);
  1677. result := power;
  1678. end;
  1679. end;
  1680. function torddef.getvardef : longint;
  1681. const
  1682. basetype2vardef : array[tordtype] of longint = (
  1683. varUndefined,
  1684. varbyte,varword,varlongword,varqword,
  1685. varshortint,varsmallint,varinteger,varint64,
  1686. varboolean,varboolean,varboolean,varboolean,
  1687. varboolean,varboolean,varUndefined,varUndefined,
  1688. varUndefined,varUndefined,varCurrency);
  1689. begin
  1690. result:=basetype2vardef[ordtype];
  1691. end;
  1692. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  1693. begin
  1694. inherited ppuwrite(ppufile);
  1695. ppufile.putbyte(byte(ordtype));
  1696. ppufile.putexprint(low);
  1697. ppufile.putexprint(high);
  1698. ppufile.writeentry(iborddef);
  1699. end;
  1700. function torddef.is_publishable : boolean;
  1701. begin
  1702. is_publishable:=(ordtype<>uvoid);
  1703. end;
  1704. function torddef.GetTypeName : string;
  1705. const
  1706. names : array[tordtype] of string[20] = (
  1707. 'untyped',
  1708. 'Byte','Word','DWord','QWord',
  1709. 'ShortInt','SmallInt','LongInt','Int64',
  1710. 'Boolean','Boolean16','Boolean32','Boolean64',
  1711. 'ByteBool','WordBool','LongBool','QWordBool',
  1712. 'Char','WideChar','Currency');
  1713. begin
  1714. GetTypeName:=names[ordtype];
  1715. end;
  1716. {****************************************************************************
  1717. TFLOATDEF
  1718. ****************************************************************************}
  1719. constructor tfloatdef.create(t : tfloattype);
  1720. begin
  1721. inherited create(floatdef);
  1722. floattype:=t;
  1723. setsize;
  1724. end;
  1725. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  1726. begin
  1727. inherited ppuload(floatdef,ppufile);
  1728. floattype:=tfloattype(ppufile.getbyte);
  1729. setsize;
  1730. end;
  1731. function tfloatdef.getcopy : tstoreddef;
  1732. begin
  1733. result:=tfloatdef.create(floattype);
  1734. result.typ:=floatdef;
  1735. tfloatdef(result).savesize:=savesize;
  1736. end;
  1737. function tfloatdef.alignment:shortint;
  1738. begin
  1739. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) then
  1740. case floattype of
  1741. sc80real,
  1742. s80real: result:=16;
  1743. s64real,
  1744. s64currency,
  1745. s64comp : result:=4;
  1746. else
  1747. result := inherited alignment;
  1748. end
  1749. else
  1750. result := inherited alignment;
  1751. end;
  1752. procedure tfloatdef.setsize;
  1753. begin
  1754. case floattype of
  1755. s32real : savesize:=4;
  1756. s80real : savesize:=10;
  1757. sc80real:
  1758. if target_info.system in [system_i386_darwin,system_i386_iphonesim,system_x86_64_darwin,
  1759. system_x86_64_linux,system_x86_64_freebsd,
  1760. system_x86_64_solaris,system_x86_64_embedded] then
  1761. savesize:=16
  1762. else
  1763. savesize:=12;
  1764. s64real,
  1765. s64currency,
  1766. s64comp : savesize:=8;
  1767. else
  1768. savesize:=0;
  1769. end;
  1770. end;
  1771. function tfloatdef.getvardef : longint;
  1772. const
  1773. floattype2vardef : array[tfloattype] of longint = (
  1774. varSingle,varDouble,varUndefined,varUndefined,
  1775. varUndefined,varCurrency,varUndefined);
  1776. begin
  1777. if (upper(typename)='TDATETIME') and
  1778. assigned(owner) and
  1779. assigned(owner.name) and
  1780. (owner.name^='SYSTEM') then
  1781. result:=varDate
  1782. else
  1783. result:=floattype2vardef[floattype];
  1784. end;
  1785. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  1786. begin
  1787. inherited ppuwrite(ppufile);
  1788. ppufile.putbyte(byte(floattype));
  1789. ppufile.writeentry(ibfloatdef);
  1790. end;
  1791. function tfloatdef.is_publishable : boolean;
  1792. begin
  1793. is_publishable:=true;
  1794. end;
  1795. function tfloatdef.GetTypeName : string;
  1796. const
  1797. names : array[tfloattype] of string[20] = (
  1798. 'Single','Double','Extended','CExtended','Comp','Currency','Float128');
  1799. begin
  1800. GetTypeName:=names[floattype];
  1801. end;
  1802. {****************************************************************************
  1803. TFILEDEF
  1804. ****************************************************************************}
  1805. constructor tfiledef.createtext;
  1806. begin
  1807. inherited create(filedef);
  1808. filetyp:=ft_text;
  1809. typedfiledef:=nil;
  1810. setsize;
  1811. end;
  1812. constructor tfiledef.createuntyped;
  1813. begin
  1814. inherited create(filedef);
  1815. filetyp:=ft_untyped;
  1816. typedfiledef:=nil;
  1817. setsize;
  1818. end;
  1819. constructor tfiledef.createtyped(def:tdef);
  1820. begin
  1821. inherited create(filedef);
  1822. filetyp:=ft_typed;
  1823. typedfiledef:=def;
  1824. setsize;
  1825. end;
  1826. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  1827. begin
  1828. inherited ppuload(filedef,ppufile);
  1829. filetyp:=tfiletyp(ppufile.getbyte);
  1830. if filetyp=ft_typed then
  1831. ppufile.getderef(typedfiledefderef)
  1832. else
  1833. typedfiledef:=nil;
  1834. setsize;
  1835. end;
  1836. function tfiledef.getcopy : tstoreddef;
  1837. begin
  1838. case filetyp of
  1839. ft_typed:
  1840. result:=tfiledef.createtyped(typedfiledef);
  1841. ft_untyped:
  1842. result:=tfiledef.createuntyped;
  1843. ft_text:
  1844. result:=tfiledef.createtext;
  1845. else
  1846. internalerror(2004121201);
  1847. end;
  1848. end;
  1849. procedure tfiledef.buildderef;
  1850. begin
  1851. inherited buildderef;
  1852. if filetyp=ft_typed then
  1853. typedfiledefderef.build(typedfiledef);
  1854. end;
  1855. procedure tfiledef.deref;
  1856. begin
  1857. inherited deref;
  1858. if filetyp=ft_typed then
  1859. typedfiledef:=tdef(typedfiledefderef.resolve);
  1860. end;
  1861. procedure tfiledef.setsize;
  1862. begin
  1863. {$ifdef cpu64bitaddr}
  1864. case filetyp of
  1865. ft_text :
  1866. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1867. savesize:=632{+8}
  1868. else
  1869. savesize:=628{+8};
  1870. ft_typed,
  1871. ft_untyped :
  1872. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1873. savesize:=372
  1874. else
  1875. savesize:=368;
  1876. end;
  1877. {$endif cpu64bitaddr}
  1878. {$ifdef cpu32bitaddr}
  1879. case filetyp of
  1880. ft_text :
  1881. savesize:=592{+4};
  1882. ft_typed,
  1883. ft_untyped :
  1884. savesize:=332;
  1885. end;
  1886. {$endif cpu32bitaddr}
  1887. {$ifdef cpu8bitaddr}
  1888. case filetyp of
  1889. ft_text :
  1890. savesize:=127;
  1891. ft_typed,
  1892. ft_untyped :
  1893. savesize:=127;
  1894. end;
  1895. {$endif cpu8bitaddr}
  1896. end;
  1897. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  1898. begin
  1899. inherited ppuwrite(ppufile);
  1900. ppufile.putbyte(byte(filetyp));
  1901. if filetyp=ft_typed then
  1902. ppufile.putderef(typedfiledefderef);
  1903. ppufile.writeentry(ibfiledef);
  1904. end;
  1905. function tfiledef.GetTypeName : string;
  1906. begin
  1907. case filetyp of
  1908. ft_untyped:
  1909. GetTypeName:='File';
  1910. ft_typed:
  1911. GetTypeName:='File Of '+typedfiledef.typename;
  1912. ft_text:
  1913. GetTypeName:='Text'
  1914. end;
  1915. end;
  1916. function tfiledef.getmangledparaname : string;
  1917. begin
  1918. case filetyp of
  1919. ft_untyped:
  1920. getmangledparaname:='FILE';
  1921. ft_typed:
  1922. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  1923. ft_text:
  1924. getmangledparaname:='TEXT'
  1925. end;
  1926. end;
  1927. {****************************************************************************
  1928. TVARIANTDEF
  1929. ****************************************************************************}
  1930. constructor tvariantdef.create(v : tvarianttype);
  1931. begin
  1932. inherited create(variantdef);
  1933. varianttype:=v;
  1934. setsize;
  1935. end;
  1936. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  1937. begin
  1938. inherited ppuload(variantdef,ppufile);
  1939. varianttype:=tvarianttype(ppufile.getbyte);
  1940. setsize;
  1941. end;
  1942. function tvariantdef.getcopy : tstoreddef;
  1943. begin
  1944. result:=tvariantdef.create(varianttype);
  1945. end;
  1946. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  1947. begin
  1948. inherited ppuwrite(ppufile);
  1949. ppufile.putbyte(byte(varianttype));
  1950. ppufile.writeentry(ibvariantdef);
  1951. end;
  1952. function tvariantdef.getvardef : longint;
  1953. begin
  1954. Result:=varVariant;
  1955. end;
  1956. procedure tvariantdef.setsize;
  1957. begin
  1958. {$ifdef cpu64bitaddr}
  1959. savesize:=24;
  1960. {$else cpu64bitaddr}
  1961. savesize:=16;
  1962. {$endif cpu64bitaddr}
  1963. end;
  1964. function tvariantdef.GetTypeName : string;
  1965. begin
  1966. case varianttype of
  1967. vt_normalvariant:
  1968. GetTypeName:='Variant';
  1969. vt_olevariant:
  1970. GetTypeName:='OleVariant';
  1971. end;
  1972. end;
  1973. function tvariantdef.needs_inittable : boolean;
  1974. begin
  1975. needs_inittable:=true;
  1976. end;
  1977. function tvariantdef.is_publishable : boolean;
  1978. begin
  1979. is_publishable:=true;
  1980. end;
  1981. {****************************************************************************
  1982. TABSTRACtpointerdef
  1983. ****************************************************************************}
  1984. constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef);
  1985. begin
  1986. inherited create(dt);
  1987. pointeddef:=def;
  1988. savesize:=sizeof(pint);
  1989. end;
  1990. constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1991. begin
  1992. inherited ppuload(dt,ppufile);
  1993. ppufile.getderef(pointeddefderef);
  1994. savesize:=sizeof(pint);
  1995. end;
  1996. procedure tabstractpointerdef.buildderef;
  1997. begin
  1998. inherited buildderef;
  1999. pointeddefderef.build(pointeddef);
  2000. end;
  2001. procedure tabstractpointerdef.deref;
  2002. begin
  2003. inherited deref;
  2004. pointeddef:=tdef(pointeddefderef.resolve);
  2005. end;
  2006. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2007. begin
  2008. inherited ppuwrite(ppufile);
  2009. ppufile.putderef(pointeddefderef);
  2010. end;
  2011. {****************************************************************************
  2012. tpointerdef
  2013. ****************************************************************************}
  2014. constructor tpointerdef.create(def:tdef);
  2015. begin
  2016. inherited create(pointerdef,def);
  2017. is_far:=false;
  2018. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2019. end;
  2020. constructor tpointerdef.createfar(def:tdef);
  2021. begin
  2022. inherited create(pointerdef,def);
  2023. is_far:=true;
  2024. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2025. end;
  2026. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  2027. begin
  2028. inherited ppuload(pointerdef,ppufile);
  2029. is_far:=(ppufile.getbyte<>0);
  2030. has_pointer_math:=(ppufile.getbyte<>0);
  2031. end;
  2032. function tpointerdef.getcopy : tstoreddef;
  2033. begin
  2034. { don't use direct pointeddef if it is a forwarddef because in other case
  2035. one of them will be destroyed on forward type resolve and the second will
  2036. point to garbage }
  2037. if pointeddef.typ=forwarddef then
  2038. result:=tpointerdef.create(tforwarddef(pointeddef).getcopy)
  2039. else
  2040. result:=tpointerdef.create(pointeddef);
  2041. tpointerdef(result).is_far:=is_far;
  2042. tpointerdef(result).has_pointer_math:=has_pointer_math;
  2043. tpointerdef(result).savesize:=savesize;
  2044. end;
  2045. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2046. begin
  2047. inherited ppuwrite(ppufile);
  2048. ppufile.putbyte(byte(is_far));
  2049. ppufile.putbyte(byte(has_pointer_math));
  2050. ppufile.writeentry(ibpointerdef);
  2051. end;
  2052. function tpointerdef.GetTypeName : string;
  2053. begin
  2054. if is_far then
  2055. GetTypeName:='^'+pointeddef.typename+';far'
  2056. else
  2057. GetTypeName:='^'+pointeddef.typename;
  2058. end;
  2059. {****************************************************************************
  2060. TCLASSREFDEF
  2061. ****************************************************************************}
  2062. constructor tclassrefdef.create(def:tdef);
  2063. begin
  2064. inherited create(classrefdef,def);
  2065. end;
  2066. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  2067. begin
  2068. inherited ppuload(classrefdef,ppufile);
  2069. end;
  2070. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  2071. begin
  2072. inherited ppuwrite(ppufile);
  2073. ppufile.writeentry(ibclassrefdef);
  2074. end;
  2075. function tclassrefdef.getcopy:tstoreddef;
  2076. begin
  2077. if pointeddef.typ=forwarddef then
  2078. result:=tclassrefdef.create(tforwarddef(pointeddef).getcopy)
  2079. else
  2080. result:=tclassrefdef.create(pointeddef);
  2081. tclassrefdef(result).savesize:=savesize;
  2082. end;
  2083. function tclassrefdef.GetTypeName : string;
  2084. begin
  2085. GetTypeName:='Class Of '+pointeddef.typename;
  2086. end;
  2087. function tclassrefdef.is_publishable : boolean;
  2088. begin
  2089. result:=true;
  2090. end;
  2091. function tclassrefdef.rtti_mangledname(rt: trttitype): string;
  2092. begin
  2093. if (tobjectdef(pointeddef).objecttype<>odt_objcclass) then
  2094. result:=inherited rtti_mangledname(rt)
  2095. else
  2096. result:=tobjectdef(pointeddef).rtti_mangledname(objcmetartti);
  2097. end;
  2098. procedure tclassrefdef.register_created_object_type;
  2099. begin
  2100. tobjectdef(pointeddef).register_created_classref_type;
  2101. end;
  2102. {***************************************************************************
  2103. TSETDEF
  2104. ***************************************************************************}
  2105. constructor tsetdef.create(def:tdef;low, high : asizeint);
  2106. var
  2107. setallocbits: aint;
  2108. packedsavesize: aint;
  2109. begin
  2110. inherited create(setdef);
  2111. elementdef:=def;
  2112. setmax:=high;
  2113. if (current_settings.setalloc=0) then
  2114. begin
  2115. setbase:=0;
  2116. if (high<32) then
  2117. savesize:=Sizeof(longint)
  2118. else if (high<256) then
  2119. savesize:=32
  2120. else
  2121. savesize:=(high+7) div 8
  2122. end
  2123. else
  2124. begin
  2125. setallocbits:=current_settings.setalloc*8;
  2126. setbase:=low and not(setallocbits-1);
  2127. packedsavesize:=current_settings.setalloc*((((high+setallocbits)-setbase)) DIV setallocbits);
  2128. savesize:=packedsavesize;
  2129. if savesize=3 then
  2130. savesize:=4;
  2131. end;
  2132. end;
  2133. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  2134. begin
  2135. inherited ppuload(setdef,ppufile);
  2136. ppufile.getderef(elementdefderef);
  2137. savesize:=ppufile.getaint;
  2138. setbase:=ppufile.getaint;
  2139. setmax:=ppufile.getaint;
  2140. end;
  2141. function tsetdef.getcopy : tstoreddef;
  2142. begin
  2143. result:=tsetdef.create(elementdef,setbase,setmax);
  2144. { the copy might have been created with a different setalloc setting }
  2145. tsetdef(result).savesize:=savesize;
  2146. end;
  2147. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  2148. begin
  2149. inherited ppuwrite(ppufile);
  2150. ppufile.putderef(elementdefderef);
  2151. ppufile.putaint(savesize);
  2152. ppufile.putaint(setbase);
  2153. ppufile.putaint(setmax);
  2154. ppufile.writeentry(ibsetdef);
  2155. end;
  2156. procedure tsetdef.buildderef;
  2157. begin
  2158. inherited buildderef;
  2159. elementdefderef.build(elementdef);
  2160. end;
  2161. procedure tsetdef.deref;
  2162. begin
  2163. inherited deref;
  2164. elementdef:=tdef(elementdefderef.resolve);
  2165. end;
  2166. function tsetdef.is_publishable : boolean;
  2167. begin
  2168. is_publishable:=savesize in [1,2,4];
  2169. end;
  2170. function tsetdef.GetTypeName : string;
  2171. begin
  2172. if assigned(elementdef) then
  2173. GetTypeName:='Set Of '+elementdef.typename
  2174. else
  2175. GetTypeName:='Empty Set';
  2176. end;
  2177. {***************************************************************************
  2178. TFORMALDEF
  2179. ***************************************************************************}
  2180. constructor tformaldef.create(Atyped:boolean);
  2181. begin
  2182. inherited create(formaldef);
  2183. typed:=Atyped;
  2184. savesize:=0;
  2185. end;
  2186. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  2187. begin
  2188. inherited ppuload(formaldef,ppufile);
  2189. typed:=boolean(ppufile.getbyte);
  2190. savesize:=0;
  2191. end;
  2192. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  2193. begin
  2194. inherited ppuwrite(ppufile);
  2195. ppufile.putbyte(byte(typed));
  2196. ppufile.writeentry(ibformaldef);
  2197. end;
  2198. function tformaldef.GetTypeName : string;
  2199. begin
  2200. if typed then
  2201. GetTypeName:='<Typed formal type>'
  2202. else
  2203. GetTypeName:='<Formal type>';
  2204. end;
  2205. {***************************************************************************
  2206. TARRAYDEF
  2207. ***************************************************************************}
  2208. constructor tarraydef.create(l,h:asizeint;def:tdef);
  2209. begin
  2210. inherited create(arraydef);
  2211. lowrange:=l;
  2212. highrange:=h;
  2213. rangedef:=def;
  2214. _elementdef:=nil;
  2215. arrayoptions:=[];
  2216. symtable:=tarraysymtable.create(self);
  2217. end;
  2218. destructor tarraydef.destroy;
  2219. begin
  2220. symtable.free;
  2221. symtable:=nil;
  2222. inherited;
  2223. end;
  2224. constructor tarraydef.create_from_pointer(def:tdef);
  2225. begin
  2226. { use -1 so that the elecount will not overflow }
  2227. self.create(0,high(aint)-1,ptrsinttype);
  2228. arrayoptions:=[ado_IsConvertedPointer];
  2229. setelementdef(def);
  2230. end;
  2231. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  2232. begin
  2233. inherited ppuload(arraydef,ppufile);
  2234. { the addresses are calculated later }
  2235. ppufile.getderef(_elementdefderef);
  2236. ppufile.getderef(rangedefderef);
  2237. lowrange:=ppufile.getaint;
  2238. highrange:=ppufile.getaint;
  2239. ppufile.getsmallset(arrayoptions);
  2240. symtable:=tarraysymtable.create(self);
  2241. tarraysymtable(symtable).ppuload(ppufile)
  2242. end;
  2243. function tarraydef.getcopy : tstoreddef;
  2244. begin
  2245. result:=tarraydef.create(lowrange,highrange,rangedef);
  2246. tarraydef(result).arrayoptions:=arrayoptions;
  2247. tarraydef(result)._elementdef:=_elementdef;
  2248. end;
  2249. procedure tarraydef.buildderef;
  2250. begin
  2251. inherited buildderef;
  2252. tarraysymtable(symtable).buildderef;
  2253. _elementdefderef.build(_elementdef);
  2254. rangedefderef.build(rangedef);
  2255. end;
  2256. procedure tarraydef.deref;
  2257. begin
  2258. inherited deref;
  2259. tarraysymtable(symtable).deref;
  2260. _elementdef:=tdef(_elementdefderef.resolve);
  2261. rangedef:=tdef(rangedefderef.resolve);
  2262. end;
  2263. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  2264. begin
  2265. inherited ppuwrite(ppufile);
  2266. ppufile.putderef(_elementdefderef);
  2267. ppufile.putderef(rangedefderef);
  2268. ppufile.putaint(lowrange);
  2269. ppufile.putaint(highrange);
  2270. ppufile.putsmallset(arrayoptions);
  2271. ppufile.writeentry(ibarraydef);
  2272. tarraysymtable(symtable).ppuwrite(ppufile);
  2273. end;
  2274. function tarraydef.elesize : asizeint;
  2275. begin
  2276. if (ado_IsBitPacked in arrayoptions) then
  2277. internalerror(2006080101);
  2278. if assigned(_elementdef) then
  2279. result:=_elementdef.size
  2280. else
  2281. result:=0;
  2282. end;
  2283. function tarraydef.elepackedbitsize : asizeint;
  2284. begin
  2285. if not(ado_IsBitPacked in arrayoptions) then
  2286. internalerror(2006080102);
  2287. if assigned(_elementdef) then
  2288. result:=_elementdef.packedbitsize
  2289. else
  2290. result:=0;
  2291. end;
  2292. function tarraydef.elecount : asizeuint;
  2293. var
  2294. qhigh,qlow : qword;
  2295. begin
  2296. if ado_IsDynamicArray in arrayoptions then
  2297. begin
  2298. result:=0;
  2299. exit;
  2300. end;
  2301. if (highrange>0) and (lowrange<0) then
  2302. begin
  2303. qhigh:=highrange;
  2304. qlow:=qword(-lowrange);
  2305. { prevent overflow, return 0 to indicate overflow }
  2306. if qhigh+qlow>qword(high(asizeint)-1) then
  2307. result:=0
  2308. else
  2309. result:=qhigh+qlow+1;
  2310. end
  2311. else
  2312. result:=int64(highrange)-lowrange+1;
  2313. end;
  2314. function tarraydef.size : asizeint;
  2315. var
  2316. cachedelecount : asizeuint;
  2317. cachedelesize : asizeint;
  2318. begin
  2319. if ado_IsDynamicArray in arrayoptions then
  2320. begin
  2321. size:=sizeof(pint);
  2322. exit;
  2323. end;
  2324. { Tarraydef.size may never be called for an open array! }
  2325. if highrange<lowrange then
  2326. internalerror(99080501);
  2327. if not (ado_IsBitPacked in arrayoptions) then
  2328. cachedelesize:=elesize
  2329. else
  2330. cachedelesize := elepackedbitsize;
  2331. cachedelecount:=elecount;
  2332. if (cachedelesize = 0) then
  2333. begin
  2334. size := 0;
  2335. exit;
  2336. end;
  2337. if (cachedelecount = 0) then
  2338. begin
  2339. size := -1;
  2340. exit;
  2341. end;
  2342. { prevent overflow, return -1 to indicate overflow }
  2343. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  2344. if (cachedelecount > asizeuint(high(asizeint))) or
  2345. ((high(asizeint) div cachedelesize) < asizeint(cachedelecount)) or
  2346. { also lowrange*elesize must be < high(asizeint) to prevent overflow when
  2347. accessing the array, see ncgmem (PFV) }
  2348. ((high(asizeint) div cachedelesize) < abs(lowrange)) then
  2349. begin
  2350. result:=-1;
  2351. exit;
  2352. end;
  2353. result:=cachedelesize*asizeint(cachedelecount);
  2354. if (ado_IsBitPacked in arrayoptions) then
  2355. { can't just add 7 and divide by 8, because that may overflow }
  2356. result:=result div 8 + ord((result mod 8)<>0);
  2357. end;
  2358. procedure tarraydef.setelementdef(def:tdef);
  2359. begin
  2360. _elementdef:=def;
  2361. if not(
  2362. (ado_IsDynamicArray in arrayoptions) or
  2363. (ado_IsConvertedPointer in arrayoptions) or
  2364. (highrange<lowrange)
  2365. ) and
  2366. (size=-1) then
  2367. Message(sym_e_segment_too_large);
  2368. end;
  2369. function tarraydef.alignment : shortint;
  2370. begin
  2371. { alignment of dyn. arrays doesn't depend on the element size }
  2372. if (ado_IsDynamicArray in arrayoptions) then
  2373. alignment:=size_2_align(sizeof(pint))
  2374. { alignment is the alignment of the elements }
  2375. else if (elementdef.typ in [arraydef,recorddef,orddef,enumdef,floatdef]) or
  2376. ((elementdef.typ=objectdef) and
  2377. is_object(elementdef)) then
  2378. alignment:=elementdef.alignment
  2379. { alignment is the size of the elements }
  2380. else if not (ado_IsBitPacked in arrayoptions) then
  2381. alignment:=size_2_align(elesize)
  2382. else
  2383. alignment:=packedbitsloadsize(elepackedbitsize);
  2384. end;
  2385. function tarraydef.needs_inittable : boolean;
  2386. begin
  2387. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  2388. end;
  2389. function tarraydef.GetTypeName : string;
  2390. begin
  2391. if (ado_IsConstString in arrayoptions) then
  2392. result:='Constant String'
  2393. else if (ado_isarrayofconst in arrayoptions) or
  2394. (ado_isConstructor in arrayoptions) then
  2395. begin
  2396. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  2397. GetTypeName:='Array Of Const'
  2398. else
  2399. GetTypeName:='Array Of Const/Constant Open Array of '+elementdef.typename;
  2400. end
  2401. else if (ado_IsDynamicArray in arrayoptions) then
  2402. GetTypeName:='Dynamic Array Of '+elementdef.typename
  2403. else if ((highrange=-1) and (lowrange=0)) then
  2404. GetTypeName:='Open Array Of '+elementdef.typename
  2405. else
  2406. begin
  2407. result := '';
  2408. if (ado_IsBitPacked in arrayoptions) then
  2409. result:='Packed ';
  2410. if rangedef.typ=enumdef then
  2411. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  2412. else
  2413. result:=result+'Array['+tostr(lowrange)+'..'+
  2414. tostr(highrange)+'] Of '+elementdef.typename
  2415. end;
  2416. end;
  2417. function tarraydef.getmangledparaname : string;
  2418. begin
  2419. if ado_isarrayofconst in arrayoptions then
  2420. getmangledparaname:='array_of_const'
  2421. else
  2422. if ((highrange=-1) and (lowrange=0)) then
  2423. getmangledparaname:='array_of_'+elementdef.mangledparaname
  2424. else
  2425. internalerror(200204176);
  2426. end;
  2427. function tarraydef.is_publishable : boolean;
  2428. begin
  2429. Result:=ado_IsDynamicArray in arrayoptions;
  2430. end;
  2431. {***************************************************************************
  2432. tabstractrecorddef
  2433. ***************************************************************************}
  2434. constructor tabstractrecorddef.create(const n:string; dt:tdeftyp);
  2435. begin
  2436. inherited create(dt);
  2437. objname:=stringdup(upper(n));
  2438. objrealname:=stringdup(n);
  2439. objectoptions:=[];
  2440. end;
  2441. constructor tabstractrecorddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2442. begin
  2443. inherited ppuload(dt,ppufile);
  2444. objrealname:=stringdup(ppufile.getstring);
  2445. objname:=stringdup(upper(objrealname^));
  2446. ppufile.getsmallset(objectoptions);
  2447. end;
  2448. procedure tabstractrecorddef.ppuwrite(ppufile: tcompilerppufile);
  2449. begin
  2450. inherited ppuwrite(ppufile);
  2451. ppufile.putstring(objrealname^);
  2452. ppufile.putsmallset(objectoptions);
  2453. end;
  2454. destructor tabstractrecorddef.destroy;
  2455. begin
  2456. stringdispose(objname);
  2457. stringdispose(objrealname);
  2458. inherited destroy;
  2459. end;
  2460. procedure tabstractrecorddef.check_forwards;
  2461. begin
  2462. tstoredsymtable(symtable).check_forwards;
  2463. end;
  2464. function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
  2465. var
  2466. i: longint;
  2467. sym: tsym;
  2468. begin
  2469. for i:=0 to symtable.SymList.Count-1 do
  2470. begin
  2471. sym:=tsym(symtable.SymList[i]);
  2472. if sym.typ=procsym then
  2473. begin
  2474. result:=tprocsym(sym).find_procdef_bytype(pt);
  2475. if assigned(result) then
  2476. exit;
  2477. end;
  2478. end;
  2479. result:=nil;
  2480. end;
  2481. function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
  2482. begin
  2483. if t=gs_record then
  2484. GetSymtable:=symtable
  2485. else
  2486. GetSymtable:=nil;
  2487. end;
  2488. function tabstractrecorddef.is_packed:boolean;
  2489. begin
  2490. result:=tabstractrecordsymtable(symtable).is_packed;
  2491. end;
  2492. function tabstractrecorddef.RttiName: string;
  2493. begin
  2494. Result:=OwnerHierarchyName+objrealname^;
  2495. end;
  2496. function tabstractrecorddef.search_enumerator_get: tprocdef;
  2497. var
  2498. sym : tsym;
  2499. i : integer;
  2500. pd : tprocdef;
  2501. hashedid : THashedIDString;
  2502. begin
  2503. result:=nil;
  2504. hashedid.id:='GETENUMERATOR';
  2505. sym:=tsym(symtable.FindWithHash(hashedid));
  2506. if assigned(sym) and (sym.typ=procsym) then
  2507. begin
  2508. for i := 0 to Tprocsym(sym).ProcdefList.Count - 1 do
  2509. begin
  2510. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2511. if (pd.proctypeoption = potype_function) and
  2512. (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) and
  2513. (pd.visibility >= vis_public) then
  2514. begin
  2515. result:=pd;
  2516. exit;
  2517. end;
  2518. end;
  2519. end;
  2520. end;
  2521. function tabstractrecorddef.search_enumerator_move: tprocdef;
  2522. var
  2523. sym : tsym;
  2524. i : integer;
  2525. pd : tprocdef;
  2526. hashedid : THashedIDString;
  2527. begin
  2528. result:=nil;
  2529. // first search for po_enumerator_movenext method modifier
  2530. // then search for public function MoveNext: Boolean
  2531. for i:=0 to symtable.SymList.Count-1 do
  2532. begin
  2533. sym:=TSym(symtable.SymList[i]);
  2534. if (sym.typ=procsym) then
  2535. begin
  2536. pd:=Tprocsym(sym).find_procdef_byoptions([po_enumerator_movenext]);
  2537. if assigned(pd) then
  2538. begin
  2539. result:=pd;
  2540. exit;
  2541. end;
  2542. end;
  2543. end;
  2544. hashedid.id:='MOVENEXT';
  2545. sym:=tsym(symtable.FindWithHash(hashedid));
  2546. if assigned(sym) and (sym.typ=procsym) then
  2547. begin
  2548. for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
  2549. begin
  2550. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2551. if (pd.proctypeoption = potype_function) and
  2552. is_boolean(pd.returndef) and
  2553. (pd.minparacount = 0) and
  2554. (pd.visibility >= vis_public) then
  2555. begin
  2556. result:=pd;
  2557. exit;
  2558. end;
  2559. end;
  2560. end;
  2561. end;
  2562. function tabstractrecorddef.search_enumerator_current: tsym;
  2563. var
  2564. sym: tsym;
  2565. i: integer;
  2566. hashedid : THashedIDString;
  2567. begin
  2568. result:=nil;
  2569. // first search for ppo_enumerator_current property modifier
  2570. // then search for public property Current
  2571. for i:=0 to symtable.SymList.Count-1 do
  2572. begin
  2573. sym:=TSym(symtable.SymList[i]);
  2574. if (sym.typ=propertysym) and (ppo_enumerator_current in tpropertysym(sym).propoptions) then
  2575. begin
  2576. result:=sym;
  2577. exit;
  2578. end;
  2579. end;
  2580. hashedid.id:='CURRENT';
  2581. sym:=tsym(symtable.FindWithHash(hashedid));
  2582. if assigned(sym) and (sym.typ=propertysym) and
  2583. (sym.visibility >= vis_public) and not tpropertysym(sym).propaccesslist[palt_read].empty then
  2584. begin
  2585. result:=sym;
  2586. exit;
  2587. end;
  2588. end;
  2589. {***************************************************************************
  2590. trecorddef
  2591. ***************************************************************************}
  2592. constructor trecorddef.create(const n:string; p:TSymtable);
  2593. begin
  2594. inherited create(n,recorddef);
  2595. symtable:=p;
  2596. { we can own the symtable only if nobody else owns a copy so far }
  2597. if symtable.refcount=1 then
  2598. symtable.defowner:=self;
  2599. isunion:=false;
  2600. end;
  2601. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  2602. begin
  2603. inherited ppuload(recorddef,ppufile);
  2604. if df_copied_def in defoptions then
  2605. ppufile.getderef(cloneddefderef)
  2606. else
  2607. begin
  2608. symtable:=trecordsymtable.create(objrealname^,0);
  2609. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  2610. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  2611. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  2612. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  2613. trecordsymtable(symtable).datasize:=ppufile.getasizeint;
  2614. trecordsymtable(symtable).paddingsize:=ppufile.getword;
  2615. trecordsymtable(symtable).ppuload(ppufile);
  2616. { requires usefieldalignment to be set }
  2617. symtable.defowner:=self;
  2618. end;
  2619. isunion:=false;
  2620. end;
  2621. destructor trecorddef.destroy;
  2622. begin
  2623. if assigned(symtable) then
  2624. begin
  2625. symtable.free;
  2626. symtable:=nil;
  2627. end;
  2628. inherited destroy;
  2629. end;
  2630. function trecorddef.getcopy : tstoreddef;
  2631. begin
  2632. result:=trecorddef.create(objrealname^,symtable.getcopy);
  2633. trecorddef(result).isunion:=isunion;
  2634. include(trecorddef(result).defoptions,df_copied_def);
  2635. end;
  2636. function trecorddef.needs_inittable : boolean;
  2637. begin
  2638. needs_inittable:=trecordsymtable(symtable).needs_init_final
  2639. end;
  2640. procedure trecorddef.buildderef;
  2641. begin
  2642. inherited buildderef;
  2643. if df_copied_def in defoptions then
  2644. cloneddefderef.build(symtable.defowner)
  2645. else
  2646. tstoredsymtable(symtable).buildderef;
  2647. end;
  2648. procedure trecorddef.deref;
  2649. begin
  2650. inherited deref;
  2651. { now dereference the definitions }
  2652. if df_copied_def in defoptions then
  2653. begin
  2654. cloneddef:=trecorddef(cloneddefderef.resolve);
  2655. symtable:=cloneddef.symtable.getcopy;
  2656. end
  2657. else
  2658. tstoredsymtable(symtable).deref;
  2659. { assign TGUID? load only from system unit }
  2660. if not(assigned(rec_tguid)) and
  2661. (upper(typename)='TGUID') and
  2662. assigned(owner) and
  2663. assigned(owner.name) and
  2664. (owner.name^='SYSTEM') then
  2665. rec_tguid:=self;
  2666. { assign JMP_BUF? load only from system unit }
  2667. if not(assigned(rec_jmp_buf)) and
  2668. (upper(typename)='JMP_BUF') and
  2669. assigned(owner) and
  2670. assigned(owner.name) and
  2671. (owner.name^='SYSTEM') then
  2672. rec_jmp_buf:=self;
  2673. end;
  2674. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  2675. begin
  2676. inherited ppuwrite(ppufile);
  2677. if df_copied_def in defoptions then
  2678. ppufile.putderef(cloneddefderef)
  2679. else
  2680. begin
  2681. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  2682. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  2683. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  2684. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  2685. ppufile.putasizeint(trecordsymtable(symtable).datasize);
  2686. ppufile.putword(trecordsymtable(symtable).paddingsize);
  2687. end;
  2688. ppufile.writeentry(ibrecorddef);
  2689. if not(df_copied_def in defoptions) then
  2690. trecordsymtable(symtable).ppuwrite(ppufile);
  2691. end;
  2692. function trecorddef.size:asizeint;
  2693. begin
  2694. result:=trecordsymtable(symtable).datasize;
  2695. end;
  2696. function trecorddef.alignment:shortint;
  2697. begin
  2698. alignment:=trecordsymtable(symtable).recordalignment;
  2699. end;
  2700. function trecorddef.padalignment:shortint;
  2701. begin
  2702. padalignment := trecordsymtable(symtable).padalignment;
  2703. end;
  2704. function trecorddef.GetTypeName : string;
  2705. begin
  2706. GetTypeName:='<record type>'
  2707. end;
  2708. {***************************************************************************
  2709. TABSTRACTPROCDEF
  2710. ***************************************************************************}
  2711. constructor tabstractprocdef.create(dt:tdeftyp;level:byte);
  2712. begin
  2713. inherited create(dt);
  2714. parast:=tparasymtable.create(self,level);
  2715. paras:=nil;
  2716. minparacount:=0;
  2717. maxparacount:=0;
  2718. proctypeoption:=potype_none;
  2719. proccalloption:=pocall_none;
  2720. procoptions:=[];
  2721. returndef:=voidtype;
  2722. savesize:=sizeof(pint);
  2723. callerargareasize:=0;
  2724. calleeargareasize:=0;
  2725. has_paraloc_info:=callnoside;
  2726. funcretloc[callerside].init;
  2727. funcretloc[calleeside].init;
  2728. check_mark_as_nested;
  2729. end;
  2730. destructor tabstractprocdef.destroy;
  2731. begin
  2732. if assigned(paras) then
  2733. begin
  2734. {$ifdef MEMDEBUG}
  2735. memprocpara.start;
  2736. {$endif MEMDEBUG}
  2737. paras.free;
  2738. paras:=nil;
  2739. {$ifdef MEMDEBUG}
  2740. memprocpara.stop;
  2741. {$endif MEMDEBUG}
  2742. end;
  2743. if assigned(parast) then
  2744. begin
  2745. {$ifdef MEMDEBUG}
  2746. memprocparast.start;
  2747. {$endif MEMDEBUG}
  2748. parast.free;
  2749. parast:=nil;
  2750. {$ifdef MEMDEBUG}
  2751. memprocparast.stop;
  2752. {$endif MEMDEBUG}
  2753. end;
  2754. funcretloc[callerside].done;
  2755. funcretloc[calleeside].done;
  2756. inherited destroy;
  2757. end;
  2758. procedure tabstractprocdef.count_para(p:TObject;arg:pointer);
  2759. begin
  2760. if (tsym(p).typ<>paravarsym) then
  2761. exit;
  2762. inc(plongint(arg)^);
  2763. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  2764. begin
  2765. if not assigned(tparavarsym(p).defaultconstsym) then
  2766. inc(minparacount);
  2767. inc(maxparacount);
  2768. end;
  2769. end;
  2770. procedure tabstractprocdef.insert_para(p:TObject;arg:pointer);
  2771. begin
  2772. if (tsym(p).typ<>paravarsym) then
  2773. exit;
  2774. paras.add(p);
  2775. end;
  2776. procedure tabstractprocdef.calcparas;
  2777. var
  2778. paracount : longint;
  2779. begin
  2780. { This can already be assigned when
  2781. we need to reresolve this unit (PFV) }
  2782. if assigned(paras) then
  2783. paras.free;
  2784. paras:=tparalist.create(false);
  2785. paracount:=0;
  2786. minparacount:=0;
  2787. maxparacount:=0;
  2788. parast.SymList.ForEachCall(@count_para,@paracount);
  2789. paras.capacity:=paracount;
  2790. { Insert parameters in table }
  2791. parast.SymList.ForEachCall(@insert_para,nil);
  2792. { Order parameters }
  2793. paras.sortparas;
  2794. end;
  2795. procedure tabstractprocdef.buildderef;
  2796. begin
  2797. { released procdef? }
  2798. if not assigned(parast) then
  2799. exit;
  2800. inherited buildderef;
  2801. returndefderef.build(returndef);
  2802. { parast }
  2803. tparasymtable(parast).buildderef;
  2804. end;
  2805. procedure tabstractprocdef.deref;
  2806. begin
  2807. inherited deref;
  2808. returndef:=tdef(returndefderef.resolve);
  2809. { parast }
  2810. tparasymtable(parast).deref;
  2811. { recalculated parameters }
  2812. calcparas;
  2813. end;
  2814. constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2815. begin
  2816. inherited ppuload(dt,ppufile);
  2817. parast:=nil;
  2818. Paras:=nil;
  2819. minparacount:=0;
  2820. maxparacount:=0;
  2821. ppufile.getderef(returndefderef);
  2822. { TODO: remove fpu_used loading}
  2823. ppufile.getbyte;
  2824. proctypeoption:=tproctypeoption(ppufile.getbyte);
  2825. proccalloption:=tproccalloption(ppufile.getbyte);
  2826. ppufile.getnormalset(procoptions);
  2827. funcretloc[callerside].init;
  2828. if po_explicitparaloc in procoptions then
  2829. funcretloc[callerside].ppuload(ppufile);
  2830. savesize:=sizeof(pint);
  2831. if (po_explicitparaloc in procoptions) then
  2832. has_paraloc_info:=callerside;
  2833. end;
  2834. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  2835. var
  2836. oldintfcrc : boolean;
  2837. begin
  2838. { released procdef? }
  2839. if not assigned(parast) then
  2840. exit;
  2841. inherited ppuwrite(ppufile);
  2842. ppufile.putderef(returndefderef);
  2843. oldintfcrc:=ppufile.do_interface_crc;
  2844. ppufile.do_interface_crc:=false;
  2845. ppufile.putbyte(0);
  2846. ppufile.putbyte(ord(proctypeoption));
  2847. ppufile.putbyte(ord(proccalloption));
  2848. ppufile.putnormalset(procoptions);
  2849. ppufile.do_interface_crc:=oldintfcrc;
  2850. if (po_explicitparaloc in procoptions) then
  2851. funcretloc[callerside].ppuwrite(ppufile);
  2852. end;
  2853. function tabstractprocdef.typename_paras(showhidden:boolean) : string;
  2854. var
  2855. hs,s : string;
  2856. hp : TParavarsym;
  2857. hpc : tconstsym;
  2858. first : boolean;
  2859. i : integer;
  2860. begin
  2861. s:='';
  2862. first:=true;
  2863. for i:=0 to paras.count-1 do
  2864. begin
  2865. hp:=tparavarsym(paras[i]);
  2866. if not(vo_is_hidden_para in hp.varoptions) or
  2867. (showhidden) then
  2868. begin
  2869. if first then
  2870. begin
  2871. s:=s+'(';
  2872. first:=false;
  2873. end
  2874. else
  2875. s:=s+',';
  2876. if vo_is_hidden_para in hp.varoptions then
  2877. s:=s+'<';
  2878. case hp.varspez of
  2879. vs_var :
  2880. s:=s+'var ';
  2881. vs_const :
  2882. s:=s+'const ';
  2883. vs_out :
  2884. s:=s+'out ';
  2885. vs_constref :
  2886. s:=s+'constref ';
  2887. end;
  2888. if hp.univpara then
  2889. s:=s+'univ ';
  2890. if assigned(hp.vardef.typesym) then
  2891. begin
  2892. hs:=hp.vardef.typesym.realname;
  2893. if hs[1]<>'$' then
  2894. s:=s+hs
  2895. else
  2896. s:=s+hp.vardef.GetTypeName;
  2897. end
  2898. else
  2899. s:=s+hp.vardef.GetTypeName;
  2900. { default value }
  2901. if assigned(hp.defaultconstsym) then
  2902. begin
  2903. hpc:=tconstsym(hp.defaultconstsym);
  2904. hs:='';
  2905. case hpc.consttyp of
  2906. conststring,
  2907. constresourcestring :
  2908. begin
  2909. If hpc.value.len>0 then
  2910. begin
  2911. setLength(hs,hpc.value.len);
  2912. { don't write past the end of hs if the constant
  2913. is > 255 chars }
  2914. move(hpc.value.valueptr^,hs[1],length(hs));
  2915. { make sure that constant strings with newline chars
  2916. don't create a linebreak in the assembler code,
  2917. since comments are line-based. Also remove nulls
  2918. because the comments are written as a pchar. }
  2919. ReplaceCase(hs,#0,'.');
  2920. ReplaceCase(hs,#10,'.');
  2921. ReplaceCase(hs,#13,'.');
  2922. end;
  2923. end;
  2924. constreal :
  2925. str(pbestreal(hpc.value.valueptr)^,hs);
  2926. constpointer :
  2927. hs:=tostr(hpc.value.valueordptr);
  2928. constord :
  2929. begin
  2930. if is_boolean(hpc.constdef) then
  2931. begin
  2932. if hpc.value.valueord<>0 then
  2933. hs:='TRUE'
  2934. else
  2935. hs:='FALSE';
  2936. end
  2937. else
  2938. hs:=tostr(hpc.value.valueord);
  2939. end;
  2940. constnil :
  2941. hs:='nil';
  2942. constset :
  2943. hs:='<set>';
  2944. end;
  2945. if hs<>'' then
  2946. s:=s+'="'+hs+'"';
  2947. end;
  2948. if vo_is_hidden_para in hp.varoptions then
  2949. s:=s+'>';
  2950. end;
  2951. end;
  2952. if not first then
  2953. s:=s+')';
  2954. if (po_varargs in procoptions) then
  2955. s:=s+';VarArgs';
  2956. typename_paras:=s;
  2957. end;
  2958. function tabstractprocdef.is_methodpointer:boolean;
  2959. begin
  2960. result:=false;
  2961. end;
  2962. function tabstractprocdef.is_addressonly:boolean;
  2963. begin
  2964. result:=true;
  2965. end;
  2966. function tabstractprocdef.no_self_node: boolean;
  2967. begin
  2968. Result:=([po_staticmethod,po_classmethod]<=procoptions)or
  2969. (proctypeoption in [potype_class_constructor,potype_class_destructor,potype_operator]);
  2970. end;
  2971. procedure tabstractprocdef.check_mark_as_nested;
  2972. begin
  2973. { nested procvars require that nested functions use the Delphi-style
  2974. nested procedure calling convention }
  2975. if (parast.symtablelevel>normal_function_level) and
  2976. (m_nested_procvars in current_settings.modeswitches) then
  2977. include(procoptions,po_delphi_nested_cc);
  2978. end;
  2979. procedure tabstractprocdef.init_paraloc_info(side: tcallercallee);
  2980. begin
  2981. if (side in [callerside,callbothsides]) and
  2982. not(has_paraloc_info in [callerside,callbothsides]) then
  2983. begin
  2984. callerargareasize:=paramanager.create_paraloc_info(self,callerside);
  2985. if has_paraloc_info in [calleeside,callbothsides] then
  2986. has_paraloc_info:=callbothsides
  2987. else
  2988. has_paraloc_info:=callerside;
  2989. end;
  2990. if (side in [calleeside,callbothsides]) and
  2991. not(has_paraloc_info in [calleeside,callbothsides]) then
  2992. begin
  2993. calleeargareasize:=paramanager.create_paraloc_info(self,calleeside);
  2994. if has_paraloc_info in [callerside,callbothsides] then
  2995. has_paraloc_info:=callbothsides
  2996. else
  2997. has_paraloc_info:=calleeside;
  2998. end;
  2999. end;
  3000. function tabstractprocdef.stack_tainting_parameter(side: tcallercallee): boolean;
  3001. var
  3002. p: tparavarsym;
  3003. ploc: PCGParalocation;
  3004. i: longint;
  3005. begin
  3006. result:=false;
  3007. init_paraloc_info(side);
  3008. for i:=0 to parast.SymList.Count-1 do
  3009. if tsym(parast.SymList[i]).typ=paravarsym then
  3010. begin
  3011. p:=tparavarsym(parast.SymList[i]);
  3012. { check if no parameter is located on the stack }
  3013. if is_open_array(p.vardef) or
  3014. is_array_of_const(p.vardef) then
  3015. begin
  3016. result:=true;
  3017. exit;
  3018. end;
  3019. ploc:=p.paraloc[side].location;
  3020. while assigned(ploc) do
  3021. begin
  3022. if (ploc^.loc=LOC_REFERENCE) then
  3023. begin
  3024. result:=true;
  3025. exit
  3026. end;
  3027. ploc:=ploc^.next;
  3028. end;
  3029. end;
  3030. end;
  3031. {***************************************************************************
  3032. TPROCDEF
  3033. ***************************************************************************}
  3034. constructor tprocdef.create(level:byte);
  3035. begin
  3036. inherited create(procdef,level);
  3037. localst:=tlocalsymtable.create(self,parast.symtablelevel);
  3038. _mangledname:=nil;
  3039. fileinfo:=current_filepos;
  3040. extnumber:=$ffff;
  3041. aliasnames:=TCmdStrList.create;
  3042. funcretsym:=nil;
  3043. forwarddef:=true;
  3044. interfacedef:=false;
  3045. hasforward:=false;
  3046. struct := nil;
  3047. import_dll:=nil;
  3048. import_name:=nil;
  3049. import_nr:=0;
  3050. inlininginfo:=nil;
  3051. deprecatedmsg:=nil;
  3052. {$ifdef i386}
  3053. fpu_used:=maxfpuregs;
  3054. {$endif i386}
  3055. interruptvector:=-1;
  3056. end;
  3057. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  3058. var
  3059. i,aliasnamescount : longint;
  3060. level : byte;
  3061. begin
  3062. inherited ppuload(procdef,ppufile);
  3063. if po_has_mangledname in procoptions then
  3064. _mangledname:=stringdup(ppufile.getstring)
  3065. else
  3066. _mangledname:=nil;
  3067. extnumber:=ppufile.getword;
  3068. level:=ppufile.getbyte;
  3069. ppufile.getderef(structderef);
  3070. ppufile.getderef(procsymderef);
  3071. ppufile.getposinfo(fileinfo);
  3072. visibility:=tvisibility(ppufile.getbyte);
  3073. ppufile.getsmallset(symoptions);
  3074. if sp_has_deprecated_msg in symoptions then
  3075. deprecatedmsg:=stringdup(ppufile.getstring)
  3076. else
  3077. deprecatedmsg:=nil;
  3078. {$ifdef powerpc}
  3079. { library symbol for AmigaOS/MorphOS }
  3080. ppufile.getderef(libsymderef);
  3081. {$endif powerpc}
  3082. { import stuff }
  3083. if po_has_importdll in procoptions then
  3084. import_dll:=stringdup(ppufile.getstring)
  3085. else
  3086. import_dll:=nil;
  3087. if po_has_importname in procoptions then
  3088. import_name:=stringdup(ppufile.getstring)
  3089. else
  3090. import_name:=nil;
  3091. import_nr:=ppufile.getword;
  3092. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3093. if target_info.system in systems_interrupt_table then
  3094. interruptvector:=ppufile.getlongint;
  3095. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3096. if (po_msgint in procoptions) then
  3097. messageinf.i:=ppufile.getlongint;
  3098. if (po_msgstr in procoptions) then
  3099. messageinf.str:=stringdup(ppufile.getstring);
  3100. if (po_dispid in procoptions) then
  3101. dispid:=ppufile.getlongint;
  3102. { inline stuff }
  3103. if (po_has_inlininginfo in procoptions) then
  3104. begin
  3105. ppufile.getderef(funcretsymderef);
  3106. new(inlininginfo);
  3107. ppufile.getsmallset(inlininginfo^.flags);
  3108. end
  3109. else
  3110. begin
  3111. inlininginfo:=nil;
  3112. funcretsym:=nil;
  3113. end;
  3114. aliasnames:=TCmdStrList.create;
  3115. { count alias names }
  3116. aliasnamescount:=ppufile.getbyte;
  3117. for i:=1 to aliasnamescount do
  3118. aliasnames.insert(ppufile.getstring);
  3119. { load para symtable }
  3120. parast:=tparasymtable.create(self,level);
  3121. tparasymtable(parast).ppuload(ppufile);
  3122. { load local symtable }
  3123. if (po_has_inlininginfo in procoptions) then
  3124. begin
  3125. localst:=tlocalsymtable.create(self,level);
  3126. tlocalsymtable(localst).ppuload(ppufile);
  3127. end
  3128. else
  3129. localst:=nil;
  3130. { inline stuff }
  3131. if (po_has_inlininginfo in procoptions) then
  3132. inlininginfo^.code:=ppuloadnodetree(ppufile);
  3133. { default values for no persistent data }
  3134. if (cs_link_deffile in current_settings.globalswitches) and
  3135. (tf_need_export in target_info.flags) and
  3136. (po_exports in procoptions) then
  3137. deffile.AddExport(mangledname);
  3138. forwarddef:=false;
  3139. interfacedef:=false;
  3140. hasforward:=false;
  3141. { Disable po_has_inlining until the derefimpl is done }
  3142. exclude(procoptions,po_has_inlininginfo);
  3143. {$ifdef i386}
  3144. fpu_used:=maxfpuregs;
  3145. {$endif i386}
  3146. end;
  3147. destructor tprocdef.destroy;
  3148. begin
  3149. aliasnames.free;
  3150. aliasnames:=nil;
  3151. if assigned(localst) and
  3152. (localst.symtabletype<>staticsymtable) then
  3153. begin
  3154. {$ifdef MEMDEBUG}
  3155. memproclocalst.start;
  3156. {$endif MEMDEBUG}
  3157. localst.free;
  3158. localst:=nil;
  3159. {$ifdef MEMDEBUG}
  3160. memproclocalst.start;
  3161. {$endif MEMDEBUG}
  3162. end;
  3163. if assigned(inlininginfo) then
  3164. begin
  3165. {$ifdef MEMDEBUG}
  3166. memprocnodetree.start;
  3167. {$endif MEMDEBUG}
  3168. tnode(inlininginfo^.code).free;
  3169. {$ifdef MEMDEBUG}
  3170. memprocnodetree.start;
  3171. {$endif MEMDEBUG}
  3172. dispose(inlininginfo);
  3173. inlininginfo:=nil;
  3174. end;
  3175. stringdispose(resultname);
  3176. stringdispose(import_dll);
  3177. stringdispose(import_name);
  3178. stringdispose(deprecatedmsg);
  3179. if (po_msgstr in procoptions) then
  3180. stringdispose(messageinf.str);
  3181. if assigned(_mangledname) then
  3182. begin
  3183. {$ifdef MEMDEBUG}
  3184. memmanglednames.start;
  3185. {$endif MEMDEBUG}
  3186. stringdispose(_mangledname);
  3187. {$ifdef MEMDEBUG}
  3188. memmanglednames.stop;
  3189. {$endif MEMDEBUG}
  3190. end;
  3191. inherited destroy;
  3192. end;
  3193. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  3194. var
  3195. oldintfcrc : boolean;
  3196. aliasnamescount : longint;
  3197. item : TCmdStrListItem;
  3198. begin
  3199. { released procdef? }
  3200. if not assigned(parast) then
  3201. exit;
  3202. inherited ppuwrite(ppufile);
  3203. if po_has_mangledname in procoptions then
  3204. ppufile.putstring(_mangledname^);
  3205. ppufile.putword(extnumber);
  3206. ppufile.putbyte(parast.symtablelevel);
  3207. ppufile.putderef(structderef);
  3208. ppufile.putderef(procsymderef);
  3209. ppufile.putposinfo(fileinfo);
  3210. ppufile.putbyte(byte(visibility));
  3211. ppufile.putsmallset(symoptions);
  3212. if sp_has_deprecated_msg in symoptions then
  3213. ppufile.putstring(deprecatedmsg^);
  3214. {$ifdef powerpc}
  3215. { library symbol for AmigaOS/MorphOS }
  3216. ppufile.putderef(libsymderef);
  3217. {$endif powerpc}
  3218. { import }
  3219. if po_has_importdll in procoptions then
  3220. ppufile.putstring(import_dll^);
  3221. if po_has_importname in procoptions then
  3222. ppufile.putstring(import_name^);
  3223. ppufile.putword(import_nr);
  3224. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3225. if target_info.system in systems_interrupt_table then
  3226. ppufile.putlongint(interruptvector);
  3227. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3228. if (po_msgint in procoptions) then
  3229. ppufile.putlongint(messageinf.i);
  3230. if (po_msgstr in procoptions) then
  3231. ppufile.putstring(messageinf.str^);
  3232. if (po_dispid in procoptions) then
  3233. ppufile.putlongint(dispid);
  3234. { inline stuff }
  3235. oldintfcrc:=ppufile.do_crc;
  3236. ppufile.do_crc:=false;
  3237. if (po_has_inlininginfo in procoptions) then
  3238. begin
  3239. ppufile.putderef(funcretsymderef);
  3240. ppufile.putsmallset(inlininginfo^.flags);
  3241. end;
  3242. { count alias names }
  3243. aliasnamescount:=0;
  3244. item:=TCmdStrListItem(aliasnames.first);
  3245. while assigned(item) do
  3246. begin
  3247. inc(aliasnamescount);
  3248. item:=TCmdStrListItem(item.next);
  3249. end;
  3250. if aliasnamescount>255 then
  3251. internalerror(200711021);
  3252. ppufile.putbyte(aliasnamescount);
  3253. item:=TCmdStrListItem(aliasnames.first);
  3254. while assigned(item) do
  3255. begin
  3256. ppufile.putstring(item.str);
  3257. item:=TCmdStrListItem(item.next);
  3258. end;
  3259. ppufile.do_crc:=oldintfcrc;
  3260. { write this entry }
  3261. ppufile.writeentry(ibprocdef);
  3262. { Save the para symtable, this is taken from the interface }
  3263. tparasymtable(parast).ppuwrite(ppufile);
  3264. { save localsymtable for inline procedures or when local
  3265. browser info is requested, this has no influence on the crc }
  3266. if (po_has_inlininginfo in procoptions) then
  3267. begin
  3268. oldintfcrc:=ppufile.do_crc;
  3269. ppufile.do_crc:=false;
  3270. tlocalsymtable(localst).ppuwrite(ppufile);
  3271. ppufile.do_crc:=oldintfcrc;
  3272. end;
  3273. { node tree for inlining }
  3274. oldintfcrc:=ppufile.do_crc;
  3275. ppufile.do_crc:=false;
  3276. if (po_has_inlininginfo in procoptions) then
  3277. ppuwritenodetree(ppufile,inlininginfo^.code);
  3278. ppufile.do_crc:=oldintfcrc;
  3279. end;
  3280. function tprocdef.fullprocname(showhidden:boolean):string;
  3281. var
  3282. s : string;
  3283. t : ttoken;
  3284. begin
  3285. {$ifdef EXTDEBUG}
  3286. showhidden:=true;
  3287. {$endif EXTDEBUG}
  3288. s:='';
  3289. if assigned(struct) then
  3290. begin
  3291. s:=struct.RttiName+'.';
  3292. if (po_classmethod in procoptions) and
  3293. not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
  3294. s:='class ' + s;
  3295. end;
  3296. if proctypeoption=potype_operator then
  3297. begin
  3298. for t:=NOTOKEN to last_overloaded do
  3299. if procsym.realname='$'+overloaded_names[t] then
  3300. begin
  3301. s:='operator '+arraytokeninfo[t].str+typename_paras(showhidden);
  3302. break;
  3303. end;
  3304. end
  3305. else
  3306. s:=s+procsym.realname+typename_paras(showhidden);
  3307. case proctypeoption of
  3308. potype_constructor:
  3309. s:='constructor '+s;
  3310. potype_destructor:
  3311. s:='destructor '+s;
  3312. potype_class_constructor:
  3313. s:='class constructor '+s;
  3314. potype_class_destructor:
  3315. s:='class destructor '+s;
  3316. else
  3317. if assigned(returndef) and
  3318. not(is_void(returndef)) then
  3319. s:=s+':'+returndef.GetTypeName;
  3320. end;
  3321. if owner.symtabletype=localsymtable then
  3322. s:=s+' is nested';
  3323. s:=s+';';
  3324. { forced calling convention? }
  3325. if (po_hascallingconvention in procoptions) then
  3326. s:=s+' '+ProcCallOptionStr[proccalloption]+';';
  3327. if (po_staticmethod in procoptions) and
  3328. not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
  3329. s:=s+' Static;';
  3330. fullprocname:=s;
  3331. end;
  3332. function tprocdef.is_methodpointer:boolean;
  3333. begin
  3334. { don't check assigned(_class), that's also the case for nested
  3335. procedures inside methods }
  3336. result:=owner.symtabletype=ObjectSymtable;
  3337. end;
  3338. function tprocdef.is_addressonly:boolean;
  3339. begin
  3340. result:=assigned(owner) and
  3341. (owner.symtabletype<>ObjectSymtable) and
  3342. (not(m_nested_procvars in current_settings.modeswitches) or
  3343. not is_nested_pd(self));
  3344. end;
  3345. procedure tprocdef.make_external;
  3346. begin
  3347. include(procoptions,po_external);
  3348. forwarddef:=false;
  3349. end;
  3350. function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
  3351. begin
  3352. case t of
  3353. gs_local :
  3354. GetSymtable:=localst;
  3355. gs_para :
  3356. GetSymtable:=parast;
  3357. else
  3358. GetSymtable:=nil;
  3359. end;
  3360. end;
  3361. procedure tprocdef.buildderef;
  3362. begin
  3363. inherited buildderef;
  3364. structderef.build(struct);
  3365. { procsym that originaly defined this definition, should be in the
  3366. same symtable }
  3367. procsymderef.build(procsym);
  3368. {$ifdef powerpc}
  3369. { library symbol for AmigaOS/MorphOS }
  3370. libsymderef.build(libsym);
  3371. {$endif powerpc}
  3372. end;
  3373. procedure tprocdef.buildderefimpl;
  3374. begin
  3375. inherited buildderefimpl;
  3376. { Localst is not available for main/unit init }
  3377. if assigned(localst) then
  3378. begin
  3379. tlocalsymtable(localst).buildderef;
  3380. tlocalsymtable(localst).buildderefimpl;
  3381. end;
  3382. { inline tree }
  3383. if (po_has_inlininginfo in procoptions) then
  3384. begin
  3385. funcretsymderef.build(funcretsym);
  3386. inlininginfo^.code.buildderefimpl;
  3387. end;
  3388. end;
  3389. procedure tprocdef.deref;
  3390. begin
  3391. inherited deref;
  3392. struct:=tabstractrecorddef(structderef.resolve);
  3393. { procsym that originaly defined this definition, should be in the
  3394. same symtable }
  3395. procsym:=tprocsym(procsymderef.resolve);
  3396. {$ifdef powerpc}
  3397. { library symbol for AmigaOS/MorphOS }
  3398. libsym:=tsym(libsymderef.resolve);
  3399. {$endif powerpc}
  3400. end;
  3401. procedure tprocdef.derefimpl;
  3402. begin
  3403. { Enable has_inlininginfo when the inlininginfo
  3404. structure is available. The has_inlininginfo was disabled
  3405. after the load, since the data was invalid }
  3406. if assigned(inlininginfo) then
  3407. include(procoptions,po_has_inlininginfo);
  3408. { Locals }
  3409. if assigned(localst) then
  3410. begin
  3411. tlocalsymtable(localst).deref;
  3412. tlocalsymtable(localst).derefimpl;
  3413. end;
  3414. { Inline }
  3415. if (po_has_inlininginfo in procoptions) then
  3416. begin
  3417. inlininginfo^.code.derefimpl;
  3418. { funcretsym, this is always located in the localst }
  3419. funcretsym:=tsym(funcretsymderef.resolve);
  3420. end
  3421. else
  3422. begin
  3423. { safety }
  3424. { Not safe! A unit may be reresolved after its interface has been
  3425. parsed but before its implementation has been parsed, and in that
  3426. case the funcretsym is still required!
  3427. funcretsym:=nil; }
  3428. end;
  3429. end;
  3430. function tprocdef.GetTypeName : string;
  3431. begin
  3432. GetTypeName := FullProcName(false);
  3433. end;
  3434. function tprocdef.mangledname : string;
  3435. var
  3436. hp : TParavarsym;
  3437. hs : string;
  3438. crc : dword;
  3439. newlen,
  3440. oldlen,
  3441. i : integer;
  3442. begin
  3443. if assigned(_mangledname) then
  3444. begin
  3445. {$ifdef compress}
  3446. mangledname:=minilzw_decode(_mangledname^);
  3447. {$else}
  3448. mangledname:=_mangledname^;
  3449. {$endif}
  3450. exit;
  3451. end;
  3452. { we need to use the symtable where the procsym is inserted,
  3453. because that is visible to the world }
  3454. mangledname:=make_mangledname('',procsym.owner,procsym.name);
  3455. oldlen:=length(mangledname);
  3456. { add parameter types }
  3457. for i:=0 to paras.count-1 do
  3458. begin
  3459. hp:=tparavarsym(paras[i]);
  3460. if not(vo_is_hidden_para in hp.varoptions) then
  3461. mangledname:=mangledname+'$'+hp.vardef.mangledparaname;
  3462. end;
  3463. { add resultdef, add $$ as separator to make it unique from a
  3464. parameter separator }
  3465. if not is_void(returndef) then
  3466. mangledname:=mangledname+'$$'+returndef.mangledparaname;
  3467. newlen:=length(mangledname);
  3468. { Replace with CRC if the parameter line is very long }
  3469. if (newlen-oldlen>12) and
  3470. ((newlen>100) or (newlen-oldlen>64)) then
  3471. begin
  3472. crc:=0;
  3473. for i:=0 to paras.count-1 do
  3474. begin
  3475. hp:=tparavarsym(paras[i]);
  3476. if not(vo_is_hidden_para in hp.varoptions) then
  3477. begin
  3478. hs:=hp.vardef.mangledparaname;
  3479. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3480. end;
  3481. end;
  3482. hs:=hp.vardef.mangledparaname;
  3483. crc:=UpdateCrc32(crc,hs[1],length(hs));
  3484. mangledname:=Copy(mangledname,1,oldlen)+'$crc'+hexstr(crc,8);
  3485. end;
  3486. {$ifdef compress}
  3487. _mangledname:=stringdup(minilzw_encode(mangledname));
  3488. {$else}
  3489. _mangledname:=stringdup(mangledname);
  3490. {$endif}
  3491. end;
  3492. function tprocdef.cplusplusmangledname : string;
  3493. function getcppparaname(p : tdef) : string;
  3494. const
  3495. {$ifdef NAMEMANGLING_GCC2}
  3496. ordtype2str : array[tordtype] of string[2] = (
  3497. '',
  3498. 'Uc','Us','Ui','Us',
  3499. 'Sc','s','i','x',
  3500. 'b','b','b','b','b',
  3501. 'c','w','x');
  3502. {$else NAMEMANGLING_GCC2}
  3503. ordtype2str : array[tordtype] of string[1] = (
  3504. 'v',
  3505. 'h','t','j','y',
  3506. 'a','s','i','x',
  3507. 'b','b','b','b',
  3508. 'b','b','b','b',
  3509. 'c','w','x');
  3510. floattype2str : array[tfloattype] of string[1] = (
  3511. 'f','d','e','e',
  3512. 'd','d','g');
  3513. {$endif NAMEMANGLING_GCC2}
  3514. var
  3515. s : string;
  3516. begin
  3517. case p.typ of
  3518. orddef:
  3519. s:=ordtype2str[torddef(p).ordtype];
  3520. pointerdef:
  3521. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  3522. {$ifndef NAMEMANGLING_GCC2}
  3523. floatdef:
  3524. s:=floattype2str[tfloatdef(p).floattype];
  3525. {$endif NAMEMANGLING_GCC2}
  3526. else
  3527. internalerror(2103001);
  3528. end;
  3529. getcppparaname:=s;
  3530. end;
  3531. var
  3532. s,s2 : string;
  3533. hp : TParavarsym;
  3534. i : integer;
  3535. begin
  3536. {$ifdef NAMEMANGLING_GCC2}
  3537. { outdated gcc 2.x name mangling scheme }
  3538. s := procsym.realname;
  3539. if procsym.owner.symtabletype=ObjectSymtable then
  3540. begin
  3541. s2:=upper(tobjectdef(procsym.owner.defowner).objrealname^);
  3542. case proctypeoption of
  3543. potype_destructor:
  3544. s:='_$_'+tostr(length(s2))+s2;
  3545. potype_constructor:
  3546. s:='___'+tostr(length(s2))+s2;
  3547. else
  3548. s:='_'+s+'__'+tostr(length(s2))+s2;
  3549. end;
  3550. end
  3551. else s:=s+'__';
  3552. s:=s+'F';
  3553. { concat modifiers }
  3554. { !!!!! }
  3555. { now we handle the parameters }
  3556. if maxparacount>0 then
  3557. begin
  3558. for i:=0 to paras.count-1 do
  3559. begin
  3560. hp:=tparavarsym(paras[i]);
  3561. { no hidden parameters form part of a C++ mangled name:
  3562. a) self is not included
  3563. b) there are no "high" or other hidden parameters
  3564. }
  3565. if vo_is_hidden_para in hp.varoptions then
  3566. continue;
  3567. s2:=getcppparaname(hp.vardef);
  3568. if hp.varspez in [vs_var,vs_out] then
  3569. s2:='R'+s2;
  3570. s:=s+s2;
  3571. end;
  3572. end
  3573. else
  3574. s:=s+'v';
  3575. cplusplusmangledname:=s;
  3576. {$else NAMEMANGLING_GCC2}
  3577. { gcc 3.x and 4.x name mangling scheme }
  3578. { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling }
  3579. if procsym.owner.symtabletype=ObjectSymtable then
  3580. begin
  3581. s:='_ZN';
  3582. s2:=tobjectdef(procsym.owner.defowner).objextname^;
  3583. s:=s+tostr(length(s2))+s2;
  3584. case proctypeoption of
  3585. potype_constructor:
  3586. s:=s+'C1';
  3587. potype_destructor:
  3588. s:=s+'D1';
  3589. else
  3590. s:=s+tostr(length(procsym.realname))+procsym.realname;
  3591. end;
  3592. s:=s+'E';
  3593. end
  3594. else
  3595. s:=procsym.realname;
  3596. { now we handle the parameters }
  3597. if maxparacount>0 then
  3598. begin
  3599. for i:=0 to paras.count-1 do
  3600. begin
  3601. hp:=tparavarsym(paras[i]);
  3602. { no hidden parameters form part of a C++ mangled name:
  3603. a) self is not included
  3604. b) there are no "high" or other hidden parameters
  3605. }
  3606. if vo_is_hidden_para in hp.varoptions then
  3607. continue;
  3608. s2:=getcppparaname(hp.vardef);
  3609. if hp.varspez in [vs_var,vs_out] then
  3610. s2:='R'+s2;
  3611. s:=s+s2;
  3612. end;
  3613. end
  3614. else
  3615. s:=s+'v';
  3616. cplusplusmangledname:=s;
  3617. {$endif NAMEMANGLING_GCC2}
  3618. end;
  3619. function tprocdef.objcmangledname : string;
  3620. var
  3621. manglednamelen: longint;
  3622. iscatmethod : boolean;
  3623. begin
  3624. if not (po_msgstr in procoptions) then
  3625. internalerror(2009030901);
  3626. { we may very well need longer strings to handle these... }
  3627. manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+
  3628. length('+"[ ]"')+length(messageinf.str^);
  3629. iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions;
  3630. if (iscatmethod) then
  3631. inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()'));
  3632. if manglednamelen>255 then
  3633. Message1(parser_e_objc_message_name_too_long,messageinf.str^);
  3634. if not(po_classmethod in procoptions) then
  3635. result:='"-['
  3636. else
  3637. result:='"+[';
  3638. { quotes are necessary because the +/- otherwise confuse the assembler
  3639. into expecting a number
  3640. }
  3641. if iscatmethod then
  3642. result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'(';
  3643. result:=result+tobjectdef(procsym.owner.defowner).objextname^;
  3644. if iscatmethod then
  3645. result:=result+')';
  3646. result:=result+' '+messageinf.str^+']"';
  3647. end;
  3648. procedure tprocdef.setmangledname(const s : string);
  3649. begin
  3650. { This is not allowed anymore, the forward declaration
  3651. already needs to create the correct mangledname, no changes
  3652. afterwards are allowed (PFV) }
  3653. { Exception: interface definitions in mode macpas, since in that }
  3654. { case no reference to the old name can exist yet (JM) }
  3655. if assigned(_mangledname) then
  3656. if ((m_mac in current_settings.modeswitches) and
  3657. (interfacedef)) then
  3658. stringdispose(_mangledname)
  3659. else
  3660. internalerror(200411171);
  3661. {$ifdef compress}
  3662. _mangledname:=stringdup(minilzw_encode(s));
  3663. {$else}
  3664. _mangledname:=stringdup(s);
  3665. {$endif}
  3666. include(procoptions,po_has_mangledname);
  3667. end;
  3668. {***************************************************************************
  3669. TPROCVARDEF
  3670. ***************************************************************************}
  3671. constructor tprocvardef.create(level:byte);
  3672. begin
  3673. inherited create(procvardef,level);
  3674. end;
  3675. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  3676. begin
  3677. inherited ppuload(procvardef,ppufile);
  3678. { load para symtable }
  3679. parast:=tparasymtable.create(self,ppufile.getbyte);
  3680. tparasymtable(parast).ppuload(ppufile);
  3681. end;
  3682. function tprocvardef.getcopy : tstoreddef;
  3683. var
  3684. i : tcallercallee;
  3685. j : longint;
  3686. begin
  3687. result:=tprocvardef.create(parast.symtablelevel);
  3688. tprocvardef(result).returndef:=returndef;
  3689. tprocvardef(result).returndefderef:=returndefderef;
  3690. tprocvardef(result).parast:=parast.getcopy;
  3691. tprocvardef(result).savesize:=savesize;
  3692. { create paralist copy }
  3693. tprocvardef(result).paras:=tparalist.create(false);
  3694. tprocvardef(result).paras.count:=paras.count;
  3695. for j:=0 to paras.count-1 do
  3696. tprocvardef(result).paras[j]:=paras[j];
  3697. tprocvardef(result).proctypeoption:=proctypeoption;
  3698. tprocvardef(result).proccalloption:=proccalloption;
  3699. tprocvardef(result).procoptions:=procoptions;
  3700. tprocvardef(result).callerargareasize:=callerargareasize;
  3701. tprocvardef(result).calleeargareasize:=calleeargareasize;
  3702. tprocvardef(result).maxparacount:=maxparacount;
  3703. tprocvardef(result).minparacount:=minparacount;
  3704. for i:=low(tcallercallee) to high(tcallercallee) do
  3705. tprocvardef(result).funcretloc[i]:=funcretloc[i].getcopy;
  3706. tprocvardef(result).has_paraloc_info:=has_paraloc_info;
  3707. {$ifdef m68k}
  3708. tprocvardef(result).exp_funcretloc:=exp_funcretloc;
  3709. {$endif}
  3710. end;
  3711. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  3712. begin
  3713. inherited ppuwrite(ppufile);
  3714. { Save the para symtable level (necessary to distinguish nested
  3715. procvars) }
  3716. ppufile.putbyte(parast.symtablelevel);
  3717. { Write this entry }
  3718. ppufile.writeentry(ibprocvardef);
  3719. { Save the para symtable, this is taken from the interface }
  3720. tparasymtable(parast).ppuwrite(ppufile);
  3721. end;
  3722. function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
  3723. begin
  3724. case t of
  3725. gs_para :
  3726. GetSymtable:=parast;
  3727. else
  3728. GetSymtable:=nil;
  3729. end;
  3730. end;
  3731. function tprocvardef.size : asizeint;
  3732. begin
  3733. if ((po_methodpointer in procoptions) or
  3734. is_nested_pd(self)) and
  3735. not(po_addressonly in procoptions) then
  3736. size:=2*sizeof(pint)
  3737. else
  3738. size:=sizeof(pint);
  3739. end;
  3740. function tprocvardef.is_methodpointer:boolean;
  3741. begin
  3742. result:=(po_methodpointer in procoptions);
  3743. end;
  3744. function tprocvardef.is_addressonly:boolean;
  3745. begin
  3746. result:=(not(po_methodpointer in procoptions) and
  3747. not is_nested_pd(self)) or
  3748. (po_addressonly in procoptions);
  3749. end;
  3750. function tprocvardef.getmangledparaname:string;
  3751. begin
  3752. if not(po_methodpointer in procoptions) then
  3753. if not is_nested_pd(self) then
  3754. result:='procvar'
  3755. else
  3756. result:='nestedprovar'
  3757. else
  3758. result:='procvarofobj'
  3759. end;
  3760. function tprocvardef.is_publishable : boolean;
  3761. begin
  3762. is_publishable:=(po_methodpointer in procoptions);
  3763. end;
  3764. function tprocvardef.GetTypeName : string;
  3765. var
  3766. s: string;
  3767. showhidden : boolean;
  3768. begin
  3769. {$ifdef EXTDEBUG}
  3770. showhidden:=true;
  3771. {$else EXTDEBUG}
  3772. showhidden:=false;
  3773. {$endif EXTDEBUG}
  3774. s:='<';
  3775. if po_classmethod in procoptions then
  3776. s := s+'class method type of'
  3777. else
  3778. if po_addressonly in procoptions then
  3779. s := s+'address of'
  3780. else
  3781. s := s+'procedure variable type of';
  3782. if assigned(returndef) and
  3783. (returndef<>voidtype) then
  3784. s:=s+' function'+typename_paras(showhidden)+':'+returndef.GetTypeName
  3785. else
  3786. s:=s+' procedure'+typename_paras(showhidden);
  3787. if po_methodpointer in procoptions then
  3788. s := s+' of object';
  3789. if is_nested_pd(self) then
  3790. s := s+' is nested';
  3791. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  3792. end;
  3793. {***************************************************************************
  3794. TOBJECTDEF
  3795. ***************************************************************************}
  3796. constructor tobjectdef.create(ot:tobjecttyp;const n:string;c:tobjectdef);
  3797. begin
  3798. inherited create(n,objectdef);
  3799. fcurrent_dispid:=0;
  3800. objecttype:=ot;
  3801. childof:=nil;
  3802. if objecttype=odt_helper then
  3803. owner.includeoption(sto_has_helper);
  3804. symtable:=tObjectSymtable.create(self,n,current_settings.packrecords);
  3805. { create space for vmt !! }
  3806. vmtentries:=TFPList.Create;
  3807. vmt_offset:=0;
  3808. set_parent(c);
  3809. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  3810. prepareguid;
  3811. { setup implemented interfaces }
  3812. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then
  3813. ImplementedInterfaces:=TFPObjectList.Create(true)
  3814. else
  3815. ImplementedInterfaces:=nil;
  3816. writing_class_record_dbginfo:=false;
  3817. end;
  3818. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  3819. var
  3820. i,
  3821. implintfcount : longint;
  3822. d : tderef;
  3823. ImplIntf : TImplementedInterface;
  3824. vmtentry : pvmtentry;
  3825. begin
  3826. inherited ppuload(objectdef,ppufile);
  3827. objecttype:=tobjecttyp(ppufile.getbyte);
  3828. objextname:=stringdup(ppufile.getstring);
  3829. { only used for external Objective-C classes/protocols }
  3830. if (objextname^='') then
  3831. stringdispose(objextname);
  3832. import_lib:=stringdup(ppufile.getstring);
  3833. { only used for external C++ classes }
  3834. if (import_lib^='') then
  3835. stringdispose(import_lib);
  3836. symtable:=tObjectSymtable.create(self,objrealname^,0);
  3837. tObjectSymtable(symtable).datasize:=ppufile.getasizeint;
  3838. tObjectSymtable(symtable).paddingsize:=ppufile.getword;
  3839. tObjectSymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  3840. tObjectSymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  3841. vmt_offset:=ppufile.getlongint;
  3842. ppufile.getderef(childofderef);
  3843. { load guid }
  3844. iidstr:=nil;
  3845. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3846. begin
  3847. new(iidguid);
  3848. ppufile.getguid(iidguid^);
  3849. iidstr:=stringdup(ppufile.getstring);
  3850. end;
  3851. if objecttype=odt_helper then
  3852. ppufile.getderef(extendeddefderef);
  3853. vmtentries:=TFPList.Create;
  3854. vmtentries.count:=ppufile.getlongint;
  3855. for i:=0 to vmtentries.count-1 do
  3856. begin
  3857. ppufile.getderef(d);
  3858. new(vmtentry);
  3859. vmtentry^.procdef:=nil;
  3860. vmtentry^.procdefderef:=d;
  3861. vmtentry^.visibility:=tvisibility(ppufile.getbyte);
  3862. vmtentries[i]:=vmtentry;
  3863. end;
  3864. { load implemented interfaces }
  3865. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then
  3866. begin
  3867. ImplementedInterfaces:=TFPObjectList.Create(true);
  3868. implintfcount:=ppufile.getlongint;
  3869. for i:=0 to implintfcount-1 do
  3870. begin
  3871. ppufile.getderef(d);
  3872. ImplIntf:=TImplementedInterface.Create_deref(d);
  3873. ImplIntf.IOffset:=ppufile.getlongint;
  3874. ImplementedInterfaces.Add(ImplIntf);
  3875. end;
  3876. end
  3877. else
  3878. ImplementedInterfaces:=nil;
  3879. if df_copied_def in defoptions then
  3880. ppufile.getderef(cloneddefderef)
  3881. else
  3882. tObjectSymtable(symtable).ppuload(ppufile);
  3883. { handles the predefined class tobject }
  3884. { the last TOBJECT which is loaded gets }
  3885. { it ! }
  3886. if (childof=nil) and
  3887. (objecttype=odt_class) and
  3888. (objname^='TOBJECT') then
  3889. class_tobject:=self;
  3890. if (childof=nil) and
  3891. (objecttype=odt_interfacecom) then
  3892. if (objname^='IUNKNOWN') then
  3893. interface_iunknown:=self
  3894. else
  3895. if (objname^='IDISPATCH') then
  3896. interface_idispatch:=self;
  3897. if (childof=nil) and
  3898. (objecttype=odt_objcclass) and
  3899. (objname^='PROTOCOL') then
  3900. objc_protocoltype:=self;
  3901. writing_class_record_dbginfo:=false;
  3902. end;
  3903. destructor tobjectdef.destroy;
  3904. begin
  3905. if assigned(symtable) then
  3906. begin
  3907. symtable.free;
  3908. symtable:=nil;
  3909. end;
  3910. stringdispose(objextname);
  3911. stringdispose(import_lib);
  3912. stringdispose(iidstr);
  3913. if assigned(ImplementedInterfaces) then
  3914. begin
  3915. ImplementedInterfaces.free;
  3916. ImplementedInterfaces:=nil;
  3917. end;
  3918. if assigned(iidguid) then
  3919. begin
  3920. dispose(iidguid);
  3921. iidguid:=nil;
  3922. end;
  3923. if assigned(vmtentries) then
  3924. begin
  3925. resetvmtentries;
  3926. vmtentries.free;
  3927. vmtentries:=nil;
  3928. end;
  3929. if assigned(vmcallstaticinfo) then
  3930. begin
  3931. freemem(vmcallstaticinfo);
  3932. vmcallstaticinfo:=nil;
  3933. end;
  3934. inherited destroy;
  3935. end;
  3936. function tobjectdef.getcopy : tstoreddef;
  3937. var
  3938. i : longint;
  3939. begin
  3940. result:=tobjectdef.create(objecttype,objrealname^,childof);
  3941. { the constructor allocates a symtable which we release to avoid memory leaks }
  3942. tobjectdef(result).symtable.free;
  3943. tobjectdef(result).symtable:=symtable.getcopy;
  3944. if assigned(objextname) then
  3945. tobjectdef(result).objextname:=stringdup(objextname^);
  3946. if assigned(import_lib) then
  3947. tobjectdef(result).import_lib:=stringdup(import_lib^);
  3948. tobjectdef(result).objectoptions:=objectoptions;
  3949. include(tobjectdef(result).defoptions,df_copied_def);
  3950. tobjectdef(result).extendeddef:=extendeddef;
  3951. tobjectdef(result).vmt_offset:=vmt_offset;
  3952. if assigned(iidguid) then
  3953. begin
  3954. new(tobjectdef(result).iidguid);
  3955. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  3956. end;
  3957. if assigned(iidstr) then
  3958. tobjectdef(result).iidstr:=stringdup(iidstr^);
  3959. if assigned(ImplementedInterfaces) then
  3960. begin
  3961. for i:=0 to ImplementedInterfaces.count-1 do
  3962. tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
  3963. end;
  3964. if assigned(vmtentries) then
  3965. begin
  3966. tobjectdef(result).vmtentries:=TFPList.Create;
  3967. tobjectdef(result).copyvmtentries(self);
  3968. end;
  3969. end;
  3970. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  3971. var
  3972. i : longint;
  3973. vmtentry : pvmtentry;
  3974. ImplIntf : TImplementedInterface;
  3975. old_do_indirect_crc: boolean;
  3976. begin
  3977. { if class1 in unit A changes, and class2 in unit B inherits from it
  3978. (so unit B uses unit A), then unit B with class2 will be recompiled.
  3979. However, if there is also a class3 in unit C that only depends on
  3980. unit B, then unit C will not be recompiled because nothing changed
  3981. to the interface of unit B. Nevertheless, unit C can indirectly
  3982. depend on unit A via derefs, and these must be updated -> the
  3983. indirect crc keeps track of such changes. }
  3984. old_do_indirect_crc:=ppufile.do_indirect_crc;
  3985. ppufile.do_indirect_crc:=true;
  3986. inherited ppuwrite(ppufile);
  3987. ppufile.putbyte(byte(objecttype));
  3988. if assigned(objextname) then
  3989. ppufile.putstring(objextname^)
  3990. else
  3991. ppufile.putstring('');
  3992. if assigned(import_lib) then
  3993. ppufile.putstring(import_lib^)
  3994. else
  3995. ppufile.putstring('');
  3996. ppufile.putasizeint(tObjectSymtable(symtable).datasize);
  3997. ppufile.putword(tObjectSymtable(symtable).paddingsize);
  3998. ppufile.putbyte(byte(tObjectSymtable(symtable).fieldalignment));
  3999. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignment));
  4000. ppufile.putlongint(vmt_offset);
  4001. ppufile.putderef(childofderef);
  4002. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4003. begin
  4004. ppufile.putguid(iidguid^);
  4005. ppufile.putstring(iidstr^);
  4006. end;
  4007. if objecttype=odt_helper then
  4008. ppufile.putderef(extendeddefderef);
  4009. ppufile.putlongint(vmtentries.count);
  4010. for i:=0 to vmtentries.count-1 do
  4011. begin
  4012. vmtentry:=pvmtentry(vmtentries[i]);
  4013. ppufile.putderef(vmtentry^.procdefderef);
  4014. ppufile.putbyte(byte(vmtentry^.visibility));
  4015. end;
  4016. if assigned(ImplementedInterfaces) then
  4017. begin
  4018. ppufile.putlongint(ImplementedInterfaces.Count);
  4019. for i:=0 to ImplementedInterfaces.Count-1 do
  4020. begin
  4021. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  4022. ppufile.putderef(ImplIntf.intfdefderef);
  4023. ppufile.putlongint(ImplIntf.Ioffset);
  4024. end;
  4025. end;
  4026. if df_copied_def in defoptions then
  4027. ppufile.putderef(cloneddefderef);
  4028. ppufile.writeentry(ibobjectdef);
  4029. if not(df_copied_def in defoptions) then
  4030. tObjectSymtable(symtable).ppuwrite(ppufile);
  4031. ppufile.do_indirect_crc:=old_do_indirect_crc;
  4032. end;
  4033. function tobjectdef.GetTypeName:string;
  4034. begin
  4035. { in this case we will go in endless recursion, because then }
  4036. { there is no tsym associated yet with the def. It can occur }
  4037. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  4038. { instead of the actual type name }
  4039. if not assigned(typesym) then
  4040. result:='<Currently Parsed Class>'
  4041. else
  4042. result:=typename;
  4043. end;
  4044. procedure tobjectdef.buildderef;
  4045. var
  4046. i : longint;
  4047. vmtentry : pvmtentry;
  4048. begin
  4049. inherited buildderef;
  4050. childofderef.build(childof);
  4051. if df_copied_def in defoptions then
  4052. cloneddefderef.build(symtable.defowner)
  4053. else
  4054. tstoredsymtable(symtable).buildderef;
  4055. if objecttype=odt_helper then
  4056. extendeddefderef.build(extendeddef);
  4057. for i:=0 to vmtentries.count-1 do
  4058. begin
  4059. vmtentry:=pvmtentry(vmtentries[i]);
  4060. vmtentry^.procdefderef.build(vmtentry^.procdef);
  4061. end;
  4062. if assigned(ImplementedInterfaces) then
  4063. begin
  4064. for i:=0 to ImplementedInterfaces.count-1 do
  4065. TImplementedInterface(ImplementedInterfaces[i]).buildderef;
  4066. end;
  4067. end;
  4068. procedure tobjectdef.deref;
  4069. var
  4070. i : longint;
  4071. vmtentry : pvmtentry;
  4072. begin
  4073. inherited deref;
  4074. childof:=tobjectdef(childofderef.resolve);
  4075. if df_copied_def in defoptions then
  4076. begin
  4077. cloneddef:=tobjectdef(cloneddefderef.resolve);
  4078. symtable:=cloneddef.symtable.getcopy;
  4079. end
  4080. else
  4081. tstoredsymtable(symtable).deref;
  4082. if objecttype=odt_helper then
  4083. extendeddef:=tdef(extendeddefderef.resolve);
  4084. for i:=0 to vmtentries.count-1 do
  4085. begin
  4086. vmtentry:=pvmtentry(vmtentries[i]);
  4087. vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve);
  4088. end;
  4089. if assigned(ImplementedInterfaces) then
  4090. begin
  4091. for i:=0 to ImplementedInterfaces.count-1 do
  4092. TImplementedInterface(ImplementedInterfaces[i]).deref;
  4093. end;
  4094. end;
  4095. procedure create_class_helper_for_procdef(def: tobject; arg: pointer);
  4096. var
  4097. pd: tprocdef absolute def;
  4098. st: tsymtable;
  4099. psym: tsym;
  4100. nname: TIDString;
  4101. begin
  4102. if (tdef(def).typ<>procdef) then
  4103. exit;
  4104. { pd.owner = objcclass symtable -> defowner = objcclassdef ->
  4105. owner = symtable in which objcclassdef is defined
  4106. }
  4107. st:=pd.owner.defowner.owner;
  4108. nname:=class_helper_prefix+tprocsym(pd.procsym).name;
  4109. { check for an existing procsym with our special name }
  4110. psym:=tsym(st.find(nname));
  4111. if not assigned(psym) then
  4112. begin
  4113. psym:=tprocsym.create(nname);
  4114. { avoid warning about this symbol being unused }
  4115. psym.IncRefCount;
  4116. { don't check for duplicates:
  4117. a) we checked above
  4118. b) in case we are in the implementation section of a unit, this
  4119. will also check for this symbol in the interface section
  4120. (since you normally cannot have symbols with the same name
  4121. both interface and implementation), and it's possible to
  4122. have class helpers for the same class in the interface and
  4123. in the implementation, and they cannot be merged since only
  4124. the once in the interface must be saved to the ppu/visible
  4125. from other units }
  4126. st.insert(psym,false);
  4127. end
  4128. else if (psym.typ<>procsym) then
  4129. internalerror(2009111501);
  4130. { add ourselves to this special procsym }
  4131. tprocsym(psym).procdeflist.add(def);
  4132. end;
  4133. procedure tobjectdef.buildderefimpl;
  4134. begin
  4135. inherited buildderefimpl;
  4136. if not (df_copied_def in defoptions) then
  4137. tstoredsymtable(symtable).buildderefimpl;
  4138. end;
  4139. procedure tobjectdef.derefimpl;
  4140. begin
  4141. inherited derefimpl;
  4142. if not (df_copied_def in defoptions) then
  4143. tstoredsymtable(symtable).derefimpl;
  4144. { the procdefs are not owned by the class helper procsyms, so they
  4145. are not stored/restored either -> re-add them here }
  4146. if (objecttype=odt_objcclass) or
  4147. (oo_is_classhelper in objectoptions) then
  4148. symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
  4149. end;
  4150. procedure tobjectdef.resetvmtentries;
  4151. var
  4152. i : longint;
  4153. begin
  4154. for i:=0 to vmtentries.Count-1 do
  4155. Dispose(pvmtentry(vmtentries[i]));
  4156. vmtentries.clear;
  4157. end;
  4158. procedure tobjectdef.copyvmtentries(objdef:tobjectdef);
  4159. var
  4160. i : longint;
  4161. vmtentry : pvmtentry;
  4162. begin
  4163. resetvmtentries;
  4164. vmtentries.count:=objdef.vmtentries.count;
  4165. for i:=0 to objdef.vmtentries.count-1 do
  4166. begin
  4167. new(vmtentry);
  4168. vmtentry^:=pvmtentry(objdef.vmtentries[i])^;
  4169. vmtentries[i]:=vmtentry;
  4170. end;
  4171. end;
  4172. function tobjectdef.getparentdef:tdef;
  4173. begin
  4174. { TODO: Remove getparentdef hack}
  4175. { With 2 forward declared classes with the child class before the
  4176. parent class the child class is written earlier to the ppu. Leaving it
  4177. possible to have a reference to the parent class for property overriding,
  4178. but the parent class still has the childof not resolved yet (PFV) }
  4179. if childof=nil then
  4180. childof:=tobjectdef(childofderef.resolve);
  4181. result:=childof;
  4182. end;
  4183. procedure tobjectdef.prepareguid;
  4184. begin
  4185. { set up guid }
  4186. if not assigned(iidguid) then
  4187. begin
  4188. new(iidguid);
  4189. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  4190. end;
  4191. { setup iidstring }
  4192. if not assigned(iidstr) then
  4193. iidstr:=stringdup(''); { default is empty string }
  4194. end;
  4195. procedure tobjectdef.set_parent( c : tobjectdef);
  4196. begin
  4197. if assigned(childof) then
  4198. exit;
  4199. childof:=c;
  4200. if not assigned(c) then
  4201. exit;
  4202. { inherit options and status }
  4203. objectoptions:=objectoptions+(c.objectoptions*inherited_objectoptions);
  4204. { add the data of the anchestor class/object }
  4205. if (objecttype in [odt_class,odt_object,odt_objcclass]) then
  4206. begin
  4207. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize+tObjectSymtable(c.symtable).datasize;
  4208. { inherit recordalignment }
  4209. tObjectSymtable(symtable).recordalignment:=tObjectSymtable(c.symtable).recordalignment;
  4210. { if both the parent and this record use C-alignment, also inherit
  4211. the current field alignment }
  4212. if (tObjectSymtable(c.symtable).usefieldalignment=C_alignment) and
  4213. (tObjectSymtable(symtable).usefieldalignment=C_alignment) then
  4214. tObjectSymtable(symtable).fieldalignment:=tObjectSymtable(c.symtable).fieldalignment;
  4215. { the padding is not inherited for Objective-C classes (maybe not
  4216. for cppclass either?) }
  4217. if objecttype=odt_objcclass then
  4218. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-tObjectSymtable(c.symtable).paddingsize;
  4219. if (oo_has_vmt in objectoptions) and
  4220. (oo_has_vmt in c.objectoptions) then
  4221. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-sizeof(pint);
  4222. { if parent has a vmt field then the offset is the same for the child PM }
  4223. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  4224. begin
  4225. vmt_offset:=c.vmt_offset;
  4226. include(objectoptions,oo_has_vmt);
  4227. end;
  4228. end;
  4229. end;
  4230. procedure tobjectdef.insertvmt;
  4231. var
  4232. vs: tfieldvarsym;
  4233. begin
  4234. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol] then
  4235. exit;
  4236. if (oo_has_vmt in objectoptions) then
  4237. internalerror(12345)
  4238. else
  4239. begin
  4240. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,
  4241. tObjectSymtable(symtable).fieldalignment);
  4242. if (tf_requires_proper_alignment in target_info.flags) then
  4243. begin
  4244. { Align VMT pointer and whole object instance if target CPU requires alignment. }
  4245. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(pint));
  4246. tObjectSymtable(symtable).alignrecord(tObjectSymtable(symtable).datasize,sizeof(pint));
  4247. end;
  4248. vs:=tfieldvarsym.create('_vptr$'+objname^,vs_value,voidpointertype,[]);
  4249. hidesym(vs);
  4250. tObjectSymtable(symtable).insert(vs);
  4251. tObjectSymtable(symtable).addfield(vs,vis_hidden);
  4252. if (tObjectSymtable(symtable).usefieldalignment<>bit_alignment) then
  4253. vmt_offset:=vs.fieldoffset
  4254. else
  4255. vmt_offset:=vs.fieldoffset div 8;
  4256. include(objectoptions,oo_has_vmt);
  4257. end;
  4258. end;
  4259. procedure tobjectdef.check_forwards;
  4260. begin
  4261. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol]) then
  4262. inherited;
  4263. if (oo_is_forward in objectoptions) then
  4264. begin
  4265. { ok, in future, the forward can be resolved }
  4266. Message1(sym_e_class_forward_not_resolved,objrealname^);
  4267. exclude(objectoptions,oo_is_forward);
  4268. end;
  4269. end;
  4270. { true if prot implements d (or if they are equal) }
  4271. function is_related_protocol(prot: tobjectdef; d : tdef) : boolean;
  4272. var
  4273. i : longint;
  4274. begin
  4275. { objcprotocols have multiple inheritance, all protocols from which
  4276. the current protocol inherits are stored in implementedinterfaces }
  4277. result:=prot=d;
  4278. if result then
  4279. exit;
  4280. for i:=0 to prot.ImplementedInterfaces.count-1 do
  4281. begin
  4282. result:=is_related_protocol(TImplementedInterface(prot.ImplementedInterfaces[i]).intfdef,d);
  4283. if result then
  4284. exit;
  4285. end;
  4286. end;
  4287. { true, if self inherits from d (or if they are equal) }
  4288. function tobjectdef.is_related(d : tdef) : boolean;
  4289. var
  4290. hp : tobjectdef;
  4291. begin
  4292. if self=d then
  4293. begin
  4294. is_related:=true;
  4295. exit;
  4296. end;
  4297. if (d.typ<>objectdef) then
  4298. begin
  4299. is_related:=false;
  4300. exit;
  4301. end;
  4302. { Objective-C protocols can use multiple inheritance }
  4303. if (objecttype=odt_objcprotocol) then
  4304. begin
  4305. is_related:=is_related_protocol(self,d);
  4306. exit
  4307. end;
  4308. { formally declared Objective-C classes match Objective-C classes with
  4309. the same name }
  4310. if (objecttype=odt_objcclass) and
  4311. (tobjectdef(d).objecttype=odt_objcclass) and
  4312. ((oo_is_formal in objectoptions) or
  4313. (oo_is_formal in tobjectdef(d).objectoptions)) and
  4314. (objrealname^=tobjectdef(d).objrealname^) then
  4315. begin
  4316. is_related:=true;
  4317. exit;
  4318. end;
  4319. hp:=childof;
  4320. while assigned(hp) do
  4321. begin
  4322. if hp=d then
  4323. begin
  4324. is_related:=true;
  4325. exit;
  4326. end;
  4327. hp:=hp.childof;
  4328. end;
  4329. is_related:=false;
  4330. end;
  4331. function tobjectdef.find_destructor: tprocdef;
  4332. var
  4333. objdef: tobjectdef;
  4334. begin
  4335. objdef:=self;
  4336. while assigned(objdef) do
  4337. begin
  4338. result:=objdef.find_procdef_bytype(potype_destructor);
  4339. if assigned(result) then
  4340. exit;
  4341. objdef:=objdef.childof;
  4342. end;
  4343. result:=nil;
  4344. end;
  4345. function tobjectdef.implements_any_interfaces: boolean;
  4346. begin
  4347. result := (ImplementedInterfaces.Count > 0) or
  4348. (assigned(childof) and childof.implements_any_interfaces);
  4349. end;
  4350. function tobjectdef.size : asizeint;
  4351. begin
  4352. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper] then
  4353. result:=sizeof(pint)
  4354. else
  4355. result:=tObjectSymtable(symtable).datasize;
  4356. end;
  4357. function tobjectdef.alignment:shortint;
  4358. begin
  4359. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper] then
  4360. alignment:=sizeof(pint)
  4361. else
  4362. alignment:=tObjectSymtable(symtable).recordalignment;
  4363. end;
  4364. function tobjectdef.vmtmethodoffset(index:longint):longint;
  4365. begin
  4366. { for offset of methods for classes, see rtl/inc/objpash.inc }
  4367. case objecttype of
  4368. odt_class:
  4369. { the +2*sizeof(pint) is size and -size }
  4370. vmtmethodoffset:=(index+10)*sizeof(pint)+2*sizeof(pint);
  4371. odt_helper,
  4372. odt_objcclass,
  4373. odt_objcprotocol:
  4374. vmtmethodoffset:=0;
  4375. odt_interfacecom,odt_interfacecorba,odt_dispinterface:
  4376. vmtmethodoffset:=index*sizeof(pint);
  4377. else
  4378. {$ifdef WITHDMT}
  4379. vmtmethodoffset:=(index+4)*sizeof(pint);
  4380. {$else WITHDMT}
  4381. vmtmethodoffset:=(index+3)*sizeof(pint);
  4382. {$endif WITHDMT}
  4383. end;
  4384. end;
  4385. function tobjectdef.vmt_mangledname : string;
  4386. begin
  4387. if not(oo_has_vmt in objectoptions) then
  4388. Message1(parser_n_object_has_no_vmt,objrealname^);
  4389. vmt_mangledname:=make_mangledname('VMT',owner,objname^);
  4390. end;
  4391. function tobjectdef.needs_inittable : boolean;
  4392. begin
  4393. case objecttype of
  4394. odt_helper,
  4395. odt_class :
  4396. needs_inittable:=false;
  4397. odt_dispinterface,
  4398. odt_interfacecom:
  4399. needs_inittable:=true;
  4400. odt_interfacecorba:
  4401. needs_inittable:=is_related(interface_iunknown);
  4402. odt_object:
  4403. needs_inittable:=tObjectSymtable(symtable).needs_init_final;
  4404. odt_cppclass,
  4405. odt_objcclass,
  4406. odt_objcprotocol:
  4407. needs_inittable:=false;
  4408. else
  4409. internalerror(200108267);
  4410. end;
  4411. end;
  4412. function tobjectdef.rtti_mangledname(rt: trttitype): string;
  4413. begin
  4414. if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
  4415. result:=inherited rtti_mangledname(rt)
  4416. else
  4417. begin
  4418. { necessary in case of a dynamic array of nsobject, or
  4419. if an nsobject field appears in a record that needs
  4420. init/finalisation }
  4421. if rt=initrtti then
  4422. begin
  4423. result:=voidpointertype.rtti_mangledname(rt);
  4424. exit;
  4425. end;
  4426. if not(target_info.system in systems_objc_nfabi) then
  4427. begin
  4428. result:=target_asm.labelprefix;
  4429. case objecttype of
  4430. odt_objcclass:
  4431. begin
  4432. case rt of
  4433. objcclassrtti:
  4434. if not(oo_is_classhelper in objectoptions) then
  4435. result:=result+'_OBJC_CLASS_'
  4436. else
  4437. result:=result+'_OBJC_CATEGORY_';
  4438. objcmetartti:
  4439. if not(oo_is_classhelper in objectoptions) then
  4440. result:=result+'_OBJC_METACLASS_'
  4441. else
  4442. internalerror(2009111511);
  4443. else
  4444. internalerror(2009092302);
  4445. end;
  4446. end;
  4447. odt_objcprotocol:
  4448. result:=result+'_OBJC_PROTOCOL_';
  4449. end;
  4450. end
  4451. else
  4452. begin
  4453. case objecttype of
  4454. odt_objcclass:
  4455. begin
  4456. if (oo_is_classhelper in objectoptions) and
  4457. (rt<>objcclassrtti) then
  4458. internalerror(2009111512);
  4459. case rt of
  4460. objcclassrtti:
  4461. if not(oo_is_classhelper in objectoptions) then
  4462. result:='_OBJC_CLASS_$_'
  4463. else
  4464. result:='_OBJC_$_CATEGORY_';
  4465. objcmetartti:
  4466. result:='_OBJC_METACLASS_$_';
  4467. objcclassrortti:
  4468. result:=lower(target_asm.labelprefix)+'_OBJC_CLASS_RO_$_';
  4469. objcmetarortti:
  4470. result:=lower(target_asm.labelprefix)+'_OBJC_METACLASS_RO_$_';
  4471. else
  4472. internalerror(2009092303);
  4473. end;
  4474. end;
  4475. odt_objcprotocol:
  4476. begin
  4477. result:=lower(target_asm.labelprefix);
  4478. case rt of
  4479. objcclassrtti:
  4480. result:=result+'_OBJC_PROTOCOL_$_';
  4481. objcmetartti:
  4482. result:=result+'_OBJC_LABEL_PROTOCOL_$_';
  4483. else
  4484. internalerror(2009092501);
  4485. end;
  4486. end;
  4487. end;
  4488. end;
  4489. result:=result+objextname^;
  4490. end;
  4491. end;
  4492. function tobjectdef.members_need_inittable : boolean;
  4493. begin
  4494. members_need_inittable:=tObjectSymtable(symtable).needs_init_final;
  4495. end;
  4496. function tobjectdef.find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  4497. var
  4498. ImplIntf : TImplementedInterface;
  4499. i : longint;
  4500. begin
  4501. result:=nil;
  4502. if not assigned(ImplementedInterfaces) then
  4503. exit;
  4504. for i:=0 to ImplementedInterfaces.Count-1 do
  4505. begin
  4506. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  4507. if ImplIntf.intfdef=aintfdef then
  4508. begin
  4509. result:=ImplIntf;
  4510. exit;
  4511. end;
  4512. end;
  4513. end;
  4514. function tobjectdef.is_publishable : boolean;
  4515. begin
  4516. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface];
  4517. end;
  4518. function tobjectdef.get_next_dispid: longint;
  4519. begin
  4520. inc(fcurrent_dispid);
  4521. result:=fcurrent_dispid;
  4522. end;
  4523. function tobjectdef.search_enumerator_get: tprocdef;
  4524. begin
  4525. result:=inherited;
  4526. if not assigned(result) and assigned(childof) then
  4527. result:=childof.search_enumerator_get;
  4528. end;
  4529. function tobjectdef.search_enumerator_move: tprocdef;
  4530. begin
  4531. result:=inherited;
  4532. if not assigned(result) and assigned(childof) then
  4533. result:=childof.search_enumerator_move;
  4534. end;
  4535. function tobjectdef.search_enumerator_current: tsym;
  4536. begin
  4537. result:=inherited;
  4538. if not assigned(result) and assigned(childof) then
  4539. result:=childof.search_enumerator_current;
  4540. end;
  4541. procedure tobjectdef.register_created_classref_type;
  4542. begin
  4543. if not classref_created_in_current_module then
  4544. begin
  4545. classref_created_in_current_module:=true;
  4546. current_module.wpoinfo.addcreatedobjtypeforclassref(self);
  4547. end;
  4548. end;
  4549. procedure tobjectdef.register_created_object_type;
  4550. begin
  4551. if not created_in_current_module then
  4552. begin
  4553. created_in_current_module:=true;
  4554. current_module.wpoinfo.addcreatedobjtype(self);
  4555. end;
  4556. end;
  4557. procedure tobjectdef.register_maybe_created_object_type;
  4558. begin
  4559. { if we know it has been created for sure, no need
  4560. to also record that it maybe can be created in
  4561. this module
  4562. }
  4563. if not (created_in_current_module) and
  4564. not (maybe_created_in_current_module) then
  4565. begin
  4566. maybe_created_in_current_module:=true;
  4567. current_module.wpoinfo.addmaybecreatedbyclassref(self);
  4568. end;
  4569. end;
  4570. procedure tobjectdef.register_vmt_call(index: longint);
  4571. begin
  4572. if (is_object(self) or is_class(self)) then
  4573. current_module.wpoinfo.addcalledvmtentry(self,index);
  4574. end;
  4575. procedure check_and_finish_msg(data: tobject; arg: pointer);
  4576. var
  4577. def: tdef absolute data;
  4578. pd: tprocdef absolute data;
  4579. i,
  4580. paracount: longint;
  4581. begin
  4582. if (def.typ=procdef) then
  4583. begin
  4584. { add all messages also under a dummy name to the symtable in
  4585. which the objcclass/protocol/category is declared, so they can
  4586. be called via id.<name>
  4587. }
  4588. create_class_helper_for_procdef(pd,nil);
  4589. { we have to wait until now to set the mangled name because it
  4590. depends on the (possibly external) class name, which is defined
  4591. at the very end. }
  4592. if not(po_msgstr in pd.procoptions) then
  4593. begin
  4594. CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
  4595. { recover to avoid internalerror later on }
  4596. include(pd.procoptions,po_msgstr);
  4597. pd.messageinf.str:=stringdup('MissingDeclaration');
  4598. end;
  4599. { Mangled name is already set in case this is a copy of
  4600. another type. }
  4601. if not(po_has_mangledname in pd.procoptions) then
  4602. begin
  4603. { check whether the number of formal parameters is correct,
  4604. and whether they have valid Objective-C types }
  4605. paracount:=0;
  4606. for i:=1 to length(pd.messageinf.str^) do
  4607. if pd.messageinf.str^[i]=':' then
  4608. inc(paracount);
  4609. for i:=0 to pd.paras.count-1 do
  4610. if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
  4611. not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
  4612. dec(paracount);
  4613. if (paracount<>0) then
  4614. MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
  4615. pd.setmangledname(pd.objcmangledname);
  4616. end
  4617. else
  4618. { all checks already done }
  4619. exit;
  4620. if not(oo_is_external in pd.struct.objectoptions) then
  4621. begin
  4622. if (po_varargs in pd.procoptions) then
  4623. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external)
  4624. else
  4625. begin
  4626. { check for "array of const" parameters }
  4627. for i:=0 to pd.parast.symlist.count-1 do
  4628. begin
  4629. if (tsym(pd.parast.symlist[i]).typ=paravarsym) and
  4630. is_array_of_const(tparavarsym(pd.parast.symlist[i]).vardef) then
  4631. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external);
  4632. end;
  4633. end;
  4634. end;
  4635. end;
  4636. end;
  4637. procedure mark_private_fields_used(data: tobject; arg: pointer);
  4638. var
  4639. sym: tsym absolute data;
  4640. begin
  4641. if (sym.typ=fieldvarsym) and
  4642. (tfieldvarsym(sym).visibility in [vis_private,vis_strictprivate]) then
  4643. sym.IncRefCount;
  4644. end;
  4645. procedure tobjectdef.finish_objc_data;
  4646. begin
  4647. self.symtable.DefList.foreachcall(@check_and_finish_msg,nil);
  4648. if (oo_is_external in objectoptions) then
  4649. self.symtable.SymList.ForEachCall(@mark_private_fields_used,nil);
  4650. end;
  4651. procedure verify_objc_vardef(data: tobject; arg: pointer);
  4652. var
  4653. sym: tabstractvarsym absolute data;
  4654. res: pboolean absolute arg;
  4655. founderrordef: tdef;
  4656. begin
  4657. if not(tsym(data).typ in [paravarsym,fieldvarsym]) then
  4658. exit;
  4659. if (sym.typ=paravarsym) and
  4660. ((vo_is_hidden_para in tparavarsym(sym).varoptions) or
  4661. is_array_of_const(tparavarsym(sym).vardef)) then
  4662. exit;
  4663. if not objcchecktype(sym.vardef,founderrordef) then
  4664. begin
  4665. MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  4666. res^:=false;
  4667. end;
  4668. end;
  4669. procedure verify_objc_procdef_paras(data: tobject; arg: pointer);
  4670. var
  4671. def: tdef absolute data;
  4672. res: pboolean absolute arg;
  4673. founderrordef: tdef;
  4674. begin
  4675. if (def.typ<>procdef) then
  4676. exit;
  4677. { check parameter types for validity }
  4678. tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg);
  4679. { check the result type for validity }
  4680. if not objcchecktype(tprocdef(def).returndef,founderrordef) then
  4681. begin
  4682. MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  4683. res^:=false;
  4684. end;
  4685. end;
  4686. function tobjectdef.check_objc_types: boolean;
  4687. begin
  4688. { done in separate step from finish_objc_data, because when
  4689. finish_objc_data is called, not all forwarddefs have been resolved
  4690. yet and we need to know all types here }
  4691. result:=true;
  4692. self.symtable.symlist.foreachcall(@verify_objc_vardef,@result);
  4693. self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result);
  4694. end;
  4695. procedure do_cpp_import_info(data: tobject; arg: pointer);
  4696. var
  4697. def: tdef absolute data;
  4698. pd: tprocdef absolute data;
  4699. begin
  4700. if (def.typ=procdef) then
  4701. begin
  4702. pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
  4703. if (oo_is_external in pd.struct.objectoptions) then
  4704. begin
  4705. { copied from psub.read_proc }
  4706. if assigned(tobjectdef(pd.struct).import_lib) then
  4707. current_module.AddExternalImport(tobjectdef(pd.struct).import_lib^,pd.mangledname,pd.mangledname,0,false,false)
  4708. else
  4709. begin
  4710. { add import name to external list for DLL scanning }
  4711. if tf_has_dllscanner in target_info.flags then
  4712. current_module.dllscannerinputlist.Add(pd.mangledname,pd);
  4713. end;
  4714. end;
  4715. end;
  4716. end;
  4717. procedure tobjectdef.finish_cpp_data;
  4718. begin
  4719. self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
  4720. end;
  4721. {****************************************************************************
  4722. TImplementedInterface
  4723. ****************************************************************************}
  4724. constructor TImplementedInterface.create(aintf: tobjectdef);
  4725. begin
  4726. inherited create;
  4727. intfdef:=aintf;
  4728. IOffset:=-1;
  4729. IType:=etStandard;
  4730. NameMappings:=nil;
  4731. procdefs:=nil;
  4732. end;
  4733. constructor TImplementedInterface.create_deref(d:tderef);
  4734. begin
  4735. inherited create;
  4736. intfdef:=nil;
  4737. intfdefderef:=d;
  4738. IOffset:=-1;
  4739. IType:=etStandard;
  4740. NameMappings:=nil;
  4741. procdefs:=nil;
  4742. end;
  4743. destructor TImplementedInterface.destroy;
  4744. var
  4745. i : longint;
  4746. mappedname : pshortstring;
  4747. begin
  4748. if assigned(NameMappings) then
  4749. begin
  4750. for i:=0 to NameMappings.Count-1 do
  4751. begin
  4752. mappedname:=pshortstring(NameMappings[i]);
  4753. stringdispose(mappedname);
  4754. end;
  4755. NameMappings.free;
  4756. NameMappings:=nil;
  4757. end;
  4758. if assigned(procdefs) then
  4759. begin
  4760. procdefs.free;
  4761. procdefs:=nil;
  4762. end;
  4763. inherited destroy;
  4764. end;
  4765. procedure TImplementedInterface.buildderef;
  4766. begin
  4767. intfdefderef.build(intfdef);
  4768. end;
  4769. procedure TImplementedInterface.deref;
  4770. begin
  4771. intfdef:=tobjectdef(intfdefderef.resolve);
  4772. end;
  4773. procedure TImplementedInterface.AddMapping(const origname,newname: string);
  4774. begin
  4775. if not assigned(NameMappings) then
  4776. NameMappings:=TFPHashList.Create;
  4777. NameMappings.Add(origname,stringdup(newname));
  4778. end;
  4779. function TImplementedInterface.GetMapping(const origname: string):string;
  4780. var
  4781. mappedname : pshortstring;
  4782. begin
  4783. result:='';
  4784. if not assigned(NameMappings) then
  4785. exit;
  4786. mappedname:=PShortstring(NameMappings.Find(origname));
  4787. if assigned(mappedname) then
  4788. result:=mappedname^;
  4789. end;
  4790. procedure TImplementedInterface.AddImplProc(pd:tprocdef);
  4791. begin
  4792. if not assigned(procdefs) then
  4793. procdefs:=TFPObjectList.Create(false);
  4794. { duplicate entries must be stored, because multiple }
  4795. { interfaces can declare methods with the same name }
  4796. { and all of these get their own VMT entry }
  4797. procdefs.Add(pd);
  4798. end;
  4799. function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  4800. var
  4801. i : longint;
  4802. begin
  4803. result:=false;
  4804. { interfaces being implemented through delegation are not mergable (FK) }
  4805. if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) or not(assigned(MergingIntf.ProcDefs)) then
  4806. exit;
  4807. weight:=0;
  4808. { empty interface is mergeable }
  4809. if ProcDefs.Count=0 then
  4810. begin
  4811. result:=true;
  4812. exit;
  4813. end;
  4814. { The interface to merge must at least the number of
  4815. procedures of this interface }
  4816. if MergingIntf.ProcDefs.Count<ProcDefs.Count then
  4817. exit;
  4818. for i:=0 to ProcDefs.Count-1 do
  4819. begin
  4820. if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
  4821. exit;
  4822. end;
  4823. weight:=ProcDefs.Count;
  4824. result:=true;
  4825. end;
  4826. function TImplementedInterface.getcopy:TImplementedInterface;
  4827. begin
  4828. Result:=TImplementedInterface.Create(nil);
  4829. { 1) the procdefs list will be freed once for each copy
  4830. 2) since the procdefs list owns its elements, those will also be freed for each copy
  4831. 3) idem for the name mappings
  4832. }
  4833. { warning: this is completely wrong on so many levels...
  4834. Move(pointer(self)^,pointer(result)^,InstanceSize);
  4835. We need to make clean copies of the different fields
  4836. this is not implemented yet, and thus we generate an internal
  4837. error instead PM 2011-06-14 }
  4838. internalerror(2011061401);
  4839. end;
  4840. {****************************************************************************
  4841. TFORWARDDEF
  4842. ****************************************************************************}
  4843. constructor tforwarddef.create(const s:string;const pos:tfileposinfo);
  4844. begin
  4845. inherited create(forwarddef);
  4846. tosymname:=stringdup(s);
  4847. forwardpos:=pos;
  4848. end;
  4849. function tforwarddef.GetTypeName:string;
  4850. begin
  4851. GetTypeName:='unresolved forward to '+tosymname^;
  4852. end;
  4853. destructor tforwarddef.destroy;
  4854. begin
  4855. stringdispose(tosymname);
  4856. inherited destroy;
  4857. end;
  4858. function tforwarddef.getcopy:tstoreddef;
  4859. begin
  4860. result:=tforwarddef.create(tosymname^, forwardpos);
  4861. end;
  4862. {****************************************************************************
  4863. TUNDEFINEDDEF
  4864. ****************************************************************************}
  4865. constructor tundefineddef.create;
  4866. begin
  4867. inherited create(undefineddef);
  4868. end;
  4869. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  4870. begin
  4871. inherited ppuload(undefineddef,ppufile);
  4872. end;
  4873. function tundefineddef.GetTypeName:string;
  4874. begin
  4875. GetTypeName:='<undefined type>';
  4876. end;
  4877. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  4878. begin
  4879. inherited ppuwrite(ppufile);
  4880. ppufile.writeentry(ibundefineddef);
  4881. end;
  4882. {****************************************************************************
  4883. TERRORDEF
  4884. ****************************************************************************}
  4885. constructor terrordef.create;
  4886. begin
  4887. inherited create(errordef);
  4888. { prevent consecutive faults }
  4889. savesize:=1;
  4890. end;
  4891. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  4892. begin
  4893. { Can't write errordefs to ppu }
  4894. internalerror(200411063);
  4895. end;
  4896. function terrordef.GetTypeName:string;
  4897. begin
  4898. GetTypeName:='<erroneous type>';
  4899. end;
  4900. function terrordef.getmangledparaname:string;
  4901. begin
  4902. getmangledparaname:='error';
  4903. end;
  4904. {****************************************************************************
  4905. Definition Helpers
  4906. ****************************************************************************}
  4907. function is_interfacecom(def: tdef): boolean;
  4908. begin
  4909. is_interfacecom:=
  4910. assigned(def) and
  4911. (def.typ=objectdef) and
  4912. (tobjectdef(def).objecttype=odt_interfacecom);
  4913. end;
  4914. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  4915. begin
  4916. is_interfacecom_or_dispinterface:=
  4917. assigned(def) and
  4918. (def.typ=objectdef) and
  4919. (tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface]);
  4920. end;
  4921. function is_interfacecorba(def: tdef): boolean;
  4922. begin
  4923. is_interfacecorba:=
  4924. assigned(def) and
  4925. (def.typ=objectdef) and
  4926. (tobjectdef(def).objecttype=odt_interfacecorba);
  4927. end;
  4928. function is_interface(def: tdef): boolean;
  4929. begin
  4930. is_interface:=
  4931. assigned(def) and
  4932. (def.typ=objectdef) and
  4933. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  4934. end;
  4935. function is_dispinterface(def: tdef): boolean;
  4936. begin
  4937. result:=
  4938. assigned(def) and
  4939. (def.typ=objectdef) and
  4940. (tobjectdef(def).objecttype=odt_dispinterface);
  4941. end;
  4942. function is_class(def: tdef): boolean;
  4943. begin
  4944. is_class:=
  4945. assigned(def) and
  4946. (def.typ=objectdef) and
  4947. (tobjectdef(def).objecttype=odt_class);
  4948. end;
  4949. function is_object(def: tdef): boolean;
  4950. begin
  4951. is_object:=
  4952. assigned(def) and
  4953. (def.typ=objectdef) and
  4954. (tobjectdef(def).objecttype=odt_object);
  4955. end;
  4956. function is_cppclass(def: tdef): boolean;
  4957. begin
  4958. is_cppclass:=
  4959. assigned(def) and
  4960. (def.typ=objectdef) and
  4961. (tobjectdef(def).objecttype=odt_cppclass);
  4962. end;
  4963. function is_objcclass(def: tdef): boolean;
  4964. begin
  4965. is_objcclass:=
  4966. assigned(def) and
  4967. (def.typ=objectdef) and
  4968. (tobjectdef(def).objecttype=odt_objcclass);
  4969. end;
  4970. function is_objectpascal_helper(def: tdef): boolean;
  4971. begin
  4972. result:=
  4973. assigned(def) and
  4974. (def.typ=objectdef) and
  4975. (tobjectdef(def).objecttype=odt_helper);
  4976. end;
  4977. function is_objcclassref(def: tdef): boolean;
  4978. begin
  4979. is_objcclassref:=
  4980. assigned(def) and
  4981. (def.typ=classrefdef) and
  4982. is_objcclass(tclassrefdef(def).pointeddef);
  4983. end;
  4984. function is_objcprotocol(def: tdef): boolean;
  4985. begin
  4986. result:=
  4987. assigned(def) and
  4988. (def.typ=objectdef) and
  4989. (tobjectdef(def).objecttype=odt_objcprotocol);
  4990. end;
  4991. function is_objccategory(def: tdef): boolean;
  4992. begin
  4993. result:=
  4994. assigned(def) and
  4995. (def.typ=objectdef) and
  4996. { if used as a forward type }
  4997. ((tobjectdef(def).objecttype=odt_objccategory) or
  4998. { if used as after it has been resolved }
  4999. ((tobjectdef(def).objecttype=odt_objcclass) and
  5000. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5001. end;
  5002. function is_objc_class_or_protocol(def: tdef): boolean;
  5003. begin
  5004. result:=
  5005. assigned(def) and
  5006. (def.typ=objectdef) and
  5007. (tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]);
  5008. end;
  5009. function is_objc_protocol_or_category(def: tdef): boolean;
  5010. begin
  5011. result:=
  5012. assigned(def) and
  5013. (def.typ=objectdef) and
  5014. ((tobjectdef(def).objecttype = odt_objcprotocol) or
  5015. ((tobjectdef(def).objecttype = odt_objcclass) and
  5016. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5017. end;
  5018. function is_classhelper(def: tdef): boolean;
  5019. begin
  5020. result:=
  5021. is_objectpascal_helper(def) or
  5022. is_objccategory(def);
  5023. end;
  5024. function is_class_or_interface(def: tdef): boolean;
  5025. begin
  5026. result:=
  5027. assigned(def) and
  5028. (def.typ=objectdef) and
  5029. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  5030. end;
  5031. function is_class_or_interface_or_objc(def: tdef): boolean;
  5032. begin
  5033. result:=
  5034. assigned(def) and
  5035. (def.typ=objectdef) and
  5036. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]);
  5037. end;
  5038. function is_class_or_interface_or_object(def: tdef): boolean;
  5039. begin
  5040. result:=
  5041. assigned(def) and
  5042. (def.typ=objectdef) and
  5043. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_object]);
  5044. end;
  5045. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  5046. begin
  5047. result:=
  5048. assigned(def) and
  5049. (def.typ=objectdef) and
  5050. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  5051. end;
  5052. function is_implicit_pointer_object_type(def: tdef): boolean;
  5053. begin
  5054. result:=
  5055. assigned(def) and
  5056. (def.typ=objectdef) and
  5057. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper]);
  5058. end;
  5059. function is_class_or_object(def: tdef): boolean;
  5060. begin
  5061. result:=
  5062. assigned(def) and
  5063. (def.typ=objectdef) and
  5064. (tobjectdef(def).objecttype in [odt_class,odt_object]);
  5065. end;
  5066. function is_record(def: tdef): boolean;
  5067. begin
  5068. result:=
  5069. assigned(def) and
  5070. (def.typ=recorddef);
  5071. end;
  5072. procedure loadobjctypes;
  5073. begin
  5074. objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_CLASS',true).typedef);
  5075. objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER',true).typedef);
  5076. objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID',true).typedef);
  5077. objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL',true).typedef);
  5078. objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT',true).typedef);
  5079. end;
  5080. procedure maybeloadcocoatypes;
  5081. var
  5082. tsym: ttypesym;
  5083. begin
  5084. if assigned(objc_fastenumeration) then
  5085. exit;
  5086. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONPROTOCOL',false);
  5087. if assigned(tsym) then
  5088. objc_fastenumeration:=tobjectdef(tsym.typedef)
  5089. else
  5090. objc_fastenumeration:=nil;
  5091. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONSTATE',false);
  5092. if assigned(tsym) then
  5093. objc_fastenumerationstate:=trecorddef(tsym.typedef)
  5094. else
  5095. objc_fastenumerationstate:=nil;
  5096. end;
  5097. function use_vectorfpu(def : tdef) : boolean;
  5098. begin
  5099. {$ifdef x86}
  5100. {$define use_vectorfpuimplemented}
  5101. use_vectorfpu:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  5102. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  5103. {$endif x86}
  5104. {$ifdef arm}
  5105. {$define use_vectorfpuimplemented}
  5106. use_vectorfpu:=(current_settings.fputype in vfp_scalar);
  5107. {$endif arm}
  5108. {$ifndef use_vectorfpuimplemented}
  5109. use_vectorfpu:=false;
  5110. {$endif}
  5111. end;
  5112. end.