symdef.pas 297 KB

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