symdef.pas 306 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349635063516352635363546355635663576358635963606361636263636364636563666367636863696370637163726373637463756376637763786379638063816382638363846385638663876388638963906391639263936394639563966397639863996400640164026403640464056406640764086409641064116412641364146415641664176418641964206421642264236424642564266427642864296430643164326433643464356436643764386439644064416442644364446445644664476448644964506451645264536454645564566457645864596460646164626463646464656466646764686469647064716472647364746475647664776478647964806481648264836484648564866487648864896490649164926493649464956496649764986499650065016502650365046505650665076508650965106511651265136514651565166517651865196520652165226523652465256526652765286529653065316532653365346535653665376538653965406541654265436544654565466547654865496550655165526553655465556556655765586559656065616562656365646565656665676568656965706571657265736574657565766577657865796580658165826583658465856586658765886589659065916592659365946595659665976598659966006601660266036604660566066607660866096610661166126613661466156616661766186619662066216622662366246625662666276628662966306631663266336634663566366637663866396640664166426643664466456646664766486649665066516652665366546655665666576658665966606661666266636664666566666667666866696670667166726673667466756676667766786679668066816682668366846685668666876688668966906691669266936694669566966697669866996700670167026703670467056706670767086709671067116712671367146715671667176718671967206721672267236724672567266727672867296730673167326733673467356736673767386739674067416742674367446745674667476748674967506751675267536754675567566757675867596760676167626763676467656766676767686769677067716772677367746775677667776778677967806781678267836784678567866787678867896790679167926793679467956796679767986799680068016802680368046805680668076808680968106811681268136814681568166817681868196820682168226823682468256826682768286829683068316832683368346835683668376838683968406841684268436844684568466847684868496850685168526853685468556856685768586859686068616862686368646865686668676868686968706871687268736874687568766877687868796880688168826883688468856886688768886889689068916892689368946895689668976898689969006901690269036904690569066907690869096910691169126913691469156916691769186919692069216922692369246925692669276928692969306931693269336934693569366937693869396940694169426943694469456946694769486949695069516952695369546955695669576958695969606961696269636964696569666967696869696970697169726973697469756976697769786979698069816982698369846985698669876988698969906991699269936994699569966997699869997000700170027003700470057006700770087009701070117012701370147015701670177018701970207021702270237024702570267027702870297030703170327033703470357036703770387039704070417042704370447045704670477048704970507051705270537054705570567057705870597060706170627063706470657066706770687069707070717072707370747075707670777078707970807081708270837084708570867087708870897090709170927093709470957096709770987099710071017102710371047105710671077108710971107111711271137114711571167117711871197120712171227123712471257126712771287129713071317132713371347135713671377138713971407141714271437144714571467147714871497150715171527153715471557156715771587159716071617162716371647165716671677168716971707171717271737174717571767177717871797180718171827183718471857186718771887189719071917192719371947195719671977198719972007201720272037204720572067207720872097210721172127213721472157216721772187219722072217222722372247225722672277228722972307231723272337234723572367237723872397240724172427243724472457246724772487249725072517252725372547255725672577258725972607261726272637264726572667267726872697270727172727273727472757276727772787279728072817282728372847285728672877288728972907291729272937294729572967297729872997300730173027303730473057306730773087309731073117312731373147315731673177318731973207321732273237324732573267327732873297330733173327333733473357336733773387339734073417342734373447345734673477348734973507351735273537354735573567357735873597360736173627363736473657366736773687369737073717372737373747375737673777378737973807381738273837384738573867387738873897390739173927393739473957396739773987399740074017402740374047405740674077408740974107411741274137414741574167417741874197420742174227423742474257426742774287429743074317432743374347435743674377438743974407441744274437444744574467447744874497450745174527453745474557456745774587459746074617462746374647465746674677468746974707471747274737474747574767477747874797480748174827483748474857486748774887489749074917492749374947495749674977498749975007501750275037504750575067507750875097510751175127513751475157516751775187519752075217522752375247525752675277528752975307531753275337534753575367537753875397540754175427543754475457546754775487549755075517552755375547555755675577558755975607561756275637564756575667567756875697570757175727573757475757576757775787579758075817582758375847585758675877588758975907591759275937594759575967597759875997600760176027603760476057606760776087609761076117612761376147615761676177618761976207621762276237624762576267627762876297630763176327633763476357636763776387639764076417642764376447645764676477648764976507651765276537654765576567657765876597660766176627663766476657666766776687669767076717672767376747675767676777678767976807681768276837684768576867687768876897690769176927693769476957696769776987699770077017702770377047705770677077708770977107711771277137714771577167717771877197720772177227723772477257726772777287729773077317732773377347735773677377738773977407741774277437744774577467747774877497750775177527753775477557756775777587759776077617762776377647765776677677768776977707771777277737774777577767777777877797780778177827783778477857786778777887789779077917792779377947795779677977798779978007801780278037804780578067807780878097810781178127813781478157816781778187819782078217822782378247825782678277828782978307831783278337834783578367837783878397840784178427843784478457846784778487849785078517852785378547855785678577858785978607861786278637864786578667867786878697870787178727873787478757876787778787879788078817882788378847885788678877888788978907891789278937894789578967897789878997900790179027903790479057906790779087909791079117912791379147915791679177918791979207921792279237924792579267927792879297930793179327933793479357936793779387939794079417942794379447945794679477948794979507951795279537954795579567957795879597960796179627963796479657966796779687969797079717972797379747975797679777978797979807981798279837984798579867987798879897990799179927993799479957996799779987999800080018002800380048005800680078008800980108011801280138014801580168017801880198020802180228023802480258026802780288029803080318032803380348035803680378038803980408041804280438044804580468047804880498050805180528053805480558056805780588059806080618062806380648065806680678068806980708071807280738074807580768077807880798080808180828083808480858086808780888089809080918092809380948095809680978098809981008101810281038104810581068107810881098110811181128113811481158116811781188119812081218122812381248125812681278128812981308131813281338134813581368137813881398140814181428143814481458146814781488149815081518152815381548155815681578158815981608161816281638164816581668167816881698170817181728173817481758176817781788179818081818182818381848185818681878188818981908191819281938194819581968197819881998200820182028203820482058206820782088209821082118212821382148215821682178218821982208221822282238224822582268227822882298230823182328233823482358236823782388239824082418242824382448245824682478248824982508251825282538254825582568257825882598260826182628263826482658266826782688269827082718272827382748275827682778278827982808281828282838284828582868287828882898290829182928293829482958296829782988299830083018302830383048305830683078308830983108311831283138314831583168317831883198320832183228323832483258326832783288329833083318332833383348335833683378338833983408341834283438344834583468347834883498350835183528353835483558356835783588359836083618362836383648365836683678368836983708371837283738374837583768377837883798380838183828383838483858386838783888389839083918392839383948395839683978398839984008401840284038404840584068407840884098410841184128413841484158416841784188419842084218422842384248425842684278428842984308431843284338434843584368437843884398440844184428443844484458446844784488449845084518452845384548455845684578458845984608461846284638464846584668467846884698470847184728473847484758476847784788479848084818482848384848485848684878488848984908491849284938494849584968497849884998500850185028503850485058506850785088509851085118512851385148515851685178518851985208521852285238524852585268527852885298530853185328533853485358536853785388539854085418542854385448545854685478548854985508551855285538554855585568557855885598560856185628563856485658566856785688569857085718572857385748575857685778578857985808581858285838584858585868587858885898590859185928593859485958596859785988599860086018602860386048605860686078608860986108611861286138614861586168617861886198620862186228623862486258626862786288629863086318632863386348635863686378638863986408641864286438644864586468647864886498650865186528653865486558656865786588659866086618662866386648665866686678668866986708671867286738674867586768677867886798680868186828683868486858686868786888689869086918692869386948695869686978698869987008701870287038704870587068707870887098710871187128713871487158716871787188719872087218722872387248725872687278728872987308731873287338734873587368737873887398740874187428743874487458746874787488749875087518752875387548755875687578758875987608761876287638764876587668767876887698770877187728773877487758776877787788779878087818782878387848785878687878788878987908791879287938794879587968797879887998800880188028803880488058806880788088809881088118812881388148815881688178818881988208821882288238824882588268827882888298830883188328833883488358836883788388839884088418842884388448845884688478848884988508851885288538854885588568857885888598860886188628863886488658866886788688869887088718872887388748875887688778878887988808881888288838884888588868887888888898890889188928893889488958896889788988899890089018902890389048905890689078908890989108911891289138914891589168917891889198920892189228923892489258926892789288929893089318932893389348935893689378938893989408941894289438944894589468947894889498950895189528953895489558956895789588959896089618962896389648965896689678968896989708971897289738974897589768977897889798980898189828983898489858986898789888989899089918992899389948995899689978998899990009001900290039004900590069007900890099010901190129013901490159016901790189019902090219022902390249025902690279028902990309031903290339034903590369037903890399040904190429043904490459046904790489049905090519052905390549055905690579058905990609061906290639064906590669067906890699070907190729073907490759076907790789079908090819082908390849085908690879088908990909091909290939094909590969097909890999100910191029103910491059106910791089109911091119112911391149115911691179118911991209121912291239124912591269127912891299130913191329133913491359136913791389139914091419142
  1. {
  2. Symbol table implementation for the definitions
  3. Copyright (c) 1998-2005 by Florian Klaempfl, Pierre Muller
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit symdef;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cclasses,widestr,
  23. { global }
  24. globtype,globals,tokens,constexp,
  25. { symtable }
  26. symconst,symbase,symtype,
  27. { node }
  28. node,
  29. { aasm }
  30. aasmtai,
  31. cpuinfo,
  32. cgbase,
  33. parabase
  34. ;
  35. type
  36. {************************************************
  37. TDef
  38. ************************************************}
  39. tgenericconstraintdata=class
  40. interfaces : tfpobjectlist;
  41. interfacesderef : tfplist;
  42. flags : tgenericconstraintflags;
  43. { only required while parsing }
  44. fileinfo : tfileposinfo;
  45. constructor create;
  46. destructor destroy;override;
  47. procedure ppuload(ppufile:tcompilerppufile);
  48. procedure ppuwrite(ppufile:tcompilerppufile);
  49. procedure buildderef;
  50. procedure deref;
  51. end;
  52. { trtti_attribute_list }
  53. trtti_attribute = class
  54. typesym : tsym;
  55. typesymderef : tderef;
  56. typeconstr : tdef;
  57. typeconstrderef : tderef;
  58. { these two are not stored in PPU }
  59. constructorcall : tnode;
  60. constructorpd : tdef;
  61. paras : array of tnode;
  62. constructor ppuload(ppufile:tcompilerppufile);
  63. procedure ppuwrite(ppufile:tcompilerppufile);
  64. procedure ppuload_subentries(ppufile:tcompilerppufile);
  65. procedure ppuwrite_subentries(ppufile:tcompilerppufile);
  66. destructor destroy;override;
  67. procedure buildderef;
  68. procedure deref;
  69. end;
  70. trtti_attribute_list = class
  71. rtti_attributes : TFPObjectList;
  72. { if the attribute list is bound to a def or symbol }
  73. is_bound : Boolean;
  74. class procedure bind(var dangling,owned:trtti_attribute_list);
  75. procedure addattribute(atypesym:tsym;typeconstr:tdef;constructorcall:tnode;constref paras:array of tnode);
  76. procedure addattribute(attr:trtti_attribute);
  77. destructor destroy; override;
  78. function get_attribute_count:longint;
  79. procedure buildderef;
  80. procedure deref;
  81. class function ppuload(ppufile:tcompilerppufile):trtti_attribute_list;
  82. class procedure ppuwrite(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  83. class procedure ppuload_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  84. class procedure ppuwrite_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  85. end;
  86. { tstoreddef }
  87. tstoreddef = class(tdef)
  88. private
  89. {$ifdef symansistr}
  90. _fullownerhierarchyname : ansistring;
  91. {$else symansistr}
  92. _fullownerhierarchyname : pshortstring;
  93. {$endif symansistr}
  94. procedure writeentry(ppufile: tcompilerppufile; ibnr: byte);
  95. protected
  96. typesymderef : tderef;
  97. procedure ppuwrite_platform(ppufile:tcompilerppufile);virtual;
  98. procedure ppuload_platform(ppufile:tcompilerppufile);virtual;
  99. { a (possibly) reusable def is always created on the basis of another
  100. def, and contains a reference to this other def. If this other
  101. def is in a non-persistent symboltable, the new def cannot actually
  102. be safely reused everywhere in the current module. This routine
  103. abtracts that checking, and also restores the symtable stack
  104. (which had to be reset before creating the new def, so that the new
  105. def did not automatically get added to its top) }
  106. class procedure setup_reusable_def(origdef, newdef: tdef; res: PHashSetItem; oldsymtablestack: tsymtablestack);
  107. public
  108. {$ifdef EXTDEBUG}
  109. fileinfo : tfileposinfo;
  110. {$endif}
  111. { generic support }
  112. genericdef : tstoreddef;
  113. genericdefderef : tderef;
  114. generictokenbuf : tdynamicarray;
  115. { this list contains references to the symbols that make up the
  116. generic parameters; the symbols are not owned by this list
  117. Note: this list is allocated on demand! }
  118. genericparas : tfphashobjectlist;
  119. genericparaderefs : tfplist;
  120. { contains additional data if this def is a generic constraint
  121. Note: this class is allocated on demand! }
  122. genconstraintdata : tgenericconstraintdata;
  123. { this is Nil if the def has no RTTI attributes }
  124. rtti_attribute_list : trtti_attribute_list;
  125. constructor create(dt:tdeftyp;doregister:boolean);
  126. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  127. destructor destroy;override;
  128. function getcopy : tstoreddef;virtual;
  129. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  130. { this is called directly after ppuload }
  131. procedure ppuload_subentries(ppufile:tcompilerppufile);virtual;
  132. { this is called directly after ppuwrite }
  133. procedure ppuwrite_subentries(ppufile:tcompilerppufile);virtual;
  134. procedure buildderef;override;
  135. procedure buildderefimpl;override;
  136. procedure deref;override;
  137. procedure derefimpl;override;
  138. function size:asizeint;override;
  139. function getvardef:longint;override;
  140. function alignment:shortint;override;
  141. function is_publishable : boolean;override;
  142. function needs_inittable : boolean;override;
  143. function has_non_trivial_init_child(check_parent:boolean):boolean;override;
  144. function rtti_mangledname(rt:trttitype):TSymStr;override;
  145. function OwnerHierarchyName: string; override;
  146. function fullownerhierarchyname(skipprocparams:boolean):TSymStr;override;
  147. function needs_separate_initrtti:boolean;override;
  148. function in_currentunit: boolean;
  149. { regvars }
  150. function is_intregable : boolean;
  151. function is_fpuregable : boolean;
  152. { def can be put into a register if it is const/immutable }
  153. function is_const_intregable : boolean;
  154. { generics }
  155. procedure initgeneric;
  156. { this function can be used to determine whether a def is really a
  157. generic declaration or just a normal type declared inside another
  158. generic }
  159. function is_generic:boolean;
  160. { same as above for specializations }
  161. function is_specialization:boolean;
  162. { generic utilities }
  163. function is_generic_param_const(index:integer):boolean;inline;
  164. function get_generic_param_def(index:integer):tdef;inline;
  165. { registers this def in the unit's deflist; no-op if already registered }
  166. procedure register_def; override;
  167. { add the def to the top of the symtable stack if it's not yet owned
  168. by another symtable }
  169. procedure maybe_put_in_symtable_stack;
  170. private
  171. savesize : asizeuint;
  172. end;
  173. tfiletyp = (ft_text,ft_typed,ft_untyped);
  174. tfiledef = class(tstoreddef)
  175. filetyp : tfiletyp;
  176. typedfiledef : tdef;
  177. typedfiledefderef : tderef;
  178. constructor createtext;virtual;
  179. constructor createuntyped;virtual;
  180. constructor createtyped(def : tdef);virtual;
  181. constructor ppuload(ppufile:tcompilerppufile);
  182. function getcopy : tstoreddef;override;
  183. { do not override this routine in platform-specific subclasses,
  184. override ppuwrite_platform instead }
  185. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  186. procedure buildderef;override;
  187. procedure deref;override;
  188. function GetTypeName:string;override;
  189. function getmangledparaname:TSymStr;override;
  190. function size:asizeint;override;
  191. procedure setsize;
  192. function alignment: shortint; override;
  193. end;
  194. tfiledefclass = class of tfiledef;
  195. tvariantdef = class(tstoreddef)
  196. varianttype : tvarianttype;
  197. constructor create(v : tvarianttype);virtual;
  198. constructor ppuload(ppufile:tcompilerppufile);
  199. function getcopy : tstoreddef;override;
  200. function GetTypeName:string;override;
  201. function alignment : shortint;override;
  202. { do not override this routine in platform-specific subclasses,
  203. override ppuwrite_platform instead }
  204. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  205. function getvardef:longint;override;
  206. procedure setsize;
  207. function is_publishable : boolean;override;
  208. function needs_inittable : boolean;override;
  209. end;
  210. tvariantdefclass = class of tvariantdef;
  211. tformaldef = class(tstoreddef)
  212. typed:boolean;
  213. constructor create(Atyped:boolean);virtual;
  214. constructor ppuload(ppufile:tcompilerppufile);
  215. { do not override this routine in platform-specific subclasses,
  216. override ppuwrite_platform instead }
  217. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  218. function GetTypeName:string;override;
  219. end;
  220. tformaldefclass = class of tformaldef;
  221. tforwarddef = class(tstoreddef)
  222. tosymname : pshortstring;
  223. forwardpos : tfileposinfo;
  224. constructor create(const s:string;const pos:tfileposinfo);virtual;
  225. destructor destroy;override;
  226. function getcopy:tstoreddef;override;
  227. function GetTypeName:string;override;
  228. end;
  229. tforwarddefclass = class of tforwarddef;
  230. tundefineddef = class(tstoreddef)
  231. constructor create(doregister:boolean);virtual;
  232. constructor ppuload(ppufile:tcompilerppufile);
  233. { do not override this routine in platform-specific subclasses,
  234. override ppuwrite_platform instead }
  235. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  236. function GetTypeName:string;override;
  237. end;
  238. tundefineddefclass = class of tundefineddef;
  239. terrordef = class(tstoreddef)
  240. constructor create;virtual;
  241. { do not override this routine in platform-specific subclasses,
  242. override ppuwrite_platform instead }
  243. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  244. function GetTypeName:string;override;
  245. function getmangledparaname : TSymStr;override;
  246. end;
  247. terrordefclass = class of terrordef;
  248. tabstractpointerdef = class(tstoreddef)
  249. pointeddef : tdef;
  250. pointeddefderef : tderef;
  251. constructor create(dt:tdeftyp;def:tdef);
  252. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  253. procedure ppuwrite(ppufile:tcompilerppufile);override;
  254. procedure buildderef;override;
  255. procedure deref;override;
  256. function size:asizeint;override;
  257. function alignment:shortint;override;
  258. end;
  259. tpointerdef = class(tabstractpointerdef)
  260. has_pointer_math : boolean;
  261. constructor create(def:tdef);virtual;
  262. { returns a pointerdef for def, reusing an existing one in case it
  263. exists in the current module }
  264. class function getreusable(def: tdef): tpointerdef; virtual;
  265. { same as above, but in case the def must never be freed after the
  266. current module has been compiled -- even if the def was not written
  267. to the ppu file (for defs in para locations, as we don't reset them
  268. so we don't have to recalculate them all the time) }
  269. class function getreusable_no_free(def: tdef): tpointerdef;
  270. function size:asizeint;override;
  271. function getcopy:tstoreddef;override;
  272. constructor ppuload(ppufile:tcompilerppufile);
  273. { do not override this routine in platform-specific subclasses,
  274. override ppuwrite_platform instead }
  275. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  276. function GetTypeName:string;override;
  277. {# returns the appropriate int type for pointer arithmetic with the given pointer type.
  278. When adding or subtracting a number to/from a pointer, this function returns the
  279. int type to which that number has to be converted, before the operation can be performed.
  280. Normally, this is sinttype, except on i8086, where it takes into account the
  281. special i8086 pointer types (near, far, huge). }
  282. function pointer_arithmetic_int_type:tdef;virtual;
  283. {# the unsigned version of pointer_arithmetic_int_type. Used with inc/dec. }
  284. function pointer_arithmetic_uint_type:tdef;virtual;
  285. {# returns the int type produced when subtracting two pointers of the given type.
  286. Normally, this is sinttype, except on i8086, where it takes into account the
  287. special i8086 pointer types (near, far, huge). }
  288. function pointer_subtraction_result_type:tdef;virtual;
  289. function compatible_with_pointerdef_size(ptr: tpointerdef): boolean; virtual;
  290. {# the integer index type used to convert the pointer to array (i.e. denotes int_type in: ptr[int_type]) }
  291. function converted_pointer_to_array_range_type:tdef;virtual;
  292. end;
  293. tpointerdefclass = class of tpointerdef;
  294. tprocdef = class;
  295. tabstractrecorddef= class(tstoreddef)
  296. private
  297. rttistring : string;
  298. {$ifdef DEBUG_NODE_XML}
  299. protected
  300. procedure XMLPrintDefData(var T: Text; Sym: TSym); override;
  301. {$endif DEBUG_NODE_XML}
  302. public
  303. objname,
  304. objrealname : PShortString;
  305. { for C++ classes: name of the library this class is imported from }
  306. { for Java classes/records: package name }
  307. import_lib : PShortString;
  308. symtable : TSymtable;
  309. cloneddef : tabstractrecorddef;
  310. cloneddefderef : tderef;
  311. objectoptions : tobjectoptions;
  312. { for targets that initialise typed constants via explicit assignments
  313. instead of by generating an initialised data sectino }
  314. tcinitcode : tnode;
  315. constructor create(const n:string; dt:tdeftyp;doregister:boolean);
  316. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  317. procedure ppuwrite(ppufile:tcompilerppufile);override;
  318. destructor destroy; override;
  319. procedure buildderefimpl;override;
  320. procedure derefimpl;override;
  321. procedure check_forwards; virtual;
  322. function find_procdef_bytype(pt:tproctypeoption): tprocdef;
  323. function GetSymtable(t:tGetSymtable):TSymtable;override;
  324. function is_packed:boolean;
  325. function RttiName: string;
  326. { enumerator support }
  327. function search_enumerator_get: tprocdef; virtual;
  328. function search_enumerator_move: tprocdef; virtual;
  329. function search_enumerator_current: tsym; virtual;
  330. { JVM }
  331. function jvm_full_typename(with_package_name: boolean): string;
  332. { check if the symtable contains a float field }
  333. function contains_float_field : boolean;
  334. { check if the symtable contains a field that spans an aword boundary }
  335. function contains_cross_aword_field: boolean;
  336. end;
  337. pvariantrecdesc = ^tvariantrecdesc;
  338. tvariantrecbranch = record
  339. { we store only single values here and no ranges because tvariantrecdesc is only needed in iso mode
  340. which does not support range expressions in variant record definitions }
  341. values : array of Tconstexprint;
  342. nestedvariant : pvariantrecdesc;
  343. end;
  344. ppvariantrecdesc = ^pvariantrecdesc;
  345. tvariantrecdesc = record
  346. variantselector : tsym;
  347. variantselectorderef : tderef;
  348. branches : array of tvariantrecbranch;
  349. end;
  350. trecorddef = class(tabstractrecorddef)
  351. {$ifdef DEBUG_NODE_XML}
  352. protected
  353. function XMLPrintType: ansistring; override;
  354. {$endif DEBUG_NODE_XML}
  355. public
  356. variantrecdesc : pvariantrecdesc;
  357. isunion : boolean;
  358. constructor create(const n:string; p:TSymtable);virtual;
  359. constructor create_global_internal(const n: string; packrecords, recordalignmin: shortint); virtual;
  360. function add_field_by_def(const optionalname: TIDString; def: tdef): tsym;
  361. procedure add_fields_from_deflist(fieldtypes: tfplist);
  362. constructor ppuload(ppufile:tcompilerppufile);
  363. destructor destroy;override;
  364. function getcopy : tstoreddef;override;
  365. { do not override this routine in platform-specific subclasses,
  366. override ppuwrite_platform instead }
  367. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  368. procedure buildderef;override;
  369. procedure deref;override;
  370. function size:asizeint;override;
  371. function alignment : shortint;override;
  372. function padalignment: shortint;
  373. function GetTypeName:string;override;
  374. { debug }
  375. function needs_inittable : boolean;override;
  376. function needs_separate_initrtti:boolean;override;
  377. function has_non_trivial_init_child(check_parent:boolean):boolean;override;
  378. end;
  379. trecorddefclass = class of trecorddef;
  380. tobjectdef = class;
  381. { TImplementedInterface }
  382. TImplementedInterface = class
  383. private
  384. fIOffset : longint;
  385. function GetIOffset: longint;
  386. public
  387. IntfDef : tobjectdef;
  388. IntfDefDeref : tderef;
  389. IType : tinterfaceentrytype;
  390. VtblImplIntf : TImplementedInterface;
  391. NameMappings : TFPHashList;
  392. ProcDefs : TFPObjectList;
  393. ImplementsGetter : tsym;
  394. ImplementsGetterDeref : tderef;
  395. ImplementsField : tsym;
  396. constructor create(aintf: tobjectdef);virtual;
  397. constructor create_deref(intfd,getterd:tderef);virtual;
  398. destructor destroy; override;
  399. function getcopy:TImplementedInterface;
  400. procedure buildderef;
  401. procedure deref;
  402. procedure AddMapping(const origname, newname: string);
  403. function GetMapping(const origname: string):string;
  404. procedure AddImplProc(pd:tprocdef);
  405. function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  406. property IOffset: longint read GetIOffset write fIOffset;
  407. end;
  408. timplementedinterfaceclass = class of timplementedinterface;
  409. { tvmtentry }
  410. tvmtentry = record
  411. procdef : tprocdef;
  412. procdefderef : tderef;
  413. visibility : tvisibility;
  414. end;
  415. pvmtentry = ^tvmtentry;
  416. { tobjectdef }
  417. tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
  418. pmvcallstaticinfo = ^tmvcallstaticinfo;
  419. tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
  420. tobjectdef = class(tabstractrecorddef)
  421. private
  422. fcurrent_dispid: longint;
  423. {$ifdef DEBUG_NODE_XML}
  424. protected
  425. function XMLPrintType: ansistring; override;
  426. procedure XMLPrintDefInfo(var T: Text; Sym: TSym); override;
  427. procedure XMLPrintDefData(var T: Text; Sym: TSym); override;
  428. {$endif DEBUG_NODE_XML}
  429. public
  430. childof : tobjectdef;
  431. childofderef : tderef;
  432. { for Object Pascal helpers }
  433. extendeddef : tdef;
  434. extendeddefderef: tderef;
  435. helpertype : thelpertype;
  436. { for Objective-C: protocols and classes can have the same name there }
  437. objextname : pshortstring;
  438. { to be able to have a variable vmt position }
  439. { and no vmt field for objects without virtuals }
  440. vmtentries : TFPList;
  441. vmcallstaticinfo : pmvcallstaticinfo;
  442. vmt_field : tsym;
  443. vmt_fieldderef : tderef;
  444. iidguid : pguid;
  445. iidstr : pshortstring;
  446. { store implemented interfaces defs and name mappings }
  447. ImplementedInterfaces : TFPObjectList;
  448. { number of abstract methods (used by JVM target to determine whether
  449. or not the class should be marked as abstract: must be done if 1 or
  450. more abstract methods) }
  451. abstractcnt : longint;
  452. writing_class_record_dbginfo,
  453. { a class of this type has been created in this module }
  454. created_in_current_module,
  455. { a loadvmtnode for this class has been created in this
  456. module, so if a classrefdef variable of this or a parent
  457. class is used somewhere to instantiate a class, then this
  458. class may be instantiated
  459. }
  460. maybe_created_in_current_module,
  461. { a "class of" this particular class has been created in
  462. this module
  463. }
  464. classref_created_in_current_module : boolean;
  465. objecttype : tobjecttyp;
  466. constructor create(ot:tobjecttyp;const n:string;c:tobjectdef;doregister:boolean);virtual;
  467. constructor ppuload(ppufile:tcompilerppufile);
  468. destructor destroy;override;
  469. function getcopy : tstoreddef;override;
  470. { do not override this routine in platform-specific subclasses,
  471. override ppuwrite_platform instead }
  472. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  473. function GetTypeName:string;override;
  474. procedure buildderef;override;
  475. procedure deref;override;
  476. procedure derefimpl;override;
  477. procedure copyvmtentries(objdef:tobjectdef);
  478. function getparentdef:tdef;override;
  479. function size : asizeint;override;
  480. function alignment:shortint;override;
  481. function vmtmethodoffset(index:longint):longint;
  482. function members_need_inittable : boolean;
  483. { this should be called when this class implements an interface }
  484. procedure prepareguid;
  485. function is_publishable : boolean;override;
  486. function needs_inittable : boolean;override;
  487. function needs_separate_initrtti : boolean;override;
  488. function has_non_trivial_init_child(check_parent:boolean):boolean;override;
  489. function rtti_mangledname(rt:trttitype):TSymStr;override;
  490. function is_unique_objpasdef: boolean;
  491. function vmt_mangledname : TSymStr;
  492. function vmt_def: trecorddef;
  493. procedure check_forwards; override;
  494. procedure insertvmt;
  495. function vmt_offset: asizeint;
  496. procedure set_parent(c : tobjectdef);
  497. function find_destructor: tprocdef;
  498. function implements_any_interfaces: boolean;
  499. { dispinterface support }
  500. function get_next_dispid: longint;
  501. { enumerator support }
  502. function search_enumerator_get: tprocdef; override;
  503. function search_enumerator_move: tprocdef; override;
  504. function search_enumerator_current: tsym; override;
  505. { WPO }
  506. procedure register_created_object_type;override;
  507. procedure register_maybe_created_object_type;
  508. procedure register_created_classref_type;
  509. procedure register_vmt_call(index:longint);
  510. { ObjC }
  511. procedure finish_objc_data;
  512. function check_objc_types: boolean;
  513. { C++ }
  514. procedure finish_cpp_data;
  515. end;
  516. tobjectdefclass = class of tobjectdef;
  517. tclassrefdef = class(tabstractpointerdef)
  518. constructor create(def:tdef);virtual;
  519. constructor ppuload(ppufile:tcompilerppufile);
  520. { do not override this routine in platform-specific subclasses,
  521. override ppuwrite_platform instead }
  522. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  523. function getcopy:tstoreddef;override;
  524. function GetTypeName:string;override;
  525. function is_publishable : boolean;override;
  526. function rtti_mangledname(rt:trttitype):TSymStr;override;
  527. procedure register_created_object_type;override;
  528. end;
  529. tclassrefdefclass = class of tclassrefdef;
  530. tarraydef = class(tstoreddef)
  531. lowrange,
  532. highrange : asizeint;
  533. rangedef : tdef;
  534. rangedefderef : tderef;
  535. arrayoptions : tarraydefoptions;
  536. symtable : TSymtable;
  537. protected
  538. _elementdef : tdef;
  539. _elementdefderef : tderef;
  540. procedure setelementdef(def:tdef);
  541. class function getreusable_intern(def: tdef; elems: asizeint; const options: tarraydefoptions): tarraydef;
  542. public
  543. function elesize : asizeint;
  544. function elepackedbitsize : asizeint;
  545. function elecount : asizeuint;
  546. constructor create_from_pointer(def: tpointerdef);virtual;
  547. constructor create(l, h: asizeint; def: tdef);virtual;
  548. constructor create_vector(l,h:asizeint; def:tdef);
  549. constructor create_openarray;virtual;
  550. class function getreusable(def: tdef; elems: asizeint): tarraydef;
  551. class function getreusable_vector(def: tdef; elems: asizeint): tarraydef;
  552. { same as above, but in case the def must never be freed after the
  553. current module has been compiled -- even if the def was not written
  554. to the ppu file (for defs in para locations, as we don't reset them
  555. so we don't have to recalculate them all the time) }
  556. class function getreusable_no_free(def: tdef; elems: asizeint): tarraydef;
  557. class function getreusable_no_free_vector(def: tdef; elems: asizeint): tarraydef;
  558. constructor ppuload(ppufile:tcompilerppufile);
  559. destructor destroy; override;
  560. function getcopy : tstoreddef;override;
  561. { do not override this routine in platform-specific subclasses,
  562. override ppuwrite_platform instead }
  563. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  564. function GetTypeName:string;override;
  565. function getmangledparaname : TSymStr;override;
  566. procedure buildderef;override;
  567. procedure deref;override;
  568. function size : asizeint;override;
  569. function alignment : shortint;override;
  570. { returns the label of the range check string }
  571. function needs_inittable : boolean;override;
  572. function needs_separate_initrtti : boolean;override;
  573. property elementdef : tdef read _elementdef write setelementdef;
  574. function is_publishable : boolean;override;
  575. function is_hwvector: boolean;
  576. end;
  577. tarraydefclass = class of tarraydef;
  578. torddef = class(tstoreddef)
  579. low,high : TConstExprInt;
  580. ordtype : tordtype;
  581. constructor create(t : tordtype;v,b : TConstExprInt; doregister: boolean);virtual;
  582. constructor ppuload(ppufile:tcompilerppufile);
  583. function getcopy : tstoreddef;override;
  584. { do not override this routine in platform-specific subclasses,
  585. override ppuwrite_platform instead }
  586. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  587. function is_publishable : boolean;override;
  588. function GetTypeName:string;override;
  589. function alignment:shortint;override;
  590. procedure setsize;
  591. function packedbitsize: asizeint; override;
  592. function getvardef : longint;override;
  593. end;
  594. torddefclass = class of torddef;
  595. tfloatdef = class(tstoreddef)
  596. floattype : tfloattype;
  597. constructor create(t: tfloattype; doregister: boolean);virtual;
  598. constructor ppuload(ppufile:tcompilerppufile);
  599. function getcopy : tstoreddef;override;
  600. { do not override this routine in platform-specific subclasses,
  601. override ppuwrite_platform instead }
  602. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  603. function GetTypeName:string;override;
  604. function is_publishable : boolean;override;
  605. function alignment:shortint;override;
  606. function structalignment: shortint;override;
  607. procedure setsize;
  608. function getvardef:longint;override;
  609. end;
  610. tfloatdefclass = class of tfloatdef;
  611. { tabstractprocdef }
  612. tprocnameoption = (pno_showhidden, pno_proctypeoption, pno_paranames,
  613. pno_ownername, pno_noclassmarker, pno_noleadingdollar,
  614. pno_mangledname, pno_noparams);
  615. tprocnameoptions = set of tprocnameoption;
  616. tproccopytyp = (pc_normal,
  617. {$ifdef i8086}
  618. { the address in a far format }
  619. pc_far_address,
  620. { the offset part of the far address }
  621. pc_offset,
  622. {$endif i8086}
  623. { creates a procvardef describing only the code pointer
  624. of a method/netsted function/... }
  625. pc_address_only,
  626. { everything except for hidden parameters }
  627. pc_normal_no_hidden,
  628. { always creates a top-level function, removes all
  629. special parameters (self, vmt, parentfp, ...) }
  630. pc_bareproc
  631. );
  632. tcacheableproccopytyp = pc_normal..pc_address_only;
  633. tabstractprocdef = class(tstoreddef)
  634. { saves a definition to the return type }
  635. returndef : tdef;
  636. returndefderef : tderef;
  637. parast : TSymtable;
  638. paras : tparalist;
  639. proctypeoption : tproctypeoption;
  640. proccalloption : tproccalloption;
  641. procoptions : tprocoptions;
  642. callerargareasize,
  643. calleeargareasize: pint;
  644. {$ifdef m68k}
  645. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  646. {$endif}
  647. funcretloc : array[callerside..calleeside] of TCGPara;
  648. has_paraloc_info : tcallercallee; { paraloc info is available }
  649. { number of user visible parameters }
  650. maxparacount,
  651. minparacount : byte;
  652. constructor create(dt:tdeftyp;level:byte;doregister:boolean);
  653. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  654. destructor destroy;override;
  655. procedure ppuwrite(ppufile:tcompilerppufile);override;
  656. procedure buildderef;override;
  657. procedure deref;override;
  658. procedure calcparas;
  659. function mangledprocparanames(oldlen : longint) : string;
  660. function typename_paras(pno: tprocnameoptions): ansistring;
  661. function is_methodpointer:boolean;virtual;
  662. function is_addressonly:boolean;virtual;
  663. function no_self_node:boolean;
  664. { get either a copy as a procdef or procvardef }
  665. function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef; virtual;
  666. function compatible_with_pointerdef_size(ptr: tpointerdef): boolean; virtual;
  667. procedure check_mark_as_nested;
  668. procedure init_paraloc_info(side: tcallercallee);
  669. procedure done_paraloc_info(side: tcallercallee);
  670. function stack_tainting_parameter(side: tcallercallee): boolean;
  671. function is_pushleftright: boolean;virtual;
  672. function address_type:tdef;virtual;
  673. { address type, generated for ofs() }
  674. function ofs_address_type:tdef;virtual;
  675. procedure declared_far;virtual;
  676. procedure declared_near;virtual;
  677. function generate_safecall_wrapper: boolean; virtual;
  678. { returns true if the def is a generic param of the procdef }
  679. function is_generic_param(def:tdef): boolean;
  680. private
  681. procedure count_para(p:TObject;arg:pointer);
  682. procedure insert_para(p:TObject;arg:pointer);
  683. end;
  684. tprocvardef = class(tabstractprocdef)
  685. constructor create(level:byte);virtual;
  686. { returns a procvardef that represents the address of a proc(var)def }
  687. class function getreusableprocaddr(def: tabstractprocdef; copytyp: tcacheableproccopytyp): tprocvardef; virtual;
  688. { same as above, but in case the def must never be freed after the
  689. current module has been compiled -- even if the def was not written
  690. to the ppu file (for defs in para locations, as we don't reset them
  691. so we don't have to recalculate them all the time) }
  692. class function getreusableprocaddr_no_free(def: tabstractprocdef): tprocvardef;
  693. constructor ppuload(ppufile:tcompilerppufile);
  694. function getcopy : tstoreddef;override;
  695. { do not override this routine in platform-specific subclasses,
  696. override ppuwrite_platform instead }
  697. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  698. function GetSymtable(t:tGetSymtable):TSymtable;override;
  699. function size : asizeint;override;
  700. function GetTypeName:string;override;
  701. function is_publishable : boolean;override;
  702. function is_methodpointer:boolean;override;
  703. function is_addressonly:boolean;override;
  704. function getmangledparaname:TSymStr;override;
  705. function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
  706. end;
  707. tprocvardefclass = class of tprocvardef;
  708. tmessageinf = record
  709. case integer of
  710. 0 : (str : pshortstring);
  711. 1 : (i : longint);
  712. end;
  713. tinlininginfo = record
  714. { node tree }
  715. code : tnode;
  716. flags : tprocinfoflags;
  717. end;
  718. pinlininginfo = ^tinlininginfo;
  719. timplprocdefinfo = record
  720. resultname : pshortstring;
  721. parentfpstruct: tsym;
  722. parentfpstructptrtype: tdef;
  723. parentfpinitblock: tnode;
  724. procstarttai,
  725. procendtai : tai;
  726. skpara: pointer;
  727. personality: tprocdef;
  728. forwarddef,
  729. interfacedef : boolean;
  730. hasforward : boolean;
  731. is_implemented : boolean;
  732. end;
  733. pimplprocdefinfo = ^timplprocdefinfo;
  734. { tprocdef }
  735. tprocdef = class(tabstractprocdef)
  736. protected
  737. {$ifdef symansistr}
  738. _mangledname : ansistring;
  739. {$else symansistr}
  740. _mangledname : pshortstring;
  741. {$endif}
  742. _parentfpsym : tsym;
  743. { information that is only required until the implementation of the
  744. procdef has been handled }
  745. implprocdefinfo : pimplprocdefinfo;
  746. function store_localst:boolean;
  747. function GetResultName: PShortString;
  748. procedure SetResultName(AValue: PShortString);
  749. function GetParentFPStruct: tsym;
  750. procedure SetParentFPStruct(AValue: tsym);
  751. function GetParentFPStructPtrType: tdef;
  752. procedure SetParentFPStructPtrType(AValue: tdef);
  753. function GetParentFPInitBlock: tnode;
  754. procedure SetParentFPInitBlock(AValue: tnode);
  755. function Getprocstarttai: tai;
  756. procedure Setprocstarttai(AValue: tai);
  757. function Getprocendtai: tai;
  758. procedure Setprocendtai(AValue: tai);
  759. function Getskpara: pointer;
  760. procedure Setskpara(AValue: pointer);
  761. function Getpersonality: tprocdef;
  762. procedure Setpersonality(AValue: tprocdef);
  763. function Getforwarddef: boolean;
  764. procedure Setforwarddef(AValue: boolean);
  765. function Getinterfacedef: boolean;
  766. procedure Setinterfacedef(AValue: boolean);virtual;
  767. function Gethasforward: boolean;
  768. procedure Sethasforward(AValue: boolean);
  769. function GetIsEmpty: boolean;
  770. procedure SetIsEmpty(AValue: boolean);
  771. function GetHasInliningInfo: boolean;
  772. procedure SetHasInliningInfo(AValue: boolean);
  773. function Getis_implemented: boolean;
  774. procedure Setis_implemented(AValue: boolean);
  775. function getparentfpsym: tsym;
  776. public
  777. messageinf : tmessageinf;
  778. dispid : longint;
  779. {$ifndef EXTDEBUG}
  780. { where is this function defined and what were the symbol
  781. flags, needed here because there
  782. is only one symbol for all overloaded functions
  783. EXTDEBUG has fileinfo in tdef (PFV) }
  784. fileinfo : tfileposinfo;
  785. {$endif}
  786. symoptions : tsymoptions;
  787. deprecatedmsg : pshortstring;
  788. { generic support }
  789. genericdecltokenbuf : tdynamicarray;
  790. { symbol owning this definition }
  791. procsym : tsym;
  792. procsymderef : tderef;
  793. { alias names }
  794. aliasnames : TCmdStrList;
  795. { symtables }
  796. localst : TSymtable;
  797. funcretsym : tsym;
  798. funcretsymderef : tderef;
  799. struct : tabstractrecorddef;
  800. structderef : tderef;
  801. implprocoptions: timplprocoptions;
  802. { import info }
  803. import_dll,
  804. import_name : pshortstring;
  805. { info for inlining the subroutine, if this pointer is nil,
  806. the procedure can't be inlined }
  807. inlininginfo : pinlininginfo;
  808. import_nr : word;
  809. extnumber : word;
  810. { set to a value different from tsk_none in case this procdef is for
  811. a routine that has to be internally generated by the compiler }
  812. synthetickind: tsynthetickind;
  813. visibility : tvisibility;
  814. {$ifndef DISABLE_FAST_OVERLOAD_PATCH}
  815. seenmarker : pointer; // used for filtering in tcandidate
  816. {$endif}
  817. {$ifdef symansistr}
  818. section: ansistring;
  819. {$else symansistr}
  820. section: pshortstring;
  821. {$endif}
  822. constructor create(level:byte;doregister:boolean);virtual;
  823. constructor ppuload(ppufile:tcompilerppufile);
  824. destructor destroy;override;
  825. procedure freeimplprocdefinfo;
  826. { do not override this routine in platform-specific subclasses,
  827. override ppuwrite_platform instead }
  828. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  829. procedure buildderef;override;
  830. procedure buildderefimpl;override;
  831. procedure deref;override;
  832. procedure derefimpl;override;
  833. function GetSymtable(t:tGetSymtable):TSymtable;override;
  834. { warnings:
  835. * the symtablestack top has to be the symtable to which the copy
  836. should be added
  837. * getcopy does not create a finished/ready-to-use procdef; it
  838. needs to be finalised afterwards by calling
  839. symcreat.finish_copied_procdef() afterwards
  840. }
  841. function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef; override;
  842. function getcopy: tstoreddef; override;
  843. function GetTypeName : string;override;
  844. function mangledname : TSymStr; virtual;
  845. procedure setmangledname(const s : TSymStr);
  846. function needsglobalasmsym: boolean;
  847. procedure setcompilerprocname;
  848. function fullprocname(showhidden:boolean):string;
  849. function customprocname(pno: tprocnameoptions):ansistring;
  850. function defaultmangledname: TSymStr;
  851. function cplusplusmangledname : TSymStr;
  852. function objcmangledname : TSymStr;
  853. function is_methodpointer:boolean;override;
  854. function is_addressonly:boolean;override;
  855. procedure make_external;
  856. procedure init_genericdecl;
  857. function get_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean; virtual;
  858. function get_safecall_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean; virtual;
  859. { returns whether the mangled name or any of its aliases is equal to
  860. s }
  861. function has_alias_name(const s: TSymStr):boolean;
  862. { aliases to fields only required when a function is implemented in
  863. the current unit }
  864. property resultname: PShortString read GetResultName write SetResultName;
  865. { temporary reference to structure containing copies of all local
  866. variables and parameters accessed by nested routines; reference to
  867. this structure is passed as "parent frame pointer" on targets that
  868. lack this concept (at least JVM and LLVM); no need to save to/
  869. restore from ppu, since nested routines are always in the same
  870. unit }
  871. property parentfpstruct: tsym read GetParentFPStruct write SetParentFPStruct;
  872. { pointer to parentfpstruct's type (not yet valid during parsing, so
  873. cannot be used for $parentfp parameter) (no need to save to ppu) }
  874. property parentfpstructptrtype: tdef read GetParentFPStructPtrType write SetParentFPStructPtrType;
  875. { code to copy the parameters accessed from nested routines into the
  876. parentfpstruct (no need to save to ppu) }
  877. property parentfpinitblock: tnode read GetParentFPInitBlock write SetParentFPInitBlock;
  878. { First/last assembler symbol/instruction in aasmoutput list.
  879. Note: initialised after compiling the code for the procdef, but
  880. not saved to/restored from ppu. Used when inserting debug info }
  881. property procstarttai: tai read Getprocstarttai write Setprocstarttai;
  882. property procendtai: tai read Getprocendtai write Setprocendtai;
  883. { optional parameter for the synthetic routine generation logic }
  884. property skpara: pointer read Getskpara write Setskpara;
  885. { ABI-conformant exception handling personality function }
  886. property personality: tprocdef read Getpersonality write Setpersonality;
  887. { true, if the procedure is only declared
  888. (forward procedure) }
  889. property forwarddef: boolean read Getforwarddef write Setforwarddef;
  890. { true if the procedure is declared in the interface }
  891. property interfacedef: boolean read Getinterfacedef write Setinterfacedef;
  892. { true if the procedure has a forward declaration }
  893. property hasforward: boolean read Gethasforward write Sethasforward;
  894. { true if the routine's body is empty }
  895. property isempty: boolean read GetIsEmpty write SetIsEmpty;
  896. { true if all information required to inline this routine is available }
  897. property has_inlininginfo: boolean read GetHasInliningInfo write SetHasInliningInfo;
  898. { returns the $parentfp parameter for nested routines }
  899. property parentfpsym: tsym read getparentfpsym;
  900. { true if the implementation part for this procdef has been handled }
  901. property is_implemented: boolean read Getis_implemented write Setis_implemented;
  902. end;
  903. tprocdefclass = class of tprocdef;
  904. { single linked list of overloaded procs }
  905. pprocdeflist = ^tprocdeflist;
  906. tprocdeflist = record
  907. def : tprocdef;
  908. defderef : tderef;
  909. next : pprocdeflist;
  910. end;
  911. tstringdef = class(tstoreddef)
  912. encoding : tstringencoding;
  913. stringtype : tstringtype;
  914. len : asizeint;
  915. constructor createshort(l: byte; doregister: boolean);virtual;
  916. constructor loadshort(ppufile:tcompilerppufile);
  917. constructor createlong(l: asizeint; doregister: boolean);virtual;
  918. constructor loadlong(ppufile:tcompilerppufile);
  919. constructor createansi(aencoding: tstringencoding; doregister: boolean);virtual;
  920. constructor loadansi(ppufile:tcompilerppufile);
  921. constructor createwide(doregister: boolean);virtual;
  922. constructor loadwide(ppufile:tcompilerppufile);
  923. constructor createunicode(doregister: boolean);virtual;
  924. constructor loadunicode(ppufile:tcompilerppufile);virtual;
  925. function getcopy : tstoreddef;override;
  926. function stringtypname:string;
  927. { do not override this routine in platform-specific subclasses,
  928. override ppuwrite_platform instead }
  929. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  930. function GetTypeName:string;override;
  931. function getmangledparaname:TSymStr;override;
  932. function is_publishable : boolean;override;
  933. function size:asizeint;override;
  934. function alignment : shortint;override;
  935. function needs_inittable : boolean;override;
  936. function getvardef:longint;override;
  937. { returns the default char type def for the string }
  938. function get_default_char_type: tdef;
  939. { returns the default string type }
  940. function get_default_string_type: tdef;
  941. end;
  942. tstringdefclass = class of tstringdef;
  943. { tenumdef }
  944. tenumdef = class(tstoreddef)
  945. minval,
  946. maxval : asizeint;
  947. basedef : tenumdef;
  948. basedefderef : tderef;
  949. symtable : TSymtable;
  950. has_jumps : boolean;
  951. constructor create;virtual;
  952. constructor create_subrange(_basedef:tenumdef;_min,_max:asizeint);virtual;
  953. constructor ppuload(ppufile:tcompilerppufile);
  954. destructor destroy;override;
  955. function getcopy : tstoreddef;override;
  956. { do not override this routine in platform-specific subclasses,
  957. override ppuwrite_platform instead }
  958. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  959. procedure buildderef;override;
  960. procedure deref;override;
  961. function GetTypeName:string;override;
  962. function is_publishable : boolean;override;
  963. procedure calcsavesize(packenum: shortint);
  964. function packedbitsize: asizeint; override;
  965. procedure setmax(_max:asizeint);
  966. procedure setmin(_min:asizeint);
  967. function min:asizeint;
  968. function max:asizeint;
  969. function getfirstsym:tsym;
  970. function int2enumsym(l: asizeint): tsym;
  971. { returns basedef if assigned, otherwise self }
  972. function getbasedef: tenumdef;
  973. end;
  974. tenumdefclass = class of tenumdef;
  975. tsetdef = class(tstoreddef)
  976. elementdef : tdef;
  977. elementdefderef : tderef;
  978. setbase,
  979. setmax : asizeint;
  980. constructor create(def: tdef; low, high: asizeint; doregister: boolean);virtual;
  981. constructor ppuload(ppufile:tcompilerppufile);
  982. function getcopy : tstoreddef;override;
  983. { do not override this routine in platform-specific subclasses,
  984. override ppuwrite_platform instead }
  985. procedure ppuwrite(ppufile:tcompilerppufile);override;final;
  986. procedure buildderef;override;
  987. procedure deref;override;
  988. function GetTypeName:string;override;
  989. function is_publishable : boolean;override;
  990. function alignment: shortint; override;
  991. end;
  992. tsetdefclass = class of tsetdef;
  993. tgenericdummyentry = class
  994. dummysym : tsym;
  995. resolvedsym : tsym;
  996. end;
  997. tdefawaresymtablestack = class(TSymtablestack)
  998. private
  999. procedure add_helpers_and_generics(st:tsymtable;addgenerics:boolean);
  1000. procedure remove_helpers_and_generics(st:tsymtable);inline;
  1001. procedure remove_helpers(st:tsymtable);
  1002. procedure remove_generics(st:tsymtable);
  1003. procedure pushcommon(st:tsymtable);inline;
  1004. public
  1005. procedure push(st: TSymtable); override;
  1006. procedure pushafter(st,afterst:TSymtable); override;
  1007. procedure pop(st: TSymtable); override;
  1008. end;
  1009. var
  1010. current_structdef: tabstractrecorddef; { used for private functions check !! }
  1011. current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class }
  1012. current_specializedef: tstoreddef; { used to implement usage of generic class in itself }
  1013. cfiledef: tfiledefclass;
  1014. cvariantdef: tvariantdefclass;
  1015. cformaldef: tformaldefclass;
  1016. cforwarddef: tforwarddefclass;
  1017. cundefineddef: tundefineddefclass;
  1018. cerrordef: terrordefclass;
  1019. cpointerdef: tpointerdefclass;
  1020. crecorddef: trecorddefclass;
  1021. cimplementedinterface: timplementedinterfaceclass;
  1022. cobjectdef: tobjectdefclass;
  1023. cclassrefdef: tclassrefdefclass;
  1024. carraydef: tarraydefclass;
  1025. corddef: torddefclass;
  1026. cfloatdef: tfloatdefclass;
  1027. cprocvardef: tprocvardefclass;
  1028. cprocdef: tprocdefclass;
  1029. cstringdef: tstringdefclass;
  1030. cenumdef: tenumdefclass;
  1031. csetdef: tsetdefclass;
  1032. { default types }
  1033. generrordef, { error in definition }
  1034. voidpointertype, { pointer for Void-pointeddef }
  1035. charpointertype, { pointer for Char-pointeddef }
  1036. widecharpointertype, { pointer for WideChar-pointeddef }
  1037. voidcodepointertype, { pointer to code; corresponds to System.CodePointer }
  1038. voidstackpointertype, { the pointer type used for accessing parameters and local vars on the stack }
  1039. parentfpvoidpointertype, { void pointer with the size of the hidden parentfp parameter, passed to nested functions }
  1040. {$ifdef x86}
  1041. voidnearpointertype,
  1042. voidnearcspointertype,
  1043. voidneardspointertype,
  1044. voidnearsspointertype,
  1045. voidnearespointertype,
  1046. voidnearfspointertype,
  1047. voidneargspointertype,
  1048. {$ifdef i8086}
  1049. voidfarpointertype,
  1050. voidhugepointertype,
  1051. charnearpointertype,
  1052. charfarpointertype,
  1053. charhugepointertype,
  1054. bytefarpointertype, { used for Mem[] }
  1055. wordfarpointertype, { used for MemW[] }
  1056. longintfarpointertype, { used for MemL[] }
  1057. {$endif i8086}
  1058. {$endif x86}
  1059. cundefinedtype,
  1060. cformaltype, { unique formal definition }
  1061. ctypedformaltype, { unique typed formal definition }
  1062. voidtype, { Void (procedure) }
  1063. cansichartype, { Char }
  1064. cwidechartype, { WideChar }
  1065. pasbool1type, { boolean type }
  1066. pasbool8type,
  1067. pasbool16type,
  1068. pasbool32type,
  1069. pasbool64type,
  1070. bool8type,
  1071. bool16type,
  1072. bool32type,
  1073. bool64type, { implement me }
  1074. {$ifdef llvm}
  1075. llvmbool1type, { LLVM i1 type }
  1076. {$endif llvm}
  1077. u8inttype, { 8-Bit unsigned integer }
  1078. s8inttype, { 8-Bit signed integer }
  1079. u16inttype, { 16-Bit unsigned integer }
  1080. s16inttype, { 16-Bit signed integer }
  1081. u24inttype, { 24-Bit unsigned integer }
  1082. s24inttype, { 24-Bit signed integer }
  1083. u32inttype, { 32-Bit unsigned integer }
  1084. s32inttype, { 32-Bit signed integer }
  1085. u40inttype, { 40-Bit unsigned integer }
  1086. s40inttype, { 40-Bit signed integer }
  1087. u48inttype, { 48-Bit unsigned integer }
  1088. s48inttype, { 48-Bit signed integer }
  1089. u56inttype, { 56-Bit unsigned integer }
  1090. s56inttype, { 56-Bit signed integer }
  1091. u64inttype, { 64-bit unsigned integer }
  1092. s64inttype, { 64-bit signed integer }
  1093. u128inttype, { 128-bit unsigned integer }
  1094. s128inttype, { 128-bit signed integer }
  1095. s32floattype, { 32 bit floating point number }
  1096. s64floattype, { 64 bit floating point number }
  1097. s80floattype, { 80 bit floating point number }
  1098. sc80floattype, { 80 bit floating point number but stored like in C }
  1099. s64currencytype, { pointer to a currency type }
  1100. cshortstringtype, { pointer to type of short string const }
  1101. clongstringtype, { pointer to type of long string const }
  1102. cansistringtype, { pointer to type of ansi string const }
  1103. cwidestringtype, { pointer to type of wide string const }
  1104. cunicodestringtype,
  1105. openshortstringtype, { pointer to type of an open shortstring,
  1106. needed for readln() }
  1107. openchararraytype, { pointer to type of an open array of char,
  1108. needed for readln() }
  1109. cfiletype, { get the same definition for all file }
  1110. { used for stabs }
  1111. methodpointertype, { typecasting of methodpointers to extract self }
  1112. nestedprocpointertype, { typecasting of nestedprocpointers to extract parentfp }
  1113. hresultdef,
  1114. typekindtype, { def of TTypeKind for correct handling of GetTypeKind parameters }
  1115. { we use only one variant def for every variant class }
  1116. cvarianttype,
  1117. colevarianttype,
  1118. { default integer type, normally s32inttype on 32 bit systems and s64bittype on 64 bit systems }
  1119. sinttype,
  1120. uinttype,
  1121. { integer types corresponding to OS_SINT/OS_INT }
  1122. ossinttype,
  1123. osuinttype,
  1124. { integer types corresponding to the ALU size, sizeof(aint) and the ALUSInt/ALUUInt types in the system unit }
  1125. alusinttype,
  1126. aluuinttype,
  1127. { integer types corresponding to SizeInt and SizeUInt for the target platform }
  1128. sizeuinttype,
  1129. sizesinttype,
  1130. { unsigned and signed ord type with the same size as a pointer }
  1131. ptruinttype,
  1132. ptrsinttype,
  1133. { unsigned and signed ord type with the same size as a codepointer }
  1134. codeptruinttype,
  1135. codeptrsinttype,
  1136. { several types to simulate more or less C++ objects for GDB }
  1137. vmttype,
  1138. vmtarraytype,
  1139. { type of classrefs, used for stabs }
  1140. pvmttype,
  1141. { return type of the setjmp function }
  1142. exceptionreasontype : tdef;
  1143. { pointer to the anchestor of all classes }
  1144. class_tobject : tobjectdef;
  1145. { pointer to the base type for custom attributes }
  1146. class_tcustomattribute : tobjectdef;
  1147. { pointer to the ancestor of all COM interfaces }
  1148. interface_iunknown : tobjectdef;
  1149. { pointer to the ancestor of all dispinterfaces }
  1150. interface_idispatch : tobjectdef;
  1151. { pointer to the TGUID type
  1152. of all interfaces }
  1153. rec_tguid : trecorddef;
  1154. { jump buffer type, used by setjmp }
  1155. rec_jmp_buf : trecorddef;
  1156. { system.texceptaddr type, used by fpc_pushexceptaddr }
  1157. rec_exceptaddr: trecorddef;
  1158. { Objective-C base types }
  1159. objc_metaclasstype,
  1160. objc_superclasstype,
  1161. objc_idtype,
  1162. objc_seltype : tpointerdef;
  1163. objc_objecttype : trecorddef;
  1164. { base type of @protocol(protocolname) Objective-C statements }
  1165. objc_protocoltype : tobjectdef;
  1166. { helper types for for-in "fast enumeration" support in Objective-C 2.0 }
  1167. objc_fastenumeration : tobjectdef;
  1168. objc_fastenumerationstate : trecorddef;
  1169. {$ifdef llvm}
  1170. { llvm types }
  1171. { a unique def to identify any kind of metadata }
  1172. llvm_metadatatype : tdef;
  1173. {$endif llvm}
  1174. { Java base types }
  1175. { java.lang.Object }
  1176. java_jlobject : tobjectdef;
  1177. { java.lang.Throwable }
  1178. java_jlthrowable : tobjectdef;
  1179. { FPC base type for records }
  1180. java_fpcbaserecordtype : tobjectdef;
  1181. { java.lang.String }
  1182. java_jlstring : tobjectdef;
  1183. { java.lang.Enum }
  1184. java_jlenum : tobjectdef;
  1185. { java.util.EnumSet }
  1186. java_juenumset : tobjectdef;
  1187. { java.util.BitSet }
  1188. java_jubitset : tobjectdef;
  1189. { FPC java implementation of ansistrings }
  1190. java_ansistring : tobjectdef;
  1191. { FPC java implementation of shortstrings }
  1192. java_shortstring : tobjectdef;
  1193. { FPC java procvar base class }
  1194. java_procvarbase : tobjectdef;
  1195. { x86 vector types }
  1196. x86_m64type,
  1197. x86_m128type,
  1198. x86_m128dtype,
  1199. x86_m128itype,
  1200. x86_m256type,
  1201. x86_m256dtype,
  1202. x86_m256itype : tdef;
  1203. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  1204. function make_dllmangledname(const dllname,importname:TSymStr;
  1205. import_nr : word; pco : tproccalloption):TSymStr;
  1206. { should be in the types unit, but the types unit uses the node stuff :( }
  1207. function is_interfacecom(def: tdef): boolean;
  1208. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  1209. function is_any_interface_kind(def: tdef): boolean;
  1210. function is_interfacecorba(def: tdef): boolean;
  1211. function is_interface(def: tdef): boolean;
  1212. function is_dispinterface(def: tdef): boolean;
  1213. function is_object(def: tdef): boolean;
  1214. function is_class(def: tdef): boolean;
  1215. function is_cppclass(def: tdef): boolean;
  1216. function is_objectpascal_helper(def: tdef): boolean;
  1217. function is_objcclass(def: tdef): boolean;
  1218. function is_objcclassref(def: tdef): boolean;
  1219. function is_objcprotocol(def: tdef): boolean;
  1220. function is_objccategory(def: tdef): boolean;
  1221. function is_objc_class_or_protocol(def: tdef): boolean;
  1222. function is_objc_protocol_or_category(def: tdef): boolean;
  1223. function is_classhelper(def: tdef): boolean;
  1224. function is_class_or_interface(def: tdef): boolean;
  1225. function is_class_or_interface_or_objc(def: tdef): boolean;
  1226. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  1227. function is_class_or_interface_or_dispinterface_or_objc_or_java(def: tdef): boolean;
  1228. function is_class_or_interface_or_object(def: tdef): boolean;
  1229. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  1230. function is_implicit_pointer_object_type(def: tdef): boolean;
  1231. { returns true, if def is a type which is an implicit pointer to an array (dyn. array or dyn. string) }
  1232. function is_implicit_array_pointer(def: tdef): boolean;
  1233. function is_class_or_object(def: tdef): boolean;
  1234. function is_record(def: tdef): boolean;
  1235. function is_javaclass(def: tdef): boolean;
  1236. function is_javaclassref(def: tdef): boolean;
  1237. function is_javainterface(def: tdef): boolean;
  1238. function is_java_class_or_interface(def: tdef): boolean;
  1239. procedure loadobjctypes;
  1240. procedure maybeloadcocoatypes;
  1241. function use_vectorfpu(def : tdef) : boolean;
  1242. function getansistringcodepage:tstringencoding; inline;
  1243. function getansistringdef:tstringdef;
  1244. function getparaencoding(def:tdef):tstringencoding; inline;
  1245. function get_threadvar_record(def: tdef; out index_field, non_mt_data_field: tsym): trecorddef;
  1246. function get_recorddef(prefix:tinternaltypeprefix;const fields:array of tdef; packrecords:shortint): trecorddef;
  1247. { get a table def of the form
  1248. record
  1249. count: countdef;
  1250. elements: array[0..count-1] of elementdef
  1251. end;
  1252. Returns both the outer record and the inner arraydef
  1253. }
  1254. procedure get_tabledef(prefix:tinternaltypeprefix;countdef,elementdef:tdef;count:longint;packrecords:shortint;out recdef:trecorddef;out arrdef:tarraydef);
  1255. implementation
  1256. uses
  1257. SysUtils,
  1258. cutils,
  1259. { global }
  1260. verbose,
  1261. { target }
  1262. systems,paramgr,
  1263. { symtable }
  1264. symsym,symtable,defutil,objcdef,
  1265. { parser }
  1266. pgenutil,
  1267. { module }
  1268. fmodule,ppu,
  1269. { other }
  1270. aasmbase,
  1271. gendef,
  1272. fpchash,
  1273. entfile
  1274. ;
  1275. {****************************************************************************
  1276. Helpers
  1277. ****************************************************************************}
  1278. function getansistringcodepage:tstringencoding; inline;
  1279. begin
  1280. if ([cs_explicit_codepage,cs_system_codepage]*current_settings.moduleswitches)<>[] then
  1281. result:=current_settings.sourcecodepage
  1282. else
  1283. result:=0;
  1284. end;
  1285. function getansistringdef:tstringdef;
  1286. var
  1287. symtable:tsymtable;
  1288. oldstack : tsymtablestack;
  1289. begin
  1290. { if a codepage is explicitly defined in this mudule we need to return
  1291. a replacement for ansistring def }
  1292. if ([cs_explicit_codepage,cs_system_codepage]*current_settings.moduleswitches)<>[] then
  1293. begin
  1294. if not assigned(current_module) then
  1295. internalerror(2011101301);
  1296. { codepage can be redeclared only once per unit so we don't need a list of
  1297. redefined ansistring but only one pointer }
  1298. if not assigned(current_module.ansistrdef) then
  1299. begin
  1300. { if we did not create it yet we need to do this now }
  1301. if current_module.in_interface then
  1302. symtable:=current_module.globalsymtable
  1303. else
  1304. symtable:=current_module.localsymtable;
  1305. { create a temporary stack as it's not good (TM) to mess around
  1306. with the order if the unit contains generics or helpers; don't
  1307. use a def aware symtablestack though }
  1308. oldstack:=symtablestack;
  1309. symtablestack:=tsymtablestack.create;
  1310. symtablestack.push(symtable);
  1311. current_module.ansistrdef:=cstringdef.createansi(current_settings.sourcecodepage,true);
  1312. symtablestack.pop(symtable);
  1313. symtablestack.free;
  1314. symtablestack:=oldstack;
  1315. end;
  1316. result:=tstringdef(current_module.ansistrdef);
  1317. end
  1318. else
  1319. result:=tstringdef(cansistringtype);
  1320. end;
  1321. function getparaencoding(def:tdef):tstringencoding; inline;
  1322. begin
  1323. { don't pass CP_NONE encoding to internal functions
  1324. they expect 0 encoding instead
  1325. exception: result of string concatenation, because if you pass the
  1326. result of a string concatenation to a rawbytestring, the result of
  1327. that concatenation shouldn't be converted to defaultsystemcodepage
  1328. if all strings have the same type }
  1329. result:=tstringdef(def).encoding;
  1330. if result=globals.CP_NONE then
  1331. result:=0
  1332. end;
  1333. function get_threadvar_record(def: tdef; out index_field, non_mt_data_field: tsym): trecorddef;
  1334. var
  1335. typ: ttypesym;
  1336. name: string;
  1337. begin
  1338. name:=internaltypeprefixName[itp_threadvar_record]+def.unique_id_str;
  1339. typ:=try_search_current_module_type(name);
  1340. if assigned(typ) then
  1341. begin
  1342. result:=trecorddef(ttypesym(typ).typedef);
  1343. index_field:=tsym(result.symtable.symlist[0]);
  1344. non_mt_data_field:=tsym(result.symtable.symlist[1]);
  1345. exit;
  1346. end;
  1347. { set recordalinmin to sizeof(pint), so the second field gets put at
  1348. offset = sizeof(pint) as expected }
  1349. result:=crecorddef.create_global_internal(
  1350. name,sizeof(pint),sizeof(pint));
  1351. {$ifdef cpu16bitaddr}
  1352. index_field:=result.add_field_by_def('',u16inttype);
  1353. {$else cpu16bitaddr}
  1354. index_field:=result.add_field_by_def('',u32inttype);
  1355. {$endif cpu16bitaddr}
  1356. non_mt_data_field:=result.add_field_by_def('',def);
  1357. { no need to add alignment padding, we won't create arrays of these }
  1358. end;
  1359. function get_recorddef(prefix:tinternaltypeprefix; const fields:array of tdef; packrecords:shortint): trecorddef;
  1360. var
  1361. fieldlist: tfplist;
  1362. srsym: tsym;
  1363. srsymtable: tsymtable;
  1364. i: longint;
  1365. name : TIDString;
  1366. begin
  1367. name:=copy(internaltypeprefixName[prefix],2,length(internaltypeprefixName[prefix]));
  1368. if searchsym_type(name,srsym,srsymtable) then
  1369. begin
  1370. result:=trecorddef(ttypesym(srsym).typedef);
  1371. exit
  1372. end;
  1373. { also always search in the current module (symtables are popped for
  1374. RTTI related code already) }
  1375. if searchsym_in_module(pointer(current_module),name,srsym,srsymtable) then
  1376. begin
  1377. result:=trecorddef(ttypesym(srsym).typedef);
  1378. exit;
  1379. end;
  1380. fieldlist:=tfplist.create;
  1381. for i:=low(fields) to high(fields) do
  1382. fieldlist.add(fields[i]);
  1383. result:=crecorddef.create_global_internal(internaltypeprefixName[prefix],packrecords,
  1384. targetinfos[target_info.system]^.alignment.recordalignmin);
  1385. result.add_fields_from_deflist(fieldlist);
  1386. fieldlist.free;
  1387. end;
  1388. procedure get_tabledef(prefix:tinternaltypeprefix;countdef,elementdef:tdef;count:longint;packrecords:shortint;out recdef:trecorddef;out arrdef:tarraydef);
  1389. var
  1390. fields: tfplist;
  1391. name: TIDString;
  1392. srsym: tsym;
  1393. srsymtable: tsymtable;
  1394. begin
  1395. { already created a message string table with this number of elements
  1396. in this unit -> reuse the def }
  1397. name:=internaltypeprefixName[prefix]+tostr(count);
  1398. if searchsym_type(copy(name,2,length(name)),srsym,srsymtable) then
  1399. begin
  1400. recdef:=trecorddef(ttypesym(srsym).typedef);
  1401. arrdef:=tarraydef(trecordsymtable(recdef.symtable).findfieldbyoffset(countdef.size).vardef);
  1402. exit
  1403. end;
  1404. { also always search in the current module (symtables are popped for
  1405. RTTI related code already) }
  1406. if searchsym_in_module(pointer(current_module),copy(name,2,length(name)),srsym,srsymtable) then
  1407. begin
  1408. recdef:=trecorddef(ttypesym(srsym).typedef);
  1409. arrdef:=tarraydef(trecordsymtable(recdef.symtable).findfieldbyoffset(countdef.size).vardef);
  1410. exit;
  1411. end;
  1412. recdef:=crecorddef.create_global_internal(name,packrecords,
  1413. targetinfos[target_info.system]^.alignment.recordalignmin);
  1414. fields:=tfplist.create;
  1415. fields.add(countdef);
  1416. if count>0 then
  1417. begin
  1418. arrdef:=carraydef.create(0,count-1,sizeuinttype);
  1419. arrdef.elementdef:=elementdef;
  1420. fields.add(arrdef);
  1421. end
  1422. else
  1423. arrdef:=nil;
  1424. recdef.add_fields_from_deflist(fields);
  1425. fields.free;
  1426. end;
  1427. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  1428. var
  1429. s,
  1430. prefix : TSymStr;
  1431. hash : qword;
  1432. begin
  1433. prefix:='';
  1434. if not assigned(st) then
  1435. internalerror(200204212);
  1436. repeat
  1437. { sub procedures }
  1438. while (st.symtabletype in [localsymtable,parasymtable]) do
  1439. begin
  1440. if st.defowner.typ<>procdef then
  1441. internalerror(200204173);
  1442. { Add the full mangledname of the routine to prevent
  1443. conflicts with two overloads both having a local entity
  1444. -- routine (tb0314), class, interface -- with the same name }
  1445. s:=tprocdef(st.defowner).procsym.name;
  1446. s:=s+tprocdef(st.defowner).mangledprocparanames(Length(s));
  1447. if prefix<>'' then
  1448. begin
  1449. if length(prefix)>(maxidlen-length(s)-1) then
  1450. begin
  1451. hash:=0;
  1452. hash:=UpdateFnv64(hash,prefix[1],length(prefix));
  1453. prefix:='$H'+Base64Mangle(hash);
  1454. end;
  1455. prefix:=s+'_'+prefix
  1456. end
  1457. else
  1458. prefix:=s;
  1459. st:=st.defowner.owner;
  1460. end;
  1461. { object/classes symtable, nested type definitions in classes require the while loop }
  1462. while st.symtabletype in [ObjectSymtable,recordsymtable] do
  1463. begin
  1464. if not (st.defowner.typ in [objectdef,recorddef]) then
  1465. internalerror(200204174);
  1466. if length(prefix)>(maxidlen-length(tabstractrecorddef(st.defowner).objname^)-3) then
  1467. begin
  1468. hash:=0;
  1469. hash:=UpdateFnv64(hash,prefix[1],length(prefix));
  1470. prefix:='$H'+Base64Mangle(hash);
  1471. end;
  1472. prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
  1473. st:=st.defowner.owner;
  1474. end;
  1475. { local classes & interfaces are possible (because of closures) }
  1476. if st.symtabletype<>localsymtable then
  1477. break;
  1478. prefix:='$'+prefix;
  1479. until false;
  1480. { symtable must now be static or global }
  1481. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  1482. internalerror(200204175);
  1483. { The mangled name is made out of at most 4 parts:
  1484. 1) Optional typeprefix given as first parameter
  1485. with '_$' appended if not empty
  1486. 2) Unit name or 'P$'+program name (never empty)
  1487. 3) optional prefix variable that contains a unique
  1488. name for the local symbol table (prepended with '$_$'
  1489. if not empty)
  1490. 4) suffix as given as third parameter,
  1491. also optional (i.e. can be empty)
  1492. prepended by '_$$_' if not empty }
  1493. result:='';
  1494. if typeprefix<>'' then
  1495. result:=result+typeprefix+'_$';
  1496. { Add P$ for program, which can have the same name as
  1497. a unit }
  1498. if (TSymtable(main_module.localsymtable)=st) and
  1499. (not main_module.is_unit) then
  1500. result:=result+'P$'+st.name^
  1501. else
  1502. result:=result+st.name^;
  1503. if prefix<>'' then
  1504. result:=result+'$_$'+prefix;
  1505. if suffix<>'' then
  1506. result:=result+'_$$_'+suffix;
  1507. if length(result)>(maxidlen-1) then
  1508. begin
  1509. hash:=0;
  1510. hash:=UpdateFnv64(hash,result[1],length(result));
  1511. result:=copy(result,1,maxidlen-(high(Base64OfUint64String)-low(Base64OfUint64String)+1)-2)+'$H'+Base64Mangle(hash);
  1512. end;
  1513. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  1514. { Further, the Mac OS X 10.5 linker does not consider symbols which do not }
  1515. { start with '_' as regular symbols (it does not generate N_GSYM entries }
  1516. { those in the debug map, leading to troubles with dsymutil). So always }
  1517. { add an underscore on darwin. }
  1518. if (target_info.system in systems_darwin) then
  1519. result := '_' + result;
  1520. end;
  1521. function make_dllmangledname(const dllname,importname:TSymStr;import_nr : word; pco : tproccalloption):TSymStr;
  1522. var
  1523. crc : cardinal;
  1524. i : longint;
  1525. use_crc : boolean;
  1526. dllprefix : TSymStr;
  1527. begin
  1528. if (target_info.system in (systems_all_windows + systems_nativent +
  1529. [system_i386_emx, system_i386_os2]))
  1530. and (dllname <> '') then
  1531. begin
  1532. dllprefix:=lower(ExtractFileName(dllname));
  1533. { Remove .dll suffix if present }
  1534. if copy(dllprefix,length(dllprefix)-3,length(dllprefix))='.dll' then
  1535. dllprefix:=copy(dllprefix,1,length(dllprefix)-4);
  1536. use_crc:=false;
  1537. for i:=1 to length(dllprefix) do
  1538. if not (dllprefix[i] in ['a'..'z','A'..'Z','_','0'..'9']) then
  1539. begin
  1540. use_crc:=true;
  1541. break;
  1542. end;
  1543. if use_crc then
  1544. begin
  1545. crc:=0;
  1546. crc:=UpdateCrc32(crc,dllprefix[1],length(dllprefix));
  1547. dllprefix:='_$dll$crc$'+hexstr(crc,8)+'$';
  1548. end
  1549. else
  1550. dllprefix:='_$dll$'+dllprefix+'$';
  1551. if importname<>'' then
  1552. result:=dllprefix+importname
  1553. else
  1554. result:=dllprefix+'_index_'+tostr(import_nr);
  1555. { Replace ? and @ in import name, since GNU AS does not allow these characters in symbol names. }
  1556. { This allows to import VC++ mangled names from DLLs. }
  1557. { Do not perform replacement, if external symbol is not imported from DLL. }
  1558. if (dllname<>'') then
  1559. begin
  1560. Replace(result,'?','__q$$');
  1561. {$ifdef arm}
  1562. { @ symbol is not allowed in ARM assembler only }
  1563. Replace(result,'@','__a$$');
  1564. {$endif arm}
  1565. end;
  1566. end
  1567. else
  1568. begin
  1569. if importname<>'' then
  1570. begin
  1571. if not(pco in [pocall_cdecl,pocall_cppdecl]) then
  1572. result:=importname
  1573. else
  1574. result:=target_info.Cprefix+importname;
  1575. end
  1576. else
  1577. result:='_index_'+tostr(import_nr);
  1578. end;
  1579. end;
  1580. {****************************************************************************
  1581. TDEFAWARESYMTABLESTACK
  1582. (symtablestack descendant that does some special actions on
  1583. the pushed/popped symtables)
  1584. ****************************************************************************}
  1585. procedure tdefawaresymtablestack.add_helpers_and_generics(st:tsymtable;addgenerics:boolean);
  1586. var
  1587. s: TSymStr;
  1588. list: TFPObjectList;
  1589. def: tdef;
  1590. sym : tsym;
  1591. i: integer;
  1592. begin
  1593. { search the symtable from first to last; the helper to use will be the
  1594. last one in the list }
  1595. for i:=0 to st.symlist.count-1 do
  1596. begin
  1597. sym:=tsym(st.symlist[i]);
  1598. if not (sym.typ in [typesym,procsym]) then
  1599. continue;
  1600. if sym.typ=typesym then
  1601. def:=ttypesym(st.SymList[i]).typedef
  1602. else
  1603. def:=nil;
  1604. if is_objectpascal_helper(def) then
  1605. begin
  1606. s:=generate_objectpascal_helper_key(tobjectdef(def).extendeddef);
  1607. Message1(sym_d_adding_helper_for,s);
  1608. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  1609. if not assigned(list) then
  1610. begin
  1611. list:=TFPObjectList.Create(false);
  1612. current_module.extendeddefs.Add(s,list);
  1613. end;
  1614. list.Add(def);
  1615. end
  1616. else
  1617. begin
  1618. if addgenerics then
  1619. add_generic_dummysym(sym);
  1620. { add nested helpers as well }
  1621. if assigned(def) and
  1622. (def.typ in [recorddef,objectdef]) and
  1623. (sto_has_helper in tabstractrecorddef(def).symtable.tableoptions) then
  1624. add_helpers_and_generics(tabstractrecorddef(def).symtable,false);
  1625. end;
  1626. end;
  1627. end;
  1628. procedure tdefawaresymtablestack.remove_helpers_and_generics(st:tsymtable);
  1629. begin
  1630. if sto_has_helper in st.tableoptions then
  1631. remove_helpers(st);
  1632. if sto_has_generic in st.tableoptions then
  1633. remove_generics(st);
  1634. end;
  1635. procedure tdefawaresymtablestack.remove_helpers(st:TSymtable);
  1636. var
  1637. i, j: integer;
  1638. tmpst: TSymtable;
  1639. list: TFPObjectList;
  1640. begin
  1641. for i:=current_module.extendeddefs.count-1 downto 0 do
  1642. begin
  1643. list:=TFPObjectList(current_module.extendeddefs[i]);
  1644. for j:=list.count-1 downto 0 do
  1645. begin
  1646. if not (list[j] is tobjectdef) then
  1647. Internalerror(2011031501);
  1648. tmpst:=tobjectdef(list[j]).owner;
  1649. repeat
  1650. if tmpst=st then
  1651. begin
  1652. list.delete(j);
  1653. break;
  1654. end
  1655. else
  1656. begin
  1657. if assigned(tmpst.defowner) then
  1658. tmpst:=tmpst.defowner.owner
  1659. else
  1660. tmpst:=nil;
  1661. end;
  1662. until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]);
  1663. end;
  1664. if list.count=0 then
  1665. current_module.extendeddefs.delete(i);
  1666. end;
  1667. end;
  1668. procedure tdefawaresymtablestack.remove_generics(st:tsymtable);
  1669. var
  1670. i,j : longint;
  1671. entry : tgenericdummyentry;
  1672. list : tfpobjectlist;
  1673. begin
  1674. for i:=current_module.genericdummysyms.count-1 downto 0 do
  1675. begin
  1676. list:=tfpobjectlist(current_module.genericdummysyms[i]);
  1677. if not assigned(list) then
  1678. continue;
  1679. for j:=list.count-1 downto 0 do
  1680. begin
  1681. entry:=tgenericdummyentry(list[j]);
  1682. if entry.dummysym.owner=st then
  1683. list.delete(j);
  1684. end;
  1685. if list.count=0 then
  1686. current_module.genericdummysyms.delete(i);
  1687. end;
  1688. end;
  1689. procedure tdefawaresymtablestack.pushcommon(st:tsymtable);
  1690. begin
  1691. if (sto_has_generic in st.tableoptions) or
  1692. (
  1693. (st.symtabletype in [globalsymtable,staticsymtable]) and
  1694. (sto_has_helper in st.tableoptions)
  1695. ) then
  1696. { nested helpers will be added as well }
  1697. add_helpers_and_generics(st,true);
  1698. end;
  1699. procedure tdefawaresymtablestack.push(st: TSymtable);
  1700. begin
  1701. pushcommon(st);
  1702. inherited push(st);
  1703. end;
  1704. procedure tdefawaresymtablestack.pushafter(st,afterst:TSymtable);
  1705. begin
  1706. pushcommon(st);
  1707. inherited pushafter(st,afterst);
  1708. end;
  1709. procedure tdefawaresymtablestack.pop(st: TSymtable);
  1710. begin
  1711. inherited pop(st);
  1712. if (sto_has_generic in st.tableoptions) or
  1713. (
  1714. (st.symtabletype in [globalsymtable,staticsymtable]) and
  1715. (sto_has_helper in st.tableoptions)
  1716. ) then
  1717. { nested helpers will be removed as well }
  1718. remove_helpers_and_generics(st);
  1719. end;
  1720. {****************************************************************************
  1721. TDEF (base class for definitions)
  1722. ****************************************************************************}
  1723. constructor tgenericconstraintdata.create;
  1724. begin
  1725. interfaces:=tfpobjectlist.create(false);
  1726. interfacesderef:=tfplist.create;
  1727. end;
  1728. destructor tgenericconstraintdata.destroy;
  1729. var
  1730. i : longint;
  1731. begin
  1732. for i:=0 to interfacesderef.count-1 do
  1733. dispose(pderef(interfacesderef[i]));
  1734. interfacesderef.free;
  1735. interfaces.free;
  1736. inherited destroy;
  1737. end;
  1738. procedure tgenericconstraintdata.ppuload(ppufile: tcompilerppufile);
  1739. var
  1740. cnt,i : longint;
  1741. intfderef : pderef;
  1742. begin
  1743. ppufile.getset(tppuset1(flags));
  1744. cnt:=ppufile.getlongint;
  1745. for i:=0 to cnt-1 do
  1746. begin
  1747. new(intfderef);
  1748. ppufile.getderef(intfderef^);
  1749. interfacesderef.add(intfderef);
  1750. end;
  1751. end;
  1752. procedure tgenericconstraintdata.ppuwrite(ppufile: tcompilerppufile);
  1753. var
  1754. i : longint;
  1755. begin
  1756. ppufile.putset(tppuset1(flags));
  1757. ppufile.putlongint(interfacesderef.count);
  1758. for i:=0 to interfacesderef.count-1 do
  1759. ppufile.putderef(pderef(interfacesderef[i])^);
  1760. end;
  1761. procedure tgenericconstraintdata.buildderef;
  1762. var
  1763. intfderef : pderef;
  1764. i : longint;
  1765. begin
  1766. for i:=0 to interfaces.count-1 do
  1767. begin
  1768. new(intfderef);
  1769. intfderef^.build(tobjectdef(interfaces[i]));
  1770. interfacesderef.add(intfderef);
  1771. end;
  1772. end;
  1773. procedure tgenericconstraintdata.deref;
  1774. var
  1775. i : longint;
  1776. begin
  1777. for i:=0 to interfacesderef.count-1 do
  1778. interfaces.add(pderef(interfacesderef[i])^.resolve);
  1779. end;
  1780. procedure tstoreddef.writeentry(ppufile: tcompilerppufile; ibnr: byte);
  1781. begin
  1782. ppuwrite_platform(ppufile);
  1783. ppufile.writeentry(ibnr);
  1784. end;
  1785. procedure tstoreddef.ppuwrite_platform(ppufile: tcompilerppufile);
  1786. begin
  1787. { by default: do nothing }
  1788. end;
  1789. procedure tstoreddef.ppuload_platform(ppufile: tcompilerppufile);
  1790. begin
  1791. { by default: do nothing }
  1792. end;
  1793. class procedure tstoreddef.setup_reusable_def(origdef, newdef: tdef; res: PHashSetItem; oldsymtablestack: tsymtablestack);
  1794. var
  1795. reusablesymtab: tsymtable;
  1796. begin
  1797. { must not yet belong to a symtable }
  1798. if assigned(newdef.owner) then
  1799. internalerror(2015111503);
  1800. reusablesymtab:=origdef.getreusablesymtab;
  1801. res^.Data:=newdef;
  1802. reusablesymtab.insertdef(newdef);
  1803. symtablestack:=oldsymtablestack;
  1804. end;
  1805. constructor tstoreddef.create(dt:tdeftyp;doregister:boolean);
  1806. begin
  1807. inherited create(dt);
  1808. savesize := 0;
  1809. {$ifdef EXTDEBUG}
  1810. fileinfo := current_filepos;
  1811. {$endif}
  1812. generictokenbuf:=nil;
  1813. genericdef:=nil;
  1814. typesymderef.reset;
  1815. genericdefderef.reset;
  1816. { Don't register forwarddefs, they are disposed at the
  1817. end of an type block }
  1818. if (dt=forwarddef) then
  1819. exit;
  1820. { Register in symtable stack }
  1821. if doregister then
  1822. begin
  1823. { immediately register interface defs, as they will always be
  1824. written to the ppu, their defid inlfuences the interface crc and
  1825. if we wait, depending on e.g. compiler defines they may get a
  1826. different defid (e.g. when a function is called, its procdef is
  1827. registered, so depending on whether or not, or when, an interface
  1828. procedure is called in the implementation, that may change its
  1829. defid otherwise) }
  1830. if assigned(current_module) and
  1831. current_module.in_interface then
  1832. register_def
  1833. else
  1834. maybe_put_in_symtable_stack;
  1835. end;
  1836. end;
  1837. destructor tstoreddef.destroy;
  1838. var
  1839. i : longint;
  1840. begin
  1841. { Direct calls are not allowed, use symtable.deletedef() }
  1842. if assigned(owner) then
  1843. internalerror(200612311);
  1844. if assigned(generictokenbuf) then
  1845. begin
  1846. generictokenbuf.free;
  1847. generictokenbuf:=nil;
  1848. end;
  1849. rtti_attribute_list.free;
  1850. genericparas.free;
  1851. if assigned(genericparaderefs) then
  1852. for i:=0 to genericparaderefs.count-1 do
  1853. dispose(pderef(genericparaderefs[i]));
  1854. genericparaderefs.free;
  1855. genconstraintdata.free;
  1856. {$ifndef symansistr}
  1857. stringdispose(_fullownerhierarchyname);
  1858. {$endif not symansistr}
  1859. inherited destroy;
  1860. end;
  1861. constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1862. var
  1863. sizeleft,i,cnt : longint;
  1864. buf : array[0..255] of byte;
  1865. symderef : pderef;
  1866. begin
  1867. inherited create(dt);
  1868. DefId:=ppufile.getlongint;
  1869. current_module.deflist[DefId]:=self;
  1870. {$ifdef EXTDEBUG}
  1871. fillchar(fileinfo,sizeof(fileinfo),0);
  1872. {$endif}
  1873. { load }
  1874. ppufile.getderef(typesymderef);
  1875. ppufile.getset(tppuset2(defoptions));
  1876. ppufile.getset(tppuset1(defstates));
  1877. if df_genconstraint in defoptions then
  1878. begin
  1879. genconstraintdata:=tgenericconstraintdata.create;
  1880. genconstraintdata.ppuload(ppufile);
  1881. end;
  1882. if [df_generic,df_specialization]*defoptions<>[] then
  1883. begin
  1884. cnt:=ppufile.getlongint;
  1885. if cnt>0 then
  1886. begin
  1887. genericparas:=tfphashobjectlist.create(false);
  1888. genericparaderefs:=tfplist.create;
  1889. for i:=0 to cnt-1 do
  1890. begin
  1891. genericparas.add(ppufile.getstring,nil);
  1892. New(symderef);
  1893. ppufile.getderef(symderef^);
  1894. genericparaderefs.add(symderef);
  1895. end;
  1896. end;
  1897. end;
  1898. if df_generic in defoptions then
  1899. begin
  1900. sizeleft:=ppufile.getlongint;
  1901. initgeneric;
  1902. while sizeleft>0 do
  1903. begin
  1904. if sizeleft>sizeof(buf) then
  1905. i:=sizeof(buf)
  1906. else
  1907. i:=sizeleft;
  1908. ppufile.getdata(buf,i);
  1909. generictokenbuf.write(buf,i);
  1910. dec(sizeleft,i);
  1911. end;
  1912. end;
  1913. if df_specialization in defoptions then
  1914. ppufile.getderef(genericdefderef);
  1915. rtti_attribute_list:=trtti_attribute_list.ppuload(ppufile);
  1916. end;
  1917. function tstoreddef.needs_separate_initrtti:boolean;
  1918. begin
  1919. result:=false;
  1920. end;
  1921. function tstoreddef.rtti_mangledname(rt : trttitype) : TSymStr;
  1922. var
  1923. prefix : string[4];
  1924. begin
  1925. if (rt=fullrtti) or (not needs_separate_initrtti) then
  1926. begin
  1927. prefix:='RTTI';
  1928. include(defstates,ds_rtti_table_used);
  1929. end
  1930. else
  1931. begin
  1932. prefix:='INIT';
  1933. include(defstates,ds_init_table_used);
  1934. end;
  1935. if assigned(typesym) and
  1936. (owner.symtabletype in [staticsymtable,globalsymtable]) then
  1937. result:=make_mangledname(prefix,typesym.owner,typesym.name)
  1938. else
  1939. result:=make_mangledname(prefix,findunitsymtable(owner),'def'+unique_id_str)
  1940. end;
  1941. function tstoreddef.OwnerHierarchyName: string;
  1942. var
  1943. tmp: tdef;
  1944. begin
  1945. tmp:=self;
  1946. result:='';
  1947. repeat
  1948. { can be not assigned in case of a forwarddef }
  1949. if assigned(tmp.owner) and
  1950. (tmp.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  1951. tmp:=tdef(tmp.owner.defowner)
  1952. else
  1953. break;
  1954. result:=tabstractrecorddef(tmp).objrealname^+'.'+result;
  1955. until tmp=nil;
  1956. end;
  1957. function tstoreddef.fullownerhierarchyname(skipprocparams:boolean): TSymStr;
  1958. var
  1959. lastowner: tsymtable;
  1960. tmp: tdef;
  1961. pno: tprocnameoptions;
  1962. begin
  1963. {$ifdef symansistr}
  1964. if not skipprocparams and (_fullownerhierarchyname<>'') then
  1965. exit(_fullownerhierarchyname);
  1966. {$else symansistr}
  1967. if not skipprocparams and assigned(_fullownerhierarchyname) then
  1968. exit(_fullownerhierarchyname^);
  1969. {$endif symansistr}
  1970. { the def can only reside inside structured types or
  1971. procedures/functions/methods }
  1972. tmp:=self;
  1973. result:='';
  1974. repeat
  1975. lastowner:=tmp.owner;
  1976. { can be not assigned in case of a forwarddef }
  1977. if not assigned(lastowner) then
  1978. break
  1979. else
  1980. tmp:=tdef(lastowner.defowner);
  1981. if not assigned(tmp) then
  1982. break;
  1983. if tmp.typ in [recorddef,objectdef] then
  1984. result:=tabstractrecorddef(tmp).objrealname^+'.'+result
  1985. else
  1986. if tmp.typ=procdef then
  1987. begin
  1988. pno:=[pno_paranames,pno_proctypeoption];
  1989. if skipprocparams then
  1990. include(pno,pno_noparams);
  1991. result:=tprocdef(tmp).customprocname(pno)+'.'+result;
  1992. end;
  1993. until tmp=nil;
  1994. { add the unit name }
  1995. if assigned(lastowner) and
  1996. assigned(lastowner.realname) then
  1997. result:=lastowner.realname^+'.'+result;
  1998. if not skipprocparams then
  1999. { don't store the name in this case }
  2000. {$ifdef symansistr}
  2001. _fullownerhierarchyname:=result;
  2002. {$else symansistr}
  2003. _fullownerhierarchyname:=stringdup(result);
  2004. {$endif symansistr}
  2005. end;
  2006. function tstoreddef.in_currentunit: boolean;
  2007. var
  2008. st: tsymtable;
  2009. begin
  2010. st:=owner;
  2011. while not(st.symtabletype in [globalsymtable,staticsymtable]) do
  2012. st:=st.defowner.owner;
  2013. result:=st.iscurrentunit;
  2014. end;
  2015. function tstoreddef.getcopy : tstoreddef;
  2016. begin
  2017. Message(sym_e_cant_create_unique_type);
  2018. getcopy:=cerrordef.create;
  2019. end;
  2020. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  2021. var
  2022. sizeleft,i : longint;
  2023. buf : array[0..255] of byte;
  2024. oldintfcrc : boolean;
  2025. begin
  2026. if defid<0 then
  2027. internalerror(2015101401);
  2028. ppufile.putlongint(DefId);
  2029. ppufile.putderef(typesymderef);
  2030. ppufile.putset(tppuset2(defoptions));
  2031. oldintfcrc:=ppufile.do_crc;
  2032. ppufile.do_crc:=false;
  2033. ppufile.putset(tppuset1(defstates));
  2034. if df_genconstraint in defoptions then
  2035. genconstraintdata.ppuwrite(ppufile);
  2036. if [df_generic,df_specialization]*defoptions<>[] then
  2037. begin
  2038. if not assigned(genericparas) then
  2039. ppufile.putlongint(0)
  2040. else
  2041. begin
  2042. if not assigned(genericparaderefs) then
  2043. internalerror(2014052305);
  2044. ppufile.putlongint(genericparas.count);
  2045. for i:=0 to genericparas.count-1 do
  2046. begin
  2047. ppufile.putstring(genericparas.nameofindex(i));
  2048. ppufile.putderef(pderef(genericparaderefs[i])^);
  2049. end;
  2050. end;
  2051. end;
  2052. if df_generic in defoptions then
  2053. begin
  2054. if assigned(generictokenbuf) then
  2055. begin
  2056. sizeleft:=generictokenbuf.size;
  2057. generictokenbuf.seek(0);
  2058. end
  2059. else
  2060. sizeleft:=0;
  2061. ppufile.putlongint(sizeleft);
  2062. while sizeleft>0 do
  2063. begin
  2064. if sizeleft>sizeof(buf) then
  2065. i:=sizeof(buf)
  2066. else
  2067. i:=sizeleft;
  2068. generictokenbuf.read(buf,i);
  2069. ppufile.putdata(buf,i);
  2070. dec(sizeleft,i);
  2071. end;
  2072. end;
  2073. ppufile.do_crc:=oldintfcrc;
  2074. if df_specialization in defoptions then
  2075. ppufile.putderef(genericdefderef);
  2076. trtti_attribute_list.ppuwrite(rtti_attribute_list,ppufile);
  2077. end;
  2078. procedure tstoreddef.ppuload_subentries(ppufile: tcompilerppufile);
  2079. begin
  2080. trtti_attribute_list.ppuload_subentries(rtti_attribute_list,ppufile);
  2081. end;
  2082. procedure tstoreddef.ppuwrite_subentries(ppufile: tcompilerppufile);
  2083. begin
  2084. trtti_attribute_list.ppuwrite_subentries(rtti_attribute_list,ppufile);
  2085. end;
  2086. procedure tstoreddef.buildderef;
  2087. var
  2088. i : longint;
  2089. sym : tsym;
  2090. symderef : pderef;
  2091. begin
  2092. if not registered then
  2093. register_def;
  2094. typesymderef.build(typesym);
  2095. genericdefderef.build(genericdef);
  2096. if assigned(rtti_attribute_list) then
  2097. rtti_attribute_list.buildderef;
  2098. if assigned(genconstraintdata) then
  2099. genconstraintdata.buildderef;
  2100. if assigned(genericparas) then
  2101. begin
  2102. if not assigned(genericparaderefs) then
  2103. genericparaderefs:=tfplist.create;
  2104. for i:=0 to genericparas.count-1 do
  2105. begin
  2106. sym:=tsym(genericparas.items[i]);
  2107. new(symderef);
  2108. symderef^.build(sym);
  2109. genericparaderefs.add(symderef);
  2110. end;
  2111. end;
  2112. end;
  2113. procedure tstoreddef.buildderefimpl;
  2114. begin
  2115. end;
  2116. procedure tstoreddef.deref;
  2117. var
  2118. symderef : pderef;
  2119. i : longint;
  2120. begin
  2121. typesym:=ttypesym(typesymderef.resolve);
  2122. if df_specialization in defoptions then
  2123. genericdef:=tstoreddef(genericdefderef.resolve);
  2124. if assigned(rtti_attribute_list) then
  2125. rtti_attribute_list.deref;
  2126. if assigned(genconstraintdata) then
  2127. genconstraintdata.deref;
  2128. if assigned(genericparas) then
  2129. begin
  2130. if not assigned(genericparaderefs) then
  2131. internalerror(2014052302);
  2132. if genericparas.count<>genericparaderefs.count then
  2133. internalerror(2014052303);
  2134. for i:=0 to genericparaderefs.count-1 do
  2135. begin
  2136. symderef:=pderef(genericparaderefs[i]);
  2137. genericparas.items[i]:=symderef^.resolve;
  2138. end;
  2139. end;
  2140. end;
  2141. procedure tstoreddef.derefimpl;
  2142. begin
  2143. end;
  2144. function tstoreddef.size : asizeint;
  2145. begin
  2146. size:=savesize;
  2147. end;
  2148. function tstoreddef.getvardef:longint;
  2149. begin
  2150. result:=varUndefined;
  2151. end;
  2152. function tstoreddef.alignment : shortint;
  2153. begin
  2154. { natural alignment by default }
  2155. alignment:=size_2_align(savesize);
  2156. { can happen if savesize = 0, e.g. for voiddef or
  2157. an empty record
  2158. }
  2159. if (alignment=0) then
  2160. alignment:=1;
  2161. end;
  2162. { returns true, if the definition can be published }
  2163. function tstoreddef.is_publishable : boolean;
  2164. begin
  2165. is_publishable:=false;
  2166. end;
  2167. { needs an init table }
  2168. function tstoreddef.needs_inittable : boolean;
  2169. begin
  2170. needs_inittable:=false;
  2171. end;
  2172. function tstoreddef.has_non_trivial_init_child(check_parent:boolean):boolean;
  2173. begin
  2174. result:=false;
  2175. end;
  2176. function tstoreddef.is_intregable : boolean;
  2177. {$ifndef cpuhighleveltarget}
  2178. var
  2179. recsize,temp: longint;
  2180. {$endif cpuhighleveltarget}
  2181. begin
  2182. case typ of
  2183. orddef,
  2184. pointerdef,
  2185. enumdef,
  2186. classrefdef:
  2187. is_intregable:=true;
  2188. procvardef :
  2189. is_intregable:=tprocvardef(self).is_addressonly or (po_methodpointer in tprocvardef(self).procoptions);
  2190. objectdef:
  2191. is_intregable:=(is_implicit_pointer_object_type(self)) and not needs_inittable;
  2192. setdef:
  2193. is_intregable:=is_smallset(self);
  2194. arraydef:
  2195. {$ifdef cpuhighleveltarget}
  2196. is_intregable:=false
  2197. {$else cpuhighleveltarget}
  2198. is_intregable:=not(is_special_array(self)) and
  2199. (tarraydef(self).size<=8) and (tarraydef(self).size in [1,2,4,8]) and
  2200. tstoreddef(tarraydef(self).elementdef).is_intregable
  2201. {$ifdef SUPPORT_MMX}
  2202. and not((cs_mmx in current_settings.localswitches) and
  2203. is_mmx_able_array(self))
  2204. {$endif SUPPORT_MMX}
  2205. {$endif cpuhighleveltarget}
  2206. ;
  2207. recorddef:
  2208. begin
  2209. {$ifdef cpuhighleveltarget}
  2210. is_intregable:=false;
  2211. {$else cpuhighleveltarget}
  2212. recsize:=size;
  2213. is_intregable:=
  2214. ispowerof2(recsize,temp) and
  2215. ((recsize<=sizeof(aint)*2) and
  2216. not trecorddef(self).contains_cross_aword_field and
  2217. { records cannot go into registers on 16 bit targets for now }
  2218. (sizeof(aint)>2) and
  2219. not trecorddef(self).contains_float_field
  2220. ) and
  2221. not needs_inittable;
  2222. {$endif cpuhighleveltarget}
  2223. end;
  2224. else
  2225. is_intregable:=false;
  2226. end;
  2227. end;
  2228. function tstoreddef.is_fpuregable : boolean;
  2229. begin
  2230. {$ifdef x86}
  2231. result:=use_vectorfpu(self);
  2232. {$else x86}
  2233. result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches)
  2234. {$ifdef xtensa}
  2235. and (FPUXTENSA_SINGLE in fpu_capabilities[init_settings.fputype]) and (tfloatdef(self).floattype=s32real)
  2236. {$endif xtensa}
  2237. {$ifdef arm}
  2238. and (((FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[init_settings.fputype]) and (tfloatdef(self).floattype=s32real)) or
  2239. (FPUARM_HAS_VFP_DOUBLE in fpu_capabilities[init_settings.fputype]))
  2240. {$endif arm}
  2241. ;
  2242. {$endif x86}
  2243. end;
  2244. function tstoreddef.is_const_intregable : boolean;
  2245. begin
  2246. case typ of
  2247. stringdef:
  2248. result:=tstringdef(self).stringtype in [st_ansistring,st_unicodestring,st_widestring];
  2249. arraydef:
  2250. result:=is_dynamic_array(self);
  2251. objectdef:
  2252. result:=is_interface(self);
  2253. else
  2254. result:=false;
  2255. end;
  2256. end;
  2257. procedure tstoreddef.initgeneric;
  2258. begin
  2259. if assigned(generictokenbuf) then
  2260. internalerror(200512131);
  2261. generictokenbuf:=tdynamicarray.create(256);
  2262. end;
  2263. function tstoreddef.is_generic: boolean;
  2264. var
  2265. sym: tsym;
  2266. i: longint;
  2267. begin
  2268. result:=assigned(genericparas) and
  2269. (genericparas.count>0) and
  2270. (df_generic in defoptions);
  2271. if result then
  2272. { if any of the type parameters does *not* belong to as (meaning it was passed
  2273. in from outside) then we aren't a generic, but a specialization }
  2274. for i:=0 to genericparas.count-1 do
  2275. begin
  2276. sym:=tsym(genericparas[i]);
  2277. { sym must be either a type or const }
  2278. if not (sym.typ in [symconst.typesym,symconst.constsym]) then
  2279. internalerror(2014050903);
  2280. if sym.owner.defowner<>self then
  2281. exit(false);
  2282. if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then
  2283. exit(false);
  2284. end;
  2285. end;
  2286. function tstoreddef.is_generic_param_const(index:integer):boolean;
  2287. begin
  2288. result:=tsym(genericparas[index]).typ=constsym;
  2289. end;
  2290. function tstoreddef.get_generic_param_def(index:integer):tdef;
  2291. begin
  2292. if tsym(genericparas[index]).typ=constsym then
  2293. result:=tconstsym(genericparas[index]).constdef
  2294. else
  2295. result:=ttypesym(genericparas[index]).typedef;
  2296. end;
  2297. function tstoreddef.is_specialization: boolean;
  2298. var
  2299. i : longint;
  2300. sym : tsym;
  2301. begin
  2302. result:=assigned(genericparas) and
  2303. (genericparas.count>0) and
  2304. (df_specialization in defoptions);
  2305. if result then
  2306. begin
  2307. { if at least one of the generic parameters is not owned by us (meaning it was
  2308. passed in from outside) then we have a specialization, otherwise we have a generic }
  2309. for i:=0 to genericparas.count-1 do
  2310. begin
  2311. sym:=tsym(genericparas[i]);
  2312. { sym must be either a type or const }
  2313. if not (sym.typ in [symconst.typesym,symconst.constsym]) then
  2314. internalerror(2014050904);
  2315. if sym.owner.defowner<>self then
  2316. exit(true);
  2317. if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then
  2318. exit(true);
  2319. end;
  2320. result:=false;
  2321. end;
  2322. end;
  2323. procedure tstoreddef.register_def;
  2324. var
  2325. gst : tgetsymtable;
  2326. st : tsymtable;
  2327. begin
  2328. if registered then
  2329. exit;
  2330. { Register in current_module }
  2331. if assigned(current_module) then
  2332. begin
  2333. exclude(defoptions,df_not_registered_no_free);
  2334. for gst:=low(tgetsymtable) to high(tgetsymtable) do
  2335. begin
  2336. st:=getsymtable(gst);
  2337. if assigned(st) then
  2338. tstoredsymtable(st).register_children;
  2339. end;
  2340. if defid<defid_not_registered then
  2341. defid:=deflist_index
  2342. else
  2343. begin
  2344. current_module.deflist.Add(self);
  2345. defid:=current_module.deflist.Count-1;
  2346. registered_in_module:=current_module;
  2347. end;
  2348. maybe_put_in_symtable_stack;
  2349. end
  2350. else
  2351. DefId:=defid_registered_nost;
  2352. end;
  2353. procedure tstoreddef.maybe_put_in_symtable_stack;
  2354. var
  2355. insertstack: psymtablestackitem;
  2356. begin
  2357. if assigned(symtablestack) and
  2358. not assigned(self.owner) then
  2359. begin
  2360. insertstack:=symtablestack.stack;
  2361. { don't insert defs in exception symtables, as they are freed before
  2362. the module is compiled, so we can get crashes on high level targets
  2363. if they still need it while e.g. writing assembler code }
  2364. while assigned(insertstack) and
  2365. (insertstack^.symtable.symtabletype in [stt_exceptsymtable,withsymtable]) do
  2366. insertstack:=insertstack^.next;
  2367. if not assigned(insertstack) then
  2368. internalerror(200602044);
  2369. if insertstack^.symtable.sealed then
  2370. internalerror(2015022301);
  2371. insertstack^.symtable.insertdef(self);
  2372. end;
  2373. end;
  2374. {****************************************************************************
  2375. Tstringdef
  2376. ****************************************************************************}
  2377. constructor tstringdef.createshort(l: byte; doregister: boolean);
  2378. begin
  2379. inherited create(stringdef,doregister);
  2380. stringtype:=st_shortstring;
  2381. encoding:=0;
  2382. len:=l;
  2383. end;
  2384. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  2385. begin
  2386. inherited ppuload(stringdef,ppufile);
  2387. stringtype:=st_shortstring;
  2388. encoding:=0;
  2389. len:=ppufile.getbyte;
  2390. ppuload_platform(ppufile);
  2391. end;
  2392. constructor tstringdef.createlong(l: asizeint; doregister: boolean);
  2393. begin
  2394. inherited create(stringdef,doregister);
  2395. stringtype:=st_longstring;
  2396. encoding:=0;
  2397. len:=l;
  2398. end;
  2399. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  2400. begin
  2401. inherited ppuload(stringdef,ppufile);
  2402. stringtype:=st_longstring;
  2403. encoding:=0;
  2404. len:=ppufile.getasizeint;
  2405. ppuload_platform(ppufile);
  2406. end;
  2407. constructor tstringdef.createansi(aencoding: tstringencoding; doregister: boolean);
  2408. begin
  2409. inherited create(stringdef,doregister);
  2410. stringtype:=st_ansistring;
  2411. encoding:=aencoding;
  2412. len:=-1;
  2413. end;
  2414. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  2415. begin
  2416. inherited ppuload(stringdef,ppufile);
  2417. stringtype:=st_ansistring;
  2418. len:=ppufile.getasizeint;
  2419. encoding:=ppufile.getword;
  2420. ppuload_platform(ppufile);
  2421. end;
  2422. constructor tstringdef.createwide(doregister: boolean);
  2423. begin
  2424. inherited create(stringdef,doregister);
  2425. stringtype:=st_widestring;
  2426. if target_info.endian=endian_little then
  2427. encoding:=CP_UTF16LE
  2428. else
  2429. encoding:=CP_UTF16BE;
  2430. len:=-1;
  2431. end;
  2432. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  2433. begin
  2434. inherited ppuload(stringdef,ppufile);
  2435. stringtype:=st_widestring;
  2436. if target_info.endian=endian_little then
  2437. encoding:=CP_UTF16LE
  2438. else
  2439. encoding:=CP_UTF16BE;
  2440. len:=ppufile.getasizeint;
  2441. ppuload_platform(ppufile);
  2442. end;
  2443. constructor tstringdef.createunicode(doregister: boolean);
  2444. begin
  2445. inherited create(stringdef,doregister);
  2446. stringtype:=st_unicodestring;
  2447. if target_info.endian=endian_little then
  2448. encoding:=CP_UTF16LE
  2449. else
  2450. encoding:=CP_UTF16BE;
  2451. len:=-1;
  2452. end;
  2453. constructor tstringdef.loadunicode(ppufile:tcompilerppufile);
  2454. begin
  2455. inherited ppuload(stringdef,ppufile);
  2456. stringtype:=st_unicodestring;
  2457. len:=ppufile.getasizeint;
  2458. encoding:=ppufile.getword;
  2459. ppuload_platform(ppufile);
  2460. end;
  2461. function tstringdef.getcopy : tstoreddef;
  2462. begin
  2463. result:=cstringdef.create(typ,true);
  2464. result.typ:=stringdef;
  2465. tstringdef(result).stringtype:=stringtype;
  2466. tstringdef(result).encoding:=encoding;
  2467. tstringdef(result).len:=len;
  2468. end;
  2469. function tstringdef.stringtypname:string;
  2470. const
  2471. typname:array[tstringtype] of string[10]=(
  2472. 'shortstr','longstr','ansistr','widestr','unicodestr'
  2473. );
  2474. begin
  2475. stringtypname:=typname[stringtype];
  2476. end;
  2477. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  2478. begin
  2479. inherited ppuwrite(ppufile);
  2480. if stringtype=st_shortstring then
  2481. begin
  2482. {$ifdef extdebug}
  2483. if len > 255 then internalerror(12122002);
  2484. {$endif}
  2485. ppufile.putbyte(byte(len))
  2486. end
  2487. else
  2488. ppufile.putasizeint(len);
  2489. if stringtype in [st_ansistring,st_unicodestring] then
  2490. ppufile.putword(encoding);
  2491. case stringtype of
  2492. st_shortstring : writeentry(ppufile,ibshortstringdef);
  2493. st_longstring : writeentry(ppufile,iblongstringdef);
  2494. st_ansistring : writeentry(ppufile,ibansistringdef);
  2495. st_widestring : writeentry(ppufile,ibwidestringdef);
  2496. st_unicodestring : writeentry(ppufile,ibunicodestringdef);
  2497. end;
  2498. end;
  2499. function tstringdef.needs_inittable : boolean;
  2500. begin
  2501. needs_inittable:=stringtype in [st_ansistring,st_widestring,st_unicodestring];
  2502. end;
  2503. function tstringdef.GetTypeName : string;
  2504. const
  2505. names : array[tstringtype] of string[15] = (
  2506. 'ShortString','LongString','AnsiString','WideString','UnicodeString');
  2507. begin
  2508. GetTypeName:=names[stringtype];
  2509. case stringtype of
  2510. st_ansistring,st_unicodestring:
  2511. GetTypeName:=GetTypeName+'('+tostr(encoding)+')';
  2512. st_shortstring:
  2513. GetTypeName:=GetTypeName+'['+tostr(len)+']';
  2514. else
  2515. ;
  2516. end;
  2517. end;
  2518. function tstringdef.getvardef : longint;
  2519. const
  2520. vardef : array[tstringtype] of longint = (
  2521. varUndefined,varUndefined,varString,varOleStr,varUString);
  2522. begin
  2523. result:=vardef[stringtype];
  2524. end;
  2525. function tstringdef.get_default_char_type: tdef;
  2526. begin
  2527. case stringtype of
  2528. st_shortstring,
  2529. st_longstring,
  2530. st_ansistring:
  2531. result:=cansichartype;
  2532. st_unicodestring,
  2533. st_widestring:
  2534. result:=cwidechartype;
  2535. end;
  2536. end;
  2537. function tstringdef.get_default_string_type: tdef;
  2538. begin
  2539. case stringtype of
  2540. st_shortstring:
  2541. result:=cshortstringtype;
  2542. { st_longstring is currently not supported but
  2543. when it is this case will need to be supplied }
  2544. st_longstring:
  2545. internalerror(2021040801);
  2546. st_ansistring:
  2547. result:=cansistringtype;
  2548. st_widestring:
  2549. result:=cwidestringtype;
  2550. st_unicodestring:
  2551. result:=cunicodestringtype;
  2552. end
  2553. end;
  2554. function tstringdef.alignment : shortint;
  2555. begin
  2556. case stringtype of
  2557. st_unicodestring,
  2558. st_widestring,
  2559. st_ansistring:
  2560. alignment:=voidpointertype.alignment;
  2561. st_longstring,
  2562. st_shortstring:
  2563. { char to string accesses byte 0 and 1 with one word access }
  2564. if (tf_requires_proper_alignment in target_info.flags) or
  2565. { macpas needs an alignment of 2 (MetroWerks compatible) }
  2566. (m_mac in current_settings.modeswitches) then
  2567. alignment:=size_2_align(2)
  2568. else
  2569. alignment:=size_2_align(1);
  2570. end;
  2571. end;
  2572. function tstringdef.getmangledparaname : TSymStr;
  2573. begin
  2574. getmangledparaname:='STRING';
  2575. end;
  2576. function tstringdef.is_publishable : boolean;
  2577. begin
  2578. is_publishable:=true;
  2579. end;
  2580. function tstringdef.size: asizeint;
  2581. begin
  2582. case stringtype of
  2583. st_shortstring:
  2584. Result:=len+1;
  2585. st_longstring,
  2586. st_ansistring,
  2587. st_widestring,
  2588. st_unicodestring:
  2589. Result:=voidpointertype.size;
  2590. end;
  2591. end;
  2592. {****************************************************************************
  2593. TENUMDEF
  2594. ****************************************************************************}
  2595. constructor tenumdef.create;
  2596. begin
  2597. inherited create(enumdef,true);
  2598. minval:=0;
  2599. maxval:=0;
  2600. calcsavesize(current_settings.packenum);
  2601. has_jumps:=false;
  2602. basedef:=nil;
  2603. basedefderef.reset;
  2604. symtable:=tenumsymtable.create(self);
  2605. end;
  2606. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  2607. begin
  2608. inherited create(enumdef,true);
  2609. minval:=_min;
  2610. maxval:=_max;
  2611. basedef:=_basedef;
  2612. calcsavesize(current_settings.packenum);
  2613. has_jumps:=false;
  2614. symtable:=basedef.symtable.getcopy;
  2615. include(defoptions, df_copied_def);
  2616. end;
  2617. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  2618. begin
  2619. inherited ppuload(enumdef,ppufile);
  2620. minval:=ppufile.getaint;
  2621. maxval:=ppufile.getaint;
  2622. savesize:=ppufile.getaint;
  2623. has_jumps:=false;
  2624. if df_copied_def in defoptions then
  2625. begin
  2626. symtable:=nil;
  2627. ppufile.getderef(basedefderef);
  2628. ppuload_platform(ppufile);
  2629. end
  2630. else
  2631. begin
  2632. ppuload_platform(ppufile);
  2633. // create with nil defowner first to prevent values changes on insert
  2634. symtable:=tenumsymtable.create(nil);
  2635. tenumsymtable(symtable).ppuload(ppufile);
  2636. symtable.defowner:=self;
  2637. end;
  2638. end;
  2639. destructor tenumdef.destroy;
  2640. begin
  2641. symtable.free;
  2642. symtable:=nil;
  2643. inherited destroy;
  2644. end;
  2645. function tenumdef.getcopy : tstoreddef;
  2646. begin
  2647. if assigned(basedef) then
  2648. result:=cenumdef.create_subrange(basedef,minval,maxval)
  2649. else
  2650. begin
  2651. result:=cenumdef.create;
  2652. tenumdef(result).minval:=minval;
  2653. tenumdef(result).maxval:=maxval;
  2654. tenumdef(result).symtable.free;
  2655. tenumdef(result).symtable:=symtable.getcopy;
  2656. tenumdef(result).basedef:=self;
  2657. end;
  2658. tenumdef(result).has_jumps:=has_jumps;
  2659. tenumdef(result).basedefderef:=basedefderef;
  2660. include(tenumdef(result).defoptions,df_copied_def);
  2661. end;
  2662. procedure tenumdef.calcsavesize(packenum: shortint);
  2663. begin
  2664. {$IFNDEF cpu64bitaddr} {$push}{$warnings off} {$ENDIF} //comparison always false warning
  2665. if (packenum=8) or (int64(min)<low(longint)) or (int64(max)>high(cardinal)) then
  2666. savesize:=8
  2667. {$IFNDEF cpu64bitaddr} {$pop} {$ENDIF}
  2668. else
  2669. {$IFDEF cpu16bitaddr} {$push}{$warnings off} {$ENDIF} //comparison always false warning
  2670. if (packenum=4) or (min<low(smallint)) or (max>high(word)) then
  2671. savesize:=4
  2672. {$IFDEF cpu16bitaddr} {$pop} {$ENDIF}
  2673. else
  2674. if (packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  2675. savesize:=2
  2676. else
  2677. savesize:=1;
  2678. end;
  2679. function tenumdef.packedbitsize: asizeint;
  2680. var
  2681. sizeval: tconstexprint;
  2682. power: longint;
  2683. begin
  2684. result := 0;
  2685. if (minval >= 0) and
  2686. (maxval <= 1) then
  2687. result := 1
  2688. else
  2689. begin
  2690. if (minval>=0) then
  2691. sizeval:=maxval
  2692. else
  2693. { don't count 0 twice, but take into account that range goes from -n-1..n }
  2694. sizeval:=(cutils.max(-minval,maxval+1)*2)-1;
  2695. { 256 must become 512 etc. }
  2696. nextpowerof2(sizeval+1,power);
  2697. result := power;
  2698. end;
  2699. end;
  2700. procedure tenumdef.setmax(_max:asizeint);
  2701. begin
  2702. maxval:=_max;
  2703. calcsavesize(current_settings.packenum);
  2704. end;
  2705. procedure tenumdef.setmin(_min:asizeint);
  2706. begin
  2707. minval:=_min;
  2708. calcsavesize(current_settings.packenum);
  2709. end;
  2710. function tenumdef.min:asizeint;
  2711. begin
  2712. min:=minval;
  2713. end;
  2714. function tenumdef.max:asizeint;
  2715. begin
  2716. max:=maxval;
  2717. end;
  2718. function tenumdef.getfirstsym: tsym;
  2719. var
  2720. i:integer;
  2721. begin
  2722. for i := 0 to symtable.SymList.Count - 1 do
  2723. begin
  2724. result:=tsym(symtable.SymList[i]);
  2725. if tenumsym(result).value=minval then
  2726. exit;
  2727. end;
  2728. result:=nil;
  2729. end;
  2730. function tenumdef.int2enumsym(l: asizeint): tsym;
  2731. var
  2732. i: longint;
  2733. sym: tsym;
  2734. bdef: tenumdef;
  2735. begin
  2736. result:=nil;
  2737. if (l<minval) or
  2738. (l>maxval) then
  2739. exit;
  2740. bdef:=getbasedef;
  2741. for i:=0 to bdef.symtable.symlist.count-1 do
  2742. begin
  2743. sym:=tsym(bdef.symtable.symlist[i]);
  2744. if (sym.typ=enumsym) and
  2745. (tenumsym(sym).value=l) then
  2746. begin
  2747. result:=sym;
  2748. exit;
  2749. end;
  2750. end;
  2751. end;
  2752. function tenumdef.getbasedef: tenumdef;
  2753. begin
  2754. if not assigned(basedef) then
  2755. result:=self
  2756. else
  2757. result:=basedef;
  2758. end;
  2759. procedure tenumdef.buildderef;
  2760. begin
  2761. inherited buildderef;
  2762. if df_copied_def in defoptions then
  2763. basedefderef.build(basedef)
  2764. else
  2765. tenumsymtable(symtable).buildderef;
  2766. end;
  2767. procedure tenumdef.deref;
  2768. begin
  2769. inherited deref;
  2770. if df_copied_def in defoptions then
  2771. begin
  2772. basedef:=tenumdef(basedefderef.resolve);
  2773. symtable:=basedef.symtable.getcopy;
  2774. end
  2775. else
  2776. tenumsymtable(symtable).deref(false);
  2777. end;
  2778. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  2779. begin
  2780. inherited ppuwrite(ppufile);
  2781. ppufile.putaint(min);
  2782. ppufile.putaint(max);
  2783. ppufile.putaint(savesize);
  2784. if df_copied_def in defoptions then
  2785. ppufile.putderef(basedefderef);
  2786. writeentry(ppufile,ibenumdef);
  2787. if not (df_copied_def in defoptions) then
  2788. tenumsymtable(symtable).ppuwrite(ppufile);
  2789. end;
  2790. function tenumdef.is_publishable : boolean;
  2791. begin
  2792. is_publishable:=true;
  2793. end;
  2794. function tenumdef.GetTypeName : string;
  2795. begin
  2796. GetTypeName:='<enumeration type>';
  2797. end;
  2798. {****************************************************************************
  2799. TRTTI_ATTRIBUTE_LIST
  2800. ****************************************************************************}
  2801. constructor trtti_attribute.ppuload(ppufile: tcompilerppufile);
  2802. begin
  2803. ppufile.getderef(typesymderef);
  2804. ppufile.getderef(typeconstrderef);
  2805. setlength(paras,ppufile.getlongint);
  2806. end;
  2807. procedure trtti_attribute.ppuwrite(ppufile: tcompilerppufile);
  2808. begin
  2809. ppufile.putderef(typesymderef);
  2810. ppufile.putderef(typeconstrderef);
  2811. ppufile.putlongint(length(paras));
  2812. end;
  2813. procedure trtti_attribute.ppuload_subentries(ppufile: tcompilerppufile);
  2814. var
  2815. i : sizeint;
  2816. begin
  2817. for i:=0 to high(paras) do
  2818. paras[i]:=ppuloadnodetree(ppufile);
  2819. end;
  2820. procedure trtti_attribute.ppuwrite_subentries(ppufile: tcompilerppufile);
  2821. var
  2822. i : sizeint;
  2823. begin
  2824. for i:=0 to high(paras) do
  2825. ppuwritenodetree(ppufile,paras[i]);
  2826. end;
  2827. destructor trtti_attribute.destroy;
  2828. var
  2829. n : tnode;
  2830. begin
  2831. constructorcall.free;
  2832. for n in paras do
  2833. n.free;
  2834. inherited destroy;
  2835. end;
  2836. procedure trtti_attribute.buildderef;
  2837. var
  2838. i : sizeint;
  2839. begin
  2840. typesymderef.build(typesym);
  2841. typeconstrderef.build(typeconstr);
  2842. for i:=0 to high(paras) do
  2843. paras[i].buildderefimpl;
  2844. end;
  2845. procedure trtti_attribute.deref;
  2846. var
  2847. i : sizeint;
  2848. begin
  2849. typesym:=tsym(typesymderef.resolve);
  2850. typeconstr:=tdef(typeconstrderef.resolve);
  2851. for i:=0 to high(paras) do
  2852. paras[i].derefimpl;
  2853. end;
  2854. class procedure trtti_attribute_list.bind(var dangling,owned:trtti_attribute_list);
  2855. begin
  2856. if assigned(owned) then
  2857. internalerror(2019071001);
  2858. if not assigned(dangling) then
  2859. exit;
  2860. if dangling.is_bound then
  2861. internalerror(2019071002);
  2862. current_module.used_rtti_attrs.concatlistcopy(dangling.rtti_attributes);
  2863. dangling.is_bound:=true;
  2864. owned:=dangling;
  2865. dangling:=nil;
  2866. end;
  2867. procedure trtti_attribute_list.addattribute(atypesym:tsym;typeconstr:tdef;constructorcall:tnode;constref paras:array of tnode);
  2868. var
  2869. newattribute : trtti_attribute;
  2870. i : sizeint;
  2871. begin
  2872. if not assigned(rtti_attributes) then
  2873. rtti_attributes:=TFPObjectList.Create(true);
  2874. newattribute:=trtti_attribute.Create;
  2875. newattribute.typesym:=atypesym;
  2876. newattribute.typeconstr:=typeconstr;
  2877. newattribute.constructorcall:=constructorcall;
  2878. setlength(newattribute.paras,length(paras));
  2879. for i:=0 to high(paras) do
  2880. newattribute.paras[i]:=paras[i];
  2881. rtti_attributes.Add(newattribute);
  2882. end;
  2883. procedure trtti_attribute_list.addattribute(attr:trtti_attribute);
  2884. begin
  2885. if not assigned(rtti_attributes) then
  2886. rtti_attributes:=TFPObjectList.Create(true);
  2887. rtti_attributes.add(attr);
  2888. end;
  2889. destructor trtti_attribute_list.destroy;
  2890. begin
  2891. rtti_attributes.Free;
  2892. inherited destroy;
  2893. end;
  2894. function trtti_attribute_list.get_attribute_count:longint;
  2895. begin
  2896. if assigned(rtti_attributes) then
  2897. result:=rtti_attributes.Count
  2898. else
  2899. result:=0;
  2900. end;
  2901. procedure trtti_attribute_list.buildderef;
  2902. var
  2903. i : sizeint;
  2904. begin
  2905. if not assigned(rtti_attributes) then
  2906. exit;
  2907. for i:=0 to rtti_attributes.count-1 do
  2908. trtti_attribute(rtti_attributes[i]).buildderef;
  2909. end;
  2910. procedure trtti_attribute_list.deref;
  2911. var
  2912. i : sizeint;
  2913. begin
  2914. if not assigned(rtti_attributes) then
  2915. exit;
  2916. for i:=0 to rtti_attributes.count-1 do
  2917. trtti_attribute(rtti_attributes[i]).deref;
  2918. end;
  2919. class procedure trtti_attribute_list.ppuload_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  2920. var
  2921. i : sizeint;
  2922. begin
  2923. if assigned(attrlist) then
  2924. begin
  2925. if not assigned(attrlist.rtti_attributes) then
  2926. internalerror(2019071101);
  2927. for i:=0 to attrlist.rtti_attributes.count-1 do
  2928. trtti_attribute(attrlist.rtti_attributes[i]).ppuload_subentries(ppufile);
  2929. end;
  2930. end;
  2931. class procedure trtti_attribute_list.ppuwrite_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  2932. var
  2933. i : sizeint;
  2934. begin
  2935. if assigned(attrlist) and assigned(attrlist.rtti_attributes) then
  2936. begin
  2937. for i:=0 to attrlist.rtti_attributes.count-1 do
  2938. trtti_attribute(attrlist.rtti_attributes[i]).ppuwrite_subentries(ppufile);
  2939. end;
  2940. end;
  2941. class function trtti_attribute_list.ppuload(ppufile:tcompilerppufile):trtti_attribute_list;
  2942. var
  2943. cnt,i : longint;
  2944. begin
  2945. cnt:=ppufile.getlongint;
  2946. if cnt>0 then
  2947. begin
  2948. result:=trtti_attribute_list.create;
  2949. for i:=0 to cnt-1 do
  2950. result.addattribute(trtti_attribute.ppuload(ppufile));
  2951. end
  2952. else
  2953. result:=nil;
  2954. end;
  2955. class procedure trtti_attribute_list.ppuwrite(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
  2956. var
  2957. i : longint;
  2958. begin
  2959. if assigned(attrlist) and assigned(attrlist.rtti_attributes) then
  2960. begin
  2961. ppufile.putlongint(attrlist.rtti_attributes.count);
  2962. for i:=0 to attrlist.rtti_attributes.count-1 do
  2963. trtti_attribute(attrlist.rtti_attributes[i]).ppuwrite(ppufile);
  2964. end
  2965. else
  2966. ppufile.putlongint(0);
  2967. end;
  2968. {****************************************************************************
  2969. TORDDEF
  2970. ****************************************************************************}
  2971. constructor torddef.create(t : tordtype;v,b : TConstExprInt; doregister: boolean);
  2972. begin
  2973. inherited create(orddef,doregister);
  2974. low:=v;
  2975. high:=b;
  2976. ordtype:=t;
  2977. setsize;
  2978. end;
  2979. constructor torddef.ppuload(ppufile:tcompilerppufile);
  2980. begin
  2981. inherited ppuload(orddef,ppufile);
  2982. ordtype:=tordtype(ppufile.getbyte);
  2983. low:=ppufile.getexprint;
  2984. high:=ppufile.getexprint;
  2985. setsize;
  2986. ppuload_platform(ppufile);
  2987. end;
  2988. function torddef.getcopy : tstoreddef;
  2989. begin
  2990. result:=corddef.create(ordtype,low,high,true);
  2991. result.typ:=orddef;
  2992. torddef(result).low:=low;
  2993. torddef(result).high:=high;
  2994. torddef(result).ordtype:=ordtype;
  2995. torddef(result).savesize:=savesize;
  2996. end;
  2997. function torddef.alignment:shortint;
  2998. begin
  2999. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_ios]) and
  3000. (ordtype in [s64bit,u64bit]) then
  3001. result := 4
  3002. else
  3003. result := inherited alignment;
  3004. end;
  3005. procedure torddef.setsize;
  3006. const
  3007. sizetbl : array[tordtype] of longint = (
  3008. 0,
  3009. 1,2,4,8,16,
  3010. 1,2,4,8,16,
  3011. 1,1,2,4,8,
  3012. 1,2,4,8,
  3013. 1,2,8,system.high(longint)
  3014. );
  3015. begin
  3016. savesize:=sizetbl[ordtype];
  3017. if savesize=system.high(longint) then
  3018. savesize:=packedbitsize div 8;
  3019. end;
  3020. function torddef.packedbitsize: asizeint;
  3021. var
  3022. sizeval: tconstexprint;
  3023. power: longint;
  3024. begin
  3025. result := 0;
  3026. if ordtype = uvoid then
  3027. exit;
  3028. {$ifndef cpu64bitalu}
  3029. if (ordtype in [s64bit,u64bit]) then
  3030. {$else not cpu64bitalu}
  3031. if ((ordtype = u64bit) and
  3032. (high > system.high(int64))) or
  3033. ((ordtype = s64bit) and
  3034. ((low <= (system.low(int64) div 2)) or
  3035. ((low < 0) and
  3036. (high > (system.high(int64) div 2))))) then
  3037. {$endif cpu64bitalu}
  3038. result := 64
  3039. else if (
  3040. (low >= 0) and
  3041. (high <= 1)
  3042. ) or (
  3043. ordtype in [pasbool1,pasbool8,pasbool16,pasbool32,pasbool64,bool8bit,bool16bit,bool32bit,bool64bit]
  3044. ) then
  3045. result := 1
  3046. else
  3047. begin
  3048. if (low>=0) then
  3049. sizeval:=high
  3050. else
  3051. { don't count 0 twice, but take into account that range goes from -n-1..n }
  3052. sizeval:=(cutils.max(-low,high+1)*2)-1;
  3053. { 256 must become 512 etc. }
  3054. nextpowerof2(sizeval+1,power);
  3055. result := power;
  3056. end;
  3057. end;
  3058. function torddef.getvardef : longint;
  3059. const
  3060. basetype2vardef : array[tordtype] of longint = (
  3061. varUndefined,
  3062. varbyte,varword,varlongword,varqword,varUndefined,
  3063. varshortint,varsmallint,varinteger,varint64,varUndefined,
  3064. varboolean,varboolean,varboolean,varboolean,varboolean,
  3065. varboolean,varboolean,varUndefined,varUndefined,
  3066. varUndefined,varUndefined,varCurrency,varEmpty);
  3067. begin
  3068. result:=basetype2vardef[ordtype];
  3069. if result=varEmpty then
  3070. result:=basetype2vardef[range_to_basetype(low,high)];
  3071. end;
  3072. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  3073. begin
  3074. inherited ppuwrite(ppufile);
  3075. ppufile.putbyte(byte(ordtype));
  3076. ppufile.putexprint(low);
  3077. ppufile.putexprint(high);
  3078. writeentry(ppufile,iborddef);
  3079. end;
  3080. function torddef.is_publishable : boolean;
  3081. begin
  3082. is_publishable:=(ordtype<>uvoid);
  3083. end;
  3084. function torddef.GetTypeName : string;
  3085. const
  3086. names : array[tordtype] of string[20] = (
  3087. 'untyped',
  3088. 'Byte','Word','DWord','QWord','UInt128',
  3089. 'ShortInt','SmallInt','LongInt','Int64','Int128',
  3090. 'Boolean','Boolean8','Boolean16','Boolean32','Boolean64',
  3091. 'ByteBool','WordBool','LongBool','QWordBool',
  3092. 'Char','WideChar','Currency','CustomRange');
  3093. begin
  3094. GetTypeName:=names[ordtype];
  3095. end;
  3096. {****************************************************************************
  3097. TFLOATDEF
  3098. ****************************************************************************}
  3099. constructor tfloatdef.create(t: tfloattype; doregister: boolean);
  3100. begin
  3101. inherited create(floatdef,doregister);
  3102. floattype:=t;
  3103. setsize;
  3104. end;
  3105. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  3106. begin
  3107. inherited ppuload(floatdef,ppufile);
  3108. floattype:=tfloattype(ppufile.getbyte);
  3109. setsize;
  3110. ppuload_platform(ppufile);
  3111. end;
  3112. function tfloatdef.getcopy : tstoreddef;
  3113. begin
  3114. result:=cfloatdef.create(floattype,true);
  3115. result.typ:=floatdef;
  3116. tfloatdef(result).savesize:=savesize;
  3117. end;
  3118. function tfloatdef.alignment:shortint;
  3119. begin
  3120. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_ios]) then
  3121. case floattype of
  3122. sc80real,
  3123. s80real: result:=16;
  3124. s64real,
  3125. s64currency,
  3126. s64comp : result:=4;
  3127. else
  3128. result := inherited alignment;
  3129. end
  3130. else
  3131. result := inherited alignment;
  3132. end;
  3133. function tfloatdef.structalignment: shortint;
  3134. begin
  3135. { aix is really annoying: the recommended scalar alignment for both
  3136. int64 and double is 64 bits, but in structs int64 has to be aligned
  3137. to 8 bytes and double to 4 bytes }
  3138. if (target_info.system in systems_aix) and
  3139. (floattype=s64real) then
  3140. result:=4
  3141. else
  3142. result:=alignment;
  3143. end;
  3144. procedure tfloatdef.setsize;
  3145. begin
  3146. case floattype of
  3147. s32real : savesize:=4;
  3148. s80real : savesize:=10;
  3149. sc80real:
  3150. if target_info.system in [system_i386_darwin,
  3151. system_i386_iphonesim,system_x86_64_darwin,
  3152. system_x86_64_iphonesim,
  3153. system_x86_64_linux,system_x86_64_freebsd,
  3154. system_x86_64_openbsd,system_x86_64_netbsd,
  3155. system_x86_64_solaris,system_x86_64_embedded,
  3156. system_x86_64_dragonfly,system_x86_64_haiku] then
  3157. savesize:=16
  3158. else
  3159. savesize:=12;
  3160. s64real,
  3161. s64currency,
  3162. s64comp : savesize:=8;
  3163. else
  3164. savesize:=0;
  3165. end;
  3166. end;
  3167. function tfloatdef.getvardef : longint;
  3168. const
  3169. floattype2vardef : array[tfloattype] of longint = (
  3170. varSingle,varDouble,varUndefined,varUndefined,
  3171. varUndefined,varCurrency,varUndefined);
  3172. begin
  3173. if (upper(typename)='TDATETIME') and
  3174. assigned(owner) and
  3175. assigned(owner.name) and
  3176. (owner.name^='SYSTEM') then
  3177. result:=varDate
  3178. else
  3179. result:=floattype2vardef[floattype];
  3180. end;
  3181. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  3182. begin
  3183. inherited ppuwrite(ppufile);
  3184. ppufile.putbyte(byte(floattype));
  3185. writeentry(ppufile,ibfloatdef);
  3186. end;
  3187. function tfloatdef.is_publishable : boolean;
  3188. begin
  3189. is_publishable:=true;
  3190. end;
  3191. function tfloatdef.GetTypeName : string;
  3192. const
  3193. names : array[tfloattype] of string[20] = (
  3194. 'Single','Double','Extended','CExtended','Comp','Currency','Float128');
  3195. begin
  3196. GetTypeName:=names[floattype];
  3197. end;
  3198. {****************************************************************************
  3199. TFILEDEF
  3200. ****************************************************************************}
  3201. constructor tfiledef.createtext;
  3202. begin
  3203. inherited create(filedef,true);
  3204. filetyp:=ft_text;
  3205. typedfiledef:=nil;
  3206. typedfiledefderef.reset;
  3207. end;
  3208. constructor tfiledef.createuntyped;
  3209. begin
  3210. inherited create(filedef,true);
  3211. filetyp:=ft_untyped;
  3212. typedfiledef:=nil;
  3213. end;
  3214. constructor tfiledef.createtyped(def:tdef);
  3215. begin
  3216. inherited create(filedef,true);
  3217. filetyp:=ft_typed;
  3218. typedfiledef:=def;
  3219. end;
  3220. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  3221. begin
  3222. inherited ppuload(filedef,ppufile);
  3223. filetyp:=tfiletyp(ppufile.getbyte);
  3224. if filetyp=ft_typed then
  3225. ppufile.getderef(typedfiledefderef)
  3226. else
  3227. typedfiledef:=nil;
  3228. ppuload_platform(ppufile);
  3229. end;
  3230. function tfiledef.getcopy : tstoreddef;
  3231. begin
  3232. case filetyp of
  3233. ft_typed:
  3234. result:=cfiledef.createtyped(typedfiledef);
  3235. ft_untyped:
  3236. result:=cfiledef.createuntyped;
  3237. ft_text:
  3238. result:=cfiledef.createtext;
  3239. end;
  3240. end;
  3241. procedure tfiledef.buildderef;
  3242. begin
  3243. inherited buildderef;
  3244. if filetyp=ft_typed then
  3245. typedfiledefderef.build(typedfiledef);
  3246. end;
  3247. procedure tfiledef.deref;
  3248. begin
  3249. inherited deref;
  3250. if filetyp=ft_typed then
  3251. typedfiledef:=tdef(typedfiledefderef.resolve);
  3252. end;
  3253. function tfiledef.size:asizeint;
  3254. begin
  3255. if savesize=0 then
  3256. setsize;
  3257. size:=savesize;
  3258. end;
  3259. procedure tfiledef.setsize;
  3260. begin
  3261. case filetyp of
  3262. ft_text:
  3263. savesize:=search_system_type('TEXTREC').typedef.size;
  3264. ft_typed:
  3265. begin
  3266. savesize:=search_system_type('FILEREC').typedef.size;
  3267. { allocate put/get buffer in iso mode }
  3268. if m_isolike_io in current_settings.modeswitches then
  3269. inc(savesize,typedfiledef.size);
  3270. end;
  3271. ft_untyped:
  3272. savesize:=search_system_type('FILEREC').typedef.size;
  3273. end;
  3274. end;
  3275. function tfiledef.alignment: shortint;
  3276. begin
  3277. case filetyp of
  3278. ft_text:
  3279. result:=search_system_type('TEXTREC').typedef.alignment;
  3280. ft_typed,
  3281. ft_untyped:
  3282. result:=search_system_type('FILEREC').typedef.alignment;
  3283. end;
  3284. end;
  3285. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  3286. begin
  3287. inherited ppuwrite(ppufile);
  3288. ppufile.putbyte(byte(filetyp));
  3289. if filetyp=ft_typed then
  3290. ppufile.putderef(typedfiledefderef);
  3291. writeentry(ppufile,ibfiledef);
  3292. end;
  3293. function tfiledef.GetTypeName : string;
  3294. begin
  3295. case filetyp of
  3296. ft_untyped:
  3297. GetTypeName:='File';
  3298. ft_typed:
  3299. GetTypeName:='File Of '+typedfiledef.typename;
  3300. ft_text:
  3301. GetTypeName:='Text'
  3302. end;
  3303. end;
  3304. function tfiledef.getmangledparaname : TSymStr;
  3305. begin
  3306. case filetyp of
  3307. ft_untyped:
  3308. getmangledparaname:='FILE';
  3309. ft_typed:
  3310. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  3311. ft_text:
  3312. getmangledparaname:='TEXT'
  3313. end;
  3314. end;
  3315. {****************************************************************************
  3316. TVARIANTDEF
  3317. ****************************************************************************}
  3318. constructor tvariantdef.create(v : tvarianttype);
  3319. begin
  3320. inherited create(variantdef,true);
  3321. varianttype:=v;
  3322. setsize;
  3323. end;
  3324. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  3325. begin
  3326. inherited ppuload(variantdef,ppufile);
  3327. varianttype:=tvarianttype(ppufile.getbyte);
  3328. setsize;
  3329. ppuload_platform(ppufile);
  3330. end;
  3331. function tvariantdef.getcopy : tstoreddef;
  3332. begin
  3333. result:=cvariantdef.create(varianttype);
  3334. end;
  3335. function tvariantdef.alignment: shortint;
  3336. begin
  3337. result:=search_system_type('TVARDATA').typedef.alignment;
  3338. end;
  3339. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  3340. begin
  3341. inherited ppuwrite(ppufile);
  3342. ppufile.putbyte(byte(varianttype));
  3343. writeentry(ppufile,ibvariantdef);
  3344. end;
  3345. function tvariantdef.getvardef : longint;
  3346. begin
  3347. Result:=varVariant;
  3348. end;
  3349. procedure tvariantdef.setsize;
  3350. begin
  3351. {$ifdef cpu64bitaddr}
  3352. savesize:=24;
  3353. {$else cpu64bitaddr}
  3354. savesize:=16;
  3355. {$endif cpu64bitaddr}
  3356. end;
  3357. function tvariantdef.GetTypeName : string;
  3358. begin
  3359. case varianttype of
  3360. vt_normalvariant:
  3361. GetTypeName:='Variant';
  3362. vt_olevariant:
  3363. GetTypeName:='OleVariant';
  3364. end;
  3365. end;
  3366. function tvariantdef.needs_inittable : boolean;
  3367. begin
  3368. needs_inittable:=true;
  3369. end;
  3370. function tvariantdef.is_publishable : boolean;
  3371. begin
  3372. is_publishable:=true;
  3373. end;
  3374. {****************************************************************************
  3375. TABSTRACtpointerdef
  3376. ****************************************************************************}
  3377. constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef);
  3378. begin
  3379. inherited create(dt,true);
  3380. pointeddef:=def;
  3381. pointeddefderef.reset;
  3382. if df_generic in pointeddef.defoptions then
  3383. include(defoptions,df_generic);
  3384. if df_specialization in pointeddef.defoptions then
  3385. include(defoptions,df_specialization);
  3386. end;
  3387. constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  3388. begin
  3389. inherited ppuload(dt,ppufile);
  3390. ppufile.getderef(pointeddefderef);
  3391. end;
  3392. procedure tabstractpointerdef.buildderef;
  3393. begin
  3394. inherited buildderef;
  3395. pointeddefderef.build(pointeddef);
  3396. end;
  3397. procedure tabstractpointerdef.deref;
  3398. begin
  3399. inherited deref;
  3400. pointeddef:=tdef(pointeddefderef.resolve);
  3401. end;
  3402. function tabstractpointerdef.size: asizeint;
  3403. begin
  3404. Result:=voidpointertype.size;
  3405. end;
  3406. function tabstractpointerdef.alignment: shortint;
  3407. begin
  3408. alignment:=size_2_align(voidpointertype.size);
  3409. end;
  3410. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  3411. begin
  3412. inherited ppuwrite(ppufile);
  3413. ppufile.putderef(pointeddefderef);
  3414. end;
  3415. {****************************************************************************
  3416. tpointerdef
  3417. ****************************************************************************}
  3418. constructor tpointerdef.create(def:tdef);
  3419. begin
  3420. inherited create(pointerdef,def);
  3421. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  3422. if (df_specialization in tstoreddef(def).defoptions)
  3423. {$ifndef genericdef_for_nested}
  3424. { currently, nested procdefs of generic routines get df_specialization,
  3425. but no genericdef }
  3426. and assigned(tstoreddef(def).genericdef)
  3427. {$endif}
  3428. then
  3429. genericdef:=cpointerdef.getreusable(tstoreddef(def).genericdef);
  3430. end;
  3431. class function tpointerdef.getreusable(def: tdef): tpointerdef;
  3432. var
  3433. res: PHashSetItem;
  3434. oldsymtablestack: tsymtablestack;
  3435. begin
  3436. if not assigned(current_module) then
  3437. internalerror(2011071101);
  3438. res:=current_module.ptrdefs.FindOrAdd(@def,sizeof(def));
  3439. if not assigned(res^.Data) then
  3440. begin
  3441. { since these pointerdefs can be reused anywhere in the current
  3442. unit, add them to the global/staticsymtable (or local symtable
  3443. if they're a local def, because otherwise they'll be saved
  3444. to the ppu referencing a local symtable entry that doesn't
  3445. exist in the ppu) }
  3446. oldsymtablestack:=symtablestack;
  3447. { do not simply push/pop current_module.localsymtable, because
  3448. that can have side-effects (e.g., it removes helpers) }
  3449. symtablestack:=nil;
  3450. result:=cpointerdef.create(def);
  3451. setup_reusable_def(def,result,res,oldsymtablestack);
  3452. { res^.Data may still be nil -> don't overwrite result }
  3453. exit;
  3454. end;
  3455. result:=tpointerdef(res^.Data);
  3456. end;
  3457. class function tpointerdef.getreusable_no_free(def: tdef): tpointerdef;
  3458. begin
  3459. result:=getreusable(def);
  3460. if not result.is_registered then
  3461. include(result.defoptions,df_not_registered_no_free);
  3462. end;
  3463. function tpointerdef.size: asizeint;
  3464. begin
  3465. result:=sizeof(pint);
  3466. end;
  3467. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  3468. begin
  3469. inherited ppuload(pointerdef,ppufile);
  3470. has_pointer_math:=(ppufile.getbyte<>0);
  3471. ppuload_platform(ppufile);
  3472. end;
  3473. function tpointerdef.getcopy : tstoreddef;
  3474. begin
  3475. { don't use direct pointeddef if it is a forwarddef because in other case
  3476. one of them will be destroyed on forward type resolve and the second will
  3477. point to garbage }
  3478. if pointeddef.typ=forwarddef then
  3479. result:=cpointerdef.create(tforwarddef(pointeddef).getcopy)
  3480. else
  3481. result:=cpointerdef.create(pointeddef);
  3482. tpointerdef(result).has_pointer_math:=has_pointer_math;
  3483. tpointerdef(result).savesize:=savesize;
  3484. end;
  3485. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  3486. begin
  3487. inherited ppuwrite(ppufile);
  3488. ppufile.putbyte(byte(has_pointer_math));
  3489. writeentry(ppufile,ibpointerdef);
  3490. end;
  3491. function tpointerdef.GetTypeName : string;
  3492. begin
  3493. { parameter types and the resultdef of a procvardef can contain a
  3494. pointer to this procvardef itself, resulting in endless recursion ->
  3495. use the typesym's name instead if it exists (if it doesn't, such as
  3496. for anynonymous procedure types in macpas/iso mode, then there cannot
  3497. be any recursive references to it either) }
  3498. if (pointeddef.typ<>procvardef) or
  3499. not assigned(pointeddef.typesym) then
  3500. GetTypeName:='^'+pointeddef.typename
  3501. else
  3502. GetTypeName:='^'+pointeddef.typesym.realname;
  3503. end;
  3504. function tpointerdef.pointer_arithmetic_int_type:tdef;
  3505. begin
  3506. result:=ptrsinttype;
  3507. end;
  3508. function tpointerdef.pointer_arithmetic_uint_type:tdef;
  3509. begin
  3510. result:=ptruinttype;
  3511. end;
  3512. function tpointerdef.pointer_subtraction_result_type:tdef;
  3513. begin
  3514. result:=ptrsinttype;
  3515. end;
  3516. function tpointerdef.compatible_with_pointerdef_size(ptr: tpointerdef): boolean;
  3517. begin
  3518. result:=true;
  3519. end;
  3520. function tpointerdef.converted_pointer_to_array_range_type:tdef;
  3521. begin
  3522. result:=ptrsinttype;
  3523. end;
  3524. {****************************************************************************
  3525. TCLASSREFDEF
  3526. ****************************************************************************}
  3527. constructor tclassrefdef.create(def:tdef);
  3528. begin
  3529. while (def.typ=objectdef) and tobjectdef(def).is_unique_objpasdef do
  3530. def:=tobjectdef(def).childof;
  3531. inherited create(classrefdef,def);
  3532. if df_specialization in tstoreddef(def).defoptions then
  3533. genericdef:=cclassrefdef.create(tstoreddef(def).genericdef);
  3534. end;
  3535. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  3536. begin
  3537. inherited ppuload(classrefdef,ppufile);
  3538. ppuload_platform(ppufile);
  3539. end;
  3540. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  3541. begin
  3542. inherited ppuwrite(ppufile);
  3543. writeentry(ppufile,ibclassrefdef);
  3544. end;
  3545. function tclassrefdef.getcopy:tstoreddef;
  3546. begin
  3547. if pointeddef.typ=forwarddef then
  3548. result:=cclassrefdef.create(tforwarddef(pointeddef).getcopy)
  3549. else
  3550. result:=cclassrefdef.create(pointeddef);
  3551. end;
  3552. function tclassrefdef.GetTypeName : string;
  3553. begin
  3554. GetTypeName:='Class Of '+pointeddef.typename;
  3555. end;
  3556. function tclassrefdef.is_publishable : boolean;
  3557. begin
  3558. result:=true;
  3559. end;
  3560. function tclassrefdef.rtti_mangledname(rt: trttitype): TSymStr;
  3561. begin
  3562. if (tobjectdef(pointeddef).objecttype<>odt_objcclass) then
  3563. result:=inherited rtti_mangledname(rt)
  3564. else
  3565. result:=tobjectdef(pointeddef).rtti_mangledname(objcmetartti);
  3566. end;
  3567. procedure tclassrefdef.register_created_object_type;
  3568. begin
  3569. tobjectdef(pointeddef).register_created_classref_type;
  3570. end;
  3571. {***************************************************************************
  3572. TSETDEF
  3573. ***************************************************************************}
  3574. constructor tsetdef.create(def: tdef; low, high: asizeint; doregister: boolean);
  3575. var
  3576. setallocbits: aint;
  3577. packedsavesize: aint;
  3578. actual_setalloc: ShortInt;
  3579. begin
  3580. inherited create(setdef,doregister);
  3581. elementdef:=def;
  3582. elementdefderef.reset;
  3583. setmax:=high;
  3584. actual_setalloc:=current_settings.setalloc;
  3585. {$if defined(cpu8bitalu) or defined(cpu16bitalu)}
  3586. if actual_setalloc=0 then
  3587. actual_setalloc:=1;
  3588. {$endif}
  3589. if (actual_setalloc=0) then
  3590. begin
  3591. setbase:=0;
  3592. if (high<32) then
  3593. savesize:=Sizeof(longint)
  3594. else if (high<256) then
  3595. savesize:=32
  3596. else
  3597. savesize:=(high+7) div 8
  3598. end
  3599. else
  3600. begin
  3601. setallocbits:=actual_setalloc*8;
  3602. setbase:=low and not(setallocbits-1);
  3603. packedsavesize:=actual_setalloc*((((high+setallocbits)-setbase)) DIV setallocbits);
  3604. savesize:=packedsavesize;
  3605. {$if not defined(cpu8bitalu) and not defined(cpu16bitalu)}
  3606. if savesize=3 then
  3607. savesize:=4;
  3608. {$endif}
  3609. end;
  3610. end;
  3611. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  3612. begin
  3613. inherited ppuload(setdef,ppufile);
  3614. ppufile.getderef(elementdefderef);
  3615. savesize:=ppufile.getasizeint;
  3616. setbase:=ppufile.getasizeint;
  3617. setmax:=ppufile.getasizeint;
  3618. ppuload_platform(ppufile);
  3619. end;
  3620. function tsetdef.getcopy : tstoreddef;
  3621. begin
  3622. result:=csetdef.create(elementdef,setbase,setmax,true);
  3623. { the copy might have been created with a different setalloc setting }
  3624. tsetdef(result).savesize:=savesize;
  3625. end;
  3626. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  3627. begin
  3628. inherited ppuwrite(ppufile);
  3629. ppufile.putderef(elementdefderef);
  3630. ppufile.putasizeint(savesize);
  3631. ppufile.putasizeint(setbase);
  3632. ppufile.putasizeint(setmax);
  3633. writeentry(ppufile,ibsetdef);
  3634. end;
  3635. procedure tsetdef.buildderef;
  3636. begin
  3637. inherited buildderef;
  3638. elementdefderef.build(elementdef);
  3639. end;
  3640. procedure tsetdef.deref;
  3641. begin
  3642. inherited deref;
  3643. elementdef:=tdef(elementdefderef.resolve);
  3644. end;
  3645. function tsetdef.is_publishable : boolean;
  3646. begin
  3647. is_publishable:=savesize in [1,2,4];
  3648. end;
  3649. function tsetdef.alignment: shortint;
  3650. begin
  3651. Result:=inherited;
  3652. if result>sizeof(aint) then
  3653. result:=sizeof(aint);
  3654. end;
  3655. function tsetdef.GetTypeName : string;
  3656. begin
  3657. if assigned(elementdef) then
  3658. GetTypeName:='Set Of '+elementdef.typename
  3659. else
  3660. GetTypeName:='Empty Set';
  3661. end;
  3662. {***************************************************************************
  3663. TFORMALDEF
  3664. ***************************************************************************}
  3665. constructor tformaldef.create(Atyped:boolean);
  3666. begin
  3667. inherited create(formaldef,true);
  3668. typed:=Atyped;
  3669. savesize:=0;
  3670. end;
  3671. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  3672. begin
  3673. inherited ppuload(formaldef,ppufile);
  3674. typed:=boolean(ppufile.getbyte);
  3675. savesize:=0;
  3676. ppuload_platform(ppufile);
  3677. end;
  3678. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  3679. begin
  3680. inherited ppuwrite(ppufile);
  3681. ppufile.putbyte(byte(typed));
  3682. writeentry(ppufile,ibformaldef);
  3683. end;
  3684. function tformaldef.GetTypeName : string;
  3685. begin
  3686. if typed then
  3687. GetTypeName:='<Typed formal type>'
  3688. else
  3689. GetTypeName:='<Formal type>';
  3690. end;
  3691. {***************************************************************************
  3692. TARRAYDEF
  3693. ***************************************************************************}
  3694. constructor tarraydef.create(l, h: asizeint; def: tdef);
  3695. begin
  3696. inherited create(arraydef,true);
  3697. lowrange:=l;
  3698. highrange:=h;
  3699. rangedef:=def;
  3700. rangedefderef.reset;
  3701. _elementdef:=nil;
  3702. _elementdefderef.reset;
  3703. arrayoptions:=[];
  3704. symtable:=tarraysymtable.create(self);
  3705. end;
  3706. constructor tarraydef.create_vector(l ,h: asizeint; def: tdef);
  3707. begin
  3708. self.create(l,h,def);
  3709. include(arrayoptions,ado_IsVector);
  3710. end;
  3711. constructor tarraydef.create_openarray;
  3712. begin
  3713. self.create(0,-1,sizesinttype);
  3714. include(arrayoptions,ado_OpenArray);
  3715. end;
  3716. class function tarraydef.getreusable_intern(def: tdef; elems: asizeint; const options: tarraydefoptions): tarraydef;
  3717. var
  3718. res: PHashSetItem;
  3719. oldsymtablestack: tsymtablestack;
  3720. arrdesc: packed record
  3721. def: tdef;
  3722. elecount: asizeint;
  3723. options: tarraydefoptions
  3724. end;
  3725. begin
  3726. if not assigned(current_module) then
  3727. internalerror(2011081301);
  3728. arrdesc.def:=def;
  3729. arrdesc.elecount:=elems;
  3730. arrdesc.options:=options;
  3731. res:=current_module.arraydefs.FindOrAdd(@arrdesc,sizeof(arrdesc));
  3732. if not assigned(res^.Data) then
  3733. begin
  3734. { since these pointerdefs can be reused anywhere in the current
  3735. unit, add them to the global/staticsymtable (or local symtable
  3736. if they're a local def, because otherwise they'll be saved
  3737. to the ppu referencing a local symtable entry that doesn't
  3738. exist in the ppu) }
  3739. oldsymtablestack:=symtablestack;
  3740. { do not simply push/pop current_module.localsymtable, because
  3741. that can have side-effects (e.g., it removes helpers) }
  3742. symtablestack:=nil;
  3743. result:=carraydef.create(0,elems-1,sizesinttype);
  3744. result.elementdef:=def;
  3745. result.arrayoptions:=options;
  3746. setup_reusable_def(def,result,res,oldsymtablestack);
  3747. { res^.Data may still be nil -> don't overwrite result }
  3748. exit;
  3749. end;
  3750. result:=tarraydef(res^.Data);
  3751. end;
  3752. class function tarraydef.getreusable(def: tdef; elems: asizeint): tarraydef;
  3753. begin
  3754. result:=getreusable_intern(def,elems,[]);
  3755. end;
  3756. class function tarraydef.getreusable_vector(def: tdef; elems: asizeint): tarraydef;
  3757. begin
  3758. result:=getreusable_intern(def,elems,[ado_IsVector]);
  3759. end;
  3760. class function tarraydef.getreusable_no_free(def: tdef; elems: asizeint): tarraydef;
  3761. begin
  3762. result:=getreusable(def,elems);
  3763. if not result.is_registered then
  3764. include(result.defoptions,df_not_registered_no_free);
  3765. end;
  3766. class function tarraydef.getreusable_no_free_vector(def: tdef; elems: asizeint): tarraydef;
  3767. begin
  3768. result:=getreusable_vector(def,elems);
  3769. if not result.is_registered then
  3770. include(result.defoptions,df_not_registered_no_free);
  3771. end;
  3772. destructor tarraydef.destroy;
  3773. begin
  3774. symtable.free;
  3775. symtable:=nil;
  3776. inherited;
  3777. end;
  3778. constructor tarraydef.create_from_pointer(def:tpointerdef);
  3779. begin
  3780. { divide by the element size and do -1 so the array will have a valid size,
  3781. further, the element size might be 0 e.g. for empty records, so use max(...,1)
  3782. to avoid a division by zero }
  3783. self.create(0,(high(asizeint) div max(def.pointeddef.size,1))-1,
  3784. def.converted_pointer_to_array_range_type);
  3785. arrayoptions:=[ado_IsConvertedPointer];
  3786. setelementdef(def.pointeddef);
  3787. end;
  3788. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  3789. begin
  3790. inherited ppuload(arraydef,ppufile);
  3791. { the addresses are calculated later }
  3792. ppufile.getderef(_elementdefderef);
  3793. ppufile.getderef(rangedefderef);
  3794. lowrange:=ppufile.getasizeint;
  3795. highrange:=ppufile.getasizeint;
  3796. ppufile.getset(tppuset2(arrayoptions));
  3797. ppuload_platform(ppufile);
  3798. symtable:=tarraysymtable.create(self);
  3799. tarraysymtable(symtable).ppuload(ppufile)
  3800. end;
  3801. function tarraydef.getcopy : tstoreddef;
  3802. begin
  3803. result:=carraydef.create(lowrange,highrange,rangedef);
  3804. tarraydef(result).arrayoptions:=arrayoptions;
  3805. tarraydef(result)._elementdef:=_elementdef;
  3806. end;
  3807. procedure tarraydef.buildderef;
  3808. begin
  3809. inherited buildderef;
  3810. tarraysymtable(symtable).buildderef;
  3811. _elementdefderef.build(_elementdef);
  3812. rangedefderef.build(rangedef);
  3813. end;
  3814. procedure tarraydef.deref;
  3815. begin
  3816. inherited deref;
  3817. tarraysymtable(symtable).deref(false);
  3818. _elementdef:=tdef(_elementdefderef.resolve);
  3819. rangedef:=tdef(rangedefderef.resolve);
  3820. end;
  3821. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  3822. begin
  3823. inherited ppuwrite(ppufile);
  3824. ppufile.putderef(_elementdefderef);
  3825. ppufile.putderef(rangedefderef);
  3826. ppufile.putasizeint(lowrange);
  3827. ppufile.putasizeint(highrange);
  3828. ppufile.putset(tppuset2(arrayoptions));
  3829. writeentry(ppufile,ibarraydef);
  3830. tarraysymtable(symtable).ppuwrite(ppufile);
  3831. end;
  3832. function tarraydef.elesize : asizeint;
  3833. begin
  3834. if (ado_IsBitPacked in arrayoptions) then
  3835. internalerror(2006080101);
  3836. if assigned(_elementdef) then
  3837. result:=_elementdef.size
  3838. else
  3839. result:=0;
  3840. end;
  3841. function tarraydef.elepackedbitsize : asizeint;
  3842. begin
  3843. if not(ado_IsBitPacked in arrayoptions) then
  3844. internalerror(2006080102);
  3845. if assigned(_elementdef) then
  3846. result:=_elementdef.packedbitsize
  3847. else
  3848. result:=0;
  3849. end;
  3850. function tarraydef.elecount : asizeuint;
  3851. var
  3852. qhigh,qlow : qword;
  3853. begin
  3854. if ado_IsDynamicArray in arrayoptions then
  3855. begin
  3856. result:=0;
  3857. exit;
  3858. end;
  3859. if (highrange>0) and (lowrange<0) then
  3860. begin
  3861. qhigh:=highrange;
  3862. if lowrange=low(asizeint) then
  3863. qlow:=high(asizeint) + 1
  3864. else
  3865. qlow:=qword(-lowrange);
  3866. { prevent overflow, return 0 to indicate overflow }
  3867. if qhigh+qlow>qword(high(asizeint)-1) then
  3868. result:=0
  3869. else
  3870. result:=qhigh+qlow+1;
  3871. end
  3872. else
  3873. result:=int64(highrange)-lowrange+1;
  3874. end;
  3875. function tarraydef.size : asizeint;
  3876. var
  3877. cachedelecount : asizeuint;
  3878. cachedelesize : asizeint;
  3879. begin
  3880. if ado_IsDynamicArray in arrayoptions then
  3881. begin
  3882. size:=voidpointertype.size;
  3883. exit;
  3884. end;
  3885. { Tarraydef.size may never be called for an open array! }
  3886. if ado_OpenArray in arrayoptions then
  3887. internalerror(99080501);
  3888. if not (ado_IsBitPacked in arrayoptions) then
  3889. cachedelesize:=elesize
  3890. else
  3891. cachedelesize := elepackedbitsize;
  3892. cachedelecount:=elecount;
  3893. if (cachedelesize = 0) then
  3894. begin
  3895. size := 0;
  3896. exit;
  3897. end;
  3898. if (cachedelecount = 0) then
  3899. begin
  3900. if ado_isconststring in arrayoptions then
  3901. size := 0
  3902. else
  3903. size := -1;
  3904. exit;
  3905. end;
  3906. { prevent overflow, return -1 to indicate overflow }
  3907. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  3908. if (cachedelecount > asizeuint(high(asizeint))) or
  3909. ((high(asizeint) div cachedelesize) < asizeint(cachedelecount)) or
  3910. { also lowrange*elesize must be < high(asizeint) to prevent overflow when
  3911. accessing the array, see ncgmem (PFV) }
  3912. ((high(asizeint) div cachedelesize) < abs(lowrange)) then
  3913. begin
  3914. result:=-1;
  3915. exit;
  3916. end;
  3917. result:=cachedelesize*asizeint(cachedelecount);
  3918. if (ado_IsBitPacked in arrayoptions) then
  3919. { can't just add 7 and divide by 8, because that may overflow }
  3920. result:=result div 8 + ord((result mod 8)<>0);
  3921. {$ifdef cpu16bitaddr}
  3922. if result>65535 then
  3923. begin
  3924. result:=-1;
  3925. exit;
  3926. end;
  3927. {$endif cpu16bitaddr}
  3928. end;
  3929. procedure tarraydef.setelementdef(def:tdef);
  3930. begin
  3931. _elementdef:=def;
  3932. if not(
  3933. (ado_IsDynamicArray in arrayoptions) or
  3934. (ado_IsConvertedPointer in arrayoptions) or
  3935. (ado_IsConstructor in arrayoptions) or
  3936. (ado_IsGeneric in arrayoptions) or
  3937. (highrange<lowrange)
  3938. ) and
  3939. (size=-1) then
  3940. Message(sym_e_segment_too_large);
  3941. end;
  3942. function tarraydef.alignment : shortint;
  3943. begin
  3944. if ado_IsVector in arrayoptions then
  3945. alignment:=size
  3946. { alignment of dyn. arrays doesn't depend on the element size }
  3947. else if ado_IsDynamicArray in arrayoptions then
  3948. alignment:=voidpointertype.alignment
  3949. { alignment is the target alignment for the used load size }
  3950. else if (ado_IsBitPacked in arrayoptions) and
  3951. (elementdef.typ in [enumdef,orddef]) then
  3952. alignment:=cgsize_orddef(int_cgsize(packedbitsloadsize(elepackedbitsize))).alignment
  3953. { alignment is the alignment of the elements }
  3954. else
  3955. alignment:=elementdef.alignment
  3956. end;
  3957. function tarraydef.needs_inittable : boolean;
  3958. begin
  3959. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  3960. end;
  3961. function tarraydef.needs_separate_initrtti : boolean;
  3962. begin
  3963. if ado_IsBitPacked in arrayoptions then
  3964. result:=false
  3965. else
  3966. result:=elementdef.needs_separate_initrtti;
  3967. end;
  3968. function tarraydef.GetTypeName : string;
  3969. begin
  3970. if (ado_IsConstString in arrayoptions) then
  3971. result:='Constant String'
  3972. else if (ado_isarrayofconst in arrayoptions) or
  3973. (ado_isConstructor in arrayoptions) then
  3974. begin
  3975. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  3976. GetTypeName:='Array Of Const'
  3977. else
  3978. GetTypeName:='{Array Of Const/Constant Open} Array of '+elementdef.typename;
  3979. end
  3980. else if (ado_IsDynamicArray in arrayoptions) then
  3981. GetTypeName:='{Dynamic} Array Of '+elementdef.typename
  3982. else if (ado_OpenArray in arrayoptions) then
  3983. GetTypeName:='{Open} Array Of '+elementdef.typename
  3984. else
  3985. begin
  3986. result := '';
  3987. if (ado_IsBitPacked in arrayoptions) then
  3988. result:='BitPacked ';
  3989. if rangedef.typ=enumdef then
  3990. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  3991. else
  3992. result:=result+'Array['+tostr(lowrange)+'..'+
  3993. tostr(highrange)+'] Of '+elementdef.typename
  3994. end;
  3995. end;
  3996. function tarraydef.getmangledparaname : TSymStr;
  3997. begin
  3998. if ado_isarrayofconst in arrayoptions then
  3999. getmangledparaname:='array_of_const'
  4000. else
  4001. if ((highrange=-1) and (lowrange=0)) then
  4002. getmangledparaname:='array_of_'+elementdef.mangledparaname
  4003. else
  4004. internalerror(200204176);
  4005. end;
  4006. function tarraydef.is_publishable : boolean;
  4007. begin
  4008. Result:=ado_IsDynamicArray in arrayoptions;
  4009. end;
  4010. function tarraydef.is_hwvector: boolean;
  4011. begin
  4012. result:=ado_IsVector in arrayoptions;
  4013. end;
  4014. {***************************************************************************
  4015. tabstractrecorddef
  4016. ***************************************************************************}
  4017. constructor tabstractrecorddef.create(const n:string; dt:tdeftyp;doregister:boolean);
  4018. begin
  4019. inherited create(dt,doregister);
  4020. objname:=stringdup(upper(n));
  4021. objrealname:=stringdup(n);
  4022. objectoptions:=[];
  4023. if assigned(current_module.namespace) then
  4024. begin
  4025. import_lib:=stringdup(current_module.namespace^);
  4026. replace(import_lib^,'.','/');
  4027. end;
  4028. end;
  4029. constructor tabstractrecorddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  4030. begin
  4031. inherited ppuload(dt,ppufile);
  4032. objrealname:=ppufile.getpshortstring;
  4033. objname:=stringdup(upper(objrealname^));
  4034. import_lib:=ppufile.getpshortstring;
  4035. { only used for external C++ classes and Java classes/records }
  4036. if (import_lib^='') then
  4037. stringdispose(import_lib);
  4038. ppufile.getset(tppuset4(objectoptions));
  4039. end;
  4040. procedure tabstractrecorddef.ppuwrite(ppufile: tcompilerppufile);
  4041. begin
  4042. inherited ppuwrite(ppufile);
  4043. ppufile.putstring(objrealname^);
  4044. if assigned(import_lib) then
  4045. ppufile.putstring(import_lib^)
  4046. else
  4047. ppufile.putstring('');
  4048. ppufile.putset(tppuset4(objectoptions));
  4049. end;
  4050. destructor tabstractrecorddef.destroy;
  4051. begin
  4052. stringdispose(objname);
  4053. stringdispose(objrealname);
  4054. stringdispose(import_lib);
  4055. tcinitcode.free;
  4056. inherited destroy;
  4057. end;
  4058. procedure tabstractrecorddef.buildderefimpl;
  4059. begin
  4060. inherited buildderefimpl;
  4061. if not (df_copied_def in defoptions) then
  4062. tstoredsymtable(symtable).buildderefimpl;
  4063. end;
  4064. procedure tabstractrecorddef.derefimpl;
  4065. begin
  4066. inherited derefimpl;
  4067. if not (df_copied_def in defoptions) then
  4068. tstoredsymtable(symtable).derefimpl(false);
  4069. end;
  4070. procedure tabstractrecorddef.check_forwards;
  4071. begin
  4072. { the defs of a copied def are defined for the original type only }
  4073. if not(df_copied_def in defoptions) then
  4074. tstoredsymtable(symtable).check_forwards;
  4075. end;
  4076. function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
  4077. var
  4078. i: longint;
  4079. sym: tsym;
  4080. begin
  4081. for i:=0 to symtable.SymList.Count-1 do
  4082. begin
  4083. sym:=tsym(symtable.SymList[i]);
  4084. if sym.typ=procsym then
  4085. begin
  4086. result:=tprocsym(sym).find_procdef_bytype(pt);
  4087. if assigned(result) then
  4088. exit;
  4089. end;
  4090. end;
  4091. result:=nil;
  4092. end;
  4093. function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
  4094. begin
  4095. if t=gs_record then
  4096. GetSymtable:=symtable
  4097. else
  4098. GetSymtable:=nil;
  4099. end;
  4100. function tabstractrecorddef.is_packed:boolean;
  4101. begin
  4102. result:=tabstractrecordsymtable(symtable).is_packed;
  4103. end;
  4104. function tabstractrecorddef.RttiName: string;
  4105. function generate_full_paramname(maxlength:longint):string;
  4106. const
  4107. commacount : array[boolean] of longint = (0,1);
  4108. var
  4109. fullparas,
  4110. paramname : ansistring;
  4111. module : tmodule;
  4112. sym : tsym;
  4113. def : tdef;
  4114. i : longint;
  4115. begin
  4116. { we want at least enough space for an ellipsis }
  4117. if maxlength<3 then
  4118. internalerror(2014121203);
  4119. fullparas:='';
  4120. for i:=0 to genericparas.count-1 do
  4121. begin
  4122. sym:=tsym(genericparas[i]);
  4123. module:=find_module_from_symtable(sym.owner);
  4124. if not assigned(module) then
  4125. internalerror(2014121202);
  4126. if not (sym.typ in [constsym,symconst.typesym]) then
  4127. internalerror(2020042501);
  4128. if sym.typ=constsym then
  4129. def:=tconstsym(sym).constdef
  4130. else
  4131. def:=ttypesym(sym).typedef;
  4132. paramname:=module.realmodulename^;
  4133. if def.typ in [objectdef,recorddef] then
  4134. paramname:=paramname+'.'+tabstractrecorddef(def).rttiname
  4135. else
  4136. paramname:=paramname+'.'+def.typename;
  4137. if length(fullparas)+commacount[i>0]+length(paramname)>maxlength then
  4138. begin
  4139. if i>0 then
  4140. fullparas:=fullparas+',...'
  4141. else
  4142. fullparas:=fullparas+'...';
  4143. break;
  4144. end;
  4145. { could we fit an ellipsis after this parameter if it should be too long? }
  4146. if (maxlength-(length(fullparas)+commacount[i>0]+length(paramname))<4) and (i<genericparas.count-1) then
  4147. begin
  4148. { then omit already this parameter }
  4149. if i>0 then
  4150. fullparas:=fullparas+',...'
  4151. else
  4152. fullparas:=fullparas+'...';
  4153. break;
  4154. end;
  4155. if i>0 then
  4156. fullparas:=fullparas+',';
  4157. fullparas:=fullparas+paramname;
  4158. end;
  4159. result:=fullparas;
  4160. end;
  4161. var
  4162. nongeneric,
  4163. basename : string;
  4164. i,
  4165. remlength,
  4166. paramcount,
  4167. crcidx : longint;
  4168. begin
  4169. if rttistring='' then
  4170. begin
  4171. if is_specialization then
  4172. begin
  4173. rttistring:=OwnerHierarchyName;
  4174. { there should be two $ characters, one before the CRC and one before the count }
  4175. crcidx:=-1;
  4176. for i:=length(objrealname^) downto 1 do
  4177. if objrealname^[i]='$' then
  4178. begin
  4179. crcidx:=i;
  4180. break;
  4181. end;
  4182. if crcidx<0 then
  4183. internalerror(2014121201);
  4184. basename:=copy(objrealname^,1,crcidx-1);
  4185. split_generic_name(basename,nongeneric,paramcount);
  4186. rttistring:=rttistring+nongeneric+'<';
  4187. remlength:=255-length(rttistring)-1;
  4188. if remlength<4 then
  4189. rttistring:=rttistring+'>'
  4190. else
  4191. rttistring:=rttistring+generate_full_paramname(remlength)+'>';
  4192. end
  4193. else
  4194. if is_generic then
  4195. begin
  4196. rttistring:=OwnerHierarchyName;
  4197. split_generic_name(objrealname^,nongeneric,paramcount);
  4198. rttistring:=rttistring+nongeneric+'<';
  4199. { we don't want any ',' if there is only one parameter }
  4200. for i:=0 to paramcount-0 do
  4201. rttistring:=rttistring+',';
  4202. rttistring:=rttistring+'>';
  4203. end
  4204. else
  4205. rttistring:=OwnerHierarchyName+objrealname^;
  4206. end;
  4207. result:=rttistring;
  4208. end;
  4209. function tabstractrecorddef.search_enumerator_get: tprocdef;
  4210. var
  4211. sym : tsym;
  4212. i : integer;
  4213. pd : tprocdef;
  4214. hashedid : THashedIDString;
  4215. begin
  4216. result:=nil;
  4217. hashedid.id:='GETENUMERATOR';
  4218. sym:=tsym(symtable.FindWithHash(hashedid));
  4219. if assigned(sym) and (sym.typ=procsym) then
  4220. begin
  4221. for i := 0 to Tprocsym(sym).ProcdefList.Count - 1 do
  4222. begin
  4223. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  4224. if (pd.proctypeoption = potype_function) and
  4225. (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) and
  4226. (pd.visibility >= vis_public) then
  4227. begin
  4228. result:=pd;
  4229. exit;
  4230. end;
  4231. end;
  4232. end;
  4233. end;
  4234. function tabstractrecorddef.search_enumerator_move: tprocdef;
  4235. var
  4236. sym : tsym;
  4237. i : integer;
  4238. pd : tprocdef;
  4239. hashedid : THashedIDString;
  4240. begin
  4241. result:=nil;
  4242. // first search for po_enumerator_movenext method modifier
  4243. // then search for public function MoveNext: Boolean
  4244. for i:=0 to symtable.SymList.Count-1 do
  4245. begin
  4246. sym:=TSym(symtable.SymList[i]);
  4247. if (sym.typ=procsym) then
  4248. begin
  4249. pd:=Tprocsym(sym).find_procdef_byoptions([po_enumerator_movenext]);
  4250. if assigned(pd) then
  4251. begin
  4252. result:=pd;
  4253. exit;
  4254. end;
  4255. end;
  4256. end;
  4257. hashedid.id:='MOVENEXT';
  4258. sym:=tsym(symtable.FindWithHash(hashedid));
  4259. if assigned(sym) and (sym.typ=procsym) then
  4260. begin
  4261. for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
  4262. begin
  4263. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  4264. if (pd.proctypeoption = potype_function) and
  4265. is_boolean(pd.returndef) and
  4266. (pd.minparacount = 0) and
  4267. (pd.visibility >= vis_public) then
  4268. begin
  4269. result:=pd;
  4270. exit;
  4271. end;
  4272. end;
  4273. end;
  4274. end;
  4275. function tabstractrecorddef.search_enumerator_current: tsym;
  4276. var
  4277. sym: tsym;
  4278. i: integer;
  4279. hashedid : THashedIDString;
  4280. begin
  4281. result:=nil;
  4282. // first search for ppo_enumerator_current property modifier
  4283. // then search for public property Current
  4284. for i:=0 to symtable.SymList.Count-1 do
  4285. begin
  4286. sym:=TSym(symtable.SymList[i]);
  4287. if (sym.typ=propertysym) and (ppo_enumerator_current in tpropertysym(sym).propoptions) then
  4288. begin
  4289. result:=sym;
  4290. exit;
  4291. end;
  4292. end;
  4293. hashedid.id:='CURRENT';
  4294. sym:=tsym(symtable.FindWithHash(hashedid));
  4295. if assigned(sym) and (sym.typ=propertysym) and
  4296. (sym.visibility >= vis_public) and not tpropertysym(sym).propaccesslist[palt_read].empty then
  4297. begin
  4298. result:=sym;
  4299. exit;
  4300. end;
  4301. end;
  4302. function tabstractrecorddef.jvm_full_typename(with_package_name: boolean): string;
  4303. var
  4304. st: tsymtable;
  4305. enclosingdef: tdef;
  4306. begin
  4307. if typ=objectdef then
  4308. result:=tobjectdef(self).objextname^
  4309. else if assigned(typesym) then
  4310. result:=typesym.realname
  4311. { have to generate anonymous nested type in current unit/class/record }
  4312. else
  4313. internalerror(2011032601);
  4314. { in case of specializations, add some extras to prevent name conflicts
  4315. with nested classes }
  4316. if df_specialization in defoptions then
  4317. result:='$'+result+'$specialization$';
  4318. st:=owner;
  4319. while assigned(st) and
  4320. (st.symtabletype in [objectsymtable,recordsymtable,localsymtable]) do
  4321. begin
  4322. { nested classes are named as "OuterClass$InnerClass" }
  4323. enclosingdef:=tdef(st.defowner);
  4324. if enclosingdef.typ=procdef then
  4325. result:=result+tprocdef(enclosingdef).procsym.realname+'$$'+tostr(tprocdef(enclosingdef).procsym.symid)+'$'
  4326. else if enclosingdef.typ=objectdef then
  4327. result:=tobjectdef(enclosingdef).objextname^+'$'+result
  4328. else if assigned(enclosingdef.typesym) then
  4329. result:=enclosingdef.typesym.realname+'$'+result
  4330. else
  4331. internalerror(2011060305);
  4332. st:=enclosingdef.owner;
  4333. end;
  4334. if with_package_name and
  4335. assigned(import_lib) then
  4336. result:=import_lib^+'/'+result;
  4337. end;
  4338. function tabstractrecorddef.contains_float_field: boolean;
  4339. var
  4340. i : longint;
  4341. begin
  4342. result:=true;
  4343. for i:=0 to symtable.symlist.count-1 do
  4344. begin
  4345. if (tsym(symtable.symlist[i]).typ<>fieldvarsym) or
  4346. (sp_static in tsym(symtable.symlist[i]).symoptions) then
  4347. continue;
  4348. if assigned(tfieldvarsym(symtable.symlist[i]).vardef) then
  4349. begin
  4350. if tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).is_fpuregable then
  4351. exit;
  4352. { search recursively }
  4353. if (tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).typ=recorddef) and
  4354. (tabstractrecorddef(tfieldvarsym(symtable.symlist[i]).vardef).contains_float_field) then
  4355. exit;
  4356. end;
  4357. end;
  4358. result:=false;
  4359. end;
  4360. function tabstractrecorddef.contains_cross_aword_field: boolean;
  4361. var
  4362. i : longint;
  4363. foffset, fsize: aword;
  4364. begin
  4365. result:=true;
  4366. for i:=0 to symtable.symlist.count-1 do
  4367. begin
  4368. if (tsym(symtable.symlist[i]).typ<>fieldvarsym) or
  4369. (sp_static in tsym(symtable.symlist[i]).symoptions) then
  4370. continue;
  4371. if assigned(tfieldvarsym(symtable.symlist[i]).vardef) then
  4372. begin
  4373. if is_packed then
  4374. begin
  4375. foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset;
  4376. fsize:=tfieldvarsym(symtable.symlist[i]).vardef.packedbitsize;
  4377. end
  4378. else
  4379. begin
  4380. foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset*8;
  4381. fsize:=tfieldvarsym(symtable.symlist[i]).vardef.size*8;
  4382. end;
  4383. if (fsize>0) and ((foffset div (sizeof(aword)*8)) <> ((foffset+fsize-1) div (sizeof(aword)*8))) then
  4384. exit;
  4385. { search recursively }
  4386. if (tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).typ=recorddef) and
  4387. (tabstractrecorddef(tfieldvarsym(symtable.symlist[i]).vardef).contains_cross_aword_field) then
  4388. exit;
  4389. end;
  4390. end;
  4391. result:=false;
  4392. end;
  4393. {$ifdef DEBUG_NODE_XML}
  4394. procedure tabstractrecorddef.XMLPrintDefData(var T: Text; Sym: TSym);
  4395. procedure WriteSymOptions(SourceSym: TSym);
  4396. var
  4397. i: TSymOption;
  4398. first: Boolean;
  4399. begin
  4400. First := True;
  4401. for i := Low(TSymOption) to High(TSymOption) do
  4402. if i in SourceSym.symoptions then
  4403. begin
  4404. if First then
  4405. begin
  4406. Write(T, '" symoptions="', i);
  4407. First := False;
  4408. end
  4409. else
  4410. Write(T, ',', i)
  4411. end;
  4412. end;
  4413. var
  4414. List: TFPHashObjectList;
  4415. i: Integer;
  4416. begin
  4417. WriteLn(T, PrintNodeIndention, '<size>', size, '</size>');
  4418. if (alignment = structalignment) and (alignment = aggregatealignment) then
  4419. begin
  4420. { Straightforward and simple }
  4421. WriteLn(T, PrintNodeIndention, '<alignment>', alignment, '</alignment>');
  4422. end
  4423. else
  4424. begin
  4425. WriteLn(T, PrintNodeIndention, '<alignment>');
  4426. printnodeindent;
  4427. WriteLn(T, PrintNodeIndention, '<basic>', alignment, '</basic>');
  4428. if (structalignment <> alignment) then
  4429. WriteLn(T, PrintNodeIndention, '<struct>', structalignment, '</struct>');
  4430. if (aggregatealignment <> alignment) and (aggregatealignment <> structalignment) then
  4431. WriteLn(T, PrintNodeIndention, '<aggregate>', aggregatealignment, '</aggregate>');
  4432. printnodeunindent;
  4433. WriteLn(T, PrintNodeIndention, '</alignment>');
  4434. end;
  4435. { List the fields }
  4436. List := Symtable.SymList;
  4437. for i := 0 to List.Count - 1 do
  4438. case TSym(List[i]).typ of
  4439. { staticvarsym,localvarsym,paravarsym,fieldvarsym,
  4440. typesym,procsym,unitsym,}
  4441. constsym:
  4442. with TConstSym(List[i]) do
  4443. begin
  4444. Write(T, PrintNodeIndention, '<const name="', RealName, '" pos="', fileinfo.line, ',', fileinfo.column);
  4445. WriteSymOptions(TSym(List[i]));
  4446. WriteLn(T, '">');
  4447. PrintNodeIndent;
  4448. XMLPrintConstData(T);
  4449. PrintNodeUnindent;
  4450. WriteLn(T, PrintNodeIndention, '</const>');
  4451. end;
  4452. {
  4453. errorsym,syssym,labelsym,absolutevarsym,propertysym,
  4454. macrosym,namespacesym,undefinedsym,programparasym
  4455. }
  4456. fieldvarsym:
  4457. with TFieldVarSym(List[i]) do
  4458. begin
  4459. Write(T, PrintNodeIndention, '<field name="', RealName, '" pos="', fileinfo.line, ',', fileinfo.column);
  4460. WriteSymOptions(TSym(List[i]));
  4461. WriteLn(T, '">');
  4462. PrintNodeIndent;
  4463. XMLPrintFieldData(T);
  4464. PrintNodeUnindent;
  4465. WriteLn(T, PrintNodeIndention, '</field>');
  4466. end;
  4467. else
  4468. ;
  4469. end;
  4470. end;
  4471. {$endif DEBUG_NODE_XML}
  4472. {***************************************************************************
  4473. trecorddef
  4474. ***************************************************************************}
  4475. constructor trecorddef.create(const n:string; p:TSymtable);
  4476. begin
  4477. inherited create(n,recorddef,true);
  4478. symtable:=p;
  4479. { we can own the symtable only if nobody else owns a copy so far }
  4480. if symtable.refcount=1 then
  4481. symtable.defowner:=self;
  4482. isunion:=false;
  4483. cloneddefderef.reset;
  4484. end;
  4485. constructor trecorddef.create_global_internal(const n: string; packrecords, recordalignmin: shortint);
  4486. var
  4487. name : string;
  4488. pname : pshortstring;
  4489. oldsymtablestack: tsymtablestack;
  4490. where : tsymtable;
  4491. ts: ttypesym;
  4492. begin
  4493. { construct name }
  4494. if n<>'' then
  4495. pname:=@n
  4496. else
  4497. begin
  4498. init_defid;
  4499. name:='$InternalRec'+unique_id_str;
  4500. pname:=@name;
  4501. end;
  4502. oldsymtablestack:=symtablestack;
  4503. { do not simply push/pop current_module.localsymtable, because
  4504. that can have side-effects (e.g., it removes helpers) }
  4505. symtablestack:=nil;
  4506. symtable:=trecordsymtable.create(pname^,packrecords,recordalignmin);
  4507. symtable.defowner:=self;
  4508. isunion:=false;
  4509. inherited create(pname^,recorddef,true);
  4510. where:=current_module.localsymtable;
  4511. if not assigned(where) then
  4512. where:=current_module.globalsymtable;
  4513. where.insertdef(self);
  4514. { if we specified a name, then we'll probably want to look up the
  4515. type again by name too -> create typesym }
  4516. if n<>'' then
  4517. begin
  4518. ts:=ctypesym.create(n,self);
  4519. { avoid hints about unused types (these may only be used for
  4520. typed constant data) }
  4521. ts.increfcount;
  4522. where.insertsym(ts);
  4523. end;
  4524. symtablestack:=oldsymtablestack;
  4525. { don't create RTTI for internal types, these are not exported }
  4526. defstates:=defstates+[ds_rtti_table_written,ds_init_table_written];
  4527. include(defoptions,df_internal);
  4528. end;
  4529. function trecorddef.add_field_by_def(const optionalname: TIDString; def: tdef): tsym;
  4530. var
  4531. sym: tfieldvarsym;
  4532. name: TIDString;
  4533. pname: ^TIDString;
  4534. begin
  4535. if optionalname='' then
  4536. begin
  4537. name:='$f'+tostr(trecordsymtable(symtable).symlist.count);
  4538. pname:=@name
  4539. end
  4540. else
  4541. pname:=@optionalname;
  4542. sym:=cfieldvarsym.create(pname^,vs_value,def,[]);
  4543. symtable.insertsym(sym);
  4544. trecordsymtable(symtable).addfield(sym,vis_hidden);
  4545. result:=sym;
  4546. end;
  4547. procedure trecorddef.add_fields_from_deflist(fieldtypes: tfplist);
  4548. var
  4549. i: longint;
  4550. begin
  4551. for i:=0 to fieldtypes.count-1 do
  4552. add_field_by_def('',tdef(fieldtypes[i]));
  4553. end;
  4554. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  4555. procedure readvariantrecdesc(var variantrecdesc : pvariantrecdesc);
  4556. var
  4557. i,j : longint;
  4558. begin
  4559. if ppufile.getbyte=1 then
  4560. begin
  4561. new(variantrecdesc);
  4562. ppufile.getderef(variantrecdesc^.variantselectorderef);
  4563. SetLength(variantrecdesc^.branches,ppufile.getasizeint);
  4564. for i:=0 to high(variantrecdesc^.branches) do
  4565. begin
  4566. SetLength(variantrecdesc^.branches[i].values,ppufile.getasizeint);
  4567. for j:=0 to high(variantrecdesc^.branches[i].values) do
  4568. variantrecdesc^.branches[i].values[j]:=ppufile.getexprint;
  4569. readvariantrecdesc(variantrecdesc^.branches[i].nestedvariant);
  4570. end;
  4571. end
  4572. else
  4573. variantrecdesc:=nil;
  4574. end;
  4575. begin
  4576. inherited ppuload(recorddef,ppufile);
  4577. if df_copied_def in defoptions then
  4578. begin
  4579. ppufile.getderef(cloneddefderef);
  4580. ppuload_platform(ppufile);
  4581. end
  4582. else
  4583. begin
  4584. symtable:=trecordsymtable.create(objrealname^,0,0);
  4585. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  4586. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  4587. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  4588. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  4589. trecordsymtable(symtable).recordalignmin:=shortint(ppufile.getbyte);
  4590. trecordsymtable(symtable).datasize:=ppufile.getasizeint;
  4591. trecordsymtable(symtable).paddingsize:=ppufile.getword;
  4592. ppufile.getset(tppuset1(trecordsymtable(symtable).managementoperators));
  4593. { position of ppuload_platform call must correspond
  4594. to position of writeentry in ppuwrite method }
  4595. ppuload_platform(ppufile);
  4596. trecordsymtable(symtable).ppuload(ppufile);
  4597. { the variantrecdesc is needed only for iso-like new statements new(prec,1,2,3 ...);
  4598. but because iso mode supports no units, there is no need to store the variantrecdesc
  4599. in the ppu
  4600. }
  4601. // readvariantrecdesc(variantrecdesc);
  4602. { requires usefieldalignment to be set }
  4603. symtable.defowner:=self;
  4604. end;
  4605. isunion:=false;
  4606. end;
  4607. destructor trecorddef.destroy;
  4608. procedure free_variantrecdesc(var variantrecdesc : pvariantrecdesc);
  4609. var
  4610. i : longint;
  4611. begin
  4612. while assigned(variantrecdesc) do
  4613. begin
  4614. for i:=0 to high(variantrecdesc^.branches) do
  4615. begin
  4616. free_variantrecdesc(variantrecdesc^.branches[i].nestedvariant);
  4617. SetLength(variantrecdesc^.branches[i].values,0);
  4618. end;
  4619. SetLength(variantrecdesc^.branches,0);
  4620. dispose(variantrecdesc);
  4621. variantrecdesc:=nil;
  4622. end;
  4623. end;
  4624. begin
  4625. if assigned(variantrecdesc) then
  4626. free_variantrecdesc(variantrecdesc);
  4627. if assigned(symtable) then
  4628. begin
  4629. symtable.free;
  4630. symtable:=nil;
  4631. end;
  4632. inherited destroy;
  4633. end;
  4634. function trecorddef.getcopy : tstoreddef;
  4635. begin
  4636. result:=crecorddef.create(objrealname^,symtable.getcopy);
  4637. trecorddef(result).isunion:=isunion;
  4638. include(trecorddef(result).defoptions,df_copied_def);
  4639. if assigned(tcinitcode) then
  4640. trecorddef(result).tcinitcode:=tcinitcode.getcopy;
  4641. if assigned(import_lib) then
  4642. trecorddef(result).import_lib:=stringdup(import_lib^);
  4643. end;
  4644. function trecorddef.needs_inittable : boolean;
  4645. begin
  4646. { each record with managed field or with any management operator needs
  4647. init table }
  4648. needs_inittable:=(trecordsymtable(symtable).managementoperators<>[]) or
  4649. trecordsymtable(symtable).needs_init_final
  4650. end;
  4651. function trecorddef.needs_separate_initrtti : boolean;
  4652. begin
  4653. result:=true;
  4654. end;
  4655. function trecorddef.has_non_trivial_init_child(check_parent:boolean):boolean;
  4656. begin
  4657. result:=trecordsymtable(symtable).has_non_trivial_init;
  4658. end;
  4659. procedure trecorddef.buildderef;
  4660. begin
  4661. inherited buildderef;
  4662. if df_copied_def in defoptions then
  4663. cloneddefderef.build(symtable.defowner)
  4664. else
  4665. tstoredsymtable(symtable).buildderef;
  4666. end;
  4667. procedure trecorddef.deref;
  4668. begin
  4669. inherited deref;
  4670. { now dereference the definitions }
  4671. if df_copied_def in defoptions then
  4672. begin
  4673. cloneddef:=trecorddef(cloneddefderef.resolve);
  4674. symtable:=cloneddef.symtable.getcopy;
  4675. end
  4676. else
  4677. tstoredsymtable(symtable).deref(false);
  4678. { internal types, only load from the system unit }
  4679. if assigned(owner) and
  4680. assigned(owner.name) and
  4681. (owner.name^='SYSTEM') then
  4682. begin
  4683. { TGUID }
  4684. if not assigned(rec_tguid) and
  4685. (upper(typename)='TGUID') then
  4686. rec_tguid:=self
  4687. { JMP_BUF }
  4688. else if not assigned(rec_jmp_buf) and
  4689. (upper(typename)='JMP_BUF') then
  4690. rec_jmp_buf:=self
  4691. else if not assigned(rec_exceptaddr) and
  4692. (upper(typename)='TEXCEPTADDR') then
  4693. rec_exceptaddr:=self;
  4694. end;
  4695. end;
  4696. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  4697. procedure writevariantrecdesc(variantrecdesc : pvariantrecdesc);
  4698. var
  4699. i,j : longint;
  4700. begin
  4701. if assigned(variantrecdesc) then
  4702. begin
  4703. ppufile.putbyte(1);
  4704. ppufile.putderef(variantrecdesc^.variantselectorderef);
  4705. ppufile.putasizeint(length(variantrecdesc^.branches));
  4706. for i:=0 to high(variantrecdesc^.branches) do
  4707. begin
  4708. ppufile.putasizeint(length(variantrecdesc^.branches[i].values));
  4709. for j:=0 to high(variantrecdesc^.branches[i].values) do
  4710. ppufile.putexprint(variantrecdesc^.branches[i].values[j]);
  4711. writevariantrecdesc(variantrecdesc^.branches[i].nestedvariant);
  4712. end;
  4713. end
  4714. else
  4715. ppufile.putbyte(0);
  4716. end;
  4717. begin
  4718. inherited ppuwrite(ppufile);
  4719. if df_copied_def in defoptions then
  4720. ppufile.putderef(cloneddefderef)
  4721. else
  4722. begin
  4723. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  4724. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  4725. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  4726. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  4727. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignmin));
  4728. ppufile.putasizeint(trecordsymtable(symtable).datasize);
  4729. ppufile.putword(trecordsymtable(symtable).paddingsize);
  4730. ppufile.putset(tppuset1(trecordsymtable(symtable).managementoperators));
  4731. { the variantrecdesc is needed only for iso-like new statements new(prec,1,2,3 ...);
  4732. but because iso mode supports no units, there is no need to store the variantrecdesc
  4733. in the ppu
  4734. }
  4735. // writevariantrecdesc(variantrecdesc);
  4736. end;
  4737. writeentry(ppufile,ibrecorddef);
  4738. if not(df_copied_def in defoptions) then
  4739. trecordsymtable(symtable).ppuwrite(ppufile);
  4740. end;
  4741. function trecorddef.size:asizeint;
  4742. begin
  4743. result:=trecordsymtable(symtable).datasize;
  4744. end;
  4745. function trecorddef.alignment:shortint;
  4746. begin
  4747. alignment:=trecordsymtable(symtable).recordalignment;
  4748. end;
  4749. function trecorddef.padalignment:shortint;
  4750. begin
  4751. padalignment := trecordsymtable(symtable).padalignment;
  4752. end;
  4753. function trecorddef.GetTypeName : string;
  4754. begin
  4755. GetTypeName:='<record type>'
  4756. end;
  4757. {$ifdef DEBUG_NODE_XML}
  4758. function TRecordDef.XMLPrintType: ansistring;
  4759. begin
  4760. Result := '&lt;record&gt;';
  4761. end;
  4762. {$endif DEBUG_NODE_XML}
  4763. {***************************************************************************
  4764. TABSTRACTPROCDEF
  4765. ***************************************************************************}
  4766. constructor tabstractprocdef.create(dt:tdeftyp;level:byte;doregister:boolean);
  4767. begin
  4768. inherited create(dt,doregister);
  4769. parast:=tparasymtable.create(self,level);
  4770. paras:=nil;
  4771. minparacount:=0;
  4772. maxparacount:=0;
  4773. proctypeoption:=potype_none;
  4774. proccalloption:=pocall_none;
  4775. procoptions:=[];
  4776. returndef:=voidtype;
  4777. returndefderef.reset;
  4778. savesize:=sizeof(pint);
  4779. callerargareasize:=0;
  4780. calleeargareasize:=0;
  4781. has_paraloc_info:=callnoside;
  4782. funcretloc[callerside].init;
  4783. funcretloc[calleeside].init;
  4784. check_mark_as_nested;
  4785. end;
  4786. destructor tabstractprocdef.destroy;
  4787. begin
  4788. if assigned(paras) then
  4789. begin
  4790. {$ifdef MEMDEBUG}
  4791. memprocpara.start;
  4792. {$endif MEMDEBUG}
  4793. paras.free;
  4794. paras:=nil;
  4795. {$ifdef MEMDEBUG}
  4796. memprocpara.stop;
  4797. {$endif MEMDEBUG}
  4798. end;
  4799. if assigned(parast) then
  4800. begin
  4801. {$ifdef MEMDEBUG}
  4802. memprocparast.start;
  4803. {$endif MEMDEBUG}
  4804. parast.free;
  4805. parast:=nil;
  4806. {$ifdef MEMDEBUG}
  4807. memprocparast.stop;
  4808. {$endif MEMDEBUG}
  4809. end;
  4810. funcretloc[callerside].done;
  4811. funcretloc[calleeside].done;
  4812. inherited destroy;
  4813. end;
  4814. procedure tabstractprocdef.count_para(p:TObject;arg:pointer);
  4815. begin
  4816. if (tsym(p).typ<>paravarsym) then
  4817. exit;
  4818. inc(plongint(arg)^);
  4819. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  4820. begin
  4821. if not assigned(tparavarsym(p).defaultconstsym) then
  4822. inc(minparacount);
  4823. inc(maxparacount);
  4824. end;
  4825. end;
  4826. procedure tabstractprocdef.insert_para(p:TObject;arg:pointer);
  4827. begin
  4828. if (tsym(p).typ<>paravarsym) then
  4829. exit;
  4830. paras.add(p);
  4831. end;
  4832. procedure tabstractprocdef.calcparas;
  4833. var
  4834. paracount : longint;
  4835. begin
  4836. { This can already be assigned when
  4837. we need to reresolve this unit (PFV) }
  4838. if assigned(paras) then
  4839. paras.free;
  4840. paras:=tparalist.create(false);
  4841. paracount:=0;
  4842. minparacount:=0;
  4843. maxparacount:=0;
  4844. parast.SymList.ForEachCall(@count_para,@paracount);
  4845. paras.capacity:=paracount;
  4846. { Insert parameters in table }
  4847. parast.SymList.ForEachCall(@insert_para,nil);
  4848. { Order parameters }
  4849. paras.sortparas;
  4850. end;
  4851. function tabstractprocdef.mangledprocparanames(oldlen : longint) : string;
  4852. var
  4853. hash : qword;
  4854. hp : TParavarsym;
  4855. hs : TSymStr;
  4856. newlen,
  4857. i : integer;
  4858. begin
  4859. result:='';
  4860. hp:=nil;
  4861. { add parameter types }
  4862. for i:=0 to paras.count-1 do
  4863. begin
  4864. hp:=tparavarsym(paras[i]);
  4865. if not(vo_is_hidden_para in hp.varoptions) then
  4866. result:=result+'$'+hp.vardef.mangledparaname;
  4867. end;
  4868. { add resultdef, add $$ as separator to make it unique from a
  4869. parameter separator }
  4870. if not is_void(returndef) then
  4871. result:=result+'$$'+returndef.mangledparaname;
  4872. newlen:=length(result)+oldlen;
  4873. { Replace with hash if the parameter line is very long }
  4874. if (newlen-oldlen>12) and
  4875. ((newlen>100) or (newlen-oldlen>64)) then
  4876. begin
  4877. hash:=0;
  4878. for i:=0 to paras.count-1 do
  4879. begin
  4880. hp:=tparavarsym(paras[i]);
  4881. if not(vo_is_hidden_para in hp.varoptions) then
  4882. begin
  4883. hs:=hp.vardef.mangledparaname;
  4884. hash:=UpdateFnv64(hash,hs[1],length(hs));
  4885. end;
  4886. end;
  4887. if not is_void(returndef) then
  4888. begin
  4889. { add a little prefix so that x(integer; integer) is different from x(integer):integer }
  4890. hs:='$$'+returndef.mangledparaname;
  4891. hash:=UpdateFnv64(hash,hs[1],length(hs));
  4892. end;
  4893. result:='$h'+Base64Mangle(hash);
  4894. end;
  4895. end;
  4896. procedure tabstractprocdef.buildderef;
  4897. begin
  4898. { released procdef? }
  4899. if not assigned(parast) then
  4900. exit;
  4901. inherited buildderef;
  4902. returndefderef.build(returndef);
  4903. if po_explicitparaloc in procoptions then
  4904. funcretloc[callerside].buildderef;
  4905. { parast }
  4906. tparasymtable(parast).buildderef;
  4907. end;
  4908. procedure tabstractprocdef.deref;
  4909. begin
  4910. inherited deref;
  4911. returndef:=tdef(returndefderef.resolve);
  4912. if po_explicitparaloc in procoptions then
  4913. begin
  4914. funcretloc[callerside].deref;
  4915. has_paraloc_info:=callerside;
  4916. end
  4917. else
  4918. begin
  4919. { deref is called after loading from a ppu, but also after another
  4920. unit has been reloaded/recompiled and all references must be
  4921. re-resolved. Since the funcretloc contains a reference to a tdef,
  4922. reset it so that we won't try to access the stale def }
  4923. funcretloc[callerside].init;
  4924. has_paraloc_info:=callnoside;
  4925. end;
  4926. { parast }
  4927. tparasymtable(parast).deref(false);
  4928. { recalculated parameters }
  4929. calcparas;
  4930. end;
  4931. constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  4932. begin
  4933. inherited ppuload(dt,ppufile);
  4934. parast:=nil;
  4935. Paras:=nil;
  4936. minparacount:=0;
  4937. maxparacount:=0;
  4938. ppufile.getderef(returndefderef);
  4939. proctypeoption:=tproctypeoption(ppufile.getbyte);
  4940. proccalloption:=tproccalloption(ppufile.getbyte);
  4941. ppufile.getset(tppuset8(procoptions));
  4942. funcretloc[callerside].init;
  4943. if po_explicitparaloc in procoptions then
  4944. funcretloc[callerside].ppuload(ppufile);
  4945. savesize:=sizeof(pint);
  4946. if (po_explicitparaloc in procoptions) then
  4947. has_paraloc_info:=callerside;
  4948. end;
  4949. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  4950. var
  4951. oldintfcrc : boolean;
  4952. begin
  4953. { released procdef? }
  4954. if not assigned(parast) then
  4955. exit;
  4956. inherited ppuwrite(ppufile);
  4957. ppufile.putderef(returndefderef);
  4958. oldintfcrc:=ppufile.do_interface_crc;
  4959. ppufile.do_interface_crc:=false;
  4960. ppufile.putbyte(ord(proctypeoption));
  4961. ppufile.putbyte(ord(proccalloption));
  4962. ppufile.putset(tppuset8(procoptions));
  4963. ppufile.do_interface_crc:=oldintfcrc;
  4964. if (po_explicitparaloc in procoptions) then
  4965. funcretloc[callerside].ppuwrite(ppufile);
  4966. end;
  4967. function tabstractprocdef.typename_paras(pno: tprocnameoptions) : ansistring;
  4968. var
  4969. hs,s : ansistring;
  4970. hp : TParavarsym;
  4971. hpc : tconstsym;
  4972. first : boolean;
  4973. i,j : integer;
  4974. begin
  4975. s:='';
  4976. first:=true;
  4977. for i:=0 to paras.count-1 do
  4978. begin
  4979. hp:=tparavarsym(paras[i]);
  4980. if not(vo_is_hidden_para in hp.varoptions) or
  4981. (pno_showhidden in pno) then
  4982. begin
  4983. if first then
  4984. begin
  4985. s:=s+'(';
  4986. first:=false;
  4987. end
  4988. else
  4989. s:=s+';';
  4990. if vo_is_hidden_para in hp.varoptions then
  4991. s:=s+'<';
  4992. case hp.varspez of
  4993. vs_var :
  4994. s:=s+'var ';
  4995. vs_const :
  4996. s:=s+'const ';
  4997. vs_out :
  4998. s:=s+'out ';
  4999. vs_constref :
  5000. s:=s+'constref ';
  5001. else
  5002. ;
  5003. end;
  5004. if (pno_paranames in pno) then
  5005. s:=s+hp.realname+':';
  5006. if hp.univpara then
  5007. s:=s+'univ ';
  5008. if assigned(hp.vardef.typesym) then
  5009. begin
  5010. hs:=hp.vardef.typesym.realname;
  5011. if hs[1]<>'$' then
  5012. s:=s+hp.vardef.OwnerHierarchyName+hs
  5013. else
  5014. s:=s+hp.vardef.GetTypeName;
  5015. end
  5016. else
  5017. s:=s+hp.vardef.GetTypeName;
  5018. { default value }
  5019. if assigned(hp.defaultconstsym) then
  5020. begin
  5021. hpc:=tconstsym(hp.defaultconstsym);
  5022. hs:='';
  5023. case hpc.consttyp of
  5024. constwstring:
  5025. begin
  5026. if pcompilerwidestring(hpc.value.valueptr)^.len>0 then
  5027. begin
  5028. setlength(hs,pcompilerwidestring(hpc.value.valueptr)^.len);
  5029. for j:=0 to pcompilerwidestring(hpc.value.valueptr)^.len-1 do
  5030. begin
  5031. if (ord(pcompilerwidestring(hpc.value.valueptr)^.data[j])<127) and
  5032. not(byte(pcompilerwidestring(hpc.value.valueptr)^.data[j]) in [0,10,13]) then
  5033. hs[j+1]:=char(pcompilerwidestring(hpc.value.valueptr)^.data[j])
  5034. else
  5035. hs[j+1]:='.';
  5036. end;
  5037. end;
  5038. end;
  5039. conststring,
  5040. constresourcestring :
  5041. begin
  5042. if hpc.value.len>0 then
  5043. begin
  5044. setLength(hs,hpc.value.len);
  5045. { don't write past the end of hs if the constant
  5046. is > 255 chars }
  5047. move(hpc.value.valueptr^,hs[1],length(hs));
  5048. { make sure that constant strings with newline chars
  5049. don't create a linebreak in the assembler code,
  5050. since comments are line-based. Also remove nulls
  5051. because the comments are written as a pchar. }
  5052. ReplaceCase(hs,#0,'.');
  5053. ReplaceCase(hs,#10,'.');
  5054. ReplaceCase(hs,#13,'.');
  5055. end;
  5056. end;
  5057. constreal :
  5058. str(pbestreal(hpc.value.valueptr)^,hs);
  5059. constpointer :
  5060. hs:=tostr(hpc.value.valueordptr);
  5061. constord :
  5062. begin
  5063. if is_boolean(hpc.constdef) then
  5064. begin
  5065. if hpc.value.valueord<>0 then
  5066. hs:='TRUE'
  5067. else
  5068. hs:='FALSE';
  5069. end
  5070. else
  5071. hs:=tostr(hpc.value.valueord);
  5072. end;
  5073. constnil :
  5074. hs:='nil';
  5075. constset :
  5076. hs:='<set>';
  5077. constguid:
  5078. hs:=guid2string(pguid(hpc.value.valueptr)^);
  5079. constnone:
  5080. internalerror(2019050704);
  5081. end;
  5082. if hs<>'' then
  5083. s:=s+'=`'+hs+'`';
  5084. end;
  5085. if vo_is_hidden_para in hp.varoptions then
  5086. s:=s+'>';
  5087. end;
  5088. end;
  5089. if not first then
  5090. s:=s+')';
  5091. if (po_varargs in procoptions) then
  5092. s:=s+';VarArgs';
  5093. typename_paras:=s;
  5094. end;
  5095. function tabstractprocdef.is_methodpointer:boolean;
  5096. begin
  5097. result:=false;
  5098. end;
  5099. function tabstractprocdef.is_addressonly:boolean;
  5100. begin
  5101. result:=true;
  5102. end;
  5103. function tabstractprocdef.no_self_node: boolean;
  5104. begin
  5105. Result:=([po_staticmethod,po_classmethod]<=procoptions)or
  5106. (proctypeoption in [potype_class_constructor,potype_class_destructor,potype_operator]);
  5107. end;
  5108. function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef;
  5109. var
  5110. j, nestinglevel: longint;
  5111. pvs, npvs: tparavarsym;
  5112. begin
  5113. nestinglevel:=parast.symtablelevel;
  5114. if newtyp=procdef then
  5115. begin
  5116. if (copytyp<>pc_bareproc) then
  5117. result:=cprocdef.create(nestinglevel,true)
  5118. else
  5119. result:=cprocdef.create(normal_function_level,true);
  5120. tprocdef(result).visibility:=vis_public;
  5121. end
  5122. else
  5123. begin
  5124. result:=cprocvardef.create(nestinglevel);
  5125. end;
  5126. tabstractprocdef(result).returndef:=returndef;
  5127. tabstractprocdef(result).returndefderef:=returndefderef;
  5128. pvs:=nil;
  5129. npvs:=nil;
  5130. for j:=0 to parast.symlist.count-1 do
  5131. begin
  5132. case tsym(parast.symlist[j]).typ of
  5133. paravarsym:
  5134. begin
  5135. pvs:=tparavarsym(parast.symlist[j]);
  5136. { in case of bare proc, don't copy self, vmt or framepointer
  5137. parameters }
  5138. if (copytyp in [pc_bareproc,pc_normal_no_hidden]) and
  5139. (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result,vo_is_funcret]*pvs.varoptions)<>[]) then
  5140. continue;
  5141. if paraprefix='' then
  5142. npvs:=cparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
  5143. pvs.vardef,pvs.varoptions)
  5144. else if not(vo_is_high_para in pvs.varoptions) then
  5145. npvs:=cparavarsym.create(paraprefix+pvs.realname,pvs.paranr,pvs.varspez,
  5146. pvs.vardef,pvs.varoptions)
  5147. else
  5148. npvs:=cparavarsym.create('$high'+paraprefix+copy(pvs.name,5,length(pvs.name)),pvs.paranr,pvs.varspez,
  5149. pvs.vardef,pvs.varoptions);
  5150. npvs.defaultconstsym:=pvs.defaultconstsym;
  5151. tabstractprocdef(result).parast.insertsym(npvs);
  5152. end;
  5153. constsym:
  5154. begin
  5155. // ignore, reuse original constym. Should also be duplicated
  5156. // be safe though
  5157. end;
  5158. symconst.typesym:
  5159. begin
  5160. // reuse original, part of generic declaration
  5161. end
  5162. else
  5163. internalerror(201160604);
  5164. end;
  5165. end;
  5166. tabstractprocdef(result).savesize:=savesize;
  5167. if (typ<>procvardef) and
  5168. (newtyp=procvardef) then
  5169. begin
  5170. { procvars can't be (class)constructures/destructors etc }
  5171. if proctypeoption=potype_constructor then
  5172. begin
  5173. tabstractprocdef(result).returndef:=tdef(owner.defowner);
  5174. if not(is_implicit_pointer_object_type(returndef) or
  5175. (returndef.typ<>objectdef)) then
  5176. tabstractprocdef(result).returndef:=cpointerdef.getreusable(tabstractprocdef(result).returndef);
  5177. tabstractprocdef(result).proctypeoption:=potype_function;
  5178. end
  5179. else if is_void(returndef) then
  5180. tabstractprocdef(result).proctypeoption:=potype_procedure
  5181. else
  5182. tabstractprocdef(result).proctypeoption:=potype_function;
  5183. end
  5184. else
  5185. tabstractprocdef(result).proctypeoption:=proctypeoption;
  5186. tabstractprocdef(result).proccalloption:=proccalloption;
  5187. tabstractprocdef(result).procoptions:=procoptions;
  5188. if (copytyp=pc_bareproc) then
  5189. tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions*[po_explicitparaloc,po_hascallingconvention,po_varargs,po_iocheck,po_has_importname,po_has_importdll];
  5190. if newtyp=procvardef then
  5191. tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions-[po_has_importname,po_has_importdll];
  5192. if copytyp=pc_address_only then
  5193. include(tabstractprocdef(result).procoptions,po_addressonly);
  5194. tabstractprocdef(result).callerargareasize:=callerargareasize;
  5195. tabstractprocdef(result).calleeargareasize:=calleeargareasize;
  5196. tabstractprocdef(result).maxparacount:=maxparacount;
  5197. tabstractprocdef(result).minparacount:=minparacount;
  5198. if po_explicitparaloc in procoptions then
  5199. tabstractprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
  5200. { recalculate parameter info }
  5201. tabstractprocdef(result).has_paraloc_info:=callnoside;
  5202. {$ifdef m68k}
  5203. tabstractprocdef(result).exp_funcretloc:=exp_funcretloc;
  5204. {$endif}
  5205. if (typ=procdef) and
  5206. (newtyp=procvardef) and
  5207. (owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  5208. include(tprocvardef(result).procoptions,po_methodpointer);
  5209. end;
  5210. function tabstractprocdef.compatible_with_pointerdef_size(ptr: tpointerdef): boolean;
  5211. begin
  5212. result:=is_addressonly;
  5213. end;
  5214. procedure tabstractprocdef.check_mark_as_nested;
  5215. begin
  5216. { nested procvars require that nested functions use the Delphi-style
  5217. nested procedure calling convention }
  5218. if (parast.symtablelevel>normal_function_level) and
  5219. (m_nested_procvars in current_settings.modeswitches) then
  5220. include(procoptions,po_delphi_nested_cc);
  5221. end;
  5222. procedure tabstractprocdef.init_paraloc_info(side: tcallercallee);
  5223. begin
  5224. if (side in [callerside,callbothsides]) and
  5225. not(has_paraloc_info in [callerside,callbothsides]) then
  5226. begin
  5227. if not is_c_variadic(self) then
  5228. callerargareasize:=paramanager.create_paraloc_info(self,callerside)
  5229. else
  5230. callerargareasize:=paramanager.create_varargs_paraloc_info(self,callerside,nil);
  5231. if has_paraloc_info in [calleeside,callbothsides] then
  5232. has_paraloc_info:=callbothsides
  5233. else
  5234. has_paraloc_info:=callerside;
  5235. end;
  5236. if (side in [calleeside,callbothsides]) and
  5237. not(has_paraloc_info in [calleeside,callbothsides]) then
  5238. begin
  5239. if not is_c_variadic(self) then
  5240. calleeargareasize:=paramanager.create_paraloc_info(self,calleeside)
  5241. else
  5242. callerargareasize:=paramanager.create_varargs_paraloc_info(self,calleeside,nil);
  5243. if has_paraloc_info in [callerside,callbothsides] then
  5244. has_paraloc_info:=callbothsides
  5245. else
  5246. has_paraloc_info:=calleeside;
  5247. end;
  5248. end;
  5249. procedure tabstractprocdef.done_paraloc_info(side: tcallercallee);
  5250. var
  5251. i: longint;
  5252. begin
  5253. if (side in [callerside,callbothsides]) and
  5254. (has_paraloc_info in [callerside,callbothsides]) then
  5255. begin
  5256. funcretloc[callerside].done;
  5257. for i:=0 to paras.count-1 do
  5258. tparavarsym(paras[i]).paraloc[callerside].done;
  5259. if has_paraloc_info=callerside then
  5260. has_paraloc_info:=callnoside
  5261. else
  5262. has_paraloc_info:=calleeside;
  5263. end;
  5264. if (side in [calleeside,callbothsides]) and
  5265. (has_paraloc_info in [calleeside,callbothsides]) then
  5266. begin
  5267. funcretloc[calleeside].done;
  5268. for i:=0 to paras.count-1 do
  5269. tparavarsym(paras[i]).paraloc[calleeside].done;
  5270. if has_paraloc_info=calleeside then
  5271. has_paraloc_info:=callnoside
  5272. else
  5273. has_paraloc_info:=callerside;
  5274. end;
  5275. end;
  5276. function tabstractprocdef.stack_tainting_parameter(side: tcallercallee): boolean;
  5277. var
  5278. p: tparavarsym;
  5279. ploc: PCGParalocation;
  5280. i: longint;
  5281. begin
  5282. result:=false;
  5283. init_paraloc_info(side);
  5284. for i:=0 to parast.SymList.Count-1 do
  5285. if tsym(parast.SymList[i]).typ=paravarsym then
  5286. begin
  5287. p:=tparavarsym(parast.SymList[i]);
  5288. if not p.is_used then
  5289. continue;
  5290. { check if no parameter is located on the stack }
  5291. if (is_open_array(p.vardef) or
  5292. is_array_of_const(p.vardef)) and (p.varspez=vs_value) then
  5293. begin
  5294. result:=true;
  5295. exit;
  5296. end;
  5297. ploc:=p.paraloc[side].location;
  5298. while assigned(ploc) do
  5299. begin
  5300. if (ploc^.loc=LOC_REFERENCE) then
  5301. begin
  5302. result:=true;
  5303. exit
  5304. end;
  5305. ploc:=ploc^.next;
  5306. end;
  5307. end;
  5308. end;
  5309. function tabstractprocdef.is_pushleftright: boolean;
  5310. begin
  5311. result:=false;
  5312. end;
  5313. function tabstractprocdef.address_type: tdef;
  5314. begin
  5315. result:=voidcodepointertype;
  5316. end;
  5317. function tabstractprocdef.ofs_address_type:tdef;
  5318. begin
  5319. result:=address_type;
  5320. end;
  5321. procedure tabstractprocdef.declared_far;
  5322. begin
  5323. Message1(parser_w_proc_directive_ignored,'FAR');
  5324. end;
  5325. procedure tabstractprocdef.declared_near;
  5326. begin
  5327. Message1(parser_w_proc_directive_ignored,'NEAR');
  5328. end;
  5329. function tabstractprocdef.generate_safecall_wrapper: boolean;
  5330. begin
  5331. {$ifdef SUPPORT_SAFECALL}
  5332. result:=
  5333. (proccalloption=pocall_safecall) and
  5334. not(po_assembler in procoptions) and
  5335. (tf_safecall_exceptions in target_info.flags);
  5336. {$else SUPPORT_SAFECALL}
  5337. result:=false;
  5338. {$endif}
  5339. end;
  5340. function tabstractprocdef.is_generic_param(def:tdef): boolean;
  5341. begin
  5342. if def.typ=undefineddef then
  5343. result:=def.owner=self.parast
  5344. else if def.typ=objectdef then
  5345. result:=(def.owner=self.parast) and (tstoreddef(def).genconstraintdata<>nil)
  5346. else
  5347. result:=false;
  5348. end;
  5349. {***************************************************************************
  5350. TPROCDEF
  5351. ***************************************************************************}
  5352. function tprocdef.getparentfpsym: tsym;
  5353. begin
  5354. if not assigned(_parentfpsym) then
  5355. begin
  5356. _parentfpsym:=tsym(parast.Find('parentfp'));
  5357. if not assigned(_parentfpsym) then
  5358. internalerror(200309281);
  5359. end;
  5360. result:=_parentfpsym;
  5361. end;
  5362. function tprocdef.Getis_implemented: boolean;
  5363. begin
  5364. result:=not assigned(implprocdefinfo) or implprocdefinfo^.is_implemented;
  5365. end;
  5366. procedure tprocdef.Setis_implemented(AValue: boolean);
  5367. begin
  5368. if not assigned(implprocdefinfo) then
  5369. internalerror(2020062101);
  5370. implprocdefinfo^.is_implemented:=AValue;
  5371. end;
  5372. function tprocdef.store_localst: boolean;
  5373. begin
  5374. result:=has_inlininginfo or (df_generic in defoptions);
  5375. end;
  5376. function tprocdef.GetResultName: PShortString;
  5377. begin
  5378. if not assigned(implprocdefinfo) then
  5379. internalerror(2014010301);
  5380. result:=implprocdefinfo^.resultname;
  5381. end;
  5382. procedure tprocdef.SetResultName(AValue: PShortString);
  5383. begin
  5384. if not assigned(implprocdefinfo) then
  5385. internalerror(2014010302);
  5386. implprocdefinfo^.resultname:=AValue;
  5387. end;
  5388. function tprocdef.GetParentFPInitBlock: tnode;
  5389. begin
  5390. if not assigned(implprocdefinfo) then
  5391. internalerror(2014010303);
  5392. result:=implprocdefinfo^.parentfpinitblock;
  5393. end;
  5394. function tprocdef.GetParentFPStruct: tsym;
  5395. begin
  5396. if not assigned(implprocdefinfo) then
  5397. internalerror(2014010304);
  5398. result:=implprocdefinfo^.parentfpstruct;
  5399. end;
  5400. function tprocdef.GetParentFPStructPtrType: tdef;
  5401. begin
  5402. if not assigned(implprocdefinfo) then
  5403. internalerror(2014010305);
  5404. result:=implprocdefinfo^.parentfpstructptrtype;
  5405. end;
  5406. procedure tprocdef.SetParentFPInitBlock(AValue: tnode);
  5407. begin
  5408. if not assigned(implprocdefinfo) then
  5409. internalerror(2014010306);
  5410. implprocdefinfo^.parentfpinitblock:=AValue;
  5411. end;
  5412. function tprocdef.Getprocendtai: tai;
  5413. begin
  5414. if not assigned(implprocdefinfo) then
  5415. internalerror(2014010307);
  5416. result:=implprocdefinfo^.procendtai;
  5417. end;
  5418. function tprocdef.Getprocstarttai: tai;
  5419. begin
  5420. if not assigned(implprocdefinfo) then
  5421. internalerror(2014010308);
  5422. result:=implprocdefinfo^.procstarttai;
  5423. end;
  5424. procedure tprocdef.Setprocendtai(AValue: tai);
  5425. begin
  5426. if not assigned(implprocdefinfo) then
  5427. internalerror(2014010309);
  5428. implprocdefinfo^.procendtai:=AValue;
  5429. end;
  5430. function tprocdef.Getskpara: pointer;
  5431. begin
  5432. if not assigned(implprocdefinfo) then
  5433. internalerror(2014010310);
  5434. result:=implprocdefinfo^.skpara;
  5435. end;
  5436. procedure tprocdef.Setskpara(AValue: pointer);
  5437. begin
  5438. if not assigned(implprocdefinfo) then
  5439. internalerror(2014010311);
  5440. implprocdefinfo^.skpara:=AValue;
  5441. end;
  5442. function tprocdef.Getpersonality: tprocdef;
  5443. begin
  5444. if not assigned(implprocdefinfo) then
  5445. internalerror(2016121704);
  5446. result:=implprocdefinfo^.personality;
  5447. end;
  5448. procedure tprocdef.Setpersonality(AValue: tprocdef);
  5449. begin
  5450. if not assigned(implprocdefinfo) then
  5451. internalerror(2016121705);
  5452. implprocdefinfo^.personality:=AValue;
  5453. end;
  5454. function tprocdef.Getforwarddef: boolean;
  5455. begin
  5456. if not assigned(implprocdefinfo) then
  5457. internalerror(2014010312);
  5458. result:=implprocdefinfo^.forwarddef;
  5459. end;
  5460. function tprocdef.Gethasforward: boolean;
  5461. begin
  5462. if not assigned(implprocdefinfo) then
  5463. internalerror(2014010313);
  5464. result:=implprocdefinfo^.hasforward;
  5465. end;
  5466. function tprocdef.Getinterfacedef: boolean;
  5467. begin
  5468. if not assigned(implprocdefinfo) then
  5469. internalerror(2014010314);
  5470. result:=implprocdefinfo^.interfacedef;
  5471. end;
  5472. procedure tprocdef.Setforwarddef(AValue: boolean);
  5473. begin
  5474. if not assigned(implprocdefinfo) then
  5475. internalerror(2014010315);
  5476. implprocdefinfo^.forwarddef:=AValue;
  5477. end;
  5478. procedure tprocdef.Sethasforward(AValue: boolean);
  5479. begin
  5480. if not assigned(implprocdefinfo) then
  5481. internalerror(2014010316);
  5482. implprocdefinfo^.hasforward:=AValue;
  5483. end;
  5484. function tprocdef.GetIsEmpty: boolean;
  5485. begin
  5486. result:=pio_empty in implprocoptions;
  5487. end;
  5488. procedure tprocdef.SetIsEmpty(AValue: boolean);
  5489. begin
  5490. if AValue then
  5491. include(implprocoptions,pio_empty)
  5492. else
  5493. exclude(implprocoptions,pio_empty);
  5494. end;
  5495. function tprocdef.GetHasInliningInfo: boolean;
  5496. begin
  5497. result:=pio_has_inlininginfo in implprocoptions;
  5498. end;
  5499. procedure tprocdef.SetHasInliningInfo(AValue: boolean);
  5500. begin
  5501. if AValue then
  5502. include(implprocoptions,pio_has_inlininginfo)
  5503. else
  5504. exclude(implprocoptions,pio_has_inlininginfo);
  5505. end;
  5506. procedure tprocdef.Setinterfacedef(AValue: boolean);
  5507. begin
  5508. if not assigned(implprocdefinfo) then
  5509. internalerror(2014010317);
  5510. implprocdefinfo^.interfacedef:=AValue;
  5511. end;
  5512. procedure tprocdef.Setprocstarttai(AValue: tai);
  5513. begin
  5514. if not assigned(implprocdefinfo) then
  5515. internalerror(2014010318);
  5516. implprocdefinfo^.procstarttai:=AValue;
  5517. end;
  5518. procedure tprocdef.SetParentFPStruct(AValue: tsym);
  5519. begin
  5520. if not assigned(implprocdefinfo) then
  5521. internalerror(2014010319);
  5522. implprocdefinfo^.parentfpstruct:=AValue;
  5523. end;
  5524. procedure tprocdef.SetParentFPStructPtrType(AValue: tdef);
  5525. begin
  5526. if not assigned(implprocdefinfo) then
  5527. internalerror(2014010320);
  5528. implprocdefinfo^.parentfpstructptrtype:=AValue;
  5529. end;
  5530. constructor tprocdef.create(level:byte;doregister:boolean);
  5531. begin
  5532. inherited create(procdef,level,doregister);
  5533. implprocdefinfo:=allocmem(sizeof(implprocdefinfo^));
  5534. localst:=tlocalsymtable.create(self,parast.symtablelevel);
  5535. {$ifdef symansistr}
  5536. _mangledname:='';
  5537. {$else symansistr}
  5538. _mangledname:=nil;
  5539. {$endif symansistr}
  5540. {$ifndef DISABLE_FAST_OVERLOAD_PATCH}
  5541. seenmarker := nil;
  5542. {$endif}
  5543. fileinfo:=current_filepos;
  5544. extnumber:=$ffff;
  5545. aliasnames:=TCmdStrList.create;
  5546. funcretsym:=nil;
  5547. funcretsymderef.reset;
  5548. procsymderef.reset;
  5549. forwarddef:=true;
  5550. interfacedef:=false;
  5551. hasforward:=false;
  5552. struct := nil;
  5553. structderef.reset;
  5554. import_dll:=nil;
  5555. import_name:=nil;
  5556. import_nr:=0;
  5557. inlininginfo:=nil;
  5558. deprecatedmsg:=nil;
  5559. genericdecltokenbuf:=nil;
  5560. if cs_opt_fastmath in current_settings.optimizerswitches then
  5561. include(implprocoptions, pio_fastmath);
  5562. end;
  5563. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  5564. var
  5565. i,aliasnamescount,sizeleft : longint;
  5566. level : byte;
  5567. buf : array[0..255] of byte;
  5568. begin
  5569. inherited ppuload(procdef,ppufile);
  5570. {$ifdef symansistr}
  5571. if po_has_mangledname in procoptions then
  5572. _mangledname:=ppufile.getansistring
  5573. else
  5574. _mangledname:='';
  5575. {$else symansistr}
  5576. if po_has_mangledname in procoptions then
  5577. _mangledname:=ppufile.getpshortstring
  5578. else
  5579. _mangledname:=nil;
  5580. {$endif symansistr}
  5581. extnumber:=ppufile.getword;
  5582. level:=ppufile.getbyte;
  5583. ppufile.getderef(structderef);
  5584. ppufile.getderef(procsymderef);
  5585. ppufile.getposinfo(fileinfo);
  5586. visibility:=tvisibility(ppufile.getbyte);
  5587. ppufile.getset(tppuset2(symoptions));
  5588. if sp_has_deprecated_msg in symoptions then
  5589. deprecatedmsg:=ppufile.getpshortstring
  5590. else
  5591. deprecatedmsg:=nil;
  5592. { import stuff }
  5593. if po_has_importdll in procoptions then
  5594. import_dll:=ppufile.getpshortstring
  5595. else
  5596. import_dll:=nil;
  5597. if po_has_importname in procoptions then
  5598. import_name:=ppufile.getpshortstring
  5599. else
  5600. import_name:=nil;
  5601. import_nr:=ppufile.getword;
  5602. if (po_msgint in procoptions) then
  5603. messageinf.i:=ppufile.getlongint;
  5604. if (po_msgstr in procoptions) then
  5605. messageinf.str:=ppufile.getpshortstring;
  5606. if (po_dispid in procoptions) then
  5607. dispid:=ppufile.getlongint;
  5608. { inline stuff }
  5609. ppufile.getset(tppuset1(implprocoptions));
  5610. if has_inlininginfo then
  5611. begin
  5612. ppufile.getderef(funcretsymderef);
  5613. new(inlininginfo);
  5614. ppufile.getset(tppuset4(inlininginfo^.flags));
  5615. end
  5616. else
  5617. begin
  5618. inlininginfo:=nil;
  5619. funcretsym:=nil;
  5620. end;
  5621. aliasnames:=TCmdStrList.create;
  5622. { count alias names }
  5623. aliasnamescount:=ppufile.getbyte;
  5624. for i:=1 to aliasnamescount do
  5625. aliasnames.insert(ppufile.getstring);
  5626. { load the token stream containing the declaration }
  5627. sizeleft:=ppufile.getlongint;
  5628. if sizeleft>0 then
  5629. begin
  5630. init_genericdecl;
  5631. while sizeleft>0 do
  5632. begin
  5633. if sizeleft>sizeof(buf) then
  5634. i:=sizeof(buf)
  5635. else
  5636. i:=sizeleft;
  5637. ppufile.getdata(buf,i);
  5638. genericdecltokenbuf.write(buf,i);
  5639. dec(sizeleft,i);
  5640. end;
  5641. end;
  5642. ppuload_platform(ppufile);
  5643. { load para symtable }
  5644. parast:=tparasymtable.create(self,level);
  5645. tparasymtable(parast).ppuload(ppufile);
  5646. { load local symtable }
  5647. if store_localst then
  5648. begin
  5649. localst:=tlocalsymtable.create(self,level);
  5650. tlocalsymtable(localst).ppuload(ppufile);
  5651. end
  5652. else
  5653. localst:=nil;
  5654. { inline stuff }
  5655. if has_inlininginfo then
  5656. inlininginfo^.code:=ppuloadnodetree(ppufile);
  5657. { default values for no persistent data }
  5658. if (cs_link_deffile in current_settings.globalswitches) and
  5659. (tf_need_export in target_info.flags) and
  5660. (po_exports in procoptions) then
  5661. deffile.AddExport(mangledname);
  5662. { Disable po_has_inlining until the derefimpl is done }
  5663. has_inlininginfo:=false;
  5664. end;
  5665. destructor tprocdef.destroy;
  5666. begin
  5667. aliasnames.free;
  5668. aliasnames:=nil;
  5669. if assigned(localst) and
  5670. (localst.symtabletype<>staticsymtable) then
  5671. begin
  5672. {$ifdef MEMDEBUG}
  5673. memproclocalst.start;
  5674. {$endif MEMDEBUG}
  5675. localst.free;
  5676. localst:=nil;
  5677. {$ifdef MEMDEBUG}
  5678. memproclocalst.start;
  5679. {$endif MEMDEBUG}
  5680. end;
  5681. if assigned(inlininginfo) then
  5682. begin
  5683. {$ifdef MEMDEBUG}
  5684. memprocnodetree.start;
  5685. {$endif MEMDEBUG}
  5686. tnode(inlininginfo^.code).free;
  5687. {$ifdef MEMDEBUG}
  5688. memprocnodetree.start;
  5689. {$endif MEMDEBUG}
  5690. dispose(inlininginfo);
  5691. inlininginfo:=nil;
  5692. end;
  5693. freeimplprocdefinfo;
  5694. genericdecltokenbuf.free;
  5695. genericdecltokenbuf:=nil;
  5696. stringdispose(import_dll);
  5697. stringdispose(import_name);
  5698. stringdispose(deprecatedmsg);
  5699. if (po_msgstr in procoptions) then
  5700. stringdispose(messageinf.str);
  5701. {$ifndef symansistr}
  5702. if assigned(_mangledname) then
  5703. begin
  5704. {$ifdef MEMDEBUG}
  5705. memmanglednames.start;
  5706. {$endif MEMDEBUG}
  5707. stringdispose(_mangledname);
  5708. {$ifdef MEMDEBUG}
  5709. memmanglednames.stop;
  5710. {$endif MEMDEBUG}
  5711. end;
  5712. {$endif symansistr}
  5713. inherited destroy;
  5714. end;
  5715. procedure tprocdef.freeimplprocdefinfo;
  5716. begin
  5717. if assigned(implprocdefinfo) then
  5718. begin
  5719. stringdispose(implprocdefinfo^.resultname);
  5720. freemem(implprocdefinfo);
  5721. implprocdefinfo:=nil;
  5722. end;
  5723. end;
  5724. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  5725. var
  5726. oldintfcrc : boolean;
  5727. aliasnamescount,i,sizeleft : longint;
  5728. item : TCmdStrListItem;
  5729. buf : array[0..255] of byte;
  5730. begin
  5731. { released procdef? }
  5732. if not assigned(parast) then
  5733. exit;
  5734. inherited ppuwrite(ppufile);
  5735. {$ifdef symansistr}
  5736. if po_has_mangledname in procoptions then
  5737. ppufile.putansistring(_mangledname);
  5738. {$else symansistr}
  5739. if po_has_mangledname in procoptions then
  5740. ppufile.putstring(_mangledname^);
  5741. {$endif symansistr}
  5742. ppufile.putword(extnumber);
  5743. ppufile.putbyte(parast.symtablelevel);
  5744. ppufile.putderef(structderef);
  5745. ppufile.putderef(procsymderef);
  5746. ppufile.putposinfo(fileinfo);
  5747. ppufile.putbyte(byte(visibility));
  5748. ppufile.putset(tppuset2(symoptions));
  5749. if sp_has_deprecated_msg in symoptions then
  5750. ppufile.putstring(deprecatedmsg^);
  5751. { import }
  5752. if po_has_importdll in procoptions then
  5753. ppufile.putstring(import_dll^);
  5754. if po_has_importname in procoptions then
  5755. ppufile.putstring(import_name^);
  5756. ppufile.putword(import_nr);
  5757. if (po_msgint in procoptions) then
  5758. ppufile.putlongint(messageinf.i);
  5759. if (po_msgstr in procoptions) then
  5760. ppufile.putstring(messageinf.str^);
  5761. if (po_dispid in procoptions) then
  5762. ppufile.putlongint(dispid);
  5763. { inline stuff }
  5764. oldintfcrc:=ppufile.do_crc;
  5765. ppufile.do_crc:=false;
  5766. ppufile.putset(tppuset1(implprocoptions));
  5767. if has_inlininginfo then
  5768. begin
  5769. ppufile.putderef(funcretsymderef);
  5770. ppufile.putset(tppuset4(inlininginfo^.flags));
  5771. end;
  5772. { count alias names }
  5773. aliasnamescount:=0;
  5774. item:=TCmdStrListItem(aliasnames.first);
  5775. while assigned(item) do
  5776. begin
  5777. inc(aliasnamescount);
  5778. item:=TCmdStrListItem(item.next);
  5779. end;
  5780. if aliasnamescount>255 then
  5781. internalerror(200711021);
  5782. ppufile.putbyte(aliasnamescount);
  5783. item:=TCmdStrListItem(aliasnames.first);
  5784. while assigned(item) do
  5785. begin
  5786. ppufile.putstring(item.str);
  5787. item:=TCmdStrListItem(item.next);
  5788. end;
  5789. ppufile.do_crc:=oldintfcrc;
  5790. { generic tokens for the declaration }
  5791. if assigned(genericdecltokenbuf) and (genericdecltokenbuf.size>0) then
  5792. begin
  5793. sizeleft:=genericdecltokenbuf.size;
  5794. genericdecltokenbuf.seek(0);
  5795. ppufile.putlongint(sizeleft);
  5796. while sizeleft>0 do
  5797. begin
  5798. if sizeleft>sizeof(buf) then
  5799. i:=sizeof(buf)
  5800. else
  5801. i:=sizeleft;
  5802. genericdecltokenbuf.read(buf,i);
  5803. ppufile.putdata(buf,i);
  5804. dec(sizeleft,i);
  5805. end;
  5806. end
  5807. else
  5808. ppufile.putlongint(0);
  5809. { write this entry }
  5810. writeentry(ppufile,ibprocdef);
  5811. { Save the para symtable, this is taken from the interface }
  5812. tparasymtable(parast).ppuwrite(ppufile);
  5813. { save localsymtable for inline procedures or when local
  5814. browser info is requested, this has no influence on the crc }
  5815. if store_localst and not ppufile.crc_only then
  5816. begin
  5817. oldintfcrc:=ppufile.do_crc;
  5818. ppufile.do_crc:=false;
  5819. tlocalsymtable(localst).ppuwrite(ppufile);
  5820. ppufile.do_crc:=oldintfcrc;
  5821. end;
  5822. { node tree for inlining }
  5823. oldintfcrc:=ppufile.do_crc;
  5824. ppufile.do_crc:=false;
  5825. if has_inlininginfo then
  5826. ppuwritenodetree(ppufile,inlininginfo^.code);
  5827. ppufile.do_crc:=oldintfcrc;
  5828. end;
  5829. function tprocdef.fullprocname(showhidden:boolean):string;
  5830. var
  5831. pno: tprocnameoptions;
  5832. begin
  5833. pno:=[];
  5834. if showhidden then
  5835. include(pno,pno_showhidden);
  5836. result:=customprocname(pno);
  5837. end;
  5838. function tprocdef.customprocname(pno: tprocnameoptions):ansistring;
  5839. var
  5840. s, rn : ansistring;
  5841. t : ttoken;
  5842. syssym : tsyssym;
  5843. begin
  5844. {$ifdef EXTDEBUG}
  5845. include(pno,pno_showhidden);
  5846. {$endif EXTDEBUG}
  5847. s:='';
  5848. if proctypeoption=potype_operator then
  5849. begin
  5850. for t:=NOTOKEN to last_overloaded do
  5851. if procsym.realname='$'+overloaded_names[t] then
  5852. begin
  5853. s:='operator ';
  5854. if (pno_ownername in pno) and
  5855. assigned(struct) then
  5856. s:=s+struct.RttiName+'.';
  5857. s:=s+arraytokeninfo[t].str;
  5858. if not (pno_noparams in pno) then
  5859. s:=s+typename_paras(pno);
  5860. break;
  5861. end;
  5862. end
  5863. else
  5864. begin
  5865. if (po_classmethod in procoptions) and
  5866. not(pno_noclassmarker in pno) then
  5867. s:='class ';
  5868. case proctypeoption of
  5869. potype_constructor,
  5870. potype_class_constructor:
  5871. s:=s+'constructor ';
  5872. potype_class_destructor,
  5873. potype_destructor:
  5874. s:=s+'destructor ';
  5875. else
  5876. if (pno_proctypeoption in pno) then
  5877. begin
  5878. if assigned(returndef) and
  5879. not(is_void(returndef)) then
  5880. s:=s+'function '
  5881. else
  5882. s:=s+'procedure ';
  5883. end;
  5884. end;
  5885. if (pno_ownername in pno) and
  5886. (owner.symtabletype in [recordsymtable,objectsymtable]) then
  5887. s:=s+tabstractrecorddef(owner.defowner).RttiName+'.';
  5888. if (po_compilerproc in procoptions) and (extnumber<>$ffff) then
  5889. begin
  5890. syssym:=tsyssym.find_by_number(extnumber);
  5891. if not assigned(syssym) then
  5892. internalerror(2016060305);
  5893. rn:=syssym.realname;
  5894. end
  5895. else
  5896. rn:=procsym.realname;
  5897. if (pno_noleadingdollar in pno) and
  5898. (rn[1]='$') then
  5899. delete(rn,1,1);
  5900. s:=s+rn;
  5901. if not (pno_noparams in pno) then
  5902. s:=s+typename_paras(pno);
  5903. end;
  5904. if not(proctypeoption in [potype_constructor,potype_destructor,
  5905. potype_class_constructor,potype_class_destructor]) and
  5906. assigned(returndef) and
  5907. not(is_void(returndef)) then
  5908. s:=s+':'+returndef.GetTypeName;
  5909. if assigned(owner) and (owner.symtabletype=localsymtable) then
  5910. s:=s+' is nested'
  5911. else if po_is_block in procoptions then
  5912. s:=s+' is block';
  5913. s:=s+';';
  5914. if po_far in procoptions then
  5915. s:=s+' far;';
  5916. { forced calling convention? }
  5917. if (po_hascallingconvention in procoptions) then
  5918. s:=s+' '+ProcCallOptionStr[proccalloption]+';';
  5919. if (po_staticmethod in procoptions) and
  5920. not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
  5921. s:=s+' Static;';
  5922. if pno_mangledname in pno then
  5923. s:=s+' -- mangled name: '+mangledname;
  5924. customprocname:=s;
  5925. end;
  5926. function tprocdef.is_methodpointer:boolean;
  5927. begin
  5928. { don't check assigned(_class), that's also the case for nested
  5929. procedures inside methods }
  5930. result:=(owner.symtabletype in [recordsymtable,ObjectSymtable]) and not no_self_node;
  5931. end;
  5932. function tprocdef.is_addressonly:boolean;
  5933. begin
  5934. result:=assigned(owner) and
  5935. not is_methodpointer and
  5936. (not(m_nested_procvars in current_settings.modeswitches) or
  5937. not is_nested_pd(self));
  5938. end;
  5939. procedure tprocdef.make_external;
  5940. begin
  5941. include(procoptions,po_external);
  5942. forwarddef:=false;
  5943. end;
  5944. procedure tprocdef.init_genericdecl;
  5945. begin
  5946. if assigned(genericdecltokenbuf) then
  5947. internalerror(2015061901);
  5948. genericdecltokenbuf:=tdynamicarray.create(256);
  5949. end;
  5950. function tprocdef.get_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean;
  5951. begin
  5952. result:=false;
  5953. if proctypeoption=potype_constructor then
  5954. begin
  5955. result:=true;
  5956. ressym:=tsym(parast.Find('self'));
  5957. resdef:=tabstractnormalvarsym(ressym).vardef;
  5958. { and TP-style constructors return a pointer to self }
  5959. if is_object(resdef) then
  5960. resdef:=cpointerdef.getreusable(resdef);
  5961. end
  5962. else if (proccalloption=pocall_safecall) and
  5963. (tf_safecall_exceptions in target_info.flags) then
  5964. begin
  5965. result:=true;
  5966. ressym:=tsym(localst.Find('safecallresult'));
  5967. resdef:=tabstractnormalvarsym(ressym).vardef;
  5968. end
  5969. else if not is_void(returndef) then
  5970. begin
  5971. result:=true;
  5972. ressym:=funcretsym;
  5973. resdef:=tabstractnormalvarsym(ressym).vardef;
  5974. end;
  5975. end;
  5976. function tprocdef.get_safecall_funcretsym_info(out ressym: tsym; out resdef: tdef): boolean;
  5977. begin
  5978. result:=false;
  5979. if (proctypeoption<>potype_constructor) and
  5980. (proccalloption=pocall_safecall) and
  5981. (tf_safecall_exceptions in target_info.flags) then
  5982. begin
  5983. result:=true;
  5984. ressym:=tsym(localst.Find('safecallresult'));
  5985. resdef:=tabstractnormalvarsym(ressym).vardef;
  5986. end
  5987. end;
  5988. function tprocdef.has_alias_name(const s: TSymStr): boolean;
  5989. var
  5990. item : TCmdStrListItem;
  5991. begin
  5992. result:=true;
  5993. if mangledname=s then
  5994. exit;
  5995. item:=TCmdStrListItem(aliasnames.first);
  5996. while assigned(item) do
  5997. begin
  5998. if item.str=s then
  5999. exit;
  6000. item:=TCmdStrListItem(item.next);
  6001. end;
  6002. result:=false;
  6003. end;
  6004. function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
  6005. begin
  6006. case t of
  6007. gs_local :
  6008. GetSymtable:=localst;
  6009. gs_para :
  6010. GetSymtable:=parast;
  6011. else
  6012. GetSymtable:=nil;
  6013. end;
  6014. end;
  6015. function tprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
  6016. var
  6017. j : longint;
  6018. begin
  6019. result:=inherited;
  6020. if newtyp=procvardef then
  6021. begin
  6022. { create new paralist }
  6023. tprocvardef(result).calcparas;
  6024. exit;
  6025. end;
  6026. { don't copy mangled name, can be different }
  6027. tprocdef(result).messageinf:=messageinf;
  6028. tprocdef(result).dispid:=dispid;
  6029. if po_msgstr in procoptions then
  6030. tprocdef(result).messageinf.str:=stringdup(messageinf.str^);
  6031. tprocdef(result).symoptions:=symoptions;
  6032. if assigned(deprecatedmsg) then
  6033. tprocdef(result).deprecatedmsg:=stringdup(deprecatedmsg^);
  6034. { will have to be associated with appropriate procsym }
  6035. tprocdef(result).procsym:=nil;
  6036. { don't create aliases for bare copies, nor copy the funcretsym as
  6037. the function result parameter will be inserted again if necessary
  6038. (e.g. if the calling convention is changed) }
  6039. if not(copytyp in [pc_bareproc,pc_normal_no_hidden]) then
  6040. begin
  6041. tprocdef(result).aliasnames.concatListcopy(aliasnames);
  6042. if assigned(funcretsym) then
  6043. begin
  6044. if funcretsym.owner=parast then
  6045. begin
  6046. j:=parast.symlist.indexof(funcretsym);
  6047. if j<0 then
  6048. internalerror(2011040606);
  6049. tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
  6050. end
  6051. else if funcretsym.owner=localst then
  6052. begin
  6053. { nothing to do, will be inserted for the new procdef while
  6054. parsing its body (by pdecsub.insert_funcret_local) }
  6055. end
  6056. else
  6057. internalerror(2011040605);
  6058. end;
  6059. end;
  6060. { will have to be associated with a new struct }
  6061. tprocdef(result).struct:=nil;
  6062. if assigned(implprocdefinfo) then
  6063. begin
  6064. if assigned(resultname) then
  6065. tprocdef(result).resultname:=stringdup(resultname^);
  6066. tprocdef(result).synthetickind:=synthetickind;
  6067. end;
  6068. if assigned(import_dll) then
  6069. tprocdef(result).import_dll:=stringdup(import_dll^);
  6070. if assigned(import_name) then
  6071. tprocdef(result).import_name:=stringdup(import_name^);
  6072. tprocdef(result).import_nr:=import_nr;
  6073. tprocdef(result).extnumber:=$ffff;
  6074. tprocdef(result).visibility:=visibility;
  6075. { we need a separate implementation for the copied def }
  6076. tprocdef(result).forwarddef:=true;
  6077. tprocdef(result).interfacedef:=true;
  6078. { create new paralist }
  6079. tprocdef(result).calcparas;
  6080. end;
  6081. function tprocdef.getcopy: tstoreddef;
  6082. begin
  6083. result:=getcopyas(procdef,pc_normal,'');
  6084. end;
  6085. procedure tprocdef.buildderef;
  6086. begin
  6087. inherited buildderef;
  6088. structderef.build(struct);
  6089. { procsym that originaly defined this definition, should be in the
  6090. same symtable }
  6091. procsymderef.build(procsym);
  6092. end;
  6093. procedure tprocdef.buildderefimpl;
  6094. begin
  6095. inherited buildderefimpl;
  6096. { Localst is not available for main/unit init }
  6097. if store_localst and assigned(localst) then
  6098. begin
  6099. tlocalsymtable(localst).buildderef;
  6100. tlocalsymtable(localst).buildderefimpl;
  6101. end;
  6102. { inline tree }
  6103. if has_inlininginfo then
  6104. begin
  6105. funcretsymderef.build(funcretsym);
  6106. inlininginfo^.code.buildderefimpl;
  6107. end;
  6108. end;
  6109. procedure tprocdef.deref;
  6110. begin
  6111. inherited deref;
  6112. struct:=tabstractrecorddef(structderef.resolve);
  6113. { procsym that originaly defined this definition, should be in the
  6114. same symtable }
  6115. procsym:=tprocsym(procsymderef.resolve);
  6116. end;
  6117. procedure tprocdef.derefimpl;
  6118. begin
  6119. { Enable has_inlininginfo when the inlininginfo
  6120. structure is available. The has_inlininginfo was disabled
  6121. after the load, since the data was invalid }
  6122. if assigned(inlininginfo) then
  6123. has_inlininginfo:=true;
  6124. { Locals }
  6125. if store_localst and assigned(localst) then
  6126. begin
  6127. tlocalsymtable(localst).deref(false);
  6128. tlocalsymtable(localst).derefimpl(false);
  6129. end;
  6130. { Inline }
  6131. if has_inlininginfo then
  6132. begin
  6133. inlininginfo^.code.derefimpl;
  6134. { funcretsym, this is always located in the localst }
  6135. funcretsym:=tsym(funcretsymderef.resolve);
  6136. end
  6137. else
  6138. begin
  6139. { safety }
  6140. { Not safe! A unit may be reresolved after its interface has been
  6141. parsed but before its implementation has been parsed, and in that
  6142. case the funcretsym is still required!
  6143. funcretsym:=nil; }
  6144. end;
  6145. end;
  6146. function tprocdef.GetTypeName : string;
  6147. begin
  6148. GetTypeName := FullProcName(false);
  6149. end;
  6150. function tprocdef.mangledname : TSymStr;
  6151. begin
  6152. {$ifdef symansistr}
  6153. if _mangledname='' then
  6154. begin
  6155. result:=defaultmangledname;
  6156. _mangledname:=result;
  6157. end
  6158. else
  6159. result:=_mangledname;
  6160. {$else symansistr}
  6161. if not assigned(_mangledname) then
  6162. begin
  6163. result:=defaultmangledname;
  6164. _mangledname:=stringdup(mangledname);
  6165. end
  6166. else
  6167. result:=_mangledname^;
  6168. {$endif symansistr}
  6169. end;
  6170. function tprocdef.defaultmangledname: TSymStr;
  6171. var
  6172. n : TSymStr;
  6173. begin
  6174. n:=procsym.name;
  6175. { make sure that the mangled names of these overloadable methods types is
  6176. unique even if it's made lowercase (e.g. for section names) }
  6177. if proctypeoption in [potype_operator,potype_class_constructor,potype_class_destructor] then
  6178. n:='$'+n;
  6179. { we need to use the symtable where the procsym is inserted,
  6180. because that is visible to the world }
  6181. defaultmangledname:=make_mangledname('',procsym.owner,n);
  6182. defaultmangledname:=defaultmangledname+mangledprocparanames(Length(defaultmangledname))
  6183. end;
  6184. function tprocdef.cplusplusmangledname : TSymStr;
  6185. function getcppparaname(p : tdef) : TSymStr;
  6186. const
  6187. {$ifdef NAMEMANGLING_GCC2}
  6188. ordtype2str : array[tordtype] of string[2] = (
  6189. '',
  6190. 'Uc','Us','Ui','Us','',
  6191. 'Sc','s','i','x','',
  6192. 'b','b','b','b','b','b',
  6193. 'c','w','x');
  6194. {$else NAMEMANGLING_GCC2}
  6195. ordtype2str : array[tordtype] of string[1] = (
  6196. 'v',
  6197. 'h','t','j','y','',
  6198. 'a','s','i','x','',
  6199. 'b','b','b','b','b',
  6200. 'b','b','b','b',
  6201. 'c','w','x','C');
  6202. floattype2str : array[tfloattype] of string[1] = (
  6203. 'f','d','e','e',
  6204. 'd','d','g');
  6205. {$endif NAMEMANGLING_GCC2}
  6206. var
  6207. s : TSymStr;
  6208. begin
  6209. case p.typ of
  6210. orddef:
  6211. begin
  6212. s:=ordtype2str[torddef(p).ordtype];
  6213. if s='C' then
  6214. s:=ordtype2str[range_to_basetype(torddef(p).low,torddef(p).high)];
  6215. end;
  6216. pointerdef:
  6217. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  6218. {$ifndef NAMEMANGLING_GCC2}
  6219. floatdef:
  6220. s:=floattype2str[tfloatdef(p).floattype];
  6221. {$endif NAMEMANGLING_GCC2}
  6222. else
  6223. internalerror(2103001);
  6224. end;
  6225. getcppparaname:=s;
  6226. end;
  6227. var
  6228. s,s2 : TSymStr;
  6229. hp : TParavarsym;
  6230. i : integer;
  6231. begin
  6232. {$ifdef NAMEMANGLING_GCC2}
  6233. { outdated gcc 2.x name mangling scheme }
  6234. s := procsym.realname;
  6235. if procsym.owner.symtabletype=ObjectSymtable then
  6236. begin
  6237. s2:=upper(tobjectdef(procsym.owner.defowner).objrealname^);
  6238. case proctypeoption of
  6239. potype_destructor:
  6240. s:='_$_'+tostr(length(s2))+s2;
  6241. potype_constructor:
  6242. s:='___'+tostr(length(s2))+s2;
  6243. else
  6244. s:='_'+s+'__'+tostr(length(s2))+s2;
  6245. end;
  6246. end
  6247. else s:=s+'__';
  6248. s:=s+'F';
  6249. { concat modifiers }
  6250. { !!!!! }
  6251. { now we handle the parameters }
  6252. if maxparacount>0 then
  6253. begin
  6254. for i:=0 to paras.count-1 do
  6255. begin
  6256. hp:=tparavarsym(paras[i]);
  6257. { no hidden parameters form part of a C++ mangled name:
  6258. a) self is not included
  6259. b) there are no "high" or other hidden parameters
  6260. }
  6261. if vo_is_hidden_para in hp.varoptions then
  6262. continue;
  6263. s2:=getcppparaname(hp.vardef);
  6264. if hp.varspez in [vs_var,vs_out] then
  6265. s2:='R'+s2;
  6266. s:=s+s2;
  6267. end;
  6268. end
  6269. else
  6270. s:=s+'v';
  6271. cplusplusmangledname:=s;
  6272. {$else NAMEMANGLING_GCC2}
  6273. { gcc 3.x and 4.x name mangling scheme }
  6274. { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling }
  6275. if procsym.owner.symtabletype=ObjectSymtable then
  6276. begin
  6277. s:='_ZN';
  6278. s2:=tobjectdef(procsym.owner.defowner).objextname^;
  6279. s:=s+tostr(length(s2))+s2;
  6280. case proctypeoption of
  6281. potype_constructor:
  6282. s:=s+'C1';
  6283. potype_destructor:
  6284. s:=s+'D1';
  6285. else
  6286. s:=s+tostr(length(procsym.realname))+procsym.realname;
  6287. end;
  6288. s:=s+'E';
  6289. end
  6290. else
  6291. s:=procsym.realname;
  6292. { now we handle the parameters }
  6293. if maxparacount>0 then
  6294. begin
  6295. for i:=0 to paras.count-1 do
  6296. begin
  6297. hp:=tparavarsym(paras[i]);
  6298. { no hidden parameters form part of a C++ mangled name:
  6299. a) self is not included
  6300. b) there are no "high" or other hidden parameters
  6301. }
  6302. if vo_is_hidden_para in hp.varoptions then
  6303. continue;
  6304. s2:=getcppparaname(hp.vardef);
  6305. if hp.varspez in [vs_var,vs_out] then
  6306. s2:='R'+s2;
  6307. s:=s+s2;
  6308. end;
  6309. end
  6310. else
  6311. s:=s+'v';
  6312. cplusplusmangledname:=s;
  6313. {$endif NAMEMANGLING_GCC2}
  6314. end;
  6315. function tprocdef.objcmangledname : TSymStr;
  6316. var
  6317. manglednamelen: longint;
  6318. iscatmethod : boolean;
  6319. begin
  6320. if not (po_msgstr in procoptions) then
  6321. internalerror(2009030901);
  6322. { we may very well need longer strings to handle these... }
  6323. manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+
  6324. length('+"[ ]"')+length(messageinf.str^);
  6325. iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions;
  6326. if (iscatmethod) then
  6327. inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()'));
  6328. if manglednamelen>255 then
  6329. Message1(parser_e_objc_message_name_too_long,messageinf.str^);
  6330. if not(po_classmethod in procoptions) then
  6331. result:='"-['
  6332. else
  6333. result:='"+[';
  6334. { quotes are necessary because the +/- otherwise confuse the assembler
  6335. into expecting a number
  6336. }
  6337. if iscatmethod then
  6338. result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'(';
  6339. result:=result+tobjectdef(procsym.owner.defowner).objextname^;
  6340. if iscatmethod then
  6341. result:=result+')';
  6342. result:=result+' '+messageinf.str^+']"';
  6343. end;
  6344. procedure tprocdef.setmangledname(const s : TSymStr);
  6345. begin
  6346. { This is not allowed anymore, the forward declaration
  6347. already needs to create the correct mangledname, no changes
  6348. afterwards are allowed (PFV) }
  6349. { Exception: interface definitions in mode macpas, since in that }
  6350. { case no reference to the old name can exist yet (JM) }
  6351. {$ifdef symansistr}
  6352. if _mangledname<>'' then
  6353. if ((m_mac in current_settings.modeswitches) and
  6354. (interfacedef)) then
  6355. _mangledname:=''
  6356. else
  6357. internalerror(200411171);
  6358. {$else symansistr}
  6359. if assigned(_mangledname) then
  6360. if ((m_mac in current_settings.modeswitches) and
  6361. (interfacedef)) then
  6362. stringdispose(_mangledname)
  6363. else
  6364. internalerror(200411171);
  6365. {$endif symansistr}
  6366. {$ifdef jvm}
  6367. { this routine can be called for compilerproces. can't set mangled
  6368. name since it must be calculated, but it uses import_name when set
  6369. -> set that one }
  6370. import_name:=stringdup(s);
  6371. include(procoptions,po_has_importname);
  6372. include(procoptions,po_has_mangledname);
  6373. {$else}
  6374. {$ifdef symansistr}
  6375. _mangledname:=s;
  6376. {$else symansistr}
  6377. _mangledname:=stringdup(s);
  6378. {$endif symansistr}
  6379. {$endif jvm}
  6380. include(procoptions,po_has_mangledname);
  6381. end;
  6382. function tprocdef.needsglobalasmsym: boolean;
  6383. begin
  6384. result:=
  6385. (cs_profile in current_settings.moduleswitches) or
  6386. { smart linking using a library requires to promote
  6387. all non-nested procedures to AB_GLOBAL
  6388. otherwise you get undefined symbol error at linking
  6389. for msdos target with -CX option for instance }
  6390. (create_smartlink_library and not is_nested_pd(self)) or
  6391. (po_global in procoptions);
  6392. end;
  6393. procedure tprocdef.setcompilerprocname;
  6394. begin
  6395. procsym.realname:='$'+lower(procsym.name);
  6396. end;
  6397. {***************************************************************************
  6398. TPROCVARDEF
  6399. ***************************************************************************}
  6400. constructor tprocvardef.create(level:byte);
  6401. begin
  6402. inherited create(procvardef,level,true);
  6403. end;
  6404. class function tprocvardef.getreusableprocaddr(def: tabstractprocdef; copytyp: tcacheableproccopytyp): tprocvardef;
  6405. var
  6406. res: PHashSetItem;
  6407. oldsymtablestack: tsymtablestack;
  6408. key: packed record
  6409. def: tabstractprocdef;
  6410. copytyp: tcacheableproccopytyp;
  6411. end;
  6412. begin
  6413. if not assigned(current_module) then
  6414. internalerror(2011081302);
  6415. key.def:=def;
  6416. key.copytyp:=copytyp;
  6417. res:=current_module.procaddrdefs.FindOrAdd(@key,sizeof(key));
  6418. if not assigned(res^.Data) then
  6419. begin
  6420. { since these pointerdefs can be reused anywhere in the current
  6421. unit, add them to the global/staticsymtable (or local symtable
  6422. if they're a local def, because otherwise they'll be saved
  6423. to the ppu referencing a local symtable entry that doesn't
  6424. exist in the ppu) }
  6425. oldsymtablestack:=symtablestack;
  6426. { do not simply push/pop current_module.localsymtable, because
  6427. that can have side-effects (e.g., it removes helpers) }
  6428. symtablestack:=nil;
  6429. result:=tprocvardef(def.getcopyas(procvardef,copytyp,''));
  6430. setup_reusable_def(def,result,res,oldsymtablestack);
  6431. { res^.Data may still be nil -> don't overwrite result }
  6432. exit;
  6433. end;
  6434. result:=tprocvardef(res^.Data);
  6435. end;
  6436. class function tprocvardef.getreusableprocaddr_no_free(def: tabstractprocdef): tprocvardef;
  6437. begin
  6438. result:=getreusableprocaddr(def,pc_address_only);
  6439. if not result.is_registered then
  6440. include(result.defoptions,df_not_registered_no_free);
  6441. end;
  6442. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  6443. begin
  6444. inherited ppuload(procvardef,ppufile);
  6445. { load para symtable }
  6446. parast:=tparasymtable.create(self,ppufile.getbyte);
  6447. ppuload_platform(ppufile);
  6448. tparasymtable(parast).ppuload(ppufile);
  6449. end;
  6450. function tprocvardef.getcopy : tstoreddef;
  6451. var
  6452. i : tcallercallee;
  6453. j : longint;
  6454. begin
  6455. result:=cprocvardef.create(parast.symtablelevel);
  6456. tprocvardef(result).returndef:=returndef;
  6457. tprocvardef(result).returndefderef:=returndefderef;
  6458. tprocvardef(result).parast:=parast.getcopy;
  6459. tprocvardef(result).savesize:=savesize;
  6460. { create paralist copy }
  6461. calcparas;
  6462. tprocvardef(result).paras:=tparalist.create(false);
  6463. tprocvardef(result).paras.count:=paras.count;
  6464. for j:=0 to paras.count-1 do
  6465. tprocvardef(result).paras[j]:=paras[j];
  6466. tprocvardef(result).proctypeoption:=proctypeoption;
  6467. tprocvardef(result).proccalloption:=proccalloption;
  6468. tprocvardef(result).procoptions:=procoptions;
  6469. tprocvardef(result).callerargareasize:=callerargareasize;
  6470. tprocvardef(result).calleeargareasize:=calleeargareasize;
  6471. tprocvardef(result).maxparacount:=maxparacount;
  6472. tprocvardef(result).minparacount:=minparacount;
  6473. for i:=low(funcretloc) to high(funcretloc) do
  6474. tprocvardef(result).funcretloc[i]:=funcretloc[i].getcopy;
  6475. tprocvardef(result).has_paraloc_info:=has_paraloc_info;
  6476. {$ifdef m68k}
  6477. tprocvardef(result).exp_funcretloc:=exp_funcretloc;
  6478. {$endif}
  6479. end;
  6480. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  6481. begin
  6482. inherited ppuwrite(ppufile);
  6483. { Save the para symtable level (necessary to distinguish nested
  6484. procvars) }
  6485. ppufile.putbyte(parast.symtablelevel);
  6486. { Write this entry }
  6487. writeentry(ppufile,ibprocvardef);
  6488. { Save the para symtable, this is taken from the interface }
  6489. tparasymtable(parast).ppuwrite(ppufile);
  6490. end;
  6491. function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
  6492. begin
  6493. case t of
  6494. gs_para :
  6495. GetSymtable:=parast;
  6496. else
  6497. GetSymtable:=nil;
  6498. end;
  6499. end;
  6500. function tprocvardef.size : asizeint;
  6501. begin
  6502. { we return false for is_addressonly for a block (because it's not a
  6503. simple pointer to a function), but they are handled as implicit
  6504. pointers to a datastructure that contains everything ->
  6505. voidpointertype.size instead of voidcodepointertype.size }
  6506. if po_is_block in procoptions then
  6507. size:=voidpointertype.size
  6508. else if not is_addressonly then
  6509. begin
  6510. if is_nested_pd(self) then
  6511. size:=voidcodepointertype.size+parentfpvoidpointertype.size
  6512. else
  6513. size:=voidcodepointertype.size+voidpointertype.size;
  6514. end
  6515. else
  6516. size:=voidcodepointertype.size;
  6517. end;
  6518. function tprocvardef.is_methodpointer:boolean;
  6519. begin
  6520. result:=(po_methodpointer in procoptions);
  6521. end;
  6522. function tprocvardef.is_addressonly:boolean;
  6523. begin
  6524. result:=((not(po_methodpointer in procoptions) or (po_staticmethod in procoptions)) and
  6525. not(po_is_block in procoptions) and
  6526. not is_nested_pd(self)) or
  6527. (po_addressonly in procoptions);
  6528. end;
  6529. function tprocvardef.getmangledparaname:TSymStr;
  6530. begin
  6531. if not(po_methodpointer in procoptions) then
  6532. if not is_nested_pd(self) then
  6533. result:='procvar'
  6534. else
  6535. { we need the manglednames here, because nestedprocvars can be anonymous, e.g.
  6536. having not a type name or not an unique one, see webtbs/tw27515.pp
  6537. Further, use $_ ... _$ delimiters to avoid ambiguous names, see webtbs/tw27515.pp }
  6538. result:='$_nestedprovar'+mangledprocparanames(0)+'_$'
  6539. else
  6540. result:='procvarofobj'
  6541. end;
  6542. function tprocvardef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
  6543. begin
  6544. result:=inherited;
  6545. tabstractprocdef(result).calcparas;
  6546. end;
  6547. function tprocvardef.is_publishable : boolean;
  6548. begin
  6549. is_publishable:=(po_methodpointer in procoptions);
  6550. end;
  6551. function tprocvardef.GetTypeName : string;
  6552. var
  6553. s: string;
  6554. pno : tprocnameoptions;
  6555. begin
  6556. {$ifdef EXTDEBUG}
  6557. pno:=[pno_showhidden];
  6558. {$else EXTDEBUG}
  6559. pno:=[];
  6560. {$endif EXTDEBUG}
  6561. s:='<';
  6562. if po_is_block in procoptions then
  6563. s := s+'reference to'
  6564. else if po_classmethod in procoptions then
  6565. s := s+'class method type of'
  6566. else
  6567. if po_addressonly in procoptions then
  6568. s := s+'address of'
  6569. else
  6570. s := s+'procedure variable type of';
  6571. if assigned(returndef) and
  6572. (returndef<>voidtype) then
  6573. s:=s+' function'+typename_paras(pno)+':'+returndef.GetTypeName
  6574. else
  6575. s:=s+' procedure'+typename_paras(pno);
  6576. if po_methodpointer in procoptions then
  6577. s := s+' of object';
  6578. if is_nested_pd(self) then
  6579. s := s+' is nested';
  6580. if po_far in procoptions then
  6581. s := s+';far';
  6582. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  6583. end;
  6584. {***************************************************************************
  6585. TOBJECTDEF
  6586. ***************************************************************************}
  6587. constructor tobjectdef.create(ot:tobjecttyp;const n:string;c:tobjectdef;doregister:boolean);
  6588. begin
  6589. inherited create(n,objectdef,doregister);
  6590. fcurrent_dispid:=0;
  6591. objecttype:=ot;
  6592. childof:=nil;
  6593. childofderef.reset;
  6594. vmt_fieldderef.reset;
  6595. extendeddefderef.reset;
  6596. cloneddefderef.reset;
  6597. if objecttype=odt_helper then
  6598. owner.includeoption(sto_has_helper);
  6599. symtable:=tObjectSymtable.create(self,n,current_settings.packrecords,
  6600. current_settings.alignment.recordalignmin);
  6601. { create space for vmt !! }
  6602. vmtentries:=TFPList.Create;
  6603. set_parent(c);
  6604. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  6605. prepareguid;
  6606. { setup implemented interfaces }
  6607. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_objccategory,odt_javaclass,odt_interfacejava] then
  6608. ImplementedInterfaces:=TFPObjectList.Create(true)
  6609. else
  6610. ImplementedInterfaces:=nil;
  6611. writing_class_record_dbginfo:=false;
  6612. end;
  6613. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  6614. var
  6615. i,
  6616. implintfcount : longint;
  6617. d, getterd : tderef;
  6618. ImplIntf : TImplementedInterface;
  6619. vmtentry : pvmtentry;
  6620. begin
  6621. inherited ppuload(objectdef,ppufile);
  6622. objecttype:=tobjecttyp(ppufile.getbyte);
  6623. helpertype:=thelpertype(ppufile.getbyte);
  6624. objextname:=ppufile.getpshortstring;
  6625. { only used for external Objective-C classes/protocols }
  6626. if (objextname^='') then
  6627. stringdispose(objextname);
  6628. symtable:=tObjectSymtable.create(self,objrealname^,0,0);
  6629. tObjectSymtable(symtable).datasize:=ppufile.getasizeint;
  6630. tObjectSymtable(symtable).paddingsize:=ppufile.getword;
  6631. tObjectSymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  6632. tObjectSymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  6633. tObjectSymtable(symtable).recordalignmin:=shortint(ppufile.getbyte);
  6634. ppufile.getderef(vmt_fieldderef);
  6635. ppufile.getderef(childofderef);
  6636. { load guid }
  6637. iidstr:=nil;
  6638. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  6639. begin
  6640. new(iidguid);
  6641. ppufile.getguid(iidguid^);
  6642. iidstr:=ppufile.getpshortstring;
  6643. end;
  6644. abstractcnt:=ppufile.getlongint;
  6645. if objecttype=odt_helper then
  6646. ppufile.getderef(extendeddefderef);
  6647. vmtentries:=TFPList.Create;
  6648. vmtentries.count:=ppufile.getlongint;
  6649. for i:=0 to vmtentries.count-1 do
  6650. begin
  6651. ppufile.getderef(d);
  6652. new(vmtentry);
  6653. vmtentry^.procdef:=nil;
  6654. vmtentry^.procdefderef:=d;
  6655. vmtentry^.visibility:=tvisibility(ppufile.getbyte);
  6656. vmtentries[i]:=vmtentry;
  6657. end;
  6658. { load implemented interfaces }
  6659. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_objccategory,odt_javaclass,odt_interfacejava] then
  6660. begin
  6661. ImplementedInterfaces:=TFPObjectList.Create(true);
  6662. implintfcount:=ppufile.getlongint;
  6663. for i:=0 to implintfcount-1 do
  6664. begin
  6665. ppufile.getderef(d);
  6666. ppufile.getderef(getterd);
  6667. ImplIntf:=TImplementedInterface.Create_deref(d,getterd);
  6668. ImplIntf.IOffset:=ppufile.getlongint;
  6669. byte(ImplIntf.IType):=ppufile.getbyte;
  6670. ImplementedInterfaces.Add(ImplIntf);
  6671. end;
  6672. end
  6673. else
  6674. ImplementedInterfaces:=nil;
  6675. if df_copied_def in defoptions then
  6676. begin
  6677. ppufile.getderef(cloneddefderef);
  6678. ppuload_platform(ppufile);
  6679. end
  6680. else
  6681. begin
  6682. ppuload_platform(ppufile);
  6683. tObjectSymtable(symtable).ppuload(ppufile);
  6684. end;
  6685. { handles the predefined class tobject }
  6686. { the last TOBJECT which is loaded gets }
  6687. { it ! }
  6688. if (childof=nil) and
  6689. (objecttype in [odt_class,odt_javaclass]) and
  6690. (objname^='TOBJECT') then
  6691. class_tobject:=self;
  6692. if (childof=nil) and
  6693. (objecttype=odt_interfacecom) then
  6694. if (objname^='IUNKNOWN') then
  6695. interface_iunknown:=self
  6696. else
  6697. if (objname^='IDISPATCH') then
  6698. interface_idispatch:=self;
  6699. if (childof=nil) and
  6700. (objecttype=odt_objcclass) and
  6701. (objname^='PROTOCOL') then
  6702. objc_protocoltype:=self;
  6703. if (objecttype=odt_javaclass) and
  6704. not(oo_is_formal in objectoptions) then
  6705. begin
  6706. if (objname^='JLOBJECT') then
  6707. java_jlobject:=self
  6708. else if (objname^='JLTHROWABLE') then
  6709. java_jlthrowable:=self
  6710. else if (objname^='FPCBASERECORDTYPE') then
  6711. java_fpcbaserecordtype:=self
  6712. else if (objname^='JLSTRING') then
  6713. java_jlstring:=self
  6714. else if (objname^='ANSISTRINGCLASS') then
  6715. java_ansistring:=self
  6716. else if (objname^='SHORTSTRINGCLASS') then
  6717. java_shortstring:=self
  6718. else if (objname^='JLENUM') then
  6719. java_jlenum:=self
  6720. else if (objname^='JUENUMSET') then
  6721. java_juenumset:=self
  6722. else if (objname^='FPCBITSET') then
  6723. java_jubitset:=self
  6724. else if (objname^='FPCBASEPROCVARTYPE') then
  6725. java_procvarbase:=self;
  6726. end;
  6727. writing_class_record_dbginfo:=false;
  6728. end;
  6729. destructor tobjectdef.destroy;
  6730. var
  6731. i: longint;
  6732. begin
  6733. if assigned(symtable) then
  6734. begin
  6735. symtable.free;
  6736. symtable:=nil;
  6737. end;
  6738. stringdispose(objextname);
  6739. stringdispose(iidstr);
  6740. if assigned(ImplementedInterfaces) then
  6741. begin
  6742. ImplementedInterfaces.free;
  6743. ImplementedInterfaces:=nil;
  6744. end;
  6745. if assigned(iidguid) then
  6746. begin
  6747. dispose(iidguid);
  6748. iidguid:=nil;
  6749. end;
  6750. if assigned(vmtentries) then
  6751. begin
  6752. for i:=0 to vmtentries.count-1 do
  6753. dispose(pvmtentry(vmtentries[i]));
  6754. vmtentries.free;
  6755. vmtentries:=nil;
  6756. end;
  6757. if assigned(vmcallstaticinfo) then
  6758. begin
  6759. freemem(vmcallstaticinfo);
  6760. vmcallstaticinfo:=nil;
  6761. end;
  6762. inherited destroy;
  6763. end;
  6764. function tobjectdef.getcopy : tstoreddef;
  6765. var
  6766. i : longint;
  6767. begin
  6768. result:=cobjectdef.create(objecttype,objrealname^,childof,true);
  6769. { the constructor allocates a symtable which we release to avoid memory leaks }
  6770. tobjectdef(result).symtable.free;
  6771. tobjectdef(result).symtable:=symtable.getcopy;
  6772. if assigned(objextname) then
  6773. tobjectdef(result).objextname:=stringdup(objextname^);
  6774. if assigned(import_lib) then
  6775. tobjectdef(result).import_lib:=stringdup(import_lib^);
  6776. tobjectdef(result).objectoptions:=objectoptions;
  6777. include(tobjectdef(result).defoptions,df_copied_def);
  6778. tobjectdef(result).extendeddef:=extendeddef;
  6779. if assigned(tcinitcode) then
  6780. tobjectdef(result).tcinitcode:=tcinitcode.getcopy;
  6781. tobjectdef(result).vmt_field:=vmt_field;
  6782. if assigned(iidguid) then
  6783. begin
  6784. new(tobjectdef(result).iidguid);
  6785. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  6786. end;
  6787. if assigned(iidstr) then
  6788. tobjectdef(result).iidstr:=stringdup(iidstr^);
  6789. tobjectdef(result).abstractcnt:=abstractcnt;
  6790. if assigned(ImplementedInterfaces) then
  6791. begin
  6792. for i:=0 to ImplementedInterfaces.count-1 do
  6793. tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
  6794. end;
  6795. tobjectdef(result).copyvmtentries(self);
  6796. end;
  6797. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  6798. var
  6799. i : longint;
  6800. vmtentry : pvmtentry;
  6801. ImplIntf : TImplementedInterface;
  6802. old_do_indirect_crc: boolean;
  6803. begin
  6804. { if class1 in unit A changes, and class2 in unit B inherits from it
  6805. (so unit B uses unit A), then unit B with class2 will be recompiled.
  6806. However, if there is also a class3 in unit C that only depends on
  6807. unit B, then unit C will not be recompiled because nothing changed
  6808. to the interface of unit B. Nevertheless, unit C can indirectly
  6809. depend on unit A via derefs, and these must be updated -> the
  6810. indirect crc keeps track of such changes. }
  6811. old_do_indirect_crc:=ppufile.do_indirect_crc;
  6812. ppufile.do_indirect_crc:=true;
  6813. inherited ppuwrite(ppufile);
  6814. ppufile.putbyte(byte(objecttype));
  6815. ppufile.putbyte(byte(helpertype));
  6816. if assigned(objextname) then
  6817. ppufile.putstring(objextname^)
  6818. else
  6819. ppufile.putstring('');
  6820. ppufile.putasizeint(tObjectSymtable(symtable).datasize);
  6821. ppufile.putword(tObjectSymtable(symtable).paddingsize);
  6822. ppufile.putbyte(byte(tObjectSymtable(symtable).fieldalignment));
  6823. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignment));
  6824. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignmin));
  6825. ppufile.putderef(vmt_fieldderef);
  6826. ppufile.putderef(childofderef);
  6827. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  6828. begin
  6829. ppufile.putguid(iidguid^);
  6830. ppufile.putstring(iidstr^);
  6831. end;
  6832. ppufile.putlongint(abstractcnt);
  6833. if objecttype=odt_helper then
  6834. ppufile.putderef(extendeddefderef);
  6835. ppufile.putlongint(vmtentries.count);
  6836. for i:=0 to vmtentries.count-1 do
  6837. begin
  6838. vmtentry:=pvmtentry(vmtentries[i]);
  6839. ppufile.putderef(vmtentry^.procdefderef);
  6840. ppufile.putbyte(byte(vmtentry^.visibility));
  6841. end;
  6842. if assigned(ImplementedInterfaces) then
  6843. begin
  6844. ppufile.putlongint(ImplementedInterfaces.Count);
  6845. for i:=0 to ImplementedInterfaces.Count-1 do
  6846. begin
  6847. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  6848. ppufile.putderef(ImplIntf.intfdefderef);
  6849. ppufile.putderef(ImplIntf.ImplementsGetterDeref);
  6850. ppufile.putlongint(ImplIntf.Ioffset);
  6851. ppufile.putbyte(byte(ImplIntf.IType));
  6852. end;
  6853. end;
  6854. if df_copied_def in defoptions then
  6855. ppufile.putderef(cloneddefderef);
  6856. writeentry(ppufile,ibobjectdef);
  6857. if not(df_copied_def in defoptions) then
  6858. tObjectSymtable(symtable).ppuwrite(ppufile);
  6859. ppufile.do_indirect_crc:=old_do_indirect_crc;
  6860. end;
  6861. function tobjectdef.GetTypeName:string;
  6862. begin
  6863. { in this case we will go in endless recursion, because then }
  6864. { there is no tsym associated yet with the def. It can occur }
  6865. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  6866. { instead of the actual type name }
  6867. if not assigned(typesym) then
  6868. result:='<Currently Parsed Class>'
  6869. else
  6870. result:=typesymbolprettyname;
  6871. end;
  6872. procedure tobjectdef.buildderef;
  6873. var
  6874. i : longint;
  6875. vmtentry : pvmtentry;
  6876. begin
  6877. inherited buildderef;
  6878. vmt_fieldderef.build(vmt_field);
  6879. childofderef.build(childof);
  6880. if df_copied_def in defoptions then
  6881. cloneddefderef.build(symtable.defowner)
  6882. else
  6883. tstoredsymtable(symtable).buildderef;
  6884. if objecttype=odt_helper then
  6885. extendeddefderef.build(extendeddef);
  6886. for i:=0 to vmtentries.count-1 do
  6887. begin
  6888. vmtentry:=pvmtentry(vmtentries[i]);
  6889. vmtentry^.procdefderef.build(vmtentry^.procdef);
  6890. end;
  6891. if assigned(ImplementedInterfaces) then
  6892. begin
  6893. for i:=0 to ImplementedInterfaces.count-1 do
  6894. TImplementedInterface(ImplementedInterfaces[i]).buildderef;
  6895. end;
  6896. end;
  6897. procedure tobjectdef.deref;
  6898. var
  6899. i : longint;
  6900. vmtentry : pvmtentry;
  6901. begin
  6902. inherited deref;
  6903. vmt_field:=tsym(vmt_fieldderef.resolve);
  6904. childof:=tobjectdef(childofderef.resolve);
  6905. if df_copied_def in defoptions then
  6906. begin
  6907. cloneddef:=tobjectdef(cloneddefderef.resolve);
  6908. symtable:=cloneddef.symtable.getcopy;
  6909. end
  6910. else
  6911. tstoredsymtable(symtable).deref(false);
  6912. if objecttype=odt_helper then
  6913. extendeddef:=tdef(extendeddefderef.resolve);
  6914. for i:=0 to vmtentries.count-1 do
  6915. begin
  6916. vmtentry:=pvmtentry(vmtentries[i]);
  6917. vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve);
  6918. end;
  6919. if assigned(ImplementedInterfaces) then
  6920. begin
  6921. for i:=0 to ImplementedInterfaces.count-1 do
  6922. TImplementedInterface(ImplementedInterfaces[i]).deref;
  6923. end;
  6924. end;
  6925. procedure create_class_helper_for_procdef(def: tobject; arg: pointer);
  6926. var
  6927. pd: tprocdef absolute def;
  6928. st: tsymtable;
  6929. psym: tsym;
  6930. nname: TIDString;
  6931. begin
  6932. if (tdef(def).typ<>procdef) then
  6933. exit;
  6934. { pd.owner = objcclass symtable -> defowner = objcclassdef ->
  6935. owner = symtable in which objcclassdef is defined
  6936. }
  6937. st:=pd.owner.defowner.owner;
  6938. nname:=class_helper_prefix+tprocsym(pd.procsym).name;
  6939. { check for an existing procsym with our special name }
  6940. psym:=tsym(st.find(nname));
  6941. if not assigned(psym) then
  6942. begin
  6943. psym:=cprocsym.create(nname);
  6944. { avoid warning about this symbol being unused }
  6945. psym.IncRefCount;
  6946. { don't check for duplicates:
  6947. a) we checked above
  6948. b) in case we are in the implementation section of a unit, this
  6949. will also check for this symbol in the interface section
  6950. (since you normally cannot have symbols with the same name
  6951. both interface and implementation), and it's possible to
  6952. have class helpers for the same class in the interface and
  6953. in the implementation, and they cannot be merged since only
  6954. the once in the interface must be saved to the ppu/visible
  6955. from other units }
  6956. st.insertsym(psym,false);
  6957. end
  6958. else if (psym.typ<>procsym) then
  6959. internalerror(2009111501);
  6960. { add ourselves to this special procsym }
  6961. tprocsym(psym).procdeflist.add(def);
  6962. end;
  6963. procedure tobjectdef.derefimpl;
  6964. begin
  6965. inherited derefimpl;
  6966. { the procdefs are not owned by the class helper procsyms, so they
  6967. are not stored/restored either -> re-add them here }
  6968. if (objecttype in [odt_objcclass,odt_objcprotocol]) or
  6969. (oo_is_classhelper in objectoptions) then
  6970. symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
  6971. end;
  6972. procedure tobjectdef.copyvmtentries(objdef:tobjectdef);
  6973. var
  6974. i : longint;
  6975. vmtentry : pvmtentry;
  6976. begin
  6977. if vmtentries.count<>0 then
  6978. internalerror(2019081401);
  6979. vmtentries.count:=objdef.vmtentries.count;
  6980. for i:=0 to objdef.vmtentries.count-1 do
  6981. begin
  6982. new(vmtentry);
  6983. vmtentry^:=pvmtentry(objdef.vmtentries[i])^;
  6984. vmtentries[i]:=vmtentry;
  6985. end;
  6986. end;
  6987. function tobjectdef.getparentdef:tdef;
  6988. begin
  6989. { TODO: Remove getparentdef hack}
  6990. { With 2 forward declared classes with the child class before the
  6991. parent class the child class is written earlier to the ppu. Leaving it
  6992. possible to have a reference to the parent class for property overriding,
  6993. but the parent class still has the childof not resolved yet (PFV) }
  6994. if childof=nil then
  6995. childof:=tobjectdef(childofderef.resolve);
  6996. result:=childof;
  6997. end;
  6998. procedure tobjectdef.prepareguid;
  6999. begin
  7000. { set up guid }
  7001. if not assigned(iidguid) then
  7002. begin
  7003. new(iidguid);
  7004. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  7005. end;
  7006. { setup iidstring }
  7007. if not assigned(iidstr) then
  7008. iidstr:=stringdup(''); { default is empty string }
  7009. end;
  7010. procedure tobjectdef.set_parent( c : tobjectdef);
  7011. begin
  7012. if assigned(childof) then
  7013. exit;
  7014. childof:=c;
  7015. if not assigned(c) then
  7016. exit;
  7017. { inherit options and status }
  7018. objectoptions:=objectoptions+(c.objectoptions*inherited_objectoptions);
  7019. { initially has the same number of abstract methods as the parent }
  7020. abstractcnt:=c.abstractcnt;
  7021. { add the data of the anchestor class/object }
  7022. if (objecttype in [odt_class,odt_object,odt_objcclass,odt_javaclass]) then
  7023. begin
  7024. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize+tObjectSymtable(c.symtable).datasize;
  7025. { inherit recordalignment }
  7026. tObjectSymtable(symtable).recordalignment:=tObjectSymtable(c.symtable).recordalignment;
  7027. { if both the parent and this record use C-alignment, also inherit
  7028. the current field alignment }
  7029. if (tObjectSymtable(c.symtable).usefieldalignment=C_alignment) and
  7030. (tObjectSymtable(symtable).usefieldalignment=C_alignment) then
  7031. tObjectSymtable(symtable).fieldalignment:=tObjectSymtable(c.symtable).fieldalignment;
  7032. { the padding is not inherited for Objective-C classes (maybe not
  7033. for cppclass either?) }
  7034. if objecttype=odt_objcclass then
  7035. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-tObjectSymtable(c.symtable).paddingsize;
  7036. if (oo_has_vmt in objectoptions) and
  7037. (oo_has_vmt in c.objectoptions) then
  7038. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-sizeof(pint);
  7039. { if parent has a vmt field then the offset is the same for the child PM }
  7040. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  7041. begin
  7042. vmt_field:=c.vmt_field;
  7043. include(objectoptions,oo_has_vmt);
  7044. end;
  7045. end;
  7046. end;
  7047. procedure tobjectdef.insertvmt;
  7048. begin
  7049. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  7050. exit;
  7051. if (oo_has_vmt in objectoptions) then
  7052. internalerror(2020100816)
  7053. else
  7054. begin
  7055. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,
  7056. tObjectSymtable(symtable).fieldalignment);
  7057. if (tf_requires_proper_alignment in target_info.flags) then
  7058. begin
  7059. { Align VMT pointer and whole object instance if target CPU requires alignment. }
  7060. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(pint));
  7061. tObjectSymtable(symtable).alignrecord(tObjectSymtable(symtable).datasize,sizeof(pint));
  7062. end;
  7063. vmt_field:=cfieldvarsym.create('_vptr$'+objname^,vs_value,voidpointertype,[]);
  7064. hidesym(vmt_field);
  7065. tObjectSymtable(symtable).insertsym(vmt_field);
  7066. tObjectSymtable(symtable).addfield(tfieldvarsym(vmt_field),vis_hidden);
  7067. include(objectoptions,oo_has_vmt);
  7068. end;
  7069. end;
  7070. function tobjectdef.vmt_offset: asizeint;
  7071. begin
  7072. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  7073. result:=0
  7074. else if (tObjectSymtable(symtable).usefieldalignment<>bit_alignment) then
  7075. result:=tfieldvarsym(vmt_field).fieldoffset
  7076. else
  7077. result:=tfieldvarsym(vmt_field).fieldoffset div 8;
  7078. end;
  7079. procedure tobjectdef.check_forwards;
  7080. begin
  7081. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol,odt_interfacejava]) then
  7082. inherited;
  7083. if (oo_is_forward in objectoptions) then
  7084. begin
  7085. { ok, in future, the forward can be resolved }
  7086. Message1(sym_e_class_forward_not_resolved,objrealname^);
  7087. exclude(objectoptions,oo_is_forward);
  7088. end;
  7089. end;
  7090. function tobjectdef.find_destructor: tprocdef;
  7091. var
  7092. objdef: tobjectdef;
  7093. begin
  7094. objdef:=self;
  7095. while assigned(objdef) do
  7096. begin
  7097. result:=objdef.find_procdef_bytype(potype_destructor);
  7098. if assigned(result) then
  7099. exit;
  7100. objdef:=objdef.childof;
  7101. end;
  7102. result:=nil;
  7103. end;
  7104. function tobjectdef.implements_any_interfaces: boolean;
  7105. begin
  7106. result := (ImplementedInterfaces.Count > 0) or
  7107. (assigned(childof) and childof.implements_any_interfaces);
  7108. end;
  7109. function tobjectdef.size : asizeint;
  7110. begin
  7111. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  7112. result:=voidpointertype.size
  7113. else
  7114. result:=tObjectSymtable(symtable).datasize;
  7115. end;
  7116. function tobjectdef.alignment:shortint;
  7117. begin
  7118. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  7119. alignment:=voidpointertype.alignment
  7120. else
  7121. alignment:=tObjectSymtable(symtable).recordalignment;
  7122. end;
  7123. function tobjectdef.vmtmethodoffset(index:longint):longint;
  7124. begin
  7125. { for offset of methods for classes, see rtl/inc/objpash.inc }
  7126. case objecttype of
  7127. odt_class:
  7128. { the +2*sizeof(pint) is size and -size }
  7129. vmtmethodoffset:=index*voidcodepointertype.size+10*voidpointertype.size+2*sizeof(pint);
  7130. odt_helper,
  7131. odt_objcclass,
  7132. odt_objcprotocol:
  7133. vmtmethodoffset:=0;
  7134. odt_interfacecom,odt_interfacecorba,odt_dispinterface:
  7135. vmtmethodoffset:=index*voidcodepointertype.size;
  7136. odt_javaclass,
  7137. odt_interfacejava:
  7138. { invalid }
  7139. vmtmethodoffset:=-1;
  7140. else
  7141. { the +2*sizeof(pint) is size and -size }
  7142. {$ifdef WITHDMT}
  7143. vmtmethodoffset:=index*voidcodepointertype.size+2*voidpointertype.size+2*sizeof(pint);
  7144. {$else WITHDMT}
  7145. vmtmethodoffset:=index*voidcodepointertype.size+1*voidpointertype.size+2*sizeof(pint);
  7146. {$endif WITHDMT}
  7147. end;
  7148. end;
  7149. function tobjectdef.vmt_mangledname : TSymStr;
  7150. begin
  7151. if not(oo_has_vmt in objectoptions) then
  7152. Message1(parser_n_object_has_no_vmt,objrealname^);
  7153. if not is_unique_objpasdef then
  7154. vmt_mangledname:=make_mangledname('VMT',owner,objname^)
  7155. else
  7156. vmt_mangledname:=childof.vmt_mangledname;
  7157. end;
  7158. function tobjectdef.vmt_def: trecorddef;
  7159. var
  7160. where: tsymtable;
  7161. vmttypesym: tsymentry;
  7162. begin
  7163. if not is_unique_objpasdef then
  7164. begin
  7165. where:=get_top_level_symtable(true);
  7166. vmttypesym:=where.Find('vmtdef$'+mangledparaname);
  7167. if not assigned(vmttypesym) or
  7168. (vmttypesym.typ<>symconst.typesym) or
  7169. (ttypesym(vmttypesym).typedef.typ<>recorddef) then
  7170. internalerror(2015052501);
  7171. result:=trecorddef(ttypesym(vmttypesym).typedef);
  7172. end
  7173. else
  7174. result:=childof.vmt_def;
  7175. end;
  7176. function tobjectdef.needs_inittable : boolean;
  7177. var
  7178. hp : tobjectdef;
  7179. begin
  7180. case objecttype of
  7181. odt_helper,
  7182. odt_class :
  7183. needs_inittable:=false;
  7184. odt_dispinterface,
  7185. odt_interfacecom:
  7186. needs_inittable:=true;
  7187. odt_interfacecorba:
  7188. begin
  7189. hp:=childof;
  7190. while assigned(hp) do
  7191. begin
  7192. if hp=interface_iunknown then
  7193. begin
  7194. needs_inittable:=true;
  7195. exit;
  7196. end;
  7197. hp:=hp.childof;
  7198. end;
  7199. needs_inittable:=false;
  7200. end;
  7201. odt_object:
  7202. needs_inittable:=
  7203. tObjectSymtable(symtable).needs_init_final or
  7204. (assigned(childof) and
  7205. childof.needs_inittable);
  7206. odt_cppclass,
  7207. odt_objcclass,
  7208. odt_objcprotocol,
  7209. odt_javaclass,
  7210. odt_interfacejava:
  7211. needs_inittable:=false;
  7212. else
  7213. internalerror(200108267);
  7214. end;
  7215. end;
  7216. function tobjectdef.needs_separate_initrtti : boolean;
  7217. begin
  7218. result:=not (objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  7219. end;
  7220. function tobjectdef.has_non_trivial_init_child(check_parent:boolean):boolean;
  7221. begin
  7222. if objecttype in [odt_class,odt_object] then
  7223. begin
  7224. result:=tobjectsymtable(symtable).has_non_trivial_init or
  7225. (check_parent and assigned(childof) and childof.has_non_trivial_init_child(true));
  7226. end
  7227. else
  7228. result:=false;
  7229. end;
  7230. function tobjectdef.rtti_mangledname(rt: trttitype): TSymStr;
  7231. begin
  7232. if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
  7233. begin
  7234. if not is_unique_objpasdef then
  7235. result:=inherited rtti_mangledname(rt)
  7236. else
  7237. result:=childof.rtti_mangledname(rt)
  7238. end
  7239. else
  7240. begin
  7241. { necessary in case of a dynamic array of nsobject, or
  7242. if an nsobject field appears in a record that needs
  7243. init/finalisation }
  7244. if rt=initrtti then
  7245. begin
  7246. result:=voidpointertype.rtti_mangledname(rt);
  7247. exit;
  7248. end;
  7249. if not(target_info.system in systems_objc_nfabi) then
  7250. begin
  7251. result:=target_asm.labelprefix;
  7252. case objecttype of
  7253. odt_objcclass:
  7254. begin
  7255. case rt of
  7256. objcclassrtti:
  7257. if not(oo_is_classhelper in objectoptions) then
  7258. result:=result+'_OBJC_CLASS_'
  7259. else
  7260. result:=result+'_OBJC_CATEGORY_';
  7261. objcmetartti:
  7262. if not(oo_is_classhelper in objectoptions) then
  7263. result:=result+'_OBJC_METACLASS_'
  7264. else
  7265. internalerror(2009111511);
  7266. else
  7267. internalerror(2009092302);
  7268. end;
  7269. end;
  7270. odt_objcprotocol:
  7271. result:=result+'_OBJC_PROTOCOL_';
  7272. else
  7273. ;
  7274. end;
  7275. end
  7276. else
  7277. begin
  7278. case objecttype of
  7279. odt_objcclass:
  7280. begin
  7281. if (oo_is_classhelper in objectoptions) and
  7282. (rt<>objcclassrtti) then
  7283. internalerror(2009111512);
  7284. case rt of
  7285. objcclassrtti:
  7286. if not(oo_is_classhelper in objectoptions) then
  7287. result:='_OBJC_CLASS_$_'
  7288. else
  7289. result:='_OBJC_$_CATEGORY_';
  7290. objcmetartti:
  7291. result:='_OBJC_METACLASS_$_';
  7292. objcclassrortti:
  7293. result:=lower(target_asm.labelprefix)+'_OBJC_CLASS_RO_$_';
  7294. objcmetarortti:
  7295. result:=lower(target_asm.labelprefix)+'_OBJC_METACLASS_RO_$_';
  7296. else
  7297. internalerror(2009092303);
  7298. end;
  7299. end;
  7300. odt_objcprotocol:
  7301. begin
  7302. result:=lower(target_asm.labelprefix);
  7303. case rt of
  7304. objcclassrtti:
  7305. result:=result+'_OBJC_PROTOCOL_$_';
  7306. objcmetartti:
  7307. result:=result+'_OBJC_LABEL_PROTOCOL_$_';
  7308. else
  7309. internalerror(2009092501);
  7310. end;
  7311. end;
  7312. else
  7313. internalerror(2013113005);
  7314. end;
  7315. end;
  7316. result:=result+objextname^;
  7317. end;
  7318. end;
  7319. function tobjectdef.is_unique_objpasdef: boolean;
  7320. begin
  7321. result:=
  7322. (df_unique in defoptions) and
  7323. is_class_or_interface_or_dispinterface(self)
  7324. end;
  7325. function tobjectdef.members_need_inittable : boolean;
  7326. begin
  7327. members_need_inittable:=tObjectSymtable(symtable).needs_init_final;
  7328. end;
  7329. function tobjectdef.is_publishable : boolean;
  7330. begin
  7331. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface];
  7332. end;
  7333. function tobjectdef.get_next_dispid: longint;
  7334. begin
  7335. inc(fcurrent_dispid);
  7336. result:=fcurrent_dispid;
  7337. end;
  7338. function tobjectdef.search_enumerator_get: tprocdef;
  7339. begin
  7340. result:=inherited;
  7341. if not assigned(result) and assigned(childof) then
  7342. result:=childof.search_enumerator_get;
  7343. end;
  7344. function tobjectdef.search_enumerator_move: tprocdef;
  7345. begin
  7346. result:=inherited;
  7347. if not assigned(result) and assigned(childof) then
  7348. result:=childof.search_enumerator_move;
  7349. end;
  7350. function tobjectdef.search_enumerator_current: tsym;
  7351. begin
  7352. result:=inherited;
  7353. if not assigned(result) and assigned(childof) then
  7354. result:=childof.search_enumerator_current;
  7355. end;
  7356. procedure tobjectdef.register_created_classref_type;
  7357. begin
  7358. if not classref_created_in_current_module then
  7359. begin
  7360. classref_created_in_current_module:=true;
  7361. current_module.wpoinfo.addcreatedobjtypeforclassref(self);
  7362. end;
  7363. end;
  7364. procedure tobjectdef.register_created_object_type;
  7365. begin
  7366. if not created_in_current_module then
  7367. begin
  7368. created_in_current_module:=true;
  7369. current_module.wpoinfo.addcreatedobjtype(self);
  7370. end;
  7371. end;
  7372. procedure tobjectdef.register_maybe_created_object_type;
  7373. begin
  7374. { if we know it has been created for sure, no need
  7375. to also record that it maybe can be created in
  7376. this module
  7377. }
  7378. if not (created_in_current_module) and
  7379. not (maybe_created_in_current_module) then
  7380. begin
  7381. maybe_created_in_current_module:=true;
  7382. current_module.wpoinfo.addmaybecreatedbyclassref(self);
  7383. end;
  7384. end;
  7385. procedure tobjectdef.register_vmt_call(index: longint);
  7386. begin
  7387. if (is_object(self) or is_class(self)) then
  7388. current_module.wpoinfo.addcalledvmtentry(self,index);
  7389. end;
  7390. procedure check_and_finish_msg(data: tobject; arg: pointer);
  7391. var
  7392. def: tdef absolute data;
  7393. pd: tprocdef absolute data;
  7394. i,
  7395. paracount: longint;
  7396. begin
  7397. if (def.typ=procdef) then
  7398. begin
  7399. { add all messages also under a dummy name to the symtable in
  7400. which the objcclass/protocol/category is declared, so they can
  7401. be called via id.<name>
  7402. }
  7403. create_class_helper_for_procdef(pd,nil);
  7404. { we have to wait until now to set the mangled name because it
  7405. depends on the (possibly external) class name, which is defined
  7406. at the very end. }
  7407. if not(po_msgstr in pd.procoptions) then
  7408. begin
  7409. CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
  7410. { recover to avoid internalerror later on }
  7411. include(pd.procoptions,po_msgstr);
  7412. pd.messageinf.str:=stringdup('MissingDeclaration');
  7413. end;
  7414. { Mangled name is already set in case this is a copy of
  7415. another type. }
  7416. if not(po_has_mangledname in pd.procoptions) then
  7417. begin
  7418. { check whether the number of formal parameters is correct,
  7419. and whether they have valid Objective-C types }
  7420. paracount:=0;
  7421. for i:=1 to length(pd.messageinf.str^) do
  7422. if pd.messageinf.str^[i]=':' then
  7423. inc(paracount);
  7424. for i:=0 to pd.paras.count-1 do
  7425. if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
  7426. not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
  7427. dec(paracount);
  7428. if (paracount<>0) then
  7429. MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
  7430. pd.setmangledname(pd.objcmangledname);
  7431. end
  7432. else
  7433. { all checks already done }
  7434. exit;
  7435. if not(oo_is_external in pd.struct.objectoptions) then
  7436. begin
  7437. if (po_varargs in pd.procoptions) then
  7438. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external)
  7439. else
  7440. begin
  7441. { check for "array of const" parameters }
  7442. for i:=0 to pd.parast.symlist.count-1 do
  7443. begin
  7444. if (tsym(pd.parast.symlist[i]).typ=paravarsym) and
  7445. is_array_of_const(tparavarsym(pd.parast.symlist[i]).vardef) then
  7446. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external);
  7447. end;
  7448. end;
  7449. end;
  7450. end;
  7451. end;
  7452. procedure mark_private_fields_used(data: tobject; arg: pointer);
  7453. var
  7454. sym: tsym absolute data;
  7455. begin
  7456. if (sym.typ=fieldvarsym) and
  7457. (tfieldvarsym(sym).visibility in [vis_private,vis_strictprivate]) then
  7458. sym.IncRefCount;
  7459. end;
  7460. procedure tobjectdef.finish_objc_data;
  7461. begin
  7462. self.symtable.DefList.foreachcall(@check_and_finish_msg,nil);
  7463. if (oo_is_external in objectoptions) then
  7464. self.symtable.SymList.ForEachCall(@mark_private_fields_used,nil);
  7465. end;
  7466. procedure verify_objc_vardef(data: tobject; arg: pointer);
  7467. var
  7468. sym: tabstractvarsym absolute data;
  7469. res: pboolean absolute arg;
  7470. founderrordef: tdef;
  7471. begin
  7472. if not(tsym(data).typ in [paravarsym,fieldvarsym]) then
  7473. exit;
  7474. if (sym.typ=paravarsym) and
  7475. ((vo_is_hidden_para in tparavarsym(sym).varoptions) or
  7476. is_array_of_const(tparavarsym(sym).vardef)) then
  7477. exit;
  7478. if not objcchecktype(sym.vardef,founderrordef) then
  7479. begin
  7480. MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  7481. res^:=false;
  7482. end;
  7483. end;
  7484. procedure verify_objc_procdef_paras(data: tobject; arg: pointer);
  7485. var
  7486. def: tdef absolute data;
  7487. res: pboolean absolute arg;
  7488. founderrordef: tdef;
  7489. begin
  7490. if (def.typ<>procdef) then
  7491. exit;
  7492. { check parameter types for validity }
  7493. tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg);
  7494. { check the result type for validity }
  7495. if not objcchecktype(tprocdef(def).returndef,founderrordef) then
  7496. begin
  7497. MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  7498. res^:=false;
  7499. end;
  7500. end;
  7501. function tobjectdef.check_objc_types: boolean;
  7502. begin
  7503. { done in separate step from finish_objc_data, because when
  7504. finish_objc_data is called, not all forwarddefs have been resolved
  7505. yet and we need to know all types here }
  7506. result:=true;
  7507. self.symtable.symlist.foreachcall(@verify_objc_vardef,@result);
  7508. self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result);
  7509. end;
  7510. procedure do_cpp_import_info(data: tobject; arg: pointer);
  7511. var
  7512. def: tdef absolute data;
  7513. pd: tprocdef absolute data;
  7514. begin
  7515. if (def.typ=procdef) then
  7516. begin
  7517. pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
  7518. if (oo_is_external in pd.struct.objectoptions) then
  7519. begin
  7520. { copied from psub.read_proc }
  7521. if assigned(tobjectdef(pd.struct).import_lib) then
  7522. current_module.AddExternalImport(tobjectdef(pd.struct).import_lib^,pd.mangledname,pd.mangledname,0,false,false)
  7523. else
  7524. begin
  7525. { add import name to external list for DLL scanning }
  7526. if tf_has_dllscanner in target_info.flags then
  7527. current_module.dllscannerinputlist.Add(pd.mangledname,pd);
  7528. end;
  7529. end;
  7530. end;
  7531. end;
  7532. procedure tobjectdef.finish_cpp_data;
  7533. begin
  7534. self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
  7535. end;
  7536. {$ifdef DEBUG_NODE_XML}
  7537. function TObjectDef.XMLPrintType: ansistring;
  7538. begin
  7539. if (oo_is_forward in objectoptions) then
  7540. Result := '&lt;class prototype&gt;'
  7541. else
  7542. Result := '&lt;class&gt;';
  7543. end;
  7544. procedure TObjectDef.XMLPrintDefInfo(var T: Text; Sym: TSym);
  7545. var
  7546. i: TObjectOption;
  7547. first: Boolean;
  7548. begin
  7549. inherited XMLPrintDefInfo(T, Sym);
  7550. First := True;
  7551. for i := Low(TObjectOption) to High(TObjectOption) do
  7552. if i in objectoptions then
  7553. begin
  7554. if First then
  7555. begin
  7556. Write(T, ' objectoptions="', i);
  7557. First := False;
  7558. end
  7559. else
  7560. Write(T, ',', i)
  7561. end;
  7562. if not first then
  7563. Write(T, '"');
  7564. end;
  7565. procedure TObjectDef.XMLPrintDefData(var T: Text; Sym: TSym);
  7566. begin
  7567. { There's nothing useful yet if the type is only forward-declared }
  7568. if not (oo_is_forward in objectoptions) then
  7569. begin
  7570. if Assigned(childof) then
  7571. WriteLn(T, printnodeindention, '<ancestor>', SanitiseXMLString(childof.typesym.RealName), '</ancestor>');
  7572. inherited XMLPrintDefData(T, Sym);
  7573. end;
  7574. end;
  7575. {$endif DEBUG_NODE_XML}
  7576. {****************************************************************************
  7577. TImplementedInterface
  7578. ****************************************************************************}
  7579. function TImplementedInterface.GetIOffset: longint;
  7580. begin
  7581. if (fIOffset=-1) and
  7582. (IType in [etFieldValue,etFieldValueClass]) then
  7583. result:=tfieldvarsym(ImplementsField).fieldoffset
  7584. else
  7585. result:=fIOffset;
  7586. end;
  7587. constructor TImplementedInterface.create(aintf: tobjectdef);
  7588. begin
  7589. inherited create;
  7590. intfdef:=aintf;
  7591. intfdefderef.reset;
  7592. IOffset:=-1;
  7593. IType:=etStandard;
  7594. NameMappings:=nil;
  7595. procdefs:=nil;
  7596. end;
  7597. constructor TImplementedInterface.create_deref(intfd,getterd:tderef);
  7598. begin
  7599. inherited create;
  7600. intfdef:=nil;
  7601. intfdefderef:=intfd;
  7602. ImplementsGetterDeref:=getterd;
  7603. IOffset:=-1;
  7604. IType:=etStandard;
  7605. NameMappings:=nil;
  7606. procdefs:=nil;
  7607. end;
  7608. destructor TImplementedInterface.destroy;
  7609. var
  7610. i : longint;
  7611. mappedname : pshortstring;
  7612. begin
  7613. if assigned(NameMappings) then
  7614. begin
  7615. for i:=0 to NameMappings.Count-1 do
  7616. begin
  7617. mappedname:=pshortstring(NameMappings[i]);
  7618. stringdispose(mappedname);
  7619. end;
  7620. NameMappings.free;
  7621. NameMappings:=nil;
  7622. end;
  7623. if assigned(procdefs) then
  7624. begin
  7625. procdefs.free;
  7626. procdefs:=nil;
  7627. end;
  7628. inherited destroy;
  7629. end;
  7630. procedure TImplementedInterface.buildderef;
  7631. begin
  7632. intfdefderef.build(intfdef);
  7633. ImplementsGetterDeref.build(ImplementsGetter);
  7634. end;
  7635. procedure TImplementedInterface.deref;
  7636. begin
  7637. intfdef:=tobjectdef(intfdefderef.resolve);
  7638. ImplementsGetter:=tsym(ImplementsGetterDeref.resolve);
  7639. end;
  7640. procedure TImplementedInterface.AddMapping(const origname,newname: string);
  7641. begin
  7642. if not assigned(NameMappings) then
  7643. NameMappings:=TFPHashList.Create;
  7644. NameMappings.Add(origname,stringdup(newname));
  7645. end;
  7646. function TImplementedInterface.GetMapping(const origname: string):string;
  7647. var
  7648. mappedname : pshortstring;
  7649. begin
  7650. result:='';
  7651. if not assigned(NameMappings) then
  7652. exit;
  7653. mappedname:=PShortstring(NameMappings.Find(origname));
  7654. if assigned(mappedname) then
  7655. result:=mappedname^;
  7656. end;
  7657. procedure TImplementedInterface.AddImplProc(pd:tprocdef);
  7658. begin
  7659. if not assigned(procdefs) then
  7660. procdefs:=TFPObjectList.Create(false);
  7661. { duplicate entries must be stored, because multiple }
  7662. { interfaces can declare methods with the same name }
  7663. { and all of these get their own VMT entry }
  7664. procdefs.Add(pd);
  7665. end;
  7666. function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  7667. var
  7668. i : longint;
  7669. begin
  7670. result:=false;
  7671. { interfaces being implemented through delegation are not mergable (FK) }
  7672. if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) or not(assigned(MergingIntf.ProcDefs)) then
  7673. exit;
  7674. weight:=0;
  7675. { empty interface is mergeable }
  7676. if ProcDefs.Count=0 then
  7677. begin
  7678. result:=true;
  7679. exit;
  7680. end;
  7681. { The interface to merge must at least the number of
  7682. procedures of this interface }
  7683. if MergingIntf.ProcDefs.Count<ProcDefs.Count then
  7684. exit;
  7685. for i:=0 to ProcDefs.Count-1 do
  7686. begin
  7687. if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
  7688. exit;
  7689. end;
  7690. weight:=ProcDefs.Count;
  7691. result:=true;
  7692. end;
  7693. function TImplementedInterface.getcopy:TImplementedInterface;
  7694. begin
  7695. Result:=TImplementedInterface.Create(nil);
  7696. { 1) the procdefs list will be freed once for each copy
  7697. 2) since the procdefs list owns its elements, those will also be freed for each copy
  7698. 3) idem for the name mappings
  7699. }
  7700. { warning: this is completely wrong on so many levels...
  7701. Move(pointer(self)^,pointer(result)^,InstanceSize);
  7702. We need to make clean copies of the different fields
  7703. this is not implemented yet, and thus we generate an internal
  7704. error instead PM 2011-06-14 }
  7705. internalerror(2011061401);
  7706. end;
  7707. {****************************************************************************
  7708. TFORWARDDEF
  7709. ****************************************************************************}
  7710. constructor tforwarddef.create(const s:string;const pos:tfileposinfo);
  7711. begin
  7712. inherited create(forwarddef,true);
  7713. tosymname:=stringdup(s);
  7714. forwardpos:=pos;
  7715. end;
  7716. function tforwarddef.GetTypeName:string;
  7717. begin
  7718. GetTypeName:='unresolved forward to '+tosymname^;
  7719. end;
  7720. destructor tforwarddef.destroy;
  7721. begin
  7722. stringdispose(tosymname);
  7723. inherited destroy;
  7724. end;
  7725. function tforwarddef.getcopy:tstoreddef;
  7726. begin
  7727. result:=cforwarddef.create(tosymname^, forwardpos);
  7728. end;
  7729. {****************************************************************************
  7730. TUNDEFINEDDEF
  7731. ****************************************************************************}
  7732. constructor tundefineddef.create(doregister:boolean);
  7733. begin
  7734. inherited create(undefineddef,doregister);
  7735. end;
  7736. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  7737. begin
  7738. inherited ppuload(undefineddef,ppufile);
  7739. ppuload_platform(ppufile);
  7740. end;
  7741. function tundefineddef.GetTypeName:string;
  7742. begin
  7743. GetTypeName:='<undefined type>';
  7744. end;
  7745. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  7746. begin
  7747. inherited ppuwrite(ppufile);
  7748. writeentry(ppufile,ibundefineddef);
  7749. end;
  7750. {****************************************************************************
  7751. TERRORDEF
  7752. ****************************************************************************}
  7753. constructor terrordef.create;
  7754. begin
  7755. inherited create(errordef,true);
  7756. { prevent consecutive faults }
  7757. savesize:=1;
  7758. end;
  7759. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  7760. begin
  7761. { Can't write errordefs to ppu }
  7762. internalerror(200411063);
  7763. end;
  7764. function terrordef.GetTypeName:string;
  7765. begin
  7766. GetTypeName:='<erroneous type>';
  7767. end;
  7768. function terrordef.getmangledparaname:TSymStr;
  7769. begin
  7770. getmangledparaname:='error';
  7771. end;
  7772. {****************************************************************************
  7773. Definition Helpers
  7774. ****************************************************************************}
  7775. function is_interfacecom(def: tdef): boolean;
  7776. begin
  7777. is_interfacecom:=
  7778. assigned(def) and
  7779. (def.typ=objectdef) and
  7780. (tobjectdef(def).objecttype=odt_interfacecom);
  7781. end;
  7782. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  7783. begin
  7784. is_interfacecom_or_dispinterface:=
  7785. assigned(def) and
  7786. (def.typ=objectdef) and
  7787. (tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface]);
  7788. end;
  7789. function is_any_interface_kind(def: tdef): boolean;
  7790. begin
  7791. result:=
  7792. assigned(def) and
  7793. (def.typ=objectdef) and
  7794. ((tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface,odt_interfacecorba,odt_interfacejava,odt_objcprotocol]) or
  7795. is_objccategory(def));
  7796. end;
  7797. function is_interfacecorba(def: tdef): boolean;
  7798. begin
  7799. is_interfacecorba:=
  7800. assigned(def) and
  7801. (def.typ=objectdef) and
  7802. (tobjectdef(def).objecttype=odt_interfacecorba);
  7803. end;
  7804. function is_interface(def: tdef): boolean;
  7805. begin
  7806. is_interface:=
  7807. assigned(def) and
  7808. (def.typ=objectdef) and
  7809. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  7810. end;
  7811. function is_dispinterface(def: tdef): boolean;
  7812. begin
  7813. result:=
  7814. assigned(def) and
  7815. (def.typ=objectdef) and
  7816. (tobjectdef(def).objecttype=odt_dispinterface);
  7817. end;
  7818. function is_class(def: tdef): boolean;
  7819. begin
  7820. is_class:=
  7821. assigned(def) and
  7822. (def.typ=objectdef) and
  7823. (tobjectdef(def).objecttype=odt_class);
  7824. end;
  7825. function is_object(def: tdef): boolean;
  7826. begin
  7827. is_object:=
  7828. assigned(def) and
  7829. (def.typ=objectdef) and
  7830. (tobjectdef(def).objecttype=odt_object);
  7831. end;
  7832. function is_cppclass(def: tdef): boolean;
  7833. begin
  7834. is_cppclass:=
  7835. assigned(def) and
  7836. (def.typ=objectdef) and
  7837. (tobjectdef(def).objecttype=odt_cppclass);
  7838. end;
  7839. function is_objcclass(def: tdef): boolean;
  7840. begin
  7841. is_objcclass:=
  7842. assigned(def) and
  7843. (def.typ=objectdef) and
  7844. (tobjectdef(def).objecttype=odt_objcclass);
  7845. end;
  7846. function is_objectpascal_helper(def: tdef): boolean;
  7847. begin
  7848. result:=
  7849. assigned(def) and
  7850. (def.typ=objectdef) and
  7851. (tobjectdef(def).objecttype=odt_helper);
  7852. end;
  7853. function is_objcclassref(def: tdef): boolean;
  7854. begin
  7855. is_objcclassref:=
  7856. assigned(def) and
  7857. (def.typ=classrefdef) and
  7858. is_objcclass(tclassrefdef(def).pointeddef);
  7859. end;
  7860. function is_objcprotocol(def: tdef): boolean;
  7861. begin
  7862. result:=
  7863. assigned(def) and
  7864. (def.typ=objectdef) and
  7865. (tobjectdef(def).objecttype=odt_objcprotocol);
  7866. end;
  7867. function is_objccategory(def: tdef): boolean;
  7868. begin
  7869. result:=
  7870. assigned(def) and
  7871. (def.typ=objectdef) and
  7872. { if used as a forward type }
  7873. ((tobjectdef(def).objecttype=odt_objccategory) or
  7874. { if used as after it has been resolved }
  7875. ((tobjectdef(def).objecttype=odt_objcclass) and
  7876. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  7877. end;
  7878. function is_objc_class_or_protocol(def: tdef): boolean;
  7879. begin
  7880. result:=
  7881. assigned(def) and
  7882. (def.typ=objectdef) and
  7883. (tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]);
  7884. end;
  7885. function is_objc_protocol_or_category(def: tdef): boolean;
  7886. begin
  7887. result:=
  7888. assigned(def) and
  7889. (def.typ=objectdef) and
  7890. ((tobjectdef(def).objecttype = odt_objcprotocol) or
  7891. ((tobjectdef(def).objecttype = odt_objcclass) and
  7892. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  7893. end;
  7894. function is_classhelper(def: tdef): boolean;
  7895. begin
  7896. result:=
  7897. is_objectpascal_helper(def) or
  7898. is_objccategory(def);
  7899. end;
  7900. function is_class_or_interface(def: tdef): boolean;
  7901. begin
  7902. result:=
  7903. assigned(def) and
  7904. (def.typ=objectdef) and
  7905. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  7906. end;
  7907. function is_class_or_interface_or_objc(def: tdef): boolean;
  7908. begin
  7909. result:=
  7910. assigned(def) and
  7911. (def.typ=objectdef) and
  7912. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]);
  7913. end;
  7914. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  7915. begin
  7916. result:=
  7917. assigned(def) and
  7918. (def.typ=objectdef) and
  7919. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  7920. end;
  7921. function is_class_or_interface_or_dispinterface_or_objc_or_java(def: tdef): boolean;
  7922. begin
  7923. result:=
  7924. assigned(def) and
  7925. (def.typ=objectdef) and
  7926. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  7927. end;
  7928. function is_class_or_interface_or_object(def: tdef): boolean;
  7929. begin
  7930. result:=
  7931. assigned(def) and
  7932. (def.typ=objectdef) and
  7933. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_object]);
  7934. end;
  7935. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  7936. begin
  7937. result:=
  7938. assigned(def) and
  7939. (def.typ=objectdef) and
  7940. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  7941. end;
  7942. function is_implicit_pointer_object_type(def: tdef): boolean;
  7943. begin
  7944. result:=
  7945. assigned(def) and
  7946. (((def.typ=objectdef) and
  7947. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava])) or
  7948. ((target_info.system in systems_jvm) and
  7949. (def.typ=recorddef)));
  7950. end;
  7951. function is_implicit_array_pointer(def: tdef): boolean;
  7952. begin
  7953. result:=is_dynamic_array(def) or is_dynamicstring(def);
  7954. end;
  7955. function is_class_or_object(def: tdef): boolean;
  7956. begin
  7957. result:=
  7958. assigned(def) and
  7959. (def.typ=objectdef) and
  7960. (tobjectdef(def).objecttype in [odt_class,odt_object]);
  7961. end;
  7962. function is_record(def: tdef): boolean;
  7963. begin
  7964. result:=
  7965. assigned(def) and
  7966. (def.typ=recorddef);
  7967. end;
  7968. function is_javaclass(def: tdef): boolean;
  7969. begin
  7970. result:=
  7971. assigned(def) and
  7972. (def.typ=objectdef) and
  7973. (tobjectdef(def).objecttype=odt_javaclass);
  7974. end;
  7975. function is_javaclassref(def: tdef): boolean;
  7976. begin
  7977. is_javaclassref:=
  7978. assigned(def) and
  7979. (def.typ=classrefdef) and
  7980. is_javaclass(tclassrefdef(def).pointeddef);
  7981. end;
  7982. function is_javainterface(def: tdef): boolean;
  7983. begin
  7984. result:=
  7985. assigned(def) and
  7986. (def.typ=objectdef) and
  7987. (tobjectdef(def).objecttype=odt_interfacejava);
  7988. end;
  7989. function is_java_class_or_interface(def: tdef): boolean;
  7990. begin
  7991. result:=
  7992. assigned(def) and
  7993. (def.typ=objectdef) and
  7994. (tobjectdef(def).objecttype in [odt_javaclass,odt_interfacejava]);
  7995. end;
  7996. procedure loadobjctypes;
  7997. begin
  7998. objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_CLASS',true).typedef);
  7999. objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER',true).typedef);
  8000. objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID',true).typedef);
  8001. objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL',true).typedef);
  8002. objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT',true).typedef);
  8003. end;
  8004. procedure maybeloadcocoatypes;
  8005. var
  8006. tsym: ttypesym;
  8007. cocoaunit: string[15];
  8008. begin
  8009. if assigned(objc_fastenumeration) then
  8010. exit;
  8011. if not(target_info.system in [system_arm_ios,system_i386_iphonesim,system_aarch64_ios,system_x86_64_iphonesim]) then
  8012. cocoaunit:='COCOAALL'
  8013. else
  8014. cocoaunit:='IPHONEALL';
  8015. tsym:=search_named_unit_globaltype(cocoaunit,'NSFASTENUMERATIONPROTOCOL',false);
  8016. if assigned(tsym) then
  8017. objc_fastenumeration:=tobjectdef(tsym.typedef)
  8018. else
  8019. objc_fastenumeration:=nil;
  8020. tsym:=search_named_unit_globaltype(cocoaunit,'NSFASTENUMERATIONSTATE',false);
  8021. if assigned(tsym) then
  8022. objc_fastenumerationstate:=trecorddef(tsym.typedef)
  8023. else
  8024. objc_fastenumerationstate:=nil;
  8025. end;
  8026. function use_vectorfpu(def : tdef) : boolean;
  8027. begin
  8028. {$ifdef x86}
  8029. {$define use_vectorfpuimplemented}
  8030. use_vectorfpu:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  8031. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  8032. {$endif x86}
  8033. {$ifdef arm}
  8034. {$define use_vectorfpuimplemented}
  8035. use_vectorfpu:=FPUARM_HAS_VFP_EXTENSION in fpu_capabilities[current_settings.fputype];
  8036. {$endif arm}
  8037. {$ifdef aarch64}
  8038. {$define use_vectorfpuimplemented}
  8039. use_vectorfpu:=true;
  8040. {$endif aarch64}
  8041. {$ifndef use_vectorfpuimplemented}
  8042. use_vectorfpu:=false;
  8043. {$endif}
  8044. end;
  8045. end.