symdef.pas 299 KB

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