symdef.pas 194 KB

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