symdef.pas 190 KB

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