symdef.pas 323 KB

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