symdef.pas 315 KB

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