symdef.pas 223 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349635063516352635363546355635663576358635963606361636263636364636563666367636863696370637163726373637463756376637763786379638063816382638363846385638663876388638963906391639263936394639563966397639863996400640164026403640464056406640764086409641064116412641364146415641664176418641964206421642264236424642564266427642864296430643164326433643464356436643764386439644064416442644364446445644664476448644964506451645264536454645564566457645864596460646164626463646464656466646764686469647064716472647364746475647664776478647964806481648264836484648564866487648864896490649164926493649464956496649764986499650065016502650365046505650665076508650965106511651265136514651565166517651865196520652165226523652465256526652765286529653065316532653365346535653665376538653965406541654265436544654565466547654865496550655165526553655465556556655765586559656065616562656365646565656665676568656965706571657265736574657565766577657865796580658165826583658465856586658765886589659065916592659365946595659665976598659966006601660266036604660566066607660866096610661166126613661466156616661766186619662066216622662366246625662666276628662966306631663266336634663566366637663866396640664166426643664466456646664766486649665066516652665366546655665666576658665966606661666266636664666566666667666866696670667166726673667466756676667766786679668066816682668366846685668666876688668966906691669266936694669566966697669866996700670167026703670467056706670767086709671067116712671367146715671667176718671967206721672267236724672567266727672867296730673167326733673467356736673767386739674067416742674367446745674667476748674967506751675267536754675567566757675867596760676167626763676467656766676767686769677067716772677367746775677667776778677967806781678267836784678567866787678867896790679167926793679467956796679767986799680068016802680368046805680668076808680968106811681268136814681568166817681868196820682168226823682468256826682768286829683068316832683368346835683668376838683968406841684268436844684568466847684868496850685168526853685468556856685768586859686068616862
  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,
  23. { global }
  24. globtype,globals,tokens,constexp,
  25. { symtable }
  26. symconst,symbase,symtype,
  27. { ppu }
  28. ppu,
  29. { node }
  30. node,
  31. { aasm }
  32. aasmbase,aasmtai,aasmdata,
  33. cpubase,cpuinfo,
  34. cgbase,cgutils,
  35. parabase
  36. ;
  37. type
  38. {************************************************
  39. TDef
  40. ************************************************}
  41. { tstoreddef }
  42. tstoreddef = class(tdef)
  43. protected
  44. typesymderef : tderef;
  45. public
  46. {$ifdef EXTDEBUG}
  47. fileinfo : tfileposinfo;
  48. {$endif}
  49. { generic support }
  50. genericdef : tstoreddef;
  51. genericdefderef : tderef;
  52. generictokenbuf : tdynamicarray;
  53. constructor create(dt:tdeftyp);
  54. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  55. destructor destroy;override;
  56. function getcopy : tstoreddef;virtual;
  57. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  58. procedure buildderef;override;
  59. procedure buildderefimpl;override;
  60. procedure deref;override;
  61. procedure derefimpl;override;
  62. function size:asizeint;override;
  63. function getvardef:longint;override;
  64. function alignment:shortint;override;
  65. function is_publishable : boolean;override;
  66. function needs_inittable : boolean;override;
  67. function rtti_mangledname(rt:trttitype):string;override;
  68. function OwnerHierarchyName: string; override;
  69. function needs_separate_initrtti:boolean;override;
  70. function in_currentunit: boolean;
  71. { regvars }
  72. function is_intregable : boolean;
  73. function is_fpuregable : boolean;
  74. { generics }
  75. procedure initgeneric;
  76. private
  77. savesize : asizeuint;
  78. end;
  79. tfiletyp = (ft_text,ft_typed,ft_untyped);
  80. tfiledef = class(tstoreddef)
  81. filetyp : tfiletyp;
  82. typedfiledef : tdef;
  83. typedfiledefderef : tderef;
  84. constructor createtext;
  85. constructor createuntyped;
  86. constructor createtyped(def : tdef);
  87. constructor ppuload(ppufile:tcompilerppufile);
  88. function getcopy : tstoreddef;override;
  89. procedure ppuwrite(ppufile:tcompilerppufile);override;
  90. procedure buildderef;override;
  91. procedure deref;override;
  92. function GetTypeName:string;override;
  93. function getmangledparaname:TSymStr;override;
  94. procedure setsize;
  95. end;
  96. tvariantdef = class(tstoreddef)
  97. varianttype : tvarianttype;
  98. constructor create(v : tvarianttype);
  99. constructor ppuload(ppufile:tcompilerppufile);
  100. function getcopy : tstoreddef;override;
  101. function GetTypeName:string;override;
  102. procedure ppuwrite(ppufile:tcompilerppufile);override;
  103. function getvardef:longint;override;
  104. procedure setsize;
  105. function is_publishable : boolean;override;
  106. function needs_inittable : boolean;override;
  107. end;
  108. tformaldef = class(tstoreddef)
  109. typed:boolean;
  110. constructor create(Atyped:boolean);
  111. constructor ppuload(ppufile:tcompilerppufile);
  112. procedure ppuwrite(ppufile:tcompilerppufile);override;
  113. function GetTypeName:string;override;
  114. end;
  115. tforwarddef = class(tstoreddef)
  116. tosymname : pshortstring;
  117. forwardpos : tfileposinfo;
  118. constructor create(const s:string;const pos:tfileposinfo);
  119. destructor destroy;override;
  120. function getcopy:tstoreddef;override;
  121. function GetTypeName:string;override;
  122. end;
  123. tundefineddef = class(tstoreddef)
  124. constructor create;
  125. constructor ppuload(ppufile:tcompilerppufile);
  126. procedure ppuwrite(ppufile:tcompilerppufile);override;
  127. function GetTypeName:string;override;
  128. end;
  129. terrordef = class(tstoreddef)
  130. constructor create;
  131. procedure ppuwrite(ppufile:tcompilerppufile);override;
  132. function GetTypeName:string;override;
  133. function getmangledparaname : TSymStr;override;
  134. end;
  135. tabstractpointerdef = class(tstoreddef)
  136. pointeddef : tdef;
  137. pointeddefderef : tderef;
  138. constructor create(dt:tdeftyp;def:tdef);
  139. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  140. procedure ppuwrite(ppufile:tcompilerppufile);override;
  141. procedure buildderef;override;
  142. procedure deref;override;
  143. end;
  144. tpointerdef = class(tabstractpointerdef)
  145. is_far : boolean;
  146. has_pointer_math : boolean;
  147. constructor create(def:tdef);
  148. constructor createfar(def:tdef);
  149. function getcopy:tstoreddef;override;
  150. constructor ppuload(ppufile:tcompilerppufile);
  151. procedure ppuwrite(ppufile:tcompilerppufile);override;
  152. function GetTypeName:string;override;
  153. end;
  154. tprocdef = class;
  155. { tabstractrecorddef }
  156. tabstractrecorddef= class(tstoreddef)
  157. objname,
  158. objrealname : PShortString;
  159. { for C++ classes: name of the library this class is imported from }
  160. { for Java classes/records: package name }
  161. import_lib : PShortString;
  162. symtable : TSymtable;
  163. cloneddef : tabstractrecorddef;
  164. cloneddefderef : tderef;
  165. objectoptions : tobjectoptions;
  166. { for targets that initialise typed constants via explicit assignments
  167. instead of by generating an initialised data sectino }
  168. tcinitcode : tnode;
  169. constructor create(const n:string; dt:tdeftyp);
  170. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  171. procedure ppuwrite(ppufile:tcompilerppufile);override;
  172. destructor destroy; override;
  173. procedure check_forwards; virtual;
  174. function find_procdef_bytype(pt:tproctypeoption): tprocdef;
  175. function GetSymtable(t:tGetSymtable):TSymtable;override;
  176. function is_packed:boolean;
  177. function RttiName: string;
  178. { enumerator support }
  179. function search_enumerator_get: tprocdef; virtual;
  180. function search_enumerator_move: tprocdef; virtual;
  181. function search_enumerator_current: tsym; virtual;
  182. { JVM }
  183. function jvm_full_typename(with_package_name: boolean): string;
  184. end;
  185. trecorddef = class(tabstractrecorddef)
  186. public
  187. isunion : boolean;
  188. constructor create(const n:string; p:TSymtable);
  189. constructor ppuload(ppufile:tcompilerppufile);
  190. destructor destroy;override;
  191. function getcopy : tstoreddef;override;
  192. procedure ppuwrite(ppufile:tcompilerppufile);override;
  193. procedure buildderef;override;
  194. procedure deref;override;
  195. function size:asizeint;override;
  196. function alignment : shortint;override;
  197. function padalignment: shortint;
  198. function GetTypeName:string;override;
  199. { debug }
  200. function needs_inittable : boolean;override;
  201. function needs_separate_initrtti:boolean;override;
  202. { jvm }
  203. function is_related(d : tdef) : boolean;override;
  204. end;
  205. tobjectdef = class;
  206. { TImplementedInterface }
  207. TImplementedInterface = class
  208. private
  209. fIOffset : longint;
  210. function GetIOffset: longint;
  211. public
  212. IntfDef : tobjectdef;
  213. IntfDefDeref : tderef;
  214. IType : tinterfaceentrytype;
  215. VtblImplIntf : TImplementedInterface;
  216. NameMappings : TFPHashList;
  217. ProcDefs : TFPObjectList;
  218. ImplementsGetter : tsym;
  219. ImplementsField : tsym;
  220. constructor create(aintf: tobjectdef);
  221. constructor create_deref(d:tderef);
  222. destructor destroy; override;
  223. function getcopy:TImplementedInterface;
  224. procedure buildderef;
  225. procedure deref;
  226. procedure AddMapping(const origname, newname: string);
  227. function GetMapping(const origname: string):string;
  228. procedure AddImplProc(pd:tprocdef);
  229. function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  230. property IOffset: longint read GetIOffset write fIOffset;
  231. end;
  232. { tvmtentry }
  233. tvmtentry = record
  234. procdef : tprocdef;
  235. procdefderef : tderef;
  236. visibility : tvisibility;
  237. end;
  238. pvmtentry = ^tvmtentry;
  239. { tobjectdef }
  240. tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
  241. pmvcallstaticinfo = ^tmvcallstaticinfo;
  242. tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
  243. tobjectdef = class(tabstractrecorddef)
  244. private
  245. fcurrent_dispid: longint;
  246. public
  247. dwarf_struct_lab : tasmsymbol;
  248. childof : tobjectdef;
  249. childofderef : tderef;
  250. { for Object Pascal helpers }
  251. extendeddef : tdef;
  252. extendeddefderef: tderef;
  253. { for Objective-C: protocols and classes can have the same name there }
  254. objextname : pshortstring;
  255. { to be able to have a variable vmt position }
  256. { and no vmt field for objects without virtuals }
  257. vmtentries : TFPList;
  258. vmcallstaticinfo : pmvcallstaticinfo;
  259. vmt_offset : longint;
  260. iidguid : pguid;
  261. iidstr : pshortstring;
  262. { store implemented interfaces defs and name mappings }
  263. ImplementedInterfaces : TFPObjectList;
  264. { number of abstract methods (used by JVM target to determine whether
  265. or not the class should be marked as abstract: must be done if 1 or
  266. more abstract methods) }
  267. abstractcnt : longint;
  268. writing_class_record_dbginfo,
  269. { a class of this type has been created in this module }
  270. created_in_current_module,
  271. { a loadvmtnode for this class has been created in this
  272. module, so if a classrefdef variable of this or a parent
  273. class is used somewhere to instantiate a class, then this
  274. class may be instantiated
  275. }
  276. maybe_created_in_current_module,
  277. { a "class of" this particular class has been created in
  278. this module
  279. }
  280. classref_created_in_current_module : boolean;
  281. objecttype : tobjecttyp;
  282. constructor create(ot:tobjecttyp;const n:string;c:tobjectdef);
  283. constructor ppuload(ppufile:tcompilerppufile);
  284. destructor destroy;override;
  285. function getcopy : tstoreddef;override;
  286. procedure ppuwrite(ppufile:tcompilerppufile);override;
  287. function GetTypeName:string;override;
  288. procedure buildderef;override;
  289. procedure deref;override;
  290. procedure buildderefimpl;override;
  291. procedure derefimpl;override;
  292. procedure resetvmtentries;
  293. procedure copyvmtentries(objdef:tobjectdef);
  294. function getparentdef:tdef;override;
  295. function size : asizeint;override;
  296. function alignment:shortint;override;
  297. function vmtmethodoffset(index:longint):longint;
  298. function members_need_inittable : boolean;
  299. function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  300. { this should be called when this class implements an interface }
  301. procedure prepareguid;
  302. function is_publishable : boolean;override;
  303. function is_related(d : tdef) : boolean;override;
  304. function needs_inittable : boolean;override;
  305. function needs_separate_initrtti : boolean;override;
  306. function rtti_mangledname(rt:trttitype):string;override;
  307. function vmt_mangledname : TSymStr;
  308. procedure check_forwards; override;
  309. procedure insertvmt;
  310. procedure set_parent(c : tobjectdef);
  311. function find_destructor: tprocdef;
  312. function implements_any_interfaces: boolean;
  313. { dispinterface support }
  314. function get_next_dispid: longint;
  315. { enumerator support }
  316. function search_enumerator_get: tprocdef; override;
  317. function search_enumerator_move: tprocdef; override;
  318. function search_enumerator_current: tsym; override;
  319. { WPO }
  320. procedure register_created_object_type;override;
  321. procedure register_maybe_created_object_type;
  322. procedure register_created_classref_type;
  323. procedure register_vmt_call(index:longint);
  324. { ObjC }
  325. procedure finish_objc_data;
  326. function check_objc_types: boolean;
  327. { C++ }
  328. procedure finish_cpp_data;
  329. end;
  330. tclassrefdef = class(tabstractpointerdef)
  331. constructor create(def:tdef);
  332. constructor ppuload(ppufile:tcompilerppufile);
  333. procedure ppuwrite(ppufile:tcompilerppufile);override;
  334. function getcopy:tstoreddef;override;
  335. function GetTypeName:string;override;
  336. function is_publishable : boolean;override;
  337. function rtti_mangledname(rt:trttitype):string;override;
  338. procedure register_created_object_type;override;
  339. end;
  340. tarraydef = class(tstoreddef)
  341. lowrange,
  342. highrange : asizeint;
  343. rangedef : tdef;
  344. rangedefderef : tderef;
  345. arrayoptions : tarraydefoptions;
  346. symtable : TSymtable;
  347. protected
  348. _elementdef : tdef;
  349. _elementdefderef : tderef;
  350. procedure setelementdef(def:tdef);
  351. public
  352. function elesize : asizeint;
  353. function elepackedbitsize : asizeint;
  354. function elecount : asizeuint;
  355. constructor create_from_pointer(def:tdef);
  356. constructor create(l,h:asizeint;def:tdef);
  357. constructor ppuload(ppufile:tcompilerppufile);
  358. destructor destroy; override;
  359. function getcopy : tstoreddef;override;
  360. procedure ppuwrite(ppufile:tcompilerppufile);override;
  361. function GetTypeName:string;override;
  362. function getmangledparaname : TSymStr;override;
  363. procedure buildderef;override;
  364. procedure deref;override;
  365. function size : asizeint;override;
  366. function alignment : shortint;override;
  367. { returns the label of the range check string }
  368. function needs_inittable : boolean;override;
  369. function needs_separate_initrtti : boolean;override;
  370. property elementdef : tdef read _elementdef write setelementdef;
  371. function is_publishable : boolean;override;
  372. end;
  373. torddef = class(tstoreddef)
  374. low,high : TConstExprInt;
  375. ordtype : tordtype;
  376. constructor create(t : tordtype;v,b : TConstExprInt);
  377. constructor ppuload(ppufile:tcompilerppufile);
  378. function getcopy : tstoreddef;override;
  379. procedure ppuwrite(ppufile:tcompilerppufile);override;
  380. function is_publishable : boolean;override;
  381. function GetTypeName:string;override;
  382. function alignment:shortint;override;
  383. procedure setsize;
  384. function packedbitsize: asizeint; override;
  385. function getvardef : longint;override;
  386. end;
  387. tfloatdef = class(tstoreddef)
  388. floattype : tfloattype;
  389. constructor create(t : tfloattype);
  390. constructor ppuload(ppufile:tcompilerppufile);
  391. function getcopy : tstoreddef;override;
  392. procedure ppuwrite(ppufile:tcompilerppufile);override;
  393. function GetTypeName:string;override;
  394. function is_publishable : boolean;override;
  395. function alignment:shortint;override;
  396. function structalignment: shortint;override;
  397. procedure setsize;
  398. function getvardef:longint;override;
  399. end;
  400. { tabstractprocdef }
  401. tprocnameoption = (pno_showhidden, pno_proctypeoption, pno_paranames,
  402. pno_ownername, pno_noclassmarker, pno_noleadingdollar);
  403. tprocnameoptions = set of tprocnameoption;
  404. tproccopytyp = (pc_normal,
  405. { always creates a top-level function, removes all
  406. special parameters (self, vmt, parentfp, ...) }
  407. pc_bareproc
  408. );
  409. tabstractprocdef = class(tstoreddef)
  410. { saves a definition to the return type }
  411. returndef : tdef;
  412. returndefderef : tderef;
  413. parast : TSymtable;
  414. paras : tparalist;
  415. proctypeoption : tproctypeoption;
  416. proccalloption : tproccalloption;
  417. procoptions : tprocoptions;
  418. callerargareasize,
  419. calleeargareasize: pint;
  420. {$ifdef m68k}
  421. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  422. {$endif}
  423. funcretloc : array[tcallercallee] of TCGPara;
  424. has_paraloc_info : tcallercallee; { paraloc info is available }
  425. { number of user visible parameters }
  426. maxparacount,
  427. minparacount : byte;
  428. constructor create(dt:tdeftyp;level:byte);
  429. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  430. destructor destroy;override;
  431. procedure ppuwrite(ppufile:tcompilerppufile);override;
  432. procedure buildderef;override;
  433. procedure deref;override;
  434. procedure calcparas;
  435. function typename_paras(pno: tprocnameoptions): ansistring;
  436. function is_methodpointer:boolean;virtual;
  437. function is_addressonly:boolean;virtual;
  438. function no_self_node:boolean;
  439. { get either a copy as a procdef or procvardef }
  440. function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef; virtual;
  441. procedure check_mark_as_nested;
  442. procedure init_paraloc_info(side: tcallercallee);
  443. function stack_tainting_parameter(side: tcallercallee): boolean;
  444. private
  445. procedure count_para(p:TObject;arg:pointer);
  446. procedure insert_para(p:TObject;arg:pointer);
  447. end;
  448. tprocvardef = class(tabstractprocdef)
  449. {$ifdef jvm}
  450. { class representing this procvar on the Java side }
  451. classdef : tobjectdef;
  452. classdefderef : tderef;
  453. {$endif}
  454. constructor create(level:byte);
  455. constructor ppuload(ppufile:tcompilerppufile);
  456. function getcopy : tstoreddef;override;
  457. procedure ppuwrite(ppufile:tcompilerppufile);override;
  458. {$ifdef jvm}
  459. procedure buildderef;override;
  460. procedure deref;override;
  461. {$endif}
  462. function GetSymtable(t:tGetSymtable):TSymtable;override;
  463. function size : asizeint;override;
  464. function GetTypeName:string;override;
  465. function is_publishable : boolean;override;
  466. function is_methodpointer:boolean;override;
  467. function is_addressonly:boolean;override;
  468. function getmangledparaname:TSymStr;override;
  469. end;
  470. tmessageinf = record
  471. case integer of
  472. 0 : (str : pshortstring);
  473. 1 : (i : longint);
  474. end;
  475. tinlininginfo = record
  476. { node tree }
  477. code : tnode;
  478. flags : tprocinfoflags;
  479. end;
  480. pinlininginfo = ^tinlininginfo;
  481. { kinds of synthetic procdefs that can be generated }
  482. tsynthetickind = (
  483. tsk_none,
  484. tsk_anon_inherited, // anonymous inherited call
  485. tsk_jvm_clone, // Java-style clone method
  486. tsk_record_deepcopy, // deepcopy for records field by field
  487. tsk_record_initialize, // initialize for records field by field (explicit rather than via rtti)
  488. tsk_empty, // an empty routine
  489. tsk_tcinit, // initialisation of typed constants
  490. tsk_callthrough, // call through to another routine with the same parameters/return type (its def is stored in the skpara field)
  491. tsk_callthrough_nonabstract,// call through to another routine if the current class not abstract (otherwise do the same as tsk_empty)
  492. tsk_jvm_enum_values, // Java "values" class method of JLEnum descendants
  493. tsk_jvm_enum_valueof, // Java "valueOf" class method of JLEnum descendants
  494. tsk_jvm_enum_classconstr, // Java class constructor for JLEnum descendants
  495. tsk_jvm_enum_jumps_constr, // Java constructor for JLEnum descendants for enums with jumps
  496. tsk_jvm_enum_fpcordinal, // Java FPCOrdinal function that returns the enum's ordinal value from an FPC POV
  497. tsk_jvm_enum_fpcvalueof, // Java FPCValueOf function that returns the enum instance corresponding to an ordinal from an FPC POV
  498. tsk_jvm_enum_long2set, // Java fpcLongToEnumSet function that returns an enumset corresponding to a bit pattern in a jlong
  499. tsk_jvm_enum_bitset2set, // Java fpcBitSetToEnumSet function that returns an enumset corresponding to a BitSet
  500. tsk_jvm_enum_set2Set, // Java fpcEnumSetToEnumSet function that returns an enumset corresponding to another enumset (different enum kind)
  501. tsk_jvm_procvar_invoke, // Java invoke method that calls a wrapped procvar
  502. tsk_jvm_procvar_intconstr, // Java procvar class constructor that accepts an interface instance for easy Java interoperation
  503. tsk_jvm_virtual_clmethod, // Java wrapper for virtual class method
  504. tsk_field_getter, // getter for a field (callthrough property is passed in skpara)
  505. tsk_field_setter // Setter for a field (callthrough property is passed in skpara)
  506. );
  507. {$ifdef oldregvars}
  508. { register variables }
  509. pregvarinfo = ^tregvarinfo;
  510. tregvarinfo = record
  511. regvars : array[1..maxvarregs] of tsym;
  512. regvars_para : array[1..maxvarregs] of boolean;
  513. regvars_refs : array[1..maxvarregs] of longint;
  514. fpuregvars : array[1..maxfpuvarregs] of tsym;
  515. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  516. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  517. end;
  518. {$endif oldregvars}
  519. { tprocdef }
  520. tprocdef = class(tabstractprocdef)
  521. private
  522. {$ifdef symansistr}
  523. _mangledname : ansistring;
  524. {$else symansistr}
  525. _mangledname : pshortstring;
  526. {$endif}
  527. public
  528. messageinf : tmessageinf;
  529. dispid : longint;
  530. {$ifndef EXTDEBUG}
  531. { where is this function defined and what were the symbol
  532. flags, needed here because there
  533. is only one symbol for all overloaded functions
  534. EXTDEBUG has fileinfo in tdef (PFV) }
  535. fileinfo : tfileposinfo;
  536. {$endif}
  537. symoptions : tsymoptions;
  538. deprecatedmsg : pshortstring;
  539. { symbol owning this definition }
  540. procsym : tsym;
  541. procsymderef : tderef;
  542. { alias names }
  543. aliasnames : TCmdStrList;
  544. { symtables }
  545. localst : TSymtable;
  546. funcretsym : tsym;
  547. funcretsymderef : tderef;
  548. struct : tabstractrecorddef;
  549. structderef : tderef;
  550. {$if defined(powerpc) or defined(m68k)}
  551. { library symbol for AmigaOS/MorphOS }
  552. libsym : tsym;
  553. libsymderef : tderef;
  554. {$endif powerpc or m68k}
  555. { name of the result variable to insert in the localsymtable }
  556. resultname : pshortstring;
  557. { import info }
  558. import_dll,
  559. import_name : pshortstring;
  560. { info for inlining the subroutine, if this pointer is nil,
  561. the procedure can't be inlined }
  562. inlininginfo : pinlininginfo;
  563. {$ifdef jvm}
  564. { generated assembler code; used by JVM backend so it can afterwards
  565. easily write out all methods grouped per class }
  566. exprasmlist : TAsmList;
  567. {$endif jvm}
  568. { temporary reference to structure containing copies of all local
  569. variables and parameters accessed by nested routines; reference to
  570. this structure is passed as "parent frame pointer" on targets that
  571. lack this concept (at least JVM and LLVM); no need to save to/
  572. restore from ppu, since nested routines are always in the same
  573. unit (no need to save to ppu) }
  574. parentfpstruct: tsym;
  575. { pointer to parentfpstruct's type (not yet valid during parsing, so
  576. cannot be used for $parentfp parameter) (no need to save to ppu) }
  577. parentfpstructptrtype: tdef;
  578. { code to copy the parameters accessed from nested routines into the
  579. parentfpstruct (no need to save to ppu) }
  580. parentfpinitblock: tnode;
  581. {$ifdef oldregvars}
  582. regvarinfo: pregvarinfo;
  583. {$endif oldregvars}
  584. { interrupt vector }
  585. interruptvector : longint;
  586. { First/last assembler symbol/instruction in aasmoutput list.
  587. Note: initialised after compiling the code for the procdef, but
  588. not saved to/restored from ppu. Used when inserting debug info }
  589. procstarttai,
  590. procendtai : tai;
  591. import_nr : word;
  592. extnumber : word;
  593. {$ifdef i386}
  594. fpu_used : byte;
  595. {$endif i386}
  596. {$ifdef mips}
  597. { needed for stabs debugging }
  598. total_local_size : longint;
  599. {$endif mips}
  600. visibility : tvisibility;
  601. { set to a value different from tsk_none in case this procdef is for
  602. a routine that has to be internally generated by the compiler }
  603. synthetickind : tsynthetickind;
  604. { optional parameter for the synthetic routine generation logic }
  605. skpara: pointer;
  606. { true, if the procedure is only declared
  607. (forward procedure) }
  608. forwarddef,
  609. { true if the procedure is declared in the interface }
  610. interfacedef : boolean;
  611. { true if the procedure has a forward declaration }
  612. hasforward : boolean;
  613. constructor create(level:byte);
  614. constructor ppuload(ppufile:tcompilerppufile);
  615. destructor destroy;override;
  616. procedure ppuwrite(ppufile:tcompilerppufile);override;
  617. procedure buildderef;override;
  618. procedure buildderefimpl;override;
  619. procedure deref;override;
  620. procedure derefimpl;override;
  621. function GetSymtable(t:tGetSymtable):TSymtable;override;
  622. { warnings:
  623. * the symtablestack top has to be the symtable to which the copy
  624. should be added
  625. * getcopy does not create a finished/ready-to-use procdef; it
  626. needs to be finalised afterwards by calling
  627. symcreat.finish_copied_procdef() afterwards
  628. }
  629. function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef; override;
  630. function getcopy: tstoreddef; override;
  631. function GetTypeName : string;override;
  632. function mangledname : TSymStr;
  633. procedure setmangledname(const s : TSymStr);
  634. function fullprocname(showhidden:boolean):string;
  635. function customprocname(pno: tprocnameoptions):ansistring;
  636. function defaultmangledname: TSymStr;
  637. function cplusplusmangledname : TSymStr;
  638. function objcmangledname : TSymStr;
  639. {$ifdef jvm}
  640. function jvmmangledbasename(signature: boolean): TSymStr;
  641. {$endif}
  642. function is_methodpointer:boolean;override;
  643. function is_addressonly:boolean;override;
  644. procedure make_external;
  645. end;
  646. { single linked list of overloaded procs }
  647. pprocdeflist = ^tprocdeflist;
  648. tprocdeflist = record
  649. def : tprocdef;
  650. defderef : tderef;
  651. next : pprocdeflist;
  652. end;
  653. tstringdef = class(tstoreddef)
  654. encoding : tstringencoding;
  655. stringtype : tstringtype;
  656. len : asizeint;
  657. constructor createshort(l : byte);
  658. constructor loadshort(ppufile:tcompilerppufile);
  659. constructor createlong(l : asizeint);
  660. constructor loadlong(ppufile:tcompilerppufile);
  661. constructor createansi(aencoding:tstringencoding);
  662. constructor loadansi(ppufile:tcompilerppufile);
  663. constructor createwide;
  664. constructor loadwide(ppufile:tcompilerppufile);
  665. constructor createunicode;
  666. constructor loadunicode(ppufile:tcompilerppufile);
  667. function getcopy : tstoreddef;override;
  668. function stringtypname:string;
  669. procedure ppuwrite(ppufile:tcompilerppufile);override;
  670. function GetTypeName:string;override;
  671. function getmangledparaname:TSymStr;override;
  672. function is_publishable : boolean;override;
  673. function alignment : shortint;override;
  674. function needs_inittable : boolean;override;
  675. function getvardef:longint;override;
  676. function is_related(d : tdef) : boolean;override;
  677. end;
  678. { tenumdef }
  679. tenumdef = class(tstoreddef)
  680. minval,
  681. maxval : asizeint;
  682. basedef : tenumdef;
  683. basedefderef : tderef;
  684. symtable : TSymtable;
  685. {$ifdef jvm}
  686. { class representing this enum on the Java side }
  687. classdef : tobjectdef;
  688. classdefderef : tderef;
  689. {$endif}
  690. has_jumps : boolean;
  691. constructor create;
  692. constructor create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  693. constructor ppuload(ppufile:tcompilerppufile);
  694. destructor destroy;override;
  695. function getcopy : tstoreddef;override;
  696. procedure ppuwrite(ppufile:tcompilerppufile);override;
  697. procedure buildderef;override;
  698. procedure deref;override;
  699. function GetTypeName:string;override;
  700. function is_publishable : boolean;override;
  701. procedure calcsavesize;
  702. function packedbitsize: asizeint; override;
  703. procedure setmax(_max:asizeint);
  704. procedure setmin(_min:asizeint);
  705. function min:asizeint;
  706. function max:asizeint;
  707. function getfirstsym:tsym;
  708. function int2enumsym(l: asizeint): tsym;
  709. { returns basedef if assigned, otherwise self }
  710. function getbasedef: tenumdef;
  711. end;
  712. tsetdef = class(tstoreddef)
  713. elementdef : tdef;
  714. elementdefderef : tderef;
  715. setbase,
  716. setmax : aword;
  717. constructor create(def:tdef;low, high : asizeint);
  718. constructor ppuload(ppufile:tcompilerppufile);
  719. function getcopy : tstoreddef;override;
  720. procedure ppuwrite(ppufile:tcompilerppufile);override;
  721. procedure buildderef;override;
  722. procedure deref;override;
  723. function GetTypeName:string;override;
  724. function is_publishable : boolean;override;
  725. end;
  726. tdefawaresymtablestack = class(TSymtablestack)
  727. private
  728. procedure addhelpers(st: TSymtable);
  729. procedure removehelpers(st: TSymtable);
  730. public
  731. procedure push(st: TSymtable); override;
  732. procedure pop(st: TSymtable); override;
  733. end;
  734. var
  735. current_structdef: tabstractrecorddef; { used for private functions check !! }
  736. current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class }
  737. current_specializedef: tstoreddef; { used to implement usage of generic class in itself }
  738. { default types }
  739. generrordef, { error in definition }
  740. voidpointertype, { pointer for Void-pointeddef }
  741. charpointertype, { pointer for Char-pointeddef }
  742. widecharpointertype, { pointer for WideChar-pointeddef }
  743. voidfarpointertype,
  744. cundefinedtype,
  745. cformaltype, { unique formal definition }
  746. ctypedformaltype, { unique typed formal definition }
  747. voidtype, { Void (procedure) }
  748. cansichartype, { Char }
  749. cwidechartype, { WideChar }
  750. pasbool8type, { boolean type }
  751. pasbool16type,
  752. pasbool32type,
  753. pasbool64type,
  754. bool8type,
  755. bool16type,
  756. bool32type,
  757. bool64type, { implement me }
  758. u8inttype, { 8-Bit unsigned integer }
  759. s8inttype, { 8-Bit signed integer }
  760. u16inttype, { 16-Bit unsigned integer }
  761. s16inttype, { 16-Bit signed integer }
  762. u32inttype, { 32-Bit unsigned integer }
  763. s32inttype, { 32-Bit signed integer }
  764. u64inttype, { 64-bit unsigned integer }
  765. s64inttype, { 64-bit signed integer }
  766. s32floattype, { 32 bit floating point number }
  767. s64floattype, { 64 bit floating point number }
  768. s80floattype, { 80 bit floating point number }
  769. sc80floattype, { 80 bit floating point number but stored like in C }
  770. s64currencytype, { pointer to a currency type }
  771. cshortstringtype, { pointer to type of short string const }
  772. clongstringtype, { pointer to type of long string const }
  773. cansistringtype, { pointer to type of ansi string const }
  774. cwidestringtype, { pointer to type of wide string const }
  775. cunicodestringtype,
  776. openshortstringtype, { pointer to type of an open shortstring,
  777. needed for readln() }
  778. openchararraytype, { pointer to type of an open array of char,
  779. needed for readln() }
  780. cfiletype, { get the same definition for all file }
  781. { used for stabs }
  782. methodpointertype, { typecasting of methodpointers to extract self }
  783. hresultdef,
  784. { we use only one variant def for every variant class }
  785. cvarianttype,
  786. colevarianttype,
  787. { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
  788. sinttype,
  789. uinttype,
  790. { integer types corresponding to OS_SINT/OS_INT }
  791. ossinttype,
  792. osuinttype,
  793. { unsigned and signed ord type with the same size as a pointer }
  794. ptruinttype,
  795. ptrsinttype,
  796. { several types to simulate more or less C++ objects for GDB }
  797. vmttype,
  798. vmtarraytype,
  799. pvmttype : tdef; { type of classrefs, used for stabs }
  800. { pointer to the anchestor of all classes }
  801. class_tobject : tobjectdef;
  802. { pointer to the ancestor of all COM interfaces }
  803. interface_iunknown : tobjectdef;
  804. { pointer to the ancestor of all dispinterfaces }
  805. interface_idispatch : tobjectdef;
  806. { pointer to the TGUID type
  807. of all interfaces }
  808. rec_tguid : trecorddef;
  809. { pointer to jump buffer }
  810. rec_jmp_buf : trecorddef;
  811. { Objective-C base types }
  812. objc_metaclasstype,
  813. objc_superclasstype,
  814. objc_idtype,
  815. objc_seltype : tpointerdef;
  816. objc_objecttype : trecorddef;
  817. { base type of @protocol(protocolname) Objective-C statements }
  818. objc_protocoltype : tobjectdef;
  819. { helper types for for-in "fast enumeration" support in Objective-C 2.0 }
  820. objc_fastenumeration : tobjectdef;
  821. objc_fastenumerationstate : trecorddef;
  822. { Java base types }
  823. { java.lang.Object }
  824. java_jlobject : tobjectdef;
  825. { java.lang.Throwable }
  826. java_jlthrowable : tobjectdef;
  827. { FPC base type for records }
  828. java_fpcbaserecordtype : tobjectdef;
  829. { java.lang.String }
  830. java_jlstring : tobjectdef;
  831. { java.lang.Enum }
  832. java_jlenum : tobjectdef;
  833. { java.util.EnumSet }
  834. java_juenumset : tobjectdef;
  835. { java.util.BitSet }
  836. java_jubitset : tobjectdef;
  837. { FPC java implementation of ansistrings }
  838. java_ansistring : tobjectdef;
  839. { FPC java implementation of shortstrings }
  840. java_shortstring : tobjectdef;
  841. { FPC java procvar base class }
  842. java_procvarbase : tobjectdef;
  843. const
  844. {$ifdef i386}
  845. pbestrealtype : ^tdef = @s80floattype;
  846. {$endif}
  847. {$ifdef x86_64}
  848. pbestrealtype : ^tdef = @s80floattype;
  849. {$endif}
  850. {$ifdef m68k}
  851. pbestrealtype : ^tdef = @s64floattype;
  852. {$endif}
  853. {$ifdef alpha}
  854. pbestrealtype : ^tdef = @s64floattype;
  855. {$endif}
  856. {$ifdef powerpc}
  857. pbestrealtype : ^tdef = @s64floattype;
  858. {$endif}
  859. {$ifdef POWERPC64}
  860. pbestrealtype : ^tdef = @s64floattype;
  861. {$endif}
  862. {$ifdef ia64}
  863. pbestrealtype : ^tdef = @s64floattype;
  864. {$endif}
  865. {$ifdef SPARC}
  866. pbestrealtype : ^tdef = @s64floattype;
  867. {$endif SPARC}
  868. {$ifdef vis}
  869. pbestrealtype : ^tdef = @s64floattype;
  870. {$endif vis}
  871. {$ifdef ARM}
  872. pbestrealtype : ^tdef = @s64floattype;
  873. {$endif ARM}
  874. {$ifdef MIPS}
  875. pbestrealtype : ^tdef = @s64floattype;
  876. {$endif MIPS}
  877. {$ifdef AVR}
  878. pbestrealtype : ^tdef = @s64floattype;
  879. {$endif AVR}
  880. {$ifdef JVM}
  881. pbestrealtype : ^tdef = @s64floattype;
  882. {$endif JVM}
  883. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  884. function make_dllmangledname(const dllname,importname:TSymStr;
  885. import_nr : word; pco : tproccalloption):TSymStr;
  886. { should be in the types unit, but the types unit uses the node stuff :( }
  887. function is_interfacecom(def: tdef): boolean;
  888. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  889. function is_any_interface_kind(def: tdef): boolean;
  890. function is_interfacecorba(def: tdef): boolean;
  891. function is_interface(def: tdef): boolean;
  892. function is_dispinterface(def: tdef): boolean;
  893. function is_object(def: tdef): boolean;
  894. function is_class(def: tdef): boolean;
  895. function is_cppclass(def: tdef): boolean;
  896. function is_objectpascal_helper(def: tdef): boolean;
  897. function is_objcclass(def: tdef): boolean;
  898. function is_objcclassref(def: tdef): boolean;
  899. function is_objcprotocol(def: tdef): boolean;
  900. function is_objccategory(def: tdef): boolean;
  901. function is_objc_class_or_protocol(def: tdef): boolean;
  902. function is_objc_protocol_or_category(def: tdef): boolean;
  903. function is_classhelper(def: tdef): boolean;
  904. function is_class_or_interface(def: tdef): boolean;
  905. function is_class_or_interface_or_objc(def: tdef): boolean;
  906. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  907. function is_class_or_interface_or_dispinterface_or_objc_or_java(def: tdef): boolean;
  908. function is_class_or_interface_or_object(def: tdef): boolean;
  909. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  910. function is_implicit_pointer_object_type(def: tdef): boolean;
  911. function is_class_or_object(def: tdef): boolean;
  912. function is_record(def: tdef): boolean;
  913. function is_javaclass(def: tdef): boolean;
  914. function is_javaclassref(def: tdef): boolean;
  915. function is_javainterface(def: tdef): boolean;
  916. function is_java_class_or_interface(def: tdef): boolean;
  917. procedure loadobjctypes;
  918. procedure maybeloadcocoatypes;
  919. function use_vectorfpu(def : tdef) : boolean;
  920. { returns a pointerdef for def, reusing an existing one in case it exists
  921. in the current module }
  922. function getpointerdef(def: tdef): tpointerdef;
  923. { returns an arraydef for an array containing a single array of def, resuing
  924. an existing one in case it exists in the current module }
  925. function getsingletonarraydef(def: tdef): tarraydef;
  926. function getarraydef(def: tdef; elecount: asizeint): tarraydef;
  927. function getansistringcodepage:tstringencoding; inline;
  928. function getansistringdef:tstringdef;
  929. function getparaencoding(def:tdef):tstringencoding; inline;
  930. implementation
  931. uses
  932. SysUtils,
  933. cutils,
  934. { global }
  935. verbose,
  936. { target }
  937. systems,aasmcpu,paramgr,
  938. { symtable }
  939. symsym,symtable,symutil,defutil,objcdef,
  940. {$ifdef jvm}
  941. jvmdef,
  942. {$endif}
  943. { module }
  944. fmodule,
  945. { other }
  946. gendef,
  947. fpccrc
  948. ;
  949. {****************************************************************************
  950. Helpers
  951. ****************************************************************************}
  952. function getansistringcodepage:tstringencoding; inline;
  953. begin
  954. if cs_explicit_codepage in current_settings.moduleswitches then
  955. result:=current_settings.sourcecodepage
  956. else
  957. result:=0;
  958. end;
  959. function getansistringdef:tstringdef;
  960. var
  961. symtable:tsymtable;
  962. begin
  963. { if codepage is explicitly defined in this mudule we need to return
  964. a replacement for ansistring def }
  965. if cs_explicit_codepage in current_settings.moduleswitches then
  966. begin
  967. if not assigned(current_module) then
  968. internalerror(2011101301);
  969. { codepage can be redeclared only once per unit so we don't need a list of
  970. redefined ansistring but only one pointer }
  971. if not assigned(current_module.ansistrdef) then
  972. begin
  973. { if we did not create it yet we need to do this now }
  974. if current_module.is_unit then
  975. symtable:=current_module.globalsymtable
  976. else
  977. symtable:=current_module.localsymtable;
  978. symtablestack.push(symtable);
  979. current_module.ansistrdef:=tstringdef.createansi(current_settings.sourcecodepage);
  980. symtablestack.pop(symtable);
  981. end;
  982. result:=tstringdef(current_module.ansistrdef);
  983. end
  984. else
  985. result:=tstringdef(cansistringtype);
  986. end;
  987. function getparaencoding(def:tdef):tstringencoding; inline;
  988. begin
  989. { don't pass CP_NONE encoding to internal functions
  990. they expect 0 encoding instead }
  991. result:=tstringdef(def).encoding;
  992. if result=CP_NONE then
  993. result:=0
  994. end;
  995. function make_mangledname(const typeprefix:TSymStr;st:TSymtable;const suffix:TSymStr):TSymStr;
  996. var
  997. s,hs,
  998. prefix : TSymStr;
  999. oldlen,
  1000. newlen,
  1001. i : longint;
  1002. crc : dword;
  1003. hp : tparavarsym;
  1004. begin
  1005. prefix:='';
  1006. if not assigned(st) then
  1007. internalerror(200204212);
  1008. { sub procedures }
  1009. while (st.symtabletype=localsymtable) do
  1010. begin
  1011. if st.defowner.typ<>procdef then
  1012. internalerror(200204173);
  1013. { Add the full mangledname of procedure to prevent
  1014. conflicts with 2 overloads having both a nested procedure
  1015. with the same name, see tb0314 (PFV) }
  1016. s:=tprocdef(st.defowner).procsym.name;
  1017. oldlen:=length(s);
  1018. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  1019. begin
  1020. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  1021. if not(vo_is_hidden_para in hp.varoptions) then
  1022. s:=s+'$'+hp.vardef.mangledparaname;
  1023. end;
  1024. if not is_void(tprocdef(st.defowner).returndef) then
  1025. s:=s+'$$'+tprocdef(st.defowner).returndef.mangledparaname;
  1026. newlen:=length(s);
  1027. { Replace with CRC if the parameter line is very long }
  1028. if (newlen-oldlen>12) and
  1029. ((newlen+length(prefix)>100) or (newlen-oldlen>32)) then
  1030. begin
  1031. crc:=0;
  1032. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  1033. begin
  1034. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  1035. if not(vo_is_hidden_para in hp.varoptions) then
  1036. begin
  1037. hs:=hp.vardef.mangledparaname;
  1038. crc:=UpdateCrc32(crc,hs[1],length(hs));
  1039. end;
  1040. end;
  1041. hs:=hp.vardef.mangledparaname;
  1042. crc:=UpdateCrc32(crc,hs[1],length(hs));
  1043. s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
  1044. end;
  1045. if prefix<>'' then
  1046. prefix:=s+'_'+prefix
  1047. else
  1048. prefix:=s;
  1049. if length(prefix)>100 then
  1050. begin
  1051. crc:=0;
  1052. crc:=UpdateCrc32(crc,prefix[1],length(prefix));
  1053. prefix:='$CRC'+hexstr(crc,8);
  1054. end;
  1055. st:=st.defowner.owner;
  1056. end;
  1057. { object/classes symtable, nested type definitions in classes require the while loop }
  1058. while st.symtabletype in [ObjectSymtable,recordsymtable] do
  1059. begin
  1060. if not (st.defowner.typ in [objectdef,recorddef]) then
  1061. internalerror(200204174);
  1062. prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix;
  1063. st:=st.defowner.owner;
  1064. end;
  1065. { symtable must now be static or global }
  1066. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  1067. internalerror(200204175);
  1068. { The mangled name is made out of at most 4 parts:
  1069. 1) Optional typeprefix given as first parameter
  1070. with '_$' appended if not empty
  1071. 2) Unit name or 'P$'+program name (never empty)
  1072. 3) optional prefix variable that contains a unique
  1073. name for the local symbol table (prepended with '$_$'
  1074. if not empty)
  1075. 4) suffix as given as third parameter,
  1076. also optional (i.e. can be empty)
  1077. prepended by '_$$_' if not empty }
  1078. result:='';
  1079. if typeprefix<>'' then
  1080. result:=result+typeprefix+'_$';
  1081. { Add P$ for program, which can have the same name as
  1082. a unit }
  1083. if (TSymtable(main_module.localsymtable)=st) and
  1084. (not main_module.is_unit) then
  1085. result:=result+'P$'+st.name^
  1086. else
  1087. result:=result+st.name^;
  1088. if prefix<>'' then
  1089. result:=result+'$_$'+prefix;
  1090. if suffix<>'' then
  1091. result:=result+'_$$_'+suffix;
  1092. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  1093. { Further, the Mac OS X 10.5 linker does not consider symbols which do not }
  1094. { start with '_' as regular symbols (it does not generate N_GSYM entries }
  1095. { those in the debug map, leading to troubles with dsymutil). So always }
  1096. { add an underscore on darwin. }
  1097. if (target_info.system in systems_darwin) then
  1098. result := '_' + result;
  1099. end;
  1100. function make_dllmangledname(const dllname,importname:TSymStr;import_nr : word; pco : tproccalloption):TSymStr;
  1101. var
  1102. crc : cardinal;
  1103. i : longint;
  1104. use_crc : boolean;
  1105. dllprefix : TSymStr;
  1106. begin
  1107. if (target_info.system in (systems_all_windows + systems_nativent +
  1108. [system_i386_emx, system_i386_os2]))
  1109. and (dllname <> '') then
  1110. begin
  1111. dllprefix:=lower(ExtractFileName(dllname));
  1112. { Remove .dll suffix if present }
  1113. if copy(dllprefix,length(dllprefix)-3,length(dllprefix))='.dll' then
  1114. dllprefix:=copy(dllprefix,1,length(dllprefix)-4);
  1115. use_crc:=false;
  1116. for i:=1 to length(dllprefix) do
  1117. if not (dllprefix[i] in ['a'..'z','A'..'Z','_','0'..'9']) then
  1118. begin
  1119. use_crc:=true;
  1120. break;
  1121. end;
  1122. if use_crc then
  1123. begin
  1124. crc:=0;
  1125. crc:=UpdateCrc32(crc,dllprefix[1],length(dllprefix));
  1126. dllprefix:='_$dll$crc$'+hexstr(crc,8)+'$';
  1127. end
  1128. else
  1129. dllprefix:='_$dll$'+dllprefix+'$';
  1130. if importname<>'' then
  1131. result:=dllprefix+importname
  1132. else
  1133. result:=dllprefix+'_index_'+tostr(import_nr);
  1134. { Replace ? and @ in import name, since GNU AS does not allow these characters in symbol names. }
  1135. { This allows to import VC++ mangled names from DLLs. }
  1136. { Do not perform replacement, if external symbol is not imported from DLL. }
  1137. if (dllname<>'') then
  1138. begin
  1139. Replace(result,'?','__q$$');
  1140. {$ifdef arm}
  1141. { @ symbol is not allowed in ARM assembler only }
  1142. Replace(result,'@','__a$$');
  1143. {$endif arm}
  1144. end;
  1145. end
  1146. else
  1147. begin
  1148. if importname<>'' then
  1149. begin
  1150. if not(pco in [pocall_cdecl,pocall_cppdecl]) then
  1151. result:=importname
  1152. else
  1153. result:=target_info.Cprefix+importname;
  1154. end
  1155. else
  1156. result:='_index_'+tostr(import_nr);
  1157. end;
  1158. end;
  1159. {****************************************************************************
  1160. TDEFAWARESYMTABLESTACK
  1161. (symtablestack descendant that does some special actions on
  1162. the pushed/popped symtables)
  1163. ****************************************************************************}
  1164. procedure tdefawaresymtablestack.addhelpers(st: TSymtable);
  1165. var
  1166. i: integer;
  1167. s: string;
  1168. list: TFPObjectList;
  1169. def: tdef;
  1170. begin
  1171. { search the symtable from first to last; the helper to use will be the
  1172. last one in the list }
  1173. for i:=0 to st.symlist.count-1 do
  1174. begin
  1175. if not (st.symlist[i] is ttypesym) then
  1176. continue;
  1177. def:=ttypesym(st.SymList[i]).typedef;
  1178. if is_objectpascal_helper(def) and
  1179. (tobjectdef(def).extendeddef.typ in [recorddef,objectdef]) then
  1180. begin
  1181. s:=make_mangledname('',tabstractrecorddef(tobjectdef(def).extendeddef).symtable,'');
  1182. list:=TFPObjectList(current_module.extendeddefs.Find(s));
  1183. if not assigned(list) then
  1184. begin
  1185. list:=TFPObjectList.Create(false);
  1186. current_module.extendeddefs.Add(s,list);
  1187. end;
  1188. list.Add(def);
  1189. end
  1190. else
  1191. { add nested helpers as well }
  1192. if def.typ in [recorddef,objectdef] then
  1193. addhelpers(tabstractrecorddef(def).symtable);
  1194. end;
  1195. end;
  1196. procedure tdefawaresymtablestack.removehelpers(st: TSymtable);
  1197. var
  1198. i, j: integer;
  1199. tmpst: TSymtable;
  1200. list: TFPObjectList;
  1201. begin
  1202. for i:=current_module.extendeddefs.count-1 downto 0 do
  1203. begin
  1204. list:=TFPObjectList(current_module.extendeddefs[i]);
  1205. for j:=list.count-1 downto 0 do
  1206. begin
  1207. if not (list[j] is tobjectdef) then
  1208. Internalerror(2011031501);
  1209. tmpst:=tobjectdef(list[j]).owner;
  1210. repeat
  1211. if tmpst=st then
  1212. begin
  1213. list.delete(j);
  1214. break;
  1215. end
  1216. else
  1217. begin
  1218. if assigned(tmpst.defowner) then
  1219. tmpst:=tmpst.defowner.owner
  1220. else
  1221. tmpst:=nil;
  1222. end;
  1223. until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]);
  1224. end;
  1225. if list.count=0 then
  1226. current_module.extendeddefs.delete(i);
  1227. end;
  1228. end;
  1229. procedure tdefawaresymtablestack.push(st: TSymtable);
  1230. begin
  1231. { nested helpers will be added as well }
  1232. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1233. (sto_has_helper in st.tableoptions) then
  1234. addhelpers(st);
  1235. inherited push(st);
  1236. end;
  1237. procedure tdefawaresymtablestack.pop(st: TSymtable);
  1238. begin
  1239. inherited pop(st);
  1240. { nested helpers will be removed as well }
  1241. if (st.symtabletype in [globalsymtable,staticsymtable]) and
  1242. (sto_has_helper in st.tableoptions) then
  1243. removehelpers(st);
  1244. end;
  1245. {****************************************************************************
  1246. TDEF (base class for definitions)
  1247. ****************************************************************************}
  1248. constructor tstoreddef.create(dt:tdeftyp);
  1249. var
  1250. insertstack : psymtablestackitem;
  1251. begin
  1252. inherited create(dt);
  1253. savesize := 0;
  1254. {$ifdef EXTDEBUG}
  1255. fileinfo := current_filepos;
  1256. {$endif}
  1257. generictokenbuf:=nil;
  1258. genericdef:=nil;
  1259. { Don't register forwarddefs, they are disposed at the
  1260. end of an type block }
  1261. if (dt=forwarddef) then
  1262. exit;
  1263. { Register in current_module }
  1264. if assigned(current_module) then
  1265. begin
  1266. current_module.deflist.Add(self);
  1267. DefId:=current_module.deflist.Count-1;
  1268. end;
  1269. { Register in symtable stack }
  1270. if assigned(symtablestack) then
  1271. begin
  1272. insertstack:=symtablestack.stack;
  1273. while assigned(insertstack) and
  1274. (insertstack^.symtable.symtabletype=withsymtable) do
  1275. insertstack:=insertstack^.next;
  1276. if not assigned(insertstack) then
  1277. internalerror(200602044);
  1278. insertstack^.symtable.insertdef(self);
  1279. end;
  1280. end;
  1281. destructor tstoreddef.destroy;
  1282. begin
  1283. { Direct calls are not allowed, use symtable.deletedef() }
  1284. if assigned(owner) then
  1285. internalerror(200612311);
  1286. if assigned(generictokenbuf) then
  1287. begin
  1288. generictokenbuf.free;
  1289. generictokenbuf:=nil;
  1290. end;
  1291. inherited destroy;
  1292. end;
  1293. constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1294. var
  1295. sizeleft,i : longint;
  1296. buf : array[0..255] of byte;
  1297. begin
  1298. inherited create(dt);
  1299. DefId:=ppufile.getlongint;
  1300. current_module.deflist[DefId]:=self;
  1301. {$ifdef EXTDEBUG}
  1302. fillchar(fileinfo,sizeof(fileinfo),0);
  1303. {$endif}
  1304. { load }
  1305. ppufile.getderef(typesymderef);
  1306. ppufile.getsmallset(defoptions);
  1307. ppufile.getsmallset(defstates);
  1308. if df_generic in defoptions then
  1309. begin
  1310. sizeleft:=ppufile.getlongint;
  1311. initgeneric;
  1312. while sizeleft>0 do
  1313. begin
  1314. if sizeleft>sizeof(buf) then
  1315. i:=sizeof(buf)
  1316. else
  1317. i:=sizeleft;
  1318. ppufile.getdata(buf,i);
  1319. generictokenbuf.write(buf,i);
  1320. dec(sizeleft,i);
  1321. end;
  1322. end;
  1323. if df_specialization in defoptions then
  1324. ppufile.getderef(genericdefderef);
  1325. end;
  1326. function tstoreddef.needs_separate_initrtti:boolean;
  1327. begin
  1328. result:=false;
  1329. end;
  1330. function Tstoreddef.rtti_mangledname(rt:trttitype):string;
  1331. var
  1332. prefix : string[4];
  1333. begin
  1334. if (rt=fullrtti) or (not needs_separate_initrtti) then
  1335. begin
  1336. prefix:='RTTI';
  1337. include(defstates,ds_rtti_table_used);
  1338. end
  1339. else
  1340. begin
  1341. prefix:='INIT';
  1342. include(defstates,ds_init_table_used);
  1343. end;
  1344. if assigned(typesym) and
  1345. (owner.symtabletype in [staticsymtable,globalsymtable]) then
  1346. result:=make_mangledname(prefix,owner,typesym.name)
  1347. else
  1348. result:=make_mangledname(prefix,findunitsymtable(owner),'DEF'+tostr(DefId))
  1349. end;
  1350. function tstoreddef.OwnerHierarchyName: string;
  1351. var
  1352. tmp: tdef;
  1353. begin
  1354. tmp:=self;
  1355. result:='';
  1356. repeat
  1357. { can be not assigned in case of a forwarddef }
  1358. if assigned(tmp.owner) and
  1359. (tmp.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
  1360. tmp:=tdef(tmp.owner.defowner)
  1361. else
  1362. break;
  1363. result:=tabstractrecorddef(tmp).objrealname^+'.'+result;
  1364. until tmp=nil;
  1365. end;
  1366. function tstoreddef.in_currentunit: boolean;
  1367. var
  1368. st: tsymtable;
  1369. begin
  1370. st:=owner;
  1371. while not(st.symtabletype in [globalsymtable,staticsymtable]) do
  1372. st:=st.defowner.owner;
  1373. result:=st.iscurrentunit;
  1374. end;
  1375. function tstoreddef.getcopy : tstoreddef;
  1376. begin
  1377. Message(sym_e_cant_create_unique_type);
  1378. getcopy:=terrordef.create;
  1379. end;
  1380. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  1381. var
  1382. sizeleft,i : longint;
  1383. buf : array[0..255] of byte;
  1384. oldintfcrc : boolean;
  1385. begin
  1386. ppufile.putlongint(DefId);
  1387. ppufile.putderef(typesymderef);
  1388. ppufile.putsmallset(defoptions);
  1389. oldintfcrc:=ppufile.do_crc;
  1390. ppufile.do_crc:=false;
  1391. ppufile.putsmallset(defstates);
  1392. if df_generic in defoptions then
  1393. begin
  1394. if assigned(generictokenbuf) then
  1395. begin
  1396. sizeleft:=generictokenbuf.size;
  1397. generictokenbuf.seek(0);
  1398. end
  1399. else
  1400. sizeleft:=0;
  1401. ppufile.putlongint(sizeleft);
  1402. while sizeleft>0 do
  1403. begin
  1404. if sizeleft>sizeof(buf) then
  1405. i:=sizeof(buf)
  1406. else
  1407. i:=sizeleft;
  1408. generictokenbuf.read(buf,i);
  1409. ppufile.putdata(buf,i);
  1410. dec(sizeleft,i);
  1411. end;
  1412. end;
  1413. ppufile.do_crc:=oldintfcrc;
  1414. if df_specialization in defoptions then
  1415. ppufile.putderef(genericdefderef);
  1416. end;
  1417. procedure tstoreddef.buildderef;
  1418. begin
  1419. typesymderef.build(typesym);
  1420. genericdefderef.build(genericdef);
  1421. end;
  1422. procedure tstoreddef.buildderefimpl;
  1423. begin
  1424. end;
  1425. procedure tstoreddef.deref;
  1426. begin
  1427. typesym:=ttypesym(typesymderef.resolve);
  1428. if df_specialization in defoptions then
  1429. genericdef:=tstoreddef(genericdefderef.resolve);
  1430. end;
  1431. procedure tstoreddef.derefimpl;
  1432. begin
  1433. end;
  1434. function tstoreddef.size : asizeint;
  1435. begin
  1436. size:=savesize;
  1437. end;
  1438. function tstoreddef.getvardef:longint;
  1439. begin
  1440. result:=varUndefined;
  1441. end;
  1442. function tstoreddef.alignment : shortint;
  1443. begin
  1444. { natural alignment by default }
  1445. alignment:=size_2_align(savesize);
  1446. { can happen if savesize = 0, e.g. for voiddef or
  1447. an empty record
  1448. }
  1449. if (alignment=0) then
  1450. alignment:=1;
  1451. end;
  1452. { returns true, if the definition can be published }
  1453. function tstoreddef.is_publishable : boolean;
  1454. begin
  1455. is_publishable:=false;
  1456. end;
  1457. { needs an init table }
  1458. function tstoreddef.needs_inittable : boolean;
  1459. begin
  1460. needs_inittable:=false;
  1461. end;
  1462. function tstoreddef.is_intregable : boolean;
  1463. var
  1464. recsize,temp: longint;
  1465. begin
  1466. is_intregable:=false;
  1467. case typ of
  1468. orddef,
  1469. pointerdef,
  1470. enumdef,
  1471. classrefdef:
  1472. is_intregable:=true;
  1473. procvardef :
  1474. is_intregable:=tprocvardef(self).is_addressonly;
  1475. objectdef:
  1476. is_intregable:=(is_implicit_pointer_object_type(self)) and not needs_inittable;
  1477. setdef:
  1478. is_intregable:=is_smallset(self);
  1479. recorddef:
  1480. begin
  1481. recsize:=size;
  1482. is_intregable:=
  1483. ispowerof2(recsize,temp) and
  1484. (recsize <= sizeof(asizeint))
  1485. and not needs_inittable;
  1486. end;
  1487. end;
  1488. end;
  1489. function tstoreddef.is_fpuregable : boolean;
  1490. begin
  1491. {$ifdef x86}
  1492. result:=use_vectorfpu(self);
  1493. {$else x86}
  1494. result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches);
  1495. {$endif x86}
  1496. end;
  1497. procedure tstoreddef.initgeneric;
  1498. begin
  1499. if assigned(generictokenbuf) then
  1500. internalerror(200512131);
  1501. generictokenbuf:=tdynamicarray.create(256);
  1502. end;
  1503. {****************************************************************************
  1504. Tstringdef
  1505. ****************************************************************************}
  1506. constructor tstringdef.createshort(l : byte);
  1507. begin
  1508. inherited create(stringdef);
  1509. stringtype:=st_shortstring;
  1510. encoding:=0;
  1511. len:=l;
  1512. savesize:=len+1;
  1513. end;
  1514. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  1515. begin
  1516. inherited ppuload(stringdef,ppufile);
  1517. stringtype:=st_shortstring;
  1518. encoding:=0;
  1519. len:=ppufile.getbyte;
  1520. savesize:=len+1;
  1521. end;
  1522. constructor tstringdef.createlong(l : asizeint);
  1523. begin
  1524. inherited create(stringdef);
  1525. stringtype:=st_longstring;
  1526. encoding:=0;
  1527. len:=l;
  1528. savesize:=sizeof(pint);
  1529. end;
  1530. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1531. begin
  1532. inherited ppuload(stringdef,ppufile);
  1533. stringtype:=st_longstring;
  1534. encoding:=0;
  1535. len:=ppufile.getasizeint;
  1536. savesize:=sizeof(pint);
  1537. end;
  1538. constructor tstringdef.createansi(aencoding:tstringencoding);
  1539. begin
  1540. inherited create(stringdef);
  1541. stringtype:=st_ansistring;
  1542. encoding:=aencoding;
  1543. len:=-1;
  1544. savesize:=sizeof(pint);
  1545. end;
  1546. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1547. begin
  1548. inherited ppuload(stringdef,ppufile);
  1549. stringtype:=st_ansistring;
  1550. len:=ppufile.getaint;
  1551. encoding:=ppufile.getword;
  1552. savesize:=sizeof(pint);
  1553. end;
  1554. constructor tstringdef.createwide;
  1555. begin
  1556. inherited create(stringdef);
  1557. stringtype:=st_widestring;
  1558. if target_info.endian=endian_little then
  1559. encoding:=CP_UTF16LE
  1560. else
  1561. encoding:=CP_UTF16BE;
  1562. len:=-1;
  1563. savesize:=sizeof(pint);
  1564. end;
  1565. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1566. begin
  1567. inherited ppuload(stringdef,ppufile);
  1568. stringtype:=st_widestring;
  1569. if target_info.endian=endian_little then
  1570. encoding:=CP_UTF16LE
  1571. else
  1572. encoding:=CP_UTF16BE;
  1573. len:=ppufile.getaint;
  1574. savesize:=sizeof(pint);
  1575. end;
  1576. constructor tstringdef.createunicode;
  1577. begin
  1578. inherited create(stringdef);
  1579. stringtype:=st_unicodestring;
  1580. if target_info.endian=endian_little then
  1581. encoding:=CP_UTF16LE
  1582. else
  1583. encoding:=CP_UTF16BE;
  1584. len:=-1;
  1585. savesize:=sizeof(pint);
  1586. end;
  1587. constructor tstringdef.loadunicode(ppufile:tcompilerppufile);
  1588. begin
  1589. inherited ppuload(stringdef,ppufile);
  1590. stringtype:=st_unicodestring;
  1591. len:=ppufile.getaint;
  1592. encoding:=ppufile.getword;
  1593. savesize:=sizeof(pint);
  1594. end;
  1595. function tstringdef.getcopy : tstoreddef;
  1596. begin
  1597. result:=tstringdef.create(typ);
  1598. result.typ:=stringdef;
  1599. tstringdef(result).stringtype:=stringtype;
  1600. tstringdef(result).encoding:=encoding;
  1601. tstringdef(result).len:=len;
  1602. tstringdef(result).savesize:=savesize;
  1603. end;
  1604. function tstringdef.stringtypname:string;
  1605. const
  1606. typname:array[tstringtype] of string[10]=(
  1607. 'shortstr','longstr','ansistr','widestr','unicodestr'
  1608. );
  1609. begin
  1610. stringtypname:=typname[stringtype];
  1611. end;
  1612. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  1613. begin
  1614. inherited ppuwrite(ppufile);
  1615. if stringtype=st_shortstring then
  1616. begin
  1617. {$ifdef extdebug}
  1618. if len > 255 then internalerror(12122002);
  1619. {$endif}
  1620. ppufile.putbyte(byte(len))
  1621. end
  1622. else
  1623. ppufile.putaint(len);
  1624. if stringtype in [st_ansistring,st_unicodestring] then
  1625. ppufile.putword(encoding);
  1626. case stringtype of
  1627. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1628. st_longstring : ppufile.writeentry(iblongstringdef);
  1629. st_ansistring : ppufile.writeentry(ibansistringdef);
  1630. st_widestring : ppufile.writeentry(ibwidestringdef);
  1631. st_unicodestring : ppufile.writeentry(ibunicodestringdef);
  1632. end;
  1633. end;
  1634. function tstringdef.needs_inittable : boolean;
  1635. begin
  1636. needs_inittable:=stringtype in [st_ansistring,st_widestring,st_unicodestring];
  1637. end;
  1638. function tstringdef.GetTypeName : string;
  1639. const
  1640. names : array[tstringtype] of string[15] = (
  1641. 'ShortString','LongString','AnsiString','WideString','UnicodeString');
  1642. begin
  1643. GetTypeName:=names[stringtype];
  1644. end;
  1645. function tstringdef.getvardef : longint;
  1646. const
  1647. vardef : array[tstringtype] of longint = (
  1648. varUndefined,varUndefined,varString,varOleStr,varUString);
  1649. begin
  1650. result:=vardef[stringtype];
  1651. end;
  1652. function tstringdef.is_related(d: tdef): boolean;
  1653. begin
  1654. result:=
  1655. (target_info.system in systems_jvm) and
  1656. (((stringtype in [st_unicodestring,st_widestring]) and
  1657. ((d=java_jlobject) or
  1658. (d=java_jlstring))) or
  1659. ((stringtype=st_ansistring) and
  1660. ((d=java_jlobject) or
  1661. (d=java_ansistring))));
  1662. end;
  1663. function tstringdef.alignment : shortint;
  1664. begin
  1665. case stringtype of
  1666. st_unicodestring,
  1667. st_widestring,
  1668. st_ansistring:
  1669. alignment:=size_2_align(savesize);
  1670. st_longstring,
  1671. st_shortstring:
  1672. { char to string accesses byte 0 and 1 with one word access }
  1673. if (tf_requires_proper_alignment in target_info.flags) or
  1674. { macpas needs an alignment of 2 (MetroWerks compatible) }
  1675. (m_mac in current_settings.modeswitches) then
  1676. alignment:=size_2_align(2)
  1677. else
  1678. alignment:=size_2_align(1);
  1679. else
  1680. internalerror(200412301);
  1681. end;
  1682. end;
  1683. function tstringdef.getmangledparaname : TSymStr;
  1684. begin
  1685. getmangledparaname:='STRING';
  1686. end;
  1687. function tstringdef.is_publishable : boolean;
  1688. begin
  1689. is_publishable:=true;
  1690. end;
  1691. {****************************************************************************
  1692. TENUMDEF
  1693. ****************************************************************************}
  1694. constructor tenumdef.create;
  1695. begin
  1696. inherited create(enumdef);
  1697. minval:=0;
  1698. maxval:=0;
  1699. calcsavesize;
  1700. has_jumps:=false;
  1701. basedef:=nil;
  1702. symtable:=tenumsymtable.create(self);
  1703. end;
  1704. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:asizeint);
  1705. begin
  1706. inherited create(enumdef);
  1707. minval:=_min;
  1708. maxval:=_max;
  1709. basedef:=_basedef;
  1710. calcsavesize;
  1711. has_jumps:=false;
  1712. symtable:=basedef.symtable.getcopy;
  1713. include(defoptions, df_copied_def);
  1714. end;
  1715. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  1716. begin
  1717. inherited ppuload(enumdef,ppufile);
  1718. minval:=ppufile.getaint;
  1719. maxval:=ppufile.getaint;
  1720. savesize:=ppufile.getaint;
  1721. has_jumps:=false;
  1722. {$ifdef jvm}
  1723. ppufile.getderef(classdefderef);
  1724. {$endif}
  1725. if df_copied_def in defoptions then
  1726. begin
  1727. symtable:=nil;
  1728. ppufile.getderef(basedefderef);
  1729. end
  1730. else
  1731. begin
  1732. // create with nil defowner first to prevent values changes on insert
  1733. symtable:=tenumsymtable.create(nil);
  1734. tenumsymtable(symtable).ppuload(ppufile);
  1735. symtable.defowner:=self;
  1736. end;
  1737. end;
  1738. destructor tenumdef.destroy;
  1739. begin
  1740. symtable.free;
  1741. symtable:=nil;
  1742. inherited destroy;
  1743. end;
  1744. function tenumdef.getcopy : tstoreddef;
  1745. begin
  1746. if assigned(basedef) then
  1747. result:=tenumdef.create_subrange(basedef,minval,maxval)
  1748. else
  1749. begin
  1750. result:=tenumdef.create;
  1751. tenumdef(result).minval:=minval;
  1752. tenumdef(result).maxval:=maxval;
  1753. tenumdef(result).symtable.free;
  1754. tenumdef(result).symtable:=symtable.getcopy;
  1755. tenumdef(result).basedef:=self;
  1756. end;
  1757. {$ifdef jvm}
  1758. tenumdef(result).classdef:=classdef;
  1759. {$endif}
  1760. tenumdef(result).has_jumps:=has_jumps;
  1761. tenumdef(result).basedefderef:=basedefderef;
  1762. include(tenumdef(result).defoptions,df_copied_def);
  1763. end;
  1764. procedure tenumdef.calcsavesize;
  1765. begin
  1766. {$IFNDEF cpu64bitaddr} {$push}{$warnings off} {$ENDIF} //comparison always false warning
  1767. if (current_settings.packenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
  1768. savesize:=8
  1769. {$IFDEF not cpu64bitaddr} {$pop} {$ENDIF}
  1770. else
  1771. if (current_settings.packenum=4) or (min<low(smallint)) or (max>high(word)) then
  1772. savesize:=4
  1773. else
  1774. if (current_settings.packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  1775. savesize:=2
  1776. else
  1777. savesize:=1;
  1778. end;
  1779. function tenumdef.packedbitsize: asizeint;
  1780. var
  1781. sizeval: tconstexprint;
  1782. power: longint;
  1783. begin
  1784. result := 0;
  1785. if (minval >= 0) and
  1786. (maxval <= 1) then
  1787. result := 1
  1788. else
  1789. begin
  1790. if (minval>=0) then
  1791. sizeval:=maxval
  1792. else
  1793. { don't count 0 twice }
  1794. sizeval:=(cutils.max(-minval,maxval)*2)-1;
  1795. { 256 must become 512 etc. }
  1796. nextpowerof2(sizeval+1,power);
  1797. result := power;
  1798. end;
  1799. end;
  1800. procedure tenumdef.setmax(_max:asizeint);
  1801. begin
  1802. maxval:=_max;
  1803. calcsavesize;
  1804. end;
  1805. procedure tenumdef.setmin(_min:asizeint);
  1806. begin
  1807. minval:=_min;
  1808. calcsavesize;
  1809. end;
  1810. function tenumdef.min:asizeint;
  1811. begin
  1812. min:=minval;
  1813. end;
  1814. function tenumdef.max:asizeint;
  1815. begin
  1816. max:=maxval;
  1817. end;
  1818. function tenumdef.getfirstsym: tsym;
  1819. var
  1820. i:integer;
  1821. begin
  1822. for i := 0 to symtable.SymList.Count - 1 do
  1823. begin
  1824. result:=tsym(symtable.SymList[i]);
  1825. if tenumsym(result).value=minval then
  1826. exit;
  1827. end;
  1828. result:=nil;
  1829. end;
  1830. function tenumdef.int2enumsym(l: asizeint): tsym;
  1831. var
  1832. i: longint;
  1833. sym: tsym;
  1834. bdef: tenumdef;
  1835. begin
  1836. result:=nil;
  1837. if (l<minval) or
  1838. (l>maxval) then
  1839. exit;
  1840. bdef:=getbasedef;
  1841. for i:=0 to bdef.symtable.symlist.count-1 do
  1842. begin
  1843. sym:=tsym(bdef.symtable.symlist[i]);
  1844. if (sym.typ=enumsym) and
  1845. (tenumsym(sym).value=l) then
  1846. begin
  1847. result:=sym;
  1848. exit;
  1849. end;
  1850. end;
  1851. end;
  1852. function tenumdef.getbasedef: tenumdef;
  1853. begin
  1854. if not assigned(basedef) then
  1855. result:=self
  1856. else
  1857. result:=basedef;
  1858. end;
  1859. procedure tenumdef.buildderef;
  1860. begin
  1861. inherited buildderef;
  1862. if df_copied_def in defoptions then
  1863. basedefderef.build(basedef)
  1864. else
  1865. tenumsymtable(symtable).buildderef;
  1866. {$ifdef jvm}
  1867. classdefderef.build(classdef);
  1868. {$endif}
  1869. end;
  1870. procedure tenumdef.deref;
  1871. begin
  1872. inherited deref;
  1873. if df_copied_def in defoptions then
  1874. begin
  1875. basedef:=tenumdef(basedefderef.resolve);
  1876. symtable:=basedef.symtable.getcopy;
  1877. end
  1878. else
  1879. tenumsymtable(symtable).deref;
  1880. {$ifdef jvm}
  1881. classdef:=tobjectdef(classdefderef.resolve);
  1882. {$endif}
  1883. end;
  1884. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  1885. begin
  1886. inherited ppuwrite(ppufile);
  1887. ppufile.putaint(min);
  1888. ppufile.putaint(max);
  1889. ppufile.putaint(savesize);
  1890. {$ifdef jvm}
  1891. ppufile.putderef(classdefderef);
  1892. {$endif}
  1893. if df_copied_def in defoptions then
  1894. ppufile.putderef(basedefderef);
  1895. ppufile.writeentry(ibenumdef);
  1896. if not (df_copied_def in defoptions) then
  1897. tenumsymtable(symtable).ppuwrite(ppufile);
  1898. end;
  1899. function tenumdef.is_publishable : boolean;
  1900. begin
  1901. is_publishable:=true;
  1902. end;
  1903. function tenumdef.GetTypeName : string;
  1904. begin
  1905. GetTypeName:='<enumeration type>';
  1906. end;
  1907. {****************************************************************************
  1908. TORDDEF
  1909. ****************************************************************************}
  1910. constructor torddef.create(t : tordtype;v,b : TConstExprInt);
  1911. begin
  1912. inherited create(orddef);
  1913. low:=v;
  1914. high:=b;
  1915. ordtype:=t;
  1916. setsize;
  1917. end;
  1918. constructor torddef.ppuload(ppufile:tcompilerppufile);
  1919. begin
  1920. inherited ppuload(orddef,ppufile);
  1921. ordtype:=tordtype(ppufile.getbyte);
  1922. low:=ppufile.getexprint;
  1923. high:=ppufile.getexprint;
  1924. setsize;
  1925. end;
  1926. function torddef.getcopy : tstoreddef;
  1927. begin
  1928. result:=torddef.create(ordtype,low,high);
  1929. result.typ:=orddef;
  1930. torddef(result).low:=low;
  1931. torddef(result).high:=high;
  1932. torddef(result).ordtype:=ordtype;
  1933. torddef(result).savesize:=savesize;
  1934. end;
  1935. function torddef.alignment:shortint;
  1936. begin
  1937. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) and
  1938. (ordtype in [s64bit,u64bit]) then
  1939. result := 4
  1940. else
  1941. result := inherited alignment;
  1942. end;
  1943. procedure torddef.setsize;
  1944. const
  1945. sizetbl : array[tordtype] of longint = (
  1946. 0,
  1947. 1,2,4,8,
  1948. 1,2,4,8,
  1949. 1,2,4,8,
  1950. 1,2,4,8,
  1951. 1,2,8
  1952. );
  1953. begin
  1954. savesize:=sizetbl[ordtype];
  1955. end;
  1956. function torddef.packedbitsize: asizeint;
  1957. var
  1958. sizeval: tconstexprint;
  1959. power: longint;
  1960. begin
  1961. result := 0;
  1962. if ordtype = uvoid then
  1963. exit;
  1964. {$ifndef cpu64bitalu}
  1965. if (ordtype in [s64bit,u64bit]) then
  1966. {$else not cpu64bitalu}
  1967. if (ordtype = u64bit) or
  1968. ((ordtype = s64bit) and
  1969. ((low <= (system.low(int64) div 2)) or
  1970. (high > (system.high(int64) div 2)))) then
  1971. {$endif cpu64bitalu}
  1972. result := 64
  1973. else if (low >= 0) and
  1974. (high <= 1) then
  1975. result := 1
  1976. else
  1977. begin
  1978. if (low>=0) then
  1979. sizeval:=high
  1980. else
  1981. { don't count 0 twice }
  1982. sizeval:=(cutils.max(-low,high)*2)-1;
  1983. { 256 must become 512 etc. }
  1984. nextpowerof2(sizeval+1,power);
  1985. result := power;
  1986. end;
  1987. end;
  1988. function torddef.getvardef : longint;
  1989. const
  1990. basetype2vardef : array[tordtype] of longint = (
  1991. varUndefined,
  1992. varbyte,varword,varlongword,varqword,
  1993. varshortint,varsmallint,varinteger,varint64,
  1994. varboolean,varboolean,varboolean,varboolean,
  1995. varboolean,varboolean,varUndefined,varUndefined,
  1996. varUndefined,varUndefined,varCurrency);
  1997. begin
  1998. result:=basetype2vardef[ordtype];
  1999. end;
  2000. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  2001. begin
  2002. inherited ppuwrite(ppufile);
  2003. ppufile.putbyte(byte(ordtype));
  2004. ppufile.putexprint(low);
  2005. ppufile.putexprint(high);
  2006. ppufile.writeentry(iborddef);
  2007. end;
  2008. function torddef.is_publishable : boolean;
  2009. begin
  2010. is_publishable:=(ordtype<>uvoid);
  2011. end;
  2012. function torddef.GetTypeName : string;
  2013. const
  2014. names : array[tordtype] of string[20] = (
  2015. 'untyped',
  2016. 'Byte','Word','DWord','QWord',
  2017. 'ShortInt','SmallInt','LongInt','Int64',
  2018. 'Boolean','Boolean16','Boolean32','Boolean64',
  2019. 'ByteBool','WordBool','LongBool','QWordBool',
  2020. 'Char','WideChar','Currency');
  2021. begin
  2022. GetTypeName:=names[ordtype];
  2023. end;
  2024. {****************************************************************************
  2025. TFLOATDEF
  2026. ****************************************************************************}
  2027. constructor tfloatdef.create(t : tfloattype);
  2028. begin
  2029. inherited create(floatdef);
  2030. floattype:=t;
  2031. setsize;
  2032. end;
  2033. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  2034. begin
  2035. inherited ppuload(floatdef,ppufile);
  2036. floattype:=tfloattype(ppufile.getbyte);
  2037. setsize;
  2038. end;
  2039. function tfloatdef.getcopy : tstoreddef;
  2040. begin
  2041. result:=tfloatdef.create(floattype);
  2042. result.typ:=floatdef;
  2043. tfloatdef(result).savesize:=savesize;
  2044. end;
  2045. function tfloatdef.alignment:shortint;
  2046. begin
  2047. if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) then
  2048. case floattype of
  2049. sc80real,
  2050. s80real: result:=16;
  2051. s64real,
  2052. s64currency,
  2053. s64comp : result:=4;
  2054. else
  2055. result := inherited alignment;
  2056. end
  2057. else
  2058. result := inherited alignment;
  2059. end;
  2060. function tfloatdef.structalignment: shortint;
  2061. begin
  2062. { aix is really annoying: the recommended scalar alignment for both
  2063. int64 and double is 64 bits, but in structs int64 has to be aligned
  2064. to 8 bytes and double to 4 bytes }
  2065. if (target_info.system in systems_aix) and
  2066. (floattype=s64real) then
  2067. result:=4
  2068. else
  2069. result:=alignment;
  2070. end;
  2071. procedure tfloatdef.setsize;
  2072. begin
  2073. case floattype of
  2074. s32real : savesize:=4;
  2075. s80real : savesize:=10;
  2076. sc80real:
  2077. if target_info.system in [system_i386_darwin,system_i386_iphonesim,system_x86_64_darwin,
  2078. system_x86_64_linux,system_x86_64_freebsd,
  2079. system_x86_64_openbsd,system_x86_64_netbsd,
  2080. system_x86_64_solaris,system_x86_64_embedded] then
  2081. savesize:=16
  2082. else
  2083. savesize:=12;
  2084. s64real,
  2085. s64currency,
  2086. s64comp : savesize:=8;
  2087. else
  2088. savesize:=0;
  2089. end;
  2090. end;
  2091. function tfloatdef.getvardef : longint;
  2092. const
  2093. floattype2vardef : array[tfloattype] of longint = (
  2094. varSingle,varDouble,varUndefined,varUndefined,
  2095. varUndefined,varCurrency,varUndefined);
  2096. begin
  2097. if (upper(typename)='TDATETIME') and
  2098. assigned(owner) and
  2099. assigned(owner.name) and
  2100. (owner.name^='SYSTEM') then
  2101. result:=varDate
  2102. else
  2103. result:=floattype2vardef[floattype];
  2104. end;
  2105. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  2106. begin
  2107. inherited ppuwrite(ppufile);
  2108. ppufile.putbyte(byte(floattype));
  2109. ppufile.writeentry(ibfloatdef);
  2110. end;
  2111. function tfloatdef.is_publishable : boolean;
  2112. begin
  2113. is_publishable:=true;
  2114. end;
  2115. function tfloatdef.GetTypeName : string;
  2116. const
  2117. names : array[tfloattype] of string[20] = (
  2118. 'Single','Double','Extended','CExtended','Comp','Currency','Float128');
  2119. begin
  2120. GetTypeName:=names[floattype];
  2121. end;
  2122. {****************************************************************************
  2123. TFILEDEF
  2124. ****************************************************************************}
  2125. constructor tfiledef.createtext;
  2126. begin
  2127. inherited create(filedef);
  2128. filetyp:=ft_text;
  2129. typedfiledef:=nil;
  2130. setsize;
  2131. end;
  2132. constructor tfiledef.createuntyped;
  2133. begin
  2134. inherited create(filedef);
  2135. filetyp:=ft_untyped;
  2136. typedfiledef:=nil;
  2137. setsize;
  2138. end;
  2139. constructor tfiledef.createtyped(def:tdef);
  2140. begin
  2141. inherited create(filedef);
  2142. filetyp:=ft_typed;
  2143. typedfiledef:=def;
  2144. setsize;
  2145. end;
  2146. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  2147. begin
  2148. inherited ppuload(filedef,ppufile);
  2149. filetyp:=tfiletyp(ppufile.getbyte);
  2150. if filetyp=ft_typed then
  2151. ppufile.getderef(typedfiledefderef)
  2152. else
  2153. typedfiledef:=nil;
  2154. setsize;
  2155. end;
  2156. function tfiledef.getcopy : tstoreddef;
  2157. begin
  2158. case filetyp of
  2159. ft_typed:
  2160. result:=tfiledef.createtyped(typedfiledef);
  2161. ft_untyped:
  2162. result:=tfiledef.createuntyped;
  2163. ft_text:
  2164. result:=tfiledef.createtext;
  2165. else
  2166. internalerror(2004121201);
  2167. end;
  2168. end;
  2169. procedure tfiledef.buildderef;
  2170. begin
  2171. inherited buildderef;
  2172. if filetyp=ft_typed then
  2173. typedfiledefderef.build(typedfiledef);
  2174. end;
  2175. procedure tfiledef.deref;
  2176. begin
  2177. inherited deref;
  2178. if filetyp=ft_typed then
  2179. typedfiledef:=tdef(typedfiledefderef.resolve);
  2180. end;
  2181. procedure tfiledef.setsize;
  2182. begin
  2183. {$ifdef cpu64bitaddr}
  2184. case filetyp of
  2185. ft_text :
  2186. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  2187. savesize:=634{+8}
  2188. else
  2189. savesize:=630{+8};
  2190. ft_typed,
  2191. ft_untyped :
  2192. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  2193. savesize:=372
  2194. else
  2195. savesize:=368;
  2196. end;
  2197. {$endif cpu64bitaddr}
  2198. {$ifdef cpu32bitaddr}
  2199. case filetyp of
  2200. ft_text :
  2201. savesize:=596; { keep this dividable by 4 for proper alignment of arrays of text, see tw0754 e.g. on arm }
  2202. ft_typed,
  2203. ft_untyped :
  2204. savesize:=332;
  2205. end;
  2206. {$endif cpu32bitaddr}
  2207. {$ifdef cpu8bitaddr}
  2208. case filetyp of
  2209. ft_text :
  2210. savesize:=127;
  2211. ft_typed,
  2212. ft_untyped :
  2213. savesize:=127;
  2214. end;
  2215. {$endif cpu8bitaddr}
  2216. end;
  2217. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  2218. begin
  2219. inherited ppuwrite(ppufile);
  2220. ppufile.putbyte(byte(filetyp));
  2221. if filetyp=ft_typed then
  2222. ppufile.putderef(typedfiledefderef);
  2223. ppufile.writeentry(ibfiledef);
  2224. end;
  2225. function tfiledef.GetTypeName : string;
  2226. begin
  2227. case filetyp of
  2228. ft_untyped:
  2229. GetTypeName:='File';
  2230. ft_typed:
  2231. GetTypeName:='File Of '+typedfiledef.typename;
  2232. ft_text:
  2233. GetTypeName:='Text'
  2234. end;
  2235. end;
  2236. function tfiledef.getmangledparaname : TSymStr;
  2237. begin
  2238. case filetyp of
  2239. ft_untyped:
  2240. getmangledparaname:='FILE';
  2241. ft_typed:
  2242. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  2243. ft_text:
  2244. getmangledparaname:='TEXT'
  2245. end;
  2246. end;
  2247. {****************************************************************************
  2248. TVARIANTDEF
  2249. ****************************************************************************}
  2250. constructor tvariantdef.create(v : tvarianttype);
  2251. begin
  2252. inherited create(variantdef);
  2253. varianttype:=v;
  2254. setsize;
  2255. end;
  2256. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  2257. begin
  2258. inherited ppuload(variantdef,ppufile);
  2259. varianttype:=tvarianttype(ppufile.getbyte);
  2260. setsize;
  2261. end;
  2262. function tvariantdef.getcopy : tstoreddef;
  2263. begin
  2264. result:=tvariantdef.create(varianttype);
  2265. end;
  2266. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  2267. begin
  2268. inherited ppuwrite(ppufile);
  2269. ppufile.putbyte(byte(varianttype));
  2270. ppufile.writeentry(ibvariantdef);
  2271. end;
  2272. function tvariantdef.getvardef : longint;
  2273. begin
  2274. Result:=varVariant;
  2275. end;
  2276. procedure tvariantdef.setsize;
  2277. begin
  2278. {$ifdef cpu64bitaddr}
  2279. savesize:=24;
  2280. {$else cpu64bitaddr}
  2281. savesize:=16;
  2282. {$endif cpu64bitaddr}
  2283. end;
  2284. function tvariantdef.GetTypeName : string;
  2285. begin
  2286. case varianttype of
  2287. vt_normalvariant:
  2288. GetTypeName:='Variant';
  2289. vt_olevariant:
  2290. GetTypeName:='OleVariant';
  2291. end;
  2292. end;
  2293. function tvariantdef.needs_inittable : boolean;
  2294. begin
  2295. needs_inittable:=true;
  2296. end;
  2297. function tvariantdef.is_publishable : boolean;
  2298. begin
  2299. is_publishable:=true;
  2300. end;
  2301. {****************************************************************************
  2302. TABSTRACtpointerdef
  2303. ****************************************************************************}
  2304. constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef);
  2305. begin
  2306. inherited create(dt);
  2307. pointeddef:=def;
  2308. savesize:=sizeof(pint);
  2309. end;
  2310. constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2311. begin
  2312. inherited ppuload(dt,ppufile);
  2313. ppufile.getderef(pointeddefderef);
  2314. savesize:=sizeof(pint);
  2315. end;
  2316. procedure tabstractpointerdef.buildderef;
  2317. begin
  2318. inherited buildderef;
  2319. pointeddefderef.build(pointeddef);
  2320. end;
  2321. procedure tabstractpointerdef.deref;
  2322. begin
  2323. inherited deref;
  2324. pointeddef:=tdef(pointeddefderef.resolve);
  2325. end;
  2326. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2327. begin
  2328. inherited ppuwrite(ppufile);
  2329. ppufile.putderef(pointeddefderef);
  2330. end;
  2331. {****************************************************************************
  2332. tpointerdef
  2333. ****************************************************************************}
  2334. constructor tpointerdef.create(def:tdef);
  2335. begin
  2336. inherited create(pointerdef,def);
  2337. is_far:=false;
  2338. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2339. end;
  2340. constructor tpointerdef.createfar(def:tdef);
  2341. begin
  2342. inherited create(pointerdef,def);
  2343. is_far:=true;
  2344. has_pointer_math:=cs_pointermath in current_settings.localswitches;
  2345. end;
  2346. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  2347. begin
  2348. inherited ppuload(pointerdef,ppufile);
  2349. is_far:=(ppufile.getbyte<>0);
  2350. has_pointer_math:=(ppufile.getbyte<>0);
  2351. end;
  2352. function tpointerdef.getcopy : tstoreddef;
  2353. begin
  2354. { don't use direct pointeddef if it is a forwarddef because in other case
  2355. one of them will be destroyed on forward type resolve and the second will
  2356. point to garbage }
  2357. if pointeddef.typ=forwarddef then
  2358. result:=tpointerdef.create(tforwarddef(pointeddef).getcopy)
  2359. else
  2360. result:=tpointerdef.create(pointeddef);
  2361. tpointerdef(result).is_far:=is_far;
  2362. tpointerdef(result).has_pointer_math:=has_pointer_math;
  2363. tpointerdef(result).savesize:=savesize;
  2364. end;
  2365. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  2366. begin
  2367. inherited ppuwrite(ppufile);
  2368. ppufile.putbyte(byte(is_far));
  2369. ppufile.putbyte(byte(has_pointer_math));
  2370. ppufile.writeentry(ibpointerdef);
  2371. end;
  2372. function tpointerdef.GetTypeName : string;
  2373. begin
  2374. if is_far then
  2375. GetTypeName:='^'+pointeddef.typename+';far'
  2376. else
  2377. GetTypeName:='^'+pointeddef.typename;
  2378. end;
  2379. {****************************************************************************
  2380. TCLASSREFDEF
  2381. ****************************************************************************}
  2382. constructor tclassrefdef.create(def:tdef);
  2383. begin
  2384. inherited create(classrefdef,def);
  2385. end;
  2386. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  2387. begin
  2388. inherited ppuload(classrefdef,ppufile);
  2389. end;
  2390. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  2391. begin
  2392. inherited ppuwrite(ppufile);
  2393. ppufile.writeentry(ibclassrefdef);
  2394. end;
  2395. function tclassrefdef.getcopy:tstoreddef;
  2396. begin
  2397. if pointeddef.typ=forwarddef then
  2398. result:=tclassrefdef.create(tforwarddef(pointeddef).getcopy)
  2399. else
  2400. result:=tclassrefdef.create(pointeddef);
  2401. tclassrefdef(result).savesize:=savesize;
  2402. end;
  2403. function tclassrefdef.GetTypeName : string;
  2404. begin
  2405. GetTypeName:='Class Of '+pointeddef.typename;
  2406. end;
  2407. function tclassrefdef.is_publishable : boolean;
  2408. begin
  2409. result:=true;
  2410. end;
  2411. function tclassrefdef.rtti_mangledname(rt: trttitype): string;
  2412. begin
  2413. if (tobjectdef(pointeddef).objecttype<>odt_objcclass) then
  2414. result:=inherited rtti_mangledname(rt)
  2415. else
  2416. result:=tobjectdef(pointeddef).rtti_mangledname(objcmetartti);
  2417. end;
  2418. procedure tclassrefdef.register_created_object_type;
  2419. begin
  2420. tobjectdef(pointeddef).register_created_classref_type;
  2421. end;
  2422. {***************************************************************************
  2423. TSETDEF
  2424. ***************************************************************************}
  2425. constructor tsetdef.create(def:tdef;low, high : asizeint);
  2426. var
  2427. setallocbits: aint;
  2428. packedsavesize: aint;
  2429. begin
  2430. inherited create(setdef);
  2431. elementdef:=def;
  2432. setmax:=high;
  2433. if (current_settings.setalloc=0) then
  2434. begin
  2435. setbase:=0;
  2436. if (high<32) then
  2437. savesize:=Sizeof(longint)
  2438. else if (high<256) then
  2439. savesize:=32
  2440. else
  2441. savesize:=(high+7) div 8
  2442. end
  2443. else
  2444. begin
  2445. setallocbits:=current_settings.setalloc*8;
  2446. setbase:=low and not(setallocbits-1);
  2447. packedsavesize:=current_settings.setalloc*((((high+setallocbits)-setbase)) DIV setallocbits);
  2448. savesize:=packedsavesize;
  2449. if savesize=3 then
  2450. savesize:=4;
  2451. end;
  2452. end;
  2453. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  2454. begin
  2455. inherited ppuload(setdef,ppufile);
  2456. ppufile.getderef(elementdefderef);
  2457. savesize:=ppufile.getaint;
  2458. setbase:=ppufile.getaint;
  2459. setmax:=ppufile.getaint;
  2460. end;
  2461. function tsetdef.getcopy : tstoreddef;
  2462. begin
  2463. result:=tsetdef.create(elementdef,setbase,setmax);
  2464. { the copy might have been created with a different setalloc setting }
  2465. tsetdef(result).savesize:=savesize;
  2466. end;
  2467. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  2468. begin
  2469. inherited ppuwrite(ppufile);
  2470. ppufile.putderef(elementdefderef);
  2471. ppufile.putaint(savesize);
  2472. ppufile.putaint(setbase);
  2473. ppufile.putaint(setmax);
  2474. ppufile.writeentry(ibsetdef);
  2475. end;
  2476. procedure tsetdef.buildderef;
  2477. begin
  2478. inherited buildderef;
  2479. elementdefderef.build(elementdef);
  2480. end;
  2481. procedure tsetdef.deref;
  2482. begin
  2483. inherited deref;
  2484. elementdef:=tdef(elementdefderef.resolve);
  2485. end;
  2486. function tsetdef.is_publishable : boolean;
  2487. begin
  2488. is_publishable:=savesize in [1,2,4];
  2489. end;
  2490. function tsetdef.GetTypeName : string;
  2491. begin
  2492. if assigned(elementdef) then
  2493. GetTypeName:='Set Of '+elementdef.typename
  2494. else
  2495. GetTypeName:='Empty Set';
  2496. end;
  2497. {***************************************************************************
  2498. TFORMALDEF
  2499. ***************************************************************************}
  2500. constructor tformaldef.create(Atyped:boolean);
  2501. begin
  2502. inherited create(formaldef);
  2503. typed:=Atyped;
  2504. savesize:=0;
  2505. end;
  2506. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  2507. begin
  2508. inherited ppuload(formaldef,ppufile);
  2509. typed:=boolean(ppufile.getbyte);
  2510. savesize:=0;
  2511. end;
  2512. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  2513. begin
  2514. inherited ppuwrite(ppufile);
  2515. ppufile.putbyte(byte(typed));
  2516. ppufile.writeentry(ibformaldef);
  2517. end;
  2518. function tformaldef.GetTypeName : string;
  2519. begin
  2520. if typed then
  2521. GetTypeName:='<Typed formal type>'
  2522. else
  2523. GetTypeName:='<Formal type>';
  2524. end;
  2525. {***************************************************************************
  2526. TARRAYDEF
  2527. ***************************************************************************}
  2528. constructor tarraydef.create(l,h:asizeint;def:tdef);
  2529. begin
  2530. inherited create(arraydef);
  2531. lowrange:=l;
  2532. highrange:=h;
  2533. rangedef:=def;
  2534. _elementdef:=nil;
  2535. arrayoptions:=[];
  2536. symtable:=tarraysymtable.create(self);
  2537. end;
  2538. destructor tarraydef.destroy;
  2539. begin
  2540. symtable.free;
  2541. symtable:=nil;
  2542. inherited;
  2543. end;
  2544. constructor tarraydef.create_from_pointer(def:tdef);
  2545. begin
  2546. { use -1 so that the elecount will not overflow }
  2547. self.create(0,high(asizeint)-1,ptrsinttype);
  2548. arrayoptions:=[ado_IsConvertedPointer];
  2549. setelementdef(def);
  2550. end;
  2551. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  2552. begin
  2553. inherited ppuload(arraydef,ppufile);
  2554. { the addresses are calculated later }
  2555. ppufile.getderef(_elementdefderef);
  2556. ppufile.getderef(rangedefderef);
  2557. lowrange:=ppufile.getaint;
  2558. highrange:=ppufile.getaint;
  2559. ppufile.getsmallset(arrayoptions);
  2560. symtable:=tarraysymtable.create(self);
  2561. tarraysymtable(symtable).ppuload(ppufile)
  2562. end;
  2563. function tarraydef.getcopy : tstoreddef;
  2564. begin
  2565. result:=tarraydef.create(lowrange,highrange,rangedef);
  2566. tarraydef(result).arrayoptions:=arrayoptions;
  2567. tarraydef(result)._elementdef:=_elementdef;
  2568. end;
  2569. procedure tarraydef.buildderef;
  2570. begin
  2571. inherited buildderef;
  2572. tarraysymtable(symtable).buildderef;
  2573. _elementdefderef.build(_elementdef);
  2574. rangedefderef.build(rangedef);
  2575. end;
  2576. procedure tarraydef.deref;
  2577. begin
  2578. inherited deref;
  2579. tarraysymtable(symtable).deref;
  2580. _elementdef:=tdef(_elementdefderef.resolve);
  2581. rangedef:=tdef(rangedefderef.resolve);
  2582. end;
  2583. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  2584. begin
  2585. inherited ppuwrite(ppufile);
  2586. ppufile.putderef(_elementdefderef);
  2587. ppufile.putderef(rangedefderef);
  2588. ppufile.putaint(lowrange);
  2589. ppufile.putaint(highrange);
  2590. ppufile.putsmallset(arrayoptions);
  2591. ppufile.writeentry(ibarraydef);
  2592. tarraysymtable(symtable).ppuwrite(ppufile);
  2593. end;
  2594. function tarraydef.elesize : asizeint;
  2595. begin
  2596. if (ado_IsBitPacked in arrayoptions) then
  2597. internalerror(2006080101);
  2598. if assigned(_elementdef) then
  2599. result:=_elementdef.size
  2600. else
  2601. result:=0;
  2602. end;
  2603. function tarraydef.elepackedbitsize : asizeint;
  2604. begin
  2605. if not(ado_IsBitPacked in arrayoptions) then
  2606. internalerror(2006080102);
  2607. if assigned(_elementdef) then
  2608. result:=_elementdef.packedbitsize
  2609. else
  2610. result:=0;
  2611. end;
  2612. function tarraydef.elecount : asizeuint;
  2613. var
  2614. qhigh,qlow : qword;
  2615. begin
  2616. if ado_IsDynamicArray in arrayoptions then
  2617. begin
  2618. result:=0;
  2619. exit;
  2620. end;
  2621. if (highrange>0) and (lowrange<0) then
  2622. begin
  2623. qhigh:=highrange;
  2624. qlow:=qword(-lowrange);
  2625. { prevent overflow, return 0 to indicate overflow }
  2626. if qhigh+qlow>qword(high(asizeint)-1) then
  2627. result:=0
  2628. else
  2629. result:=qhigh+qlow+1;
  2630. end
  2631. else
  2632. result:=int64(highrange)-lowrange+1;
  2633. end;
  2634. function tarraydef.size : asizeint;
  2635. var
  2636. cachedelecount : asizeuint;
  2637. cachedelesize : asizeint;
  2638. begin
  2639. if ado_IsDynamicArray in arrayoptions then
  2640. begin
  2641. size:=sizeof(pint);
  2642. exit;
  2643. end;
  2644. { Tarraydef.size may never be called for an open array! }
  2645. if highrange<lowrange then
  2646. internalerror(99080501);
  2647. if not (ado_IsBitPacked in arrayoptions) then
  2648. cachedelesize:=elesize
  2649. else
  2650. cachedelesize := elepackedbitsize;
  2651. cachedelecount:=elecount;
  2652. if (cachedelesize = 0) then
  2653. begin
  2654. size := 0;
  2655. exit;
  2656. end;
  2657. if (cachedelecount = 0) then
  2658. begin
  2659. size := -1;
  2660. exit;
  2661. end;
  2662. { prevent overflow, return -1 to indicate overflow }
  2663. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  2664. if (cachedelecount > asizeuint(high(asizeint))) or
  2665. ((high(asizeint) div cachedelesize) < asizeint(cachedelecount)) or
  2666. { also lowrange*elesize must be < high(asizeint) to prevent overflow when
  2667. accessing the array, see ncgmem (PFV) }
  2668. ((high(asizeint) div cachedelesize) < abs(lowrange)) then
  2669. begin
  2670. result:=-1;
  2671. exit;
  2672. end;
  2673. result:=cachedelesize*asizeint(cachedelecount);
  2674. if (ado_IsBitPacked in arrayoptions) then
  2675. { can't just add 7 and divide by 8, because that may overflow }
  2676. result:=result div 8 + ord((result mod 8)<>0);
  2677. end;
  2678. procedure tarraydef.setelementdef(def:tdef);
  2679. begin
  2680. _elementdef:=def;
  2681. if not(
  2682. (ado_IsDynamicArray in arrayoptions) or
  2683. (ado_IsConvertedPointer in arrayoptions) or
  2684. (highrange<lowrange)
  2685. ) and
  2686. (size=-1) then
  2687. Message(sym_e_segment_too_large);
  2688. end;
  2689. function tarraydef.alignment : shortint;
  2690. begin
  2691. { alignment of dyn. arrays doesn't depend on the element size }
  2692. if (ado_IsDynamicArray in arrayoptions) then
  2693. alignment:=size_2_align(sizeof(pint))
  2694. { alignment is the alignment of the elements }
  2695. else if (elementdef.typ in [arraydef,recorddef,orddef,enumdef,floatdef]) or
  2696. ((elementdef.typ=objectdef) and
  2697. is_object(elementdef)) then
  2698. alignment:=elementdef.alignment
  2699. { alignment is the size of the elements }
  2700. else if not (ado_IsBitPacked in arrayoptions) then
  2701. alignment:=size_2_align(elesize)
  2702. else
  2703. alignment:=packedbitsloadsize(elepackedbitsize);
  2704. end;
  2705. function tarraydef.needs_inittable : boolean;
  2706. begin
  2707. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  2708. end;
  2709. function tarraydef.needs_separate_initrtti : boolean;
  2710. begin
  2711. if ado_IsBitPacked in arrayoptions then
  2712. result:=false
  2713. else
  2714. result:=elementdef.needs_separate_initrtti;
  2715. end;
  2716. function tarraydef.GetTypeName : string;
  2717. begin
  2718. if (ado_IsConstString in arrayoptions) then
  2719. result:='Constant String'
  2720. else if (ado_isarrayofconst in arrayoptions) or
  2721. (ado_isConstructor in arrayoptions) then
  2722. begin
  2723. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  2724. GetTypeName:='Array Of Const'
  2725. else
  2726. GetTypeName:='{Array Of Const/Constant Open} Array of '+elementdef.typename;
  2727. end
  2728. else if (ado_IsDynamicArray in arrayoptions) then
  2729. GetTypeName:='{Dynamic} Array Of '+elementdef.typename
  2730. else if ((highrange=-1) and (lowrange=0)) then
  2731. GetTypeName:='{Open} Array Of '+elementdef.typename
  2732. else
  2733. begin
  2734. result := '';
  2735. if (ado_IsBitPacked in arrayoptions) then
  2736. result:='BitPacked ';
  2737. if rangedef.typ=enumdef then
  2738. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  2739. else
  2740. result:=result+'Array['+tostr(lowrange)+'..'+
  2741. tostr(highrange)+'] Of '+elementdef.typename
  2742. end;
  2743. end;
  2744. function tarraydef.getmangledparaname : TSymStr;
  2745. begin
  2746. if ado_isarrayofconst in arrayoptions then
  2747. getmangledparaname:='array_of_const'
  2748. else
  2749. if ((highrange=-1) and (lowrange=0)) then
  2750. getmangledparaname:='array_of_'+elementdef.mangledparaname
  2751. else
  2752. internalerror(200204176);
  2753. end;
  2754. function tarraydef.is_publishable : boolean;
  2755. begin
  2756. Result:=ado_IsDynamicArray in arrayoptions;
  2757. end;
  2758. {***************************************************************************
  2759. tabstractrecorddef
  2760. ***************************************************************************}
  2761. constructor tabstractrecorddef.create(const n:string; dt:tdeftyp);
  2762. begin
  2763. inherited create(dt);
  2764. objname:=stringdup(upper(n));
  2765. objrealname:=stringdup(n);
  2766. objectoptions:=[];
  2767. if assigned(current_module.namespace) then
  2768. begin
  2769. import_lib:=stringdup(current_module.namespace^);
  2770. replace(import_lib^,'.','/');
  2771. end;
  2772. end;
  2773. constructor tabstractrecorddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2774. begin
  2775. inherited ppuload(dt,ppufile);
  2776. objrealname:=stringdup(ppufile.getstring);
  2777. objname:=stringdup(upper(objrealname^));
  2778. import_lib:=stringdup(ppufile.getstring);
  2779. { only used for external C++ classes and Java classes/records }
  2780. if (import_lib^='') then
  2781. stringdispose(import_lib);
  2782. ppufile.getsmallset(objectoptions);
  2783. end;
  2784. procedure tabstractrecorddef.ppuwrite(ppufile: tcompilerppufile);
  2785. begin
  2786. inherited ppuwrite(ppufile);
  2787. ppufile.putstring(objrealname^);
  2788. if assigned(import_lib) then
  2789. ppufile.putstring(import_lib^)
  2790. else
  2791. ppufile.putstring('');
  2792. ppufile.putsmallset(objectoptions);
  2793. end;
  2794. destructor tabstractrecorddef.destroy;
  2795. begin
  2796. stringdispose(objname);
  2797. stringdispose(objrealname);
  2798. stringdispose(import_lib);
  2799. tcinitcode.free;
  2800. inherited destroy;
  2801. end;
  2802. procedure tabstractrecorddef.check_forwards;
  2803. begin
  2804. tstoredsymtable(symtable).check_forwards;
  2805. end;
  2806. function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
  2807. var
  2808. i: longint;
  2809. sym: tsym;
  2810. begin
  2811. for i:=0 to symtable.SymList.Count-1 do
  2812. begin
  2813. sym:=tsym(symtable.SymList[i]);
  2814. if sym.typ=procsym then
  2815. begin
  2816. result:=tprocsym(sym).find_procdef_bytype(pt);
  2817. if assigned(result) then
  2818. exit;
  2819. end;
  2820. end;
  2821. result:=nil;
  2822. end;
  2823. function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
  2824. begin
  2825. if t=gs_record then
  2826. GetSymtable:=symtable
  2827. else
  2828. GetSymtable:=nil;
  2829. end;
  2830. function tabstractrecorddef.is_packed:boolean;
  2831. begin
  2832. result:=tabstractrecordsymtable(symtable).is_packed;
  2833. end;
  2834. function tabstractrecorddef.RttiName: string;
  2835. begin
  2836. Result:=OwnerHierarchyName+objrealname^;
  2837. end;
  2838. function tabstractrecorddef.search_enumerator_get: tprocdef;
  2839. var
  2840. sym : tsym;
  2841. i : integer;
  2842. pd : tprocdef;
  2843. hashedid : THashedIDString;
  2844. begin
  2845. result:=nil;
  2846. hashedid.id:='GETENUMERATOR';
  2847. sym:=tsym(symtable.FindWithHash(hashedid));
  2848. if assigned(sym) and (sym.typ=procsym) then
  2849. begin
  2850. for i := 0 to Tprocsym(sym).ProcdefList.Count - 1 do
  2851. begin
  2852. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2853. if (pd.proctypeoption = potype_function) and
  2854. (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) and
  2855. (pd.visibility >= vis_public) then
  2856. begin
  2857. result:=pd;
  2858. exit;
  2859. end;
  2860. end;
  2861. end;
  2862. end;
  2863. function tabstractrecorddef.search_enumerator_move: tprocdef;
  2864. var
  2865. sym : tsym;
  2866. i : integer;
  2867. pd : tprocdef;
  2868. hashedid : THashedIDString;
  2869. begin
  2870. result:=nil;
  2871. // first search for po_enumerator_movenext method modifier
  2872. // then search for public function MoveNext: Boolean
  2873. for i:=0 to symtable.SymList.Count-1 do
  2874. begin
  2875. sym:=TSym(symtable.SymList[i]);
  2876. if (sym.typ=procsym) then
  2877. begin
  2878. pd:=Tprocsym(sym).find_procdef_byoptions([po_enumerator_movenext]);
  2879. if assigned(pd) then
  2880. begin
  2881. result:=pd;
  2882. exit;
  2883. end;
  2884. end;
  2885. end;
  2886. hashedid.id:='MOVENEXT';
  2887. sym:=tsym(symtable.FindWithHash(hashedid));
  2888. if assigned(sym) and (sym.typ=procsym) then
  2889. begin
  2890. for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
  2891. begin
  2892. pd := tprocdef(Tprocsym(sym).ProcdefList[i]);
  2893. if (pd.proctypeoption = potype_function) and
  2894. is_boolean(pd.returndef) and
  2895. (pd.minparacount = 0) and
  2896. (pd.visibility >= vis_public) then
  2897. begin
  2898. result:=pd;
  2899. exit;
  2900. end;
  2901. end;
  2902. end;
  2903. end;
  2904. function tabstractrecorddef.search_enumerator_current: tsym;
  2905. var
  2906. sym: tsym;
  2907. i: integer;
  2908. hashedid : THashedIDString;
  2909. begin
  2910. result:=nil;
  2911. // first search for ppo_enumerator_current property modifier
  2912. // then search for public property Current
  2913. for i:=0 to symtable.SymList.Count-1 do
  2914. begin
  2915. sym:=TSym(symtable.SymList[i]);
  2916. if (sym.typ=propertysym) and (ppo_enumerator_current in tpropertysym(sym).propoptions) then
  2917. begin
  2918. result:=sym;
  2919. exit;
  2920. end;
  2921. end;
  2922. hashedid.id:='CURRENT';
  2923. sym:=tsym(symtable.FindWithHash(hashedid));
  2924. if assigned(sym) and (sym.typ=propertysym) and
  2925. (sym.visibility >= vis_public) and not tpropertysym(sym).propaccesslist[palt_read].empty then
  2926. begin
  2927. result:=sym;
  2928. exit;
  2929. end;
  2930. end;
  2931. function tabstractrecorddef.jvm_full_typename(with_package_name: boolean): string;
  2932. var
  2933. st: tsymtable;
  2934. enclosingdef: tdef;
  2935. begin
  2936. if typ=objectdef then
  2937. result:=tobjectdef(self).objextname^
  2938. else if assigned(typesym) then
  2939. result:=typesym.realname
  2940. { have to generate anonymous nested type in current unit/class/record }
  2941. else
  2942. internalerror(2011032601);
  2943. { in case of specializations, add some extras to prevent name conflicts
  2944. with nested classes }
  2945. if df_specialization in defoptions then
  2946. result:='$'+result+'$specialization$';
  2947. st:=owner;
  2948. while assigned(st) and
  2949. (st.symtabletype in [objectsymtable,recordsymtable,localsymtable]) do
  2950. begin
  2951. { nested classes are named as "OuterClass$InnerClass" }
  2952. enclosingdef:=tdef(st.defowner);
  2953. if enclosingdef.typ=procdef then
  2954. result:=result+tprocdef(enclosingdef).procsym.realname+'$$'+tostr(tprocdef(enclosingdef).procsym.symid)+'$'
  2955. else if enclosingdef.typ=objectdef then
  2956. result:=tobjectdef(enclosingdef).objextname^+'$'+result
  2957. else if assigned(enclosingdef.typesym) then
  2958. result:=enclosingdef.typesym.realname+'$'+result
  2959. else
  2960. internalerror(2011060305);
  2961. st:=enclosingdef.owner;
  2962. end;
  2963. if with_package_name and
  2964. assigned(import_lib) then
  2965. result:=import_lib^+'/'+result;
  2966. end;
  2967. {***************************************************************************
  2968. trecorddef
  2969. ***************************************************************************}
  2970. constructor trecorddef.create(const n:string; p:TSymtable);
  2971. begin
  2972. inherited create(n,recorddef);
  2973. symtable:=p;
  2974. { we can own the symtable only if nobody else owns a copy so far }
  2975. if symtable.refcount=1 then
  2976. symtable.defowner:=self;
  2977. isunion:=false;
  2978. end;
  2979. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  2980. begin
  2981. inherited ppuload(recorddef,ppufile);
  2982. if df_copied_def in defoptions then
  2983. ppufile.getderef(cloneddefderef)
  2984. else
  2985. begin
  2986. symtable:=trecordsymtable.create(objrealname^,0);
  2987. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  2988. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  2989. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  2990. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  2991. trecordsymtable(symtable).datasize:=ppufile.getasizeint;
  2992. trecordsymtable(symtable).paddingsize:=ppufile.getword;
  2993. trecordsymtable(symtable).ppuload(ppufile);
  2994. { requires usefieldalignment to be set }
  2995. symtable.defowner:=self;
  2996. end;
  2997. isunion:=false;
  2998. end;
  2999. destructor trecorddef.destroy;
  3000. begin
  3001. if assigned(symtable) then
  3002. begin
  3003. symtable.free;
  3004. symtable:=nil;
  3005. end;
  3006. inherited destroy;
  3007. end;
  3008. function trecorddef.getcopy : tstoreddef;
  3009. begin
  3010. result:=trecorddef.create(objrealname^,symtable.getcopy);
  3011. trecorddef(result).isunion:=isunion;
  3012. include(trecorddef(result).defoptions,df_copied_def);
  3013. if assigned(tcinitcode) then
  3014. trecorddef(result).tcinitcode:=tcinitcode.getcopy;
  3015. if assigned(import_lib) then
  3016. trecorddef(result).import_lib:=stringdup(import_lib^);
  3017. end;
  3018. function trecorddef.needs_inittable : boolean;
  3019. begin
  3020. needs_inittable:=trecordsymtable(symtable).needs_init_final
  3021. end;
  3022. function trecorddef.needs_separate_initrtti : boolean;
  3023. begin
  3024. result:=true;
  3025. end;
  3026. function trecorddef.is_related(d: tdef): boolean;
  3027. begin
  3028. { records are implemented via classes in the JVM target, and are
  3029. all descendents of the java_fpcbaserecordtype class }
  3030. is_related:=false;
  3031. if (target_info.system in systems_jvm) then
  3032. begin
  3033. if d.typ=objectdef then
  3034. begin
  3035. d:=find_real_class_definition(tobjectdef(d),false);
  3036. if (d=java_jlobject) or
  3037. (d=java_fpcbaserecordtype) then
  3038. is_related:=true
  3039. end;
  3040. end;
  3041. end;
  3042. procedure trecorddef.buildderef;
  3043. begin
  3044. inherited buildderef;
  3045. if df_copied_def in defoptions then
  3046. cloneddefderef.build(symtable.defowner)
  3047. else
  3048. tstoredsymtable(symtable).buildderef;
  3049. end;
  3050. procedure trecorddef.deref;
  3051. begin
  3052. inherited deref;
  3053. { now dereference the definitions }
  3054. if df_copied_def in defoptions then
  3055. begin
  3056. cloneddef:=trecorddef(cloneddefderef.resolve);
  3057. symtable:=cloneddef.symtable.getcopy;
  3058. end
  3059. else
  3060. tstoredsymtable(symtable).deref;
  3061. { assign TGUID? load only from system unit }
  3062. if not(assigned(rec_tguid)) and
  3063. (upper(typename)='TGUID') and
  3064. assigned(owner) and
  3065. assigned(owner.name) and
  3066. (owner.name^='SYSTEM') then
  3067. rec_tguid:=self;
  3068. { assign JMP_BUF? load only from system unit }
  3069. if not(assigned(rec_jmp_buf)) and
  3070. (upper(typename)='JMP_BUF') and
  3071. assigned(owner) and
  3072. assigned(owner.name) and
  3073. (owner.name^='SYSTEM') then
  3074. rec_jmp_buf:=self;
  3075. end;
  3076. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  3077. begin
  3078. inherited ppuwrite(ppufile);
  3079. if df_copied_def in defoptions then
  3080. ppufile.putderef(cloneddefderef)
  3081. else
  3082. begin
  3083. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  3084. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  3085. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  3086. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  3087. ppufile.putasizeint(trecordsymtable(symtable).datasize);
  3088. ppufile.putword(trecordsymtable(symtable).paddingsize);
  3089. end;
  3090. ppufile.writeentry(ibrecorddef);
  3091. if not(df_copied_def in defoptions) then
  3092. trecordsymtable(symtable).ppuwrite(ppufile);
  3093. end;
  3094. function trecorddef.size:asizeint;
  3095. begin
  3096. result:=trecordsymtable(symtable).datasize;
  3097. end;
  3098. function trecorddef.alignment:shortint;
  3099. begin
  3100. alignment:=trecordsymtable(symtable).recordalignment;
  3101. end;
  3102. function trecorddef.padalignment:shortint;
  3103. begin
  3104. padalignment := trecordsymtable(symtable).padalignment;
  3105. end;
  3106. function trecorddef.GetTypeName : string;
  3107. begin
  3108. GetTypeName:='<record type>'
  3109. end;
  3110. {***************************************************************************
  3111. TABSTRACTPROCDEF
  3112. ***************************************************************************}
  3113. constructor tabstractprocdef.create(dt:tdeftyp;level:byte);
  3114. begin
  3115. inherited create(dt);
  3116. parast:=tparasymtable.create(self,level);
  3117. paras:=nil;
  3118. minparacount:=0;
  3119. maxparacount:=0;
  3120. proctypeoption:=potype_none;
  3121. proccalloption:=pocall_none;
  3122. procoptions:=[];
  3123. returndef:=voidtype;
  3124. savesize:=sizeof(pint);
  3125. callerargareasize:=0;
  3126. calleeargareasize:=0;
  3127. has_paraloc_info:=callnoside;
  3128. funcretloc[callerside].init;
  3129. funcretloc[calleeside].init;
  3130. check_mark_as_nested;
  3131. end;
  3132. destructor tabstractprocdef.destroy;
  3133. begin
  3134. if assigned(paras) then
  3135. begin
  3136. {$ifdef MEMDEBUG}
  3137. memprocpara.start;
  3138. {$endif MEMDEBUG}
  3139. paras.free;
  3140. paras:=nil;
  3141. {$ifdef MEMDEBUG}
  3142. memprocpara.stop;
  3143. {$endif MEMDEBUG}
  3144. end;
  3145. if assigned(parast) then
  3146. begin
  3147. {$ifdef MEMDEBUG}
  3148. memprocparast.start;
  3149. {$endif MEMDEBUG}
  3150. parast.free;
  3151. parast:=nil;
  3152. {$ifdef MEMDEBUG}
  3153. memprocparast.stop;
  3154. {$endif MEMDEBUG}
  3155. end;
  3156. funcretloc[callerside].done;
  3157. funcretloc[calleeside].done;
  3158. inherited destroy;
  3159. end;
  3160. procedure tabstractprocdef.count_para(p:TObject;arg:pointer);
  3161. begin
  3162. if (tsym(p).typ<>paravarsym) then
  3163. exit;
  3164. inc(plongint(arg)^);
  3165. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  3166. begin
  3167. if not assigned(tparavarsym(p).defaultconstsym) then
  3168. inc(minparacount);
  3169. inc(maxparacount);
  3170. end;
  3171. end;
  3172. procedure tabstractprocdef.insert_para(p:TObject;arg:pointer);
  3173. begin
  3174. if (tsym(p).typ<>paravarsym) then
  3175. exit;
  3176. paras.add(p);
  3177. end;
  3178. procedure tabstractprocdef.calcparas;
  3179. var
  3180. paracount : longint;
  3181. begin
  3182. { This can already be assigned when
  3183. we need to reresolve this unit (PFV) }
  3184. if assigned(paras) then
  3185. paras.free;
  3186. paras:=tparalist.create(false);
  3187. paracount:=0;
  3188. minparacount:=0;
  3189. maxparacount:=0;
  3190. parast.SymList.ForEachCall(@count_para,@paracount);
  3191. paras.capacity:=paracount;
  3192. { Insert parameters in table }
  3193. parast.SymList.ForEachCall(@insert_para,nil);
  3194. { Order parameters }
  3195. paras.sortparas;
  3196. end;
  3197. procedure tabstractprocdef.buildderef;
  3198. begin
  3199. { released procdef? }
  3200. if not assigned(parast) then
  3201. exit;
  3202. inherited buildderef;
  3203. returndefderef.build(returndef);
  3204. if po_explicitparaloc in procoptions then
  3205. funcretloc[callerside].buildderef;
  3206. { parast }
  3207. tparasymtable(parast).buildderef;
  3208. end;
  3209. procedure tabstractprocdef.deref;
  3210. begin
  3211. inherited deref;
  3212. returndef:=tdef(returndefderef.resolve);
  3213. if po_explicitparaloc in procoptions then
  3214. begin
  3215. funcretloc[callerside].deref;
  3216. has_paraloc_info:=callerside;
  3217. end
  3218. else
  3219. begin
  3220. { deref is called after loading from a ppu, but also after another
  3221. unit has been reloaded/recompiled and all references must be
  3222. re-resolved. Since the funcretloc contains a reference to a tdef,
  3223. reset it so that we won't try to access the stale def }
  3224. funcretloc[callerside].init;
  3225. has_paraloc_info:=callnoside;
  3226. end;
  3227. { parast }
  3228. tparasymtable(parast).deref;
  3229. { recalculated parameters }
  3230. calcparas;
  3231. end;
  3232. constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  3233. begin
  3234. inherited ppuload(dt,ppufile);
  3235. parast:=nil;
  3236. Paras:=nil;
  3237. minparacount:=0;
  3238. maxparacount:=0;
  3239. ppufile.getderef(returndefderef);
  3240. { TODO: remove fpu_used loading}
  3241. ppufile.getbyte;
  3242. proctypeoption:=tproctypeoption(ppufile.getbyte);
  3243. proccalloption:=tproccalloption(ppufile.getbyte);
  3244. ppufile.getnormalset(procoptions);
  3245. funcretloc[callerside].init;
  3246. if po_explicitparaloc in procoptions then
  3247. funcretloc[callerside].ppuload(ppufile);
  3248. savesize:=sizeof(pint);
  3249. if (po_explicitparaloc in procoptions) then
  3250. has_paraloc_info:=callerside;
  3251. end;
  3252. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  3253. var
  3254. oldintfcrc : boolean;
  3255. begin
  3256. { released procdef? }
  3257. if not assigned(parast) then
  3258. exit;
  3259. inherited ppuwrite(ppufile);
  3260. ppufile.putderef(returndefderef);
  3261. oldintfcrc:=ppufile.do_interface_crc;
  3262. ppufile.do_interface_crc:=false;
  3263. ppufile.putbyte(0);
  3264. ppufile.putbyte(ord(proctypeoption));
  3265. ppufile.putbyte(ord(proccalloption));
  3266. ppufile.putnormalset(procoptions);
  3267. ppufile.do_interface_crc:=oldintfcrc;
  3268. if (po_explicitparaloc in procoptions) then
  3269. funcretloc[callerside].ppuwrite(ppufile);
  3270. end;
  3271. function tabstractprocdef.typename_paras(pno: tprocnameoptions) : ansistring;
  3272. var
  3273. hs,s : ansistring;
  3274. hp : TParavarsym;
  3275. hpc : tconstsym;
  3276. first : boolean;
  3277. i : integer;
  3278. begin
  3279. s:='';
  3280. first:=true;
  3281. for i:=0 to paras.count-1 do
  3282. begin
  3283. hp:=tparavarsym(paras[i]);
  3284. if not(vo_is_hidden_para in hp.varoptions) or
  3285. (pno_showhidden in pno) then
  3286. begin
  3287. if first then
  3288. begin
  3289. s:=s+'(';
  3290. first:=false;
  3291. end
  3292. else
  3293. s:=s+';';
  3294. if vo_is_hidden_para in hp.varoptions then
  3295. s:=s+'<';
  3296. case hp.varspez of
  3297. vs_var :
  3298. s:=s+'var ';
  3299. vs_const :
  3300. s:=s+'const ';
  3301. vs_out :
  3302. s:=s+'out ';
  3303. vs_constref :
  3304. s:=s+'constref ';
  3305. end;
  3306. if (pno_paranames in pno) then
  3307. s:=s+hp.realname+':';
  3308. if hp.univpara then
  3309. s:=s+'univ ';
  3310. if assigned(hp.vardef.typesym) then
  3311. begin
  3312. hs:=hp.vardef.typesym.realname;
  3313. if hs[1]<>'$' then
  3314. s:=s+hp.vardef.OwnerHierarchyName+hs
  3315. else
  3316. s:=s+hp.vardef.GetTypeName;
  3317. end
  3318. else
  3319. s:=s+hp.vardef.GetTypeName;
  3320. { default value }
  3321. if assigned(hp.defaultconstsym) then
  3322. begin
  3323. hpc:=tconstsym(hp.defaultconstsym);
  3324. hs:='';
  3325. case hpc.consttyp of
  3326. conststring,
  3327. constresourcestring :
  3328. begin
  3329. If hpc.value.len>0 then
  3330. begin
  3331. setLength(hs,hpc.value.len);
  3332. { don't write past the end of hs if the constant
  3333. is > 255 chars }
  3334. move(hpc.value.valueptr^,hs[1],length(hs));
  3335. { make sure that constant strings with newline chars
  3336. don't create a linebreak in the assembler code,
  3337. since comments are line-based. Also remove nulls
  3338. because the comments are written as a pchar. }
  3339. ReplaceCase(hs,#0,'.');
  3340. ReplaceCase(hs,#10,'.');
  3341. ReplaceCase(hs,#13,'.');
  3342. end;
  3343. end;
  3344. constreal :
  3345. str(pbestreal(hpc.value.valueptr)^,hs);
  3346. constpointer :
  3347. hs:=tostr(hpc.value.valueordptr);
  3348. constord :
  3349. begin
  3350. if is_boolean(hpc.constdef) then
  3351. begin
  3352. if hpc.value.valueord<>0 then
  3353. hs:='TRUE'
  3354. else
  3355. hs:='FALSE';
  3356. end
  3357. else
  3358. hs:=tostr(hpc.value.valueord);
  3359. end;
  3360. constnil :
  3361. hs:='nil';
  3362. constset :
  3363. hs:='<set>';
  3364. end;
  3365. if hs<>'' then
  3366. s:=s+'="'+hs+'"';
  3367. end;
  3368. if vo_is_hidden_para in hp.varoptions then
  3369. s:=s+'>';
  3370. end;
  3371. end;
  3372. if not first then
  3373. s:=s+')';
  3374. if (po_varargs in procoptions) then
  3375. s:=s+';VarArgs';
  3376. typename_paras:=s;
  3377. end;
  3378. function tabstractprocdef.is_methodpointer:boolean;
  3379. begin
  3380. result:=false;
  3381. end;
  3382. function tabstractprocdef.is_addressonly:boolean;
  3383. begin
  3384. result:=true;
  3385. end;
  3386. function tabstractprocdef.no_self_node: boolean;
  3387. begin
  3388. Result:=([po_staticmethod,po_classmethod]<=procoptions)or
  3389. (proctypeoption in [potype_class_constructor,potype_class_destructor,potype_operator]);
  3390. end;
  3391. function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef;
  3392. var
  3393. j, nestinglevel: longint;
  3394. pvs, npvs: tparavarsym;
  3395. csym, ncsym: tconstsym;
  3396. begin
  3397. nestinglevel:=parast.symtablelevel;
  3398. if newtyp=procdef then
  3399. begin
  3400. if (copytyp<>pc_bareproc) then
  3401. result:=tprocdef.create(nestinglevel)
  3402. else
  3403. result:=tprocdef.create(normal_function_level);
  3404. tprocdef(result).visibility:=vis_public;
  3405. end
  3406. else
  3407. begin
  3408. result:=tprocvardef.create(nestinglevel);
  3409. end;
  3410. tabstractprocdef(result).returndef:=returndef;
  3411. tabstractprocdef(result).returndefderef:=returndefderef;
  3412. pvs:=nil;
  3413. npvs:=nil;
  3414. for j:=0 to parast.symlist.count-1 do
  3415. begin
  3416. case tsym(parast.symlist[j]).typ of
  3417. paravarsym:
  3418. begin
  3419. pvs:=tparavarsym(parast.symlist[j]);
  3420. { in case of bare proc, don't copy self, vmt or framepointer
  3421. parameters }
  3422. if (copytyp=pc_bareproc) and
  3423. (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result]*pvs.varoptions)<>[]) then
  3424. continue;
  3425. npvs:=tparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
  3426. pvs.vardef,pvs.varoptions);
  3427. npvs.defaultconstsym:=pvs.defaultconstsym;
  3428. tabstractprocdef(result).parast.insert(npvs);
  3429. end;
  3430. constsym:
  3431. begin
  3432. // ignore, reuse original constym. Should also be duplicated
  3433. // be safe though
  3434. end;
  3435. symconst.typesym:
  3436. begin
  3437. // reuse original, part of generic declaration
  3438. end
  3439. else
  3440. internalerror(201160604);
  3441. end;
  3442. end;
  3443. tabstractprocdef(result).savesize:=savesize;
  3444. tabstractprocdef(result).proctypeoption:=proctypeoption;
  3445. tabstractprocdef(result).proccalloption:=proccalloption;
  3446. tabstractprocdef(result).procoptions:=procoptions;
  3447. if (copytyp=pc_bareproc) then
  3448. tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions*[po_explicitparaloc,po_hascallingconvention,po_varargs,po_iocheck,po_has_importname,po_has_importdll];
  3449. if newtyp=procvardef then
  3450. tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions-[po_has_importname,po_has_importdll];
  3451. tabstractprocdef(result).callerargareasize:=callerargareasize;
  3452. tabstractprocdef(result).calleeargareasize:=calleeargareasize;
  3453. tabstractprocdef(result).maxparacount:=maxparacount;
  3454. tabstractprocdef(result).minparacount:=minparacount;
  3455. if po_explicitparaloc in procoptions then
  3456. tabstractprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
  3457. { recalculate parameter info }
  3458. tabstractprocdef(result).has_paraloc_info:=callnoside;
  3459. {$ifdef m68k}
  3460. tabstractprocdef(result).exp_funcretloc:=exp_funcretloc;
  3461. {$endif}
  3462. if (typ=procdef) and
  3463. (newtyp=procvardef) and
  3464. (owner.symtabletype=ObjectSymtable) then
  3465. include(tprocvardef(result).procoptions,po_methodpointer);
  3466. end;
  3467. procedure tabstractprocdef.check_mark_as_nested;
  3468. begin
  3469. { nested procvars require that nested functions use the Delphi-style
  3470. nested procedure calling convention }
  3471. if (parast.symtablelevel>normal_function_level) and
  3472. (m_nested_procvars in current_settings.modeswitches) then
  3473. include(procoptions,po_delphi_nested_cc);
  3474. end;
  3475. procedure tabstractprocdef.init_paraloc_info(side: tcallercallee);
  3476. begin
  3477. if (side in [callerside,callbothsides]) and
  3478. not(has_paraloc_info in [callerside,callbothsides]) then
  3479. begin
  3480. callerargareasize:=paramanager.create_paraloc_info(self,callerside);
  3481. if has_paraloc_info in [calleeside,callbothsides] then
  3482. has_paraloc_info:=callbothsides
  3483. else
  3484. has_paraloc_info:=callerside;
  3485. end;
  3486. if (side in [calleeside,callbothsides]) and
  3487. not(has_paraloc_info in [calleeside,callbothsides]) then
  3488. begin
  3489. calleeargareasize:=paramanager.create_paraloc_info(self,calleeside);
  3490. if has_paraloc_info in [callerside,callbothsides] then
  3491. has_paraloc_info:=callbothsides
  3492. else
  3493. has_paraloc_info:=calleeside;
  3494. end;
  3495. end;
  3496. function tabstractprocdef.stack_tainting_parameter(side: tcallercallee): boolean;
  3497. var
  3498. p: tparavarsym;
  3499. ploc: PCGParalocation;
  3500. i: longint;
  3501. begin
  3502. result:=false;
  3503. init_paraloc_info(side);
  3504. for i:=0 to parast.SymList.Count-1 do
  3505. if tsym(parast.SymList[i]).typ=paravarsym then
  3506. begin
  3507. p:=tparavarsym(parast.SymList[i]);
  3508. { check if no parameter is located on the stack }
  3509. if is_open_array(p.vardef) or
  3510. is_array_of_const(p.vardef) then
  3511. begin
  3512. result:=true;
  3513. exit;
  3514. end;
  3515. ploc:=p.paraloc[side].location;
  3516. while assigned(ploc) do
  3517. begin
  3518. if (ploc^.loc=LOC_REFERENCE) then
  3519. begin
  3520. result:=true;
  3521. exit
  3522. end;
  3523. ploc:=ploc^.next;
  3524. end;
  3525. end;
  3526. end;
  3527. {***************************************************************************
  3528. TPROCDEF
  3529. ***************************************************************************}
  3530. constructor tprocdef.create(level:byte);
  3531. begin
  3532. inherited create(procdef,level);
  3533. localst:=tlocalsymtable.create(self,parast.symtablelevel);
  3534. {$ifdef symansistr}
  3535. _mangledname:='';
  3536. {$else symansistr}
  3537. _mangledname:=nil;
  3538. {$endif symansistr}
  3539. fileinfo:=current_filepos;
  3540. extnumber:=$ffff;
  3541. aliasnames:=TCmdStrList.create;
  3542. funcretsym:=nil;
  3543. forwarddef:=true;
  3544. interfacedef:=false;
  3545. hasforward:=false;
  3546. struct := nil;
  3547. import_dll:=nil;
  3548. import_name:=nil;
  3549. import_nr:=0;
  3550. inlininginfo:=nil;
  3551. deprecatedmsg:=nil;
  3552. {$ifdef i386}
  3553. fpu_used:=maxfpuregs;
  3554. {$endif i386}
  3555. interruptvector:=-1;
  3556. end;
  3557. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  3558. var
  3559. i,aliasnamescount : longint;
  3560. level : byte;
  3561. begin
  3562. inherited ppuload(procdef,ppufile);
  3563. {$ifdef symansistr}
  3564. if po_has_mangledname in procoptions then
  3565. _mangledname:=ppufile.getansistring
  3566. else
  3567. _mangledname:='';
  3568. {$else symansistr}
  3569. if po_has_mangledname in procoptions then
  3570. _mangledname:=stringdup(ppufile.getstring)
  3571. else
  3572. _mangledname:=nil;
  3573. {$endif symansistr}
  3574. extnumber:=ppufile.getword;
  3575. level:=ppufile.getbyte;
  3576. ppufile.getderef(structderef);
  3577. ppufile.getderef(procsymderef);
  3578. ppufile.getposinfo(fileinfo);
  3579. visibility:=tvisibility(ppufile.getbyte);
  3580. ppufile.getsmallset(symoptions);
  3581. if sp_has_deprecated_msg in symoptions then
  3582. deprecatedmsg:=stringdup(ppufile.getstring)
  3583. else
  3584. deprecatedmsg:=nil;
  3585. {$ifdef powerpc}
  3586. { library symbol for AmigaOS/MorphOS }
  3587. ppufile.getderef(libsymderef);
  3588. {$endif powerpc}
  3589. { import stuff }
  3590. if po_has_importdll in procoptions then
  3591. import_dll:=stringdup(ppufile.getstring)
  3592. else
  3593. import_dll:=nil;
  3594. if po_has_importname in procoptions then
  3595. import_name:=stringdup(ppufile.getstring)
  3596. else
  3597. import_name:=nil;
  3598. import_nr:=ppufile.getword;
  3599. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3600. if target_info.system in systems_interrupt_table then
  3601. interruptvector:=ppufile.getlongint;
  3602. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3603. if (po_msgint in procoptions) then
  3604. messageinf.i:=ppufile.getlongint;
  3605. if (po_msgstr in procoptions) then
  3606. messageinf.str:=stringdup(ppufile.getstring);
  3607. if (po_dispid in procoptions) then
  3608. dispid:=ppufile.getlongint;
  3609. { inline stuff }
  3610. if (po_has_inlininginfo in procoptions) then
  3611. begin
  3612. ppufile.getderef(funcretsymderef);
  3613. new(inlininginfo);
  3614. ppufile.getsmallset(inlininginfo^.flags);
  3615. end
  3616. else
  3617. begin
  3618. inlininginfo:=nil;
  3619. funcretsym:=nil;
  3620. end;
  3621. aliasnames:=TCmdStrList.create;
  3622. { count alias names }
  3623. aliasnamescount:=ppufile.getbyte;
  3624. for i:=1 to aliasnamescount do
  3625. aliasnames.insert(ppufile.getstring);
  3626. { load para symtable }
  3627. parast:=tparasymtable.create(self,level);
  3628. tparasymtable(parast).ppuload(ppufile);
  3629. { load local symtable }
  3630. if (po_has_inlininginfo in procoptions) then
  3631. begin
  3632. localst:=tlocalsymtable.create(self,level);
  3633. tlocalsymtable(localst).ppuload(ppufile);
  3634. end
  3635. else
  3636. localst:=nil;
  3637. { inline stuff }
  3638. if (po_has_inlininginfo in procoptions) then
  3639. inlininginfo^.code:=ppuloadnodetree(ppufile);
  3640. { default values for no persistent data }
  3641. if (cs_link_deffile in current_settings.globalswitches) and
  3642. (tf_need_export in target_info.flags) and
  3643. (po_exports in procoptions) then
  3644. deffile.AddExport(mangledname);
  3645. forwarddef:=false;
  3646. interfacedef:=false;
  3647. hasforward:=false;
  3648. { Disable po_has_inlining until the derefimpl is done }
  3649. exclude(procoptions,po_has_inlininginfo);
  3650. {$ifdef i386}
  3651. fpu_used:=maxfpuregs;
  3652. {$endif i386}
  3653. end;
  3654. destructor tprocdef.destroy;
  3655. begin
  3656. aliasnames.free;
  3657. aliasnames:=nil;
  3658. if assigned(localst) and
  3659. (localst.symtabletype<>staticsymtable) then
  3660. begin
  3661. {$ifdef MEMDEBUG}
  3662. memproclocalst.start;
  3663. {$endif MEMDEBUG}
  3664. localst.free;
  3665. localst:=nil;
  3666. {$ifdef MEMDEBUG}
  3667. memproclocalst.start;
  3668. {$endif MEMDEBUG}
  3669. end;
  3670. if assigned(inlininginfo) then
  3671. begin
  3672. {$ifdef MEMDEBUG}
  3673. memprocnodetree.start;
  3674. {$endif MEMDEBUG}
  3675. tnode(inlininginfo^.code).free;
  3676. {$ifdef MEMDEBUG}
  3677. memprocnodetree.start;
  3678. {$endif MEMDEBUG}
  3679. dispose(inlininginfo);
  3680. inlininginfo:=nil;
  3681. end;
  3682. {$ifdef jvm}
  3683. exprasmlist.free;
  3684. {$endif}
  3685. stringdispose(resultname);
  3686. stringdispose(import_dll);
  3687. stringdispose(import_name);
  3688. stringdispose(deprecatedmsg);
  3689. if (po_msgstr in procoptions) then
  3690. stringdispose(messageinf.str);
  3691. {$ifndef symansistr}
  3692. if assigned(_mangledname) then
  3693. begin
  3694. {$ifdef MEMDEBUG}
  3695. memmanglednames.start;
  3696. {$endif MEMDEBUG}
  3697. stringdispose(_mangledname);
  3698. {$ifdef MEMDEBUG}
  3699. memmanglednames.stop;
  3700. {$endif MEMDEBUG}
  3701. end;
  3702. {$endif symansistr}
  3703. inherited destroy;
  3704. end;
  3705. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  3706. var
  3707. oldintfcrc : boolean;
  3708. aliasnamescount : longint;
  3709. item : TCmdStrListItem;
  3710. begin
  3711. { released procdef? }
  3712. if not assigned(parast) then
  3713. exit;
  3714. inherited ppuwrite(ppufile);
  3715. {$ifdef symansistr}
  3716. if po_has_mangledname in procoptions then
  3717. ppufile.putansistring(_mangledname);
  3718. {$else symansistr}
  3719. if po_has_mangledname in procoptions then
  3720. ppufile.putstring(_mangledname^);
  3721. {$endif symansistr}
  3722. ppufile.putword(extnumber);
  3723. ppufile.putbyte(parast.symtablelevel);
  3724. ppufile.putderef(structderef);
  3725. ppufile.putderef(procsymderef);
  3726. ppufile.putposinfo(fileinfo);
  3727. ppufile.putbyte(byte(visibility));
  3728. ppufile.putsmallset(symoptions);
  3729. if sp_has_deprecated_msg in symoptions then
  3730. ppufile.putstring(deprecatedmsg^);
  3731. {$ifdef powerpc}
  3732. { library symbol for AmigaOS/MorphOS }
  3733. ppufile.putderef(libsymderef);
  3734. {$endif powerpc}
  3735. { import }
  3736. if po_has_importdll in procoptions then
  3737. ppufile.putstring(import_dll^);
  3738. if po_has_importname in procoptions then
  3739. ppufile.putstring(import_name^);
  3740. ppufile.putword(import_nr);
  3741. {$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3742. if target_info.system in systems_interrupt_table then
  3743. ppufile.putlongint(interruptvector);
  3744. {$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE}
  3745. if (po_msgint in procoptions) then
  3746. ppufile.putlongint(messageinf.i);
  3747. if (po_msgstr in procoptions) then
  3748. ppufile.putstring(messageinf.str^);
  3749. if (po_dispid in procoptions) then
  3750. ppufile.putlongint(dispid);
  3751. { inline stuff }
  3752. oldintfcrc:=ppufile.do_crc;
  3753. ppufile.do_crc:=false;
  3754. if (po_has_inlininginfo in procoptions) then
  3755. begin
  3756. ppufile.putderef(funcretsymderef);
  3757. ppufile.putsmallset(inlininginfo^.flags);
  3758. end;
  3759. { count alias names }
  3760. aliasnamescount:=0;
  3761. item:=TCmdStrListItem(aliasnames.first);
  3762. while assigned(item) do
  3763. begin
  3764. inc(aliasnamescount);
  3765. item:=TCmdStrListItem(item.next);
  3766. end;
  3767. if aliasnamescount>255 then
  3768. internalerror(200711021);
  3769. ppufile.putbyte(aliasnamescount);
  3770. item:=TCmdStrListItem(aliasnames.first);
  3771. while assigned(item) do
  3772. begin
  3773. ppufile.putstring(item.str);
  3774. item:=TCmdStrListItem(item.next);
  3775. end;
  3776. ppufile.do_crc:=oldintfcrc;
  3777. { write this entry }
  3778. ppufile.writeentry(ibprocdef);
  3779. { Save the para symtable, this is taken from the interface }
  3780. tparasymtable(parast).ppuwrite(ppufile);
  3781. { save localsymtable for inline procedures or when local
  3782. browser info is requested, this has no influence on the crc }
  3783. if (po_has_inlininginfo in procoptions) then
  3784. begin
  3785. oldintfcrc:=ppufile.do_crc;
  3786. ppufile.do_crc:=false;
  3787. tlocalsymtable(localst).ppuwrite(ppufile);
  3788. ppufile.do_crc:=oldintfcrc;
  3789. end;
  3790. { node tree for inlining }
  3791. oldintfcrc:=ppufile.do_crc;
  3792. ppufile.do_crc:=false;
  3793. if (po_has_inlininginfo in procoptions) then
  3794. ppuwritenodetree(ppufile,inlininginfo^.code);
  3795. ppufile.do_crc:=oldintfcrc;
  3796. end;
  3797. function tprocdef.fullprocname(showhidden:boolean):string;
  3798. var
  3799. pno: tprocnameoptions;
  3800. begin
  3801. pno:=[];
  3802. if showhidden then
  3803. include(pno,pno_showhidden);
  3804. result:=customprocname(pno);
  3805. end;
  3806. function tprocdef.customprocname(pno: tprocnameoptions):ansistring;
  3807. var
  3808. s, rn : ansistring;
  3809. t : ttoken;
  3810. begin
  3811. {$ifdef EXTDEBUG}
  3812. include(pno,pno_showhidden);
  3813. {$endif EXTDEBUG}
  3814. s:='';
  3815. if proctypeoption=potype_operator then
  3816. begin
  3817. for t:=NOTOKEN to last_overloaded do
  3818. if procsym.realname='$'+overloaded_names[t] then
  3819. begin
  3820. s:='operator ';
  3821. if (pno_ownername in pno) and
  3822. assigned(struct) then
  3823. s:=s+struct.RttiName+'.';
  3824. s:=s+arraytokeninfo[t].str+typename_paras(pno);
  3825. break;
  3826. end;
  3827. end
  3828. else
  3829. begin
  3830. if (po_classmethod in procoptions) and
  3831. not(pno_noclassmarker in pno) then
  3832. s:='class ';
  3833. case proctypeoption of
  3834. potype_constructor,
  3835. potype_class_constructor:
  3836. s:=s+'constructor ';
  3837. potype_class_destructor,
  3838. potype_destructor:
  3839. s:=s+'destructor ';
  3840. else
  3841. if (pno_proctypeoption in pno) and
  3842. assigned(returndef) and
  3843. not(is_void(returndef)) then
  3844. s:=s+'function '
  3845. else
  3846. s:=s+'procedure ';
  3847. end;
  3848. if (pno_ownername in pno) and
  3849. (owner.symtabletype in [recordsymtable,objectsymtable]) then
  3850. s:=s+tabstractrecorddef(owner.defowner).RttiName+'.';
  3851. rn:=procsym.realname;
  3852. if (pno_noleadingdollar in pno) and
  3853. (rn[1]='$') then
  3854. delete(rn,1,1);
  3855. s:=s+rn+typename_paras(pno);
  3856. end;
  3857. if not(proctypeoption in [potype_constructor,potype_destructor,
  3858. potype_class_constructor,potype_class_destructor]) and
  3859. assigned(returndef) and
  3860. not(is_void(returndef)) then
  3861. s:=s+':'+returndef.GetTypeName;
  3862. if owner.symtabletype=localsymtable then
  3863. s:=s+' is nested';
  3864. s:=s+';';
  3865. { forced calling convention? }
  3866. if (po_hascallingconvention in procoptions) then
  3867. s:=s+' '+ProcCallOptionStr[proccalloption]+';';
  3868. if (po_staticmethod in procoptions) and
  3869. not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
  3870. s:=s+' Static;';
  3871. customprocname:=s;
  3872. end;
  3873. function tprocdef.is_methodpointer:boolean;
  3874. begin
  3875. { don't check assigned(_class), that's also the case for nested
  3876. procedures inside methods }
  3877. result:=owner.symtabletype=ObjectSymtable;
  3878. end;
  3879. function tprocdef.is_addressonly:boolean;
  3880. begin
  3881. result:=assigned(owner) and
  3882. (owner.symtabletype<>ObjectSymtable) and
  3883. (not(m_nested_procvars in current_settings.modeswitches) or
  3884. not is_nested_pd(self));
  3885. end;
  3886. procedure tprocdef.make_external;
  3887. begin
  3888. include(procoptions,po_external);
  3889. forwarddef:=false;
  3890. end;
  3891. function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
  3892. begin
  3893. case t of
  3894. gs_local :
  3895. GetSymtable:=localst;
  3896. gs_para :
  3897. GetSymtable:=parast;
  3898. else
  3899. GetSymtable:=nil;
  3900. end;
  3901. end;
  3902. function tprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
  3903. var
  3904. i : tcallercallee;
  3905. j : longint;
  3906. pvs : tparavarsym;
  3907. begin
  3908. result:=inherited getcopyas(newtyp,copytyp);
  3909. if newtyp=procvardef then
  3910. exit;
  3911. { don't copy mangled name, can be different }
  3912. tprocdef(result).messageinf:=messageinf;
  3913. tprocdef(result).dispid:=dispid;
  3914. if po_msgstr in procoptions then
  3915. tprocdef(result).messageinf.str:=stringdup(messageinf.str^);
  3916. tprocdef(result).symoptions:=symoptions;
  3917. if assigned(deprecatedmsg) then
  3918. tprocdef(result).deprecatedmsg:=stringdup(deprecatedmsg^);
  3919. { will have to be associated with appropriate procsym }
  3920. tprocdef(result).procsym:=nil;
  3921. if copytyp<>pc_bareproc then
  3922. tprocdef(result).aliasnames.concatListcopy(aliasnames);
  3923. if assigned(funcretsym) then
  3924. begin
  3925. if funcretsym.owner=parast then
  3926. begin
  3927. j:=parast.symlist.indexof(funcretsym);
  3928. if j<0 then
  3929. internalerror(2011040606);
  3930. tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
  3931. end
  3932. else if funcretsym.owner=localst then
  3933. begin
  3934. { nothing to do, will be inserted for the new procdef while
  3935. parsing its body (by pdecsub.insert_funcret_local) }
  3936. end
  3937. else
  3938. internalerror(2011040605);
  3939. end;
  3940. { will have to be associated with a new struct }
  3941. tprocdef(result).struct:=nil;
  3942. {$if defined(powerpc) or defined(m68k)}
  3943. tprocdef(result).libsym:=libsym;
  3944. {$endif powerpc or m68k}
  3945. if assigned(resultname) then
  3946. tprocdef(result).resultname:=stringdup(resultname^);
  3947. if assigned(import_dll) then
  3948. tprocdef(result).import_dll:=stringdup(import_dll^);
  3949. if assigned(import_name) then
  3950. tprocdef(result).import_name:=stringdup(import_name^);
  3951. tprocdef(result).import_nr:=import_nr;
  3952. tprocdef(result).extnumber:=$ffff;
  3953. {$ifdef i386}
  3954. tprocdef(result).fpu_used:=fpu_used;
  3955. {$endif i386}
  3956. tprocdef(result).visibility:=visibility;
  3957. tprocdef(result).synthetickind:=synthetickind;
  3958. { we need a separate implementation for the copied def }
  3959. tprocdef(result).forwarddef:=true;
  3960. tprocdef(result).interfacedef:=true;
  3961. { create new paralist }
  3962. tprocdef(result).calcparas;
  3963. end;
  3964. function tprocdef.getcopy: tstoreddef;
  3965. begin
  3966. result:=getcopyas(procdef,pc_normal);
  3967. end;
  3968. procedure tprocdef.buildderef;
  3969. begin
  3970. inherited buildderef;
  3971. structderef.build(struct);
  3972. { procsym that originaly defined this definition, should be in the
  3973. same symtable }
  3974. procsymderef.build(procsym);
  3975. {$ifdef powerpc}
  3976. { library symbol for AmigaOS/MorphOS }
  3977. libsymderef.build(libsym);
  3978. {$endif powerpc}
  3979. end;
  3980. procedure tprocdef.buildderefimpl;
  3981. begin
  3982. inherited buildderefimpl;
  3983. { Localst is not available for main/unit init }
  3984. if assigned(localst) then
  3985. begin
  3986. tlocalsymtable(localst).buildderef;
  3987. tlocalsymtable(localst).buildderefimpl;
  3988. end;
  3989. { inline tree }
  3990. if (po_has_inlininginfo in procoptions) then
  3991. begin
  3992. funcretsymderef.build(funcretsym);
  3993. inlininginfo^.code.buildderefimpl;
  3994. end;
  3995. end;
  3996. procedure tprocdef.deref;
  3997. begin
  3998. inherited deref;
  3999. struct:=tabstractrecorddef(structderef.resolve);
  4000. { procsym that originaly defined this definition, should be in the
  4001. same symtable }
  4002. procsym:=tprocsym(procsymderef.resolve);
  4003. {$ifdef powerpc}
  4004. { library symbol for AmigaOS/MorphOS }
  4005. libsym:=tsym(libsymderef.resolve);
  4006. {$endif powerpc}
  4007. end;
  4008. procedure tprocdef.derefimpl;
  4009. begin
  4010. { Enable has_inlininginfo when the inlininginfo
  4011. structure is available. The has_inlininginfo was disabled
  4012. after the load, since the data was invalid }
  4013. if assigned(inlininginfo) then
  4014. include(procoptions,po_has_inlininginfo);
  4015. { Locals }
  4016. if assigned(localst) then
  4017. begin
  4018. tlocalsymtable(localst).deref;
  4019. tlocalsymtable(localst).derefimpl;
  4020. end;
  4021. { Inline }
  4022. if (po_has_inlininginfo in procoptions) then
  4023. begin
  4024. inlininginfo^.code.derefimpl;
  4025. { funcretsym, this is always located in the localst }
  4026. funcretsym:=tsym(funcretsymderef.resolve);
  4027. end
  4028. else
  4029. begin
  4030. { safety }
  4031. { Not safe! A unit may be reresolved after its interface has been
  4032. parsed but before its implementation has been parsed, and in that
  4033. case the funcretsym is still required!
  4034. funcretsym:=nil; }
  4035. end;
  4036. end;
  4037. function tprocdef.GetTypeName : string;
  4038. begin
  4039. GetTypeName := FullProcName(false);
  4040. end;
  4041. function tprocdef.mangledname : TSymStr;
  4042. begin
  4043. {$ifdef symansistr}
  4044. if _mangledname<>'' then
  4045. {$else symansistr}
  4046. if assigned(_mangledname) then
  4047. {$endif symansistr}
  4048. begin
  4049. {$ifdef compress}
  4050. {$error add support for ansistrings in case of symansistr}
  4051. mangledname:=minilzw_decode(_mangledname^);
  4052. {$else}
  4053. {$ifdef symansistr}
  4054. mangledname:=_mangledname;
  4055. {$else symansistr}
  4056. mangledname:=_mangledname^;
  4057. {$endif symansistr}
  4058. {$endif}
  4059. exit;
  4060. end;
  4061. {$ifndef jvm}
  4062. mangledname:=defaultmangledname;
  4063. {$else not jvm}
  4064. mangledname:=jvmmangledbasename(false);
  4065. if (po_has_importdll in procoptions) then
  4066. begin
  4067. { import_dll comes from "external 'import_dll_name' name 'external_name'" }
  4068. if assigned(import_dll) then
  4069. mangledname:=import_dll^+'/'+mangledname
  4070. else
  4071. internalerror(2010122607);
  4072. end
  4073. else
  4074. jvmaddtypeownerprefix(owner,mangledname);
  4075. {$endif not jvm}
  4076. {$ifdef compress}
  4077. {$error add support for ansistrings in case of symansistr}
  4078. _mangledname:=stringdup(minilzw_encode(mangledname));
  4079. {$else}
  4080. {$ifdef symansistr}
  4081. _mangledname:=mangledname;
  4082. {$else symansistr}
  4083. _mangledname:=stringdup(mangledname);
  4084. {$endif symansistr}
  4085. {$endif}
  4086. end;
  4087. function tprocdef.defaultmangledname: TSymStr;
  4088. var
  4089. hp : TParavarsym;
  4090. hs : TSymStr;
  4091. crc : dword;
  4092. newlen,
  4093. oldlen,
  4094. i : integer;
  4095. begin
  4096. { we need to use the symtable where the procsym is inserted,
  4097. because that is visible to the world }
  4098. defaultmangledname:=make_mangledname('',procsym.owner,procsym.name);
  4099. oldlen:=length(defaultmangledname);
  4100. { add parameter types }
  4101. for i:=0 to paras.count-1 do
  4102. begin
  4103. hp:=tparavarsym(paras[i]);
  4104. if not(vo_is_hidden_para in hp.varoptions) then
  4105. defaultmangledname:=defaultmangledname+'$'+hp.vardef.mangledparaname;
  4106. end;
  4107. { add resultdef, add $$ as separator to make it unique from a
  4108. parameter separator }
  4109. if not is_void(returndef) then
  4110. defaultmangledname:=defaultmangledname+'$$'+returndef.mangledparaname;
  4111. newlen:=length(defaultmangledname);
  4112. { Replace with CRC if the parameter line is very long }
  4113. if (newlen-oldlen>12) and
  4114. ((newlen>100) or (newlen-oldlen>64)) then
  4115. begin
  4116. crc:=0;
  4117. for i:=0 to paras.count-1 do
  4118. begin
  4119. hp:=tparavarsym(paras[i]);
  4120. if not(vo_is_hidden_para in hp.varoptions) then
  4121. begin
  4122. hs:=hp.vardef.mangledparaname;
  4123. crc:=UpdateCrc32(crc,hs[1],length(hs));
  4124. end;
  4125. end;
  4126. hs:=hp.vardef.mangledparaname;
  4127. crc:=UpdateCrc32(crc,hs[1],length(hs));
  4128. defaultmangledname:=Copy(defaultmangledname,1,oldlen)+'$crc'+hexstr(crc,8);
  4129. end;
  4130. end;
  4131. function tprocdef.cplusplusmangledname : TSymStr;
  4132. function getcppparaname(p : tdef) : TSymStr;
  4133. const
  4134. {$ifdef NAMEMANGLING_GCC2}
  4135. ordtype2str : array[tordtype] of string[2] = (
  4136. '',
  4137. 'Uc','Us','Ui','Us',
  4138. 'Sc','s','i','x',
  4139. 'b','b','b','b','b',
  4140. 'c','w','x');
  4141. {$else NAMEMANGLING_GCC2}
  4142. ordtype2str : array[tordtype] of string[1] = (
  4143. 'v',
  4144. 'h','t','j','y',
  4145. 'a','s','i','x',
  4146. 'b','b','b','b',
  4147. 'b','b','b','b',
  4148. 'c','w','x');
  4149. floattype2str : array[tfloattype] of string[1] = (
  4150. 'f','d','e','e',
  4151. 'd','d','g');
  4152. {$endif NAMEMANGLING_GCC2}
  4153. var
  4154. s : TSymStr;
  4155. begin
  4156. case p.typ of
  4157. orddef:
  4158. s:=ordtype2str[torddef(p).ordtype];
  4159. pointerdef:
  4160. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  4161. {$ifndef NAMEMANGLING_GCC2}
  4162. floatdef:
  4163. s:=floattype2str[tfloatdef(p).floattype];
  4164. {$endif NAMEMANGLING_GCC2}
  4165. else
  4166. internalerror(2103001);
  4167. end;
  4168. getcppparaname:=s;
  4169. end;
  4170. var
  4171. s,s2 : TSymStr;
  4172. hp : TParavarsym;
  4173. i : integer;
  4174. begin
  4175. {$ifdef NAMEMANGLING_GCC2}
  4176. { outdated gcc 2.x name mangling scheme }
  4177. s := procsym.realname;
  4178. if procsym.owner.symtabletype=ObjectSymtable then
  4179. begin
  4180. s2:=upper(tobjectdef(procsym.owner.defowner).objrealname^);
  4181. case proctypeoption of
  4182. potype_destructor:
  4183. s:='_$_'+tostr(length(s2))+s2;
  4184. potype_constructor:
  4185. s:='___'+tostr(length(s2))+s2;
  4186. else
  4187. s:='_'+s+'__'+tostr(length(s2))+s2;
  4188. end;
  4189. end
  4190. else s:=s+'__';
  4191. s:=s+'F';
  4192. { concat modifiers }
  4193. { !!!!! }
  4194. { now we handle the parameters }
  4195. if maxparacount>0 then
  4196. begin
  4197. for i:=0 to paras.count-1 do
  4198. begin
  4199. hp:=tparavarsym(paras[i]);
  4200. { no hidden parameters form part of a C++ mangled name:
  4201. a) self is not included
  4202. b) there are no "high" or other hidden parameters
  4203. }
  4204. if vo_is_hidden_para in hp.varoptions then
  4205. continue;
  4206. s2:=getcppparaname(hp.vardef);
  4207. if hp.varspez in [vs_var,vs_out] then
  4208. s2:='R'+s2;
  4209. s:=s+s2;
  4210. end;
  4211. end
  4212. else
  4213. s:=s+'v';
  4214. cplusplusmangledname:=s;
  4215. {$else NAMEMANGLING_GCC2}
  4216. { gcc 3.x and 4.x name mangling scheme }
  4217. { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling }
  4218. if procsym.owner.symtabletype=ObjectSymtable then
  4219. begin
  4220. s:='_ZN';
  4221. s2:=tobjectdef(procsym.owner.defowner).objextname^;
  4222. s:=s+tostr(length(s2))+s2;
  4223. case proctypeoption of
  4224. potype_constructor:
  4225. s:=s+'C1';
  4226. potype_destructor:
  4227. s:=s+'D1';
  4228. else
  4229. s:=s+tostr(length(procsym.realname))+procsym.realname;
  4230. end;
  4231. s:=s+'E';
  4232. end
  4233. else
  4234. s:=procsym.realname;
  4235. { now we handle the parameters }
  4236. if maxparacount>0 then
  4237. begin
  4238. for i:=0 to paras.count-1 do
  4239. begin
  4240. hp:=tparavarsym(paras[i]);
  4241. { no hidden parameters form part of a C++ mangled name:
  4242. a) self is not included
  4243. b) there are no "high" or other hidden parameters
  4244. }
  4245. if vo_is_hidden_para in hp.varoptions then
  4246. continue;
  4247. s2:=getcppparaname(hp.vardef);
  4248. if hp.varspez in [vs_var,vs_out] then
  4249. s2:='R'+s2;
  4250. s:=s+s2;
  4251. end;
  4252. end
  4253. else
  4254. s:=s+'v';
  4255. cplusplusmangledname:=s;
  4256. {$endif NAMEMANGLING_GCC2}
  4257. end;
  4258. function tprocdef.objcmangledname : TSymStr;
  4259. var
  4260. manglednamelen: longint;
  4261. iscatmethod : boolean;
  4262. begin
  4263. if not (po_msgstr in procoptions) then
  4264. internalerror(2009030901);
  4265. { we may very well need longer strings to handle these... }
  4266. manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+
  4267. length('+"[ ]"')+length(messageinf.str^);
  4268. iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions;
  4269. if (iscatmethod) then
  4270. inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()'));
  4271. if manglednamelen>255 then
  4272. Message1(parser_e_objc_message_name_too_long,messageinf.str^);
  4273. if not(po_classmethod in procoptions) then
  4274. result:='"-['
  4275. else
  4276. result:='"+[';
  4277. { quotes are necessary because the +/- otherwise confuse the assembler
  4278. into expecting a number
  4279. }
  4280. if iscatmethod then
  4281. result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'(';
  4282. result:=result+tobjectdef(procsym.owner.defowner).objextname^;
  4283. if iscatmethod then
  4284. result:=result+')';
  4285. result:=result+' '+messageinf.str^+']"';
  4286. end;
  4287. {$ifdef jvm}
  4288. function tprocdef.jvmmangledbasename(signature: boolean): TSymStr;
  4289. var
  4290. vs: tparavarsym;
  4291. i: longint;
  4292. founderror: tdef;
  4293. tmpresult: TSymStr;
  4294. container: tsymtable;
  4295. begin
  4296. { format:
  4297. * method definition (in Jasmin):
  4298. (private|protected|public) [static] method(parametertypes)returntype
  4299. * method invocation
  4300. package/class/method(parametertypes)returntype
  4301. -> store common part: method(parametertypes)returntype and
  4302. adorn as required when using it.
  4303. }
  4304. if not signature then
  4305. begin
  4306. { method name }
  4307. { special names for constructors and class constructors }
  4308. if proctypeoption=potype_constructor then
  4309. tmpresult:='<init>'
  4310. else if proctypeoption in [potype_class_constructor,potype_unitinit] then
  4311. tmpresult:='<clinit>'
  4312. else if po_has_importname in procoptions then
  4313. begin
  4314. if assigned(import_name) then
  4315. tmpresult:=import_name^
  4316. else
  4317. internalerror(2010122608);
  4318. end
  4319. else
  4320. begin
  4321. tmpresult:=procsym.realname;
  4322. if tmpresult[1]='$' then
  4323. tmpresult:=copy(tmpresult,2,length(tmpresult)-1);
  4324. { nested functions }
  4325. container:=owner;
  4326. while container.symtabletype=localsymtable do
  4327. begin
  4328. tmpresult:='$'+tprocdef(owner.defowner).procsym.realname+'$'+tostr(tprocdef(owner.defowner).procsym.symid)+'$'+tmpresult;
  4329. container:=container.defowner.owner;
  4330. end;
  4331. end;
  4332. end
  4333. else
  4334. tmpresult:='';
  4335. { parameter types }
  4336. tmpresult:=tmpresult+'(';
  4337. { not the case for the main program (not required for defaultmangledname
  4338. because setmangledname() is called for the main program; in case of
  4339. the JVM, this only sets the importname, however) }
  4340. if assigned(paras) then
  4341. begin
  4342. init_paraloc_info(callerside);
  4343. for i:=0 to paras.count-1 do
  4344. begin
  4345. vs:=tparavarsym(paras[i]);
  4346. { function result is not part of the mangled name }
  4347. if vo_is_funcret in vs.varoptions then
  4348. continue;
  4349. { self pointer neither, except for class methods (the JVM only
  4350. supports static class methods natively, so the self pointer
  4351. here is a regular parameter as far as the JVM is concerned }
  4352. if not(po_classmethod in procoptions) and
  4353. (vo_is_self in vs.varoptions) then
  4354. continue;
  4355. { passing by reference is emulated by passing an array of one
  4356. element containing the value; for types that aren't pointers
  4357. in regular Pascal, simply passing the underlying pointer type
  4358. does achieve regular call-by-reference semantics though;
  4359. formaldefs always have to be passed like that because their
  4360. contents can be replaced }
  4361. if paramanager.push_copyout_param(vs.varspez,vs.vardef,proccalloption) then
  4362. tmpresult:=tmpresult+'[';
  4363. { Add the parameter type. }
  4364. if not jvmaddencodedtype(vs.vardef,false,tmpresult,signature,founderror) then
  4365. { an internalerror here is also triggered in case of errors in the source code }
  4366. tmpresult:='<error>';
  4367. end;
  4368. end;
  4369. tmpresult:=tmpresult+')';
  4370. { And the type of the function result (void in case of a procedure and
  4371. constructor). }
  4372. if (proctypeoption in [potype_constructor,potype_class_constructor]) then
  4373. jvmaddencodedtype(voidtype,false,tmpresult,signature,founderror)
  4374. else if not jvmaddencodedtype(returndef,false,tmpresult,signature,founderror) then
  4375. { an internalerror here is also triggered in case of errors in the source code }
  4376. tmpresult:='<error>';
  4377. result:=tmpresult;
  4378. end;
  4379. {$endif jvm}
  4380. procedure tprocdef.setmangledname(const s : TSymStr);
  4381. begin
  4382. { This is not allowed anymore, the forward declaration
  4383. already needs to create the correct mangledname, no changes
  4384. afterwards are allowed (PFV) }
  4385. { Exception: interface definitions in mode macpas, since in that }
  4386. { case no reference to the old name can exist yet (JM) }
  4387. {$ifdef symansistr}
  4388. if _mangledname<>'' then
  4389. if ((m_mac in current_settings.modeswitches) and
  4390. (interfacedef)) then
  4391. _mangledname:=''
  4392. else
  4393. internalerror(200411171);
  4394. {$else symansistr}
  4395. if assigned(_mangledname) then
  4396. if ((m_mac in current_settings.modeswitches) and
  4397. (interfacedef)) then
  4398. stringdispose(_mangledname)
  4399. else
  4400. internalerror(200411171);
  4401. {$endif symansistr}
  4402. {$ifdef jvm}
  4403. { this routine can be called for compilerproces. can't set mangled
  4404. name since it must be calculated, but it uses import_name when set
  4405. -> set that one }
  4406. import_name:=stringdup(s);
  4407. include(procoptions,po_has_importname);
  4408. include(procoptions,po_has_mangledname);
  4409. {$else}
  4410. {$ifdef compress}
  4411. {$error add support for symansistr}
  4412. _mangledname:=stringdup(minilzw_encode(s));
  4413. {$else}
  4414. {$ifdef symansistr}
  4415. _mangledname:=s;
  4416. {$else symansistr}
  4417. _mangledname:=stringdup(s);
  4418. {$endif symansistr}
  4419. {$endif}
  4420. {$endif jvm}
  4421. include(procoptions,po_has_mangledname);
  4422. end;
  4423. {***************************************************************************
  4424. TPROCVARDEF
  4425. ***************************************************************************}
  4426. constructor tprocvardef.create(level:byte);
  4427. begin
  4428. inherited create(procvardef,level);
  4429. end;
  4430. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  4431. begin
  4432. inherited ppuload(procvardef,ppufile);
  4433. { load para symtable }
  4434. parast:=tparasymtable.create(self,ppufile.getbyte);
  4435. {$ifdef jvm}
  4436. ppufile.getderef(classdefderef);
  4437. {$endif}
  4438. tparasymtable(parast).ppuload(ppufile);
  4439. end;
  4440. function tprocvardef.getcopy : tstoreddef;
  4441. var
  4442. i : tcallercallee;
  4443. j : longint;
  4444. begin
  4445. result:=tprocvardef.create(parast.symtablelevel);
  4446. tprocvardef(result).returndef:=returndef;
  4447. tprocvardef(result).returndefderef:=returndefderef;
  4448. tprocvardef(result).parast:=parast.getcopy;
  4449. tprocvardef(result).savesize:=savesize;
  4450. { create paralist copy }
  4451. tprocvardef(result).paras:=tparalist.create(false);
  4452. tprocvardef(result).paras.count:=paras.count;
  4453. for j:=0 to paras.count-1 do
  4454. tprocvardef(result).paras[j]:=paras[j];
  4455. tprocvardef(result).proctypeoption:=proctypeoption;
  4456. tprocvardef(result).proccalloption:=proccalloption;
  4457. tprocvardef(result).procoptions:=procoptions;
  4458. tprocvardef(result).callerargareasize:=callerargareasize;
  4459. tprocvardef(result).calleeargareasize:=calleeargareasize;
  4460. tprocvardef(result).maxparacount:=maxparacount;
  4461. tprocvardef(result).minparacount:=minparacount;
  4462. for i:=low(tcallercallee) to high(tcallercallee) do
  4463. tprocvardef(result).funcretloc[i]:=funcretloc[i].getcopy;
  4464. tprocvardef(result).has_paraloc_info:=has_paraloc_info;
  4465. {$ifdef m68k}
  4466. tprocvardef(result).exp_funcretloc:=exp_funcretloc;
  4467. {$endif}
  4468. {$ifdef jvm}
  4469. tprocvardef(result).classdef:=classdef;
  4470. {$endif}
  4471. end;
  4472. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  4473. begin
  4474. inherited ppuwrite(ppufile);
  4475. { Save the para symtable level (necessary to distinguish nested
  4476. procvars) }
  4477. ppufile.putbyte(parast.symtablelevel);
  4478. {$ifdef jvm}
  4479. ppufile.putderef(classdefderef);
  4480. {$endif}
  4481. { Write this entry }
  4482. ppufile.writeentry(ibprocvardef);
  4483. { Save the para symtable, this is taken from the interface }
  4484. tparasymtable(parast).ppuwrite(ppufile);
  4485. end;
  4486. {$ifdef jvm}
  4487. procedure tprocvardef.buildderef;
  4488. begin
  4489. inherited buildderef;
  4490. classdefderef.build(classdef);
  4491. end;
  4492. procedure tprocvardef.deref;
  4493. begin
  4494. inherited deref;
  4495. classdef:=tobjectdef(classdefderef.resolve);
  4496. end;
  4497. {$endif}
  4498. function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
  4499. begin
  4500. case t of
  4501. gs_para :
  4502. GetSymtable:=parast;
  4503. else
  4504. GetSymtable:=nil;
  4505. end;
  4506. end;
  4507. function tprocvardef.size : asizeint;
  4508. begin
  4509. if ((po_methodpointer in procoptions) or
  4510. is_nested_pd(self)) and
  4511. not(po_addressonly in procoptions) then
  4512. size:=2*sizeof(pint)
  4513. else
  4514. size:=sizeof(pint);
  4515. end;
  4516. function tprocvardef.is_methodpointer:boolean;
  4517. begin
  4518. result:=(po_methodpointer in procoptions);
  4519. end;
  4520. function tprocvardef.is_addressonly:boolean;
  4521. begin
  4522. result:=(not(po_methodpointer in procoptions) and
  4523. not is_nested_pd(self)) or
  4524. (po_addressonly in procoptions);
  4525. end;
  4526. function tprocvardef.getmangledparaname:TSymStr;
  4527. begin
  4528. if not(po_methodpointer in procoptions) then
  4529. if not is_nested_pd(self) then
  4530. result:='procvar'
  4531. else
  4532. result:='nestedprovar'
  4533. else
  4534. result:='procvarofobj'
  4535. end;
  4536. function tprocvardef.is_publishable : boolean;
  4537. begin
  4538. is_publishable:=(po_methodpointer in procoptions);
  4539. end;
  4540. function tprocvardef.GetTypeName : string;
  4541. var
  4542. s: string;
  4543. pno : tprocnameoptions;
  4544. begin
  4545. {$ifdef EXTDEBUG}
  4546. pno:=[pno_showhidden];
  4547. {$else EXTDEBUG}
  4548. pno:=[];
  4549. {$endif EXTDEBUG}
  4550. s:='<';
  4551. if po_classmethod in procoptions then
  4552. s := s+'class method type of'
  4553. else
  4554. if po_addressonly in procoptions then
  4555. s := s+'address of'
  4556. else
  4557. s := s+'procedure variable type of';
  4558. if assigned(returndef) and
  4559. (returndef<>voidtype) then
  4560. s:=s+' function'+typename_paras(pno)+':'+returndef.GetTypeName
  4561. else
  4562. s:=s+' procedure'+typename_paras(pno);
  4563. if po_methodpointer in procoptions then
  4564. s := s+' of object';
  4565. if is_nested_pd(self) then
  4566. s := s+' is nested';
  4567. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  4568. end;
  4569. {***************************************************************************
  4570. TOBJECTDEF
  4571. ***************************************************************************}
  4572. constructor tobjectdef.create(ot:tobjecttyp;const n:string;c:tobjectdef);
  4573. begin
  4574. inherited create(n,objectdef);
  4575. fcurrent_dispid:=0;
  4576. objecttype:=ot;
  4577. childof:=nil;
  4578. if objecttype=odt_helper then
  4579. owner.includeoption(sto_has_helper);
  4580. symtable:=tObjectSymtable.create(self,n,current_settings.packrecords);
  4581. { create space for vmt !! }
  4582. vmtentries:=TFPList.Create;
  4583. vmt_offset:=0;
  4584. set_parent(c);
  4585. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  4586. prepareguid;
  4587. { setup implemented interfaces }
  4588. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  4589. ImplementedInterfaces:=TFPObjectList.Create(true)
  4590. else
  4591. ImplementedInterfaces:=nil;
  4592. writing_class_record_dbginfo:=false;
  4593. end;
  4594. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  4595. var
  4596. i,
  4597. implintfcount : longint;
  4598. d : tderef;
  4599. ImplIntf : TImplementedInterface;
  4600. vmtentry : pvmtentry;
  4601. begin
  4602. inherited ppuload(objectdef,ppufile);
  4603. objecttype:=tobjecttyp(ppufile.getbyte);
  4604. objextname:=stringdup(ppufile.getstring);
  4605. { only used for external Objective-C classes/protocols }
  4606. if (objextname^='') then
  4607. stringdispose(objextname);
  4608. symtable:=tObjectSymtable.create(self,objrealname^,0);
  4609. tObjectSymtable(symtable).datasize:=ppufile.getasizeint;
  4610. tObjectSymtable(symtable).paddingsize:=ppufile.getword;
  4611. tObjectSymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  4612. tObjectSymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  4613. vmt_offset:=ppufile.getlongint;
  4614. ppufile.getderef(childofderef);
  4615. { load guid }
  4616. iidstr:=nil;
  4617. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4618. begin
  4619. new(iidguid);
  4620. ppufile.getguid(iidguid^);
  4621. iidstr:=stringdup(ppufile.getstring);
  4622. end;
  4623. abstractcnt:=ppufile.getlongint;
  4624. if objecttype=odt_helper then
  4625. ppufile.getderef(extendeddefderef);
  4626. vmtentries:=TFPList.Create;
  4627. vmtentries.count:=ppufile.getlongint;
  4628. for i:=0 to vmtentries.count-1 do
  4629. begin
  4630. ppufile.getderef(d);
  4631. new(vmtentry);
  4632. vmtentry^.procdef:=nil;
  4633. vmtentry^.procdefderef:=d;
  4634. vmtentry^.visibility:=tvisibility(ppufile.getbyte);
  4635. vmtentries[i]:=vmtentry;
  4636. end;
  4637. { load implemented interfaces }
  4638. if objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  4639. begin
  4640. ImplementedInterfaces:=TFPObjectList.Create(true);
  4641. implintfcount:=ppufile.getlongint;
  4642. for i:=0 to implintfcount-1 do
  4643. begin
  4644. ppufile.getderef(d);
  4645. ImplIntf:=TImplementedInterface.Create_deref(d);
  4646. ImplIntf.IOffset:=ppufile.getlongint;
  4647. ImplementedInterfaces.Add(ImplIntf);
  4648. end;
  4649. end
  4650. else
  4651. ImplementedInterfaces:=nil;
  4652. if df_copied_def in defoptions then
  4653. ppufile.getderef(cloneddefderef)
  4654. else
  4655. tObjectSymtable(symtable).ppuload(ppufile);
  4656. { handles the predefined class tobject }
  4657. { the last TOBJECT which is loaded gets }
  4658. { it ! }
  4659. if (childof=nil) and
  4660. (objecttype in [odt_class,odt_javaclass]) and
  4661. (objname^='TOBJECT') then
  4662. class_tobject:=self;
  4663. if (childof=nil) and
  4664. (objecttype=odt_interfacecom) then
  4665. if (objname^='IUNKNOWN') then
  4666. interface_iunknown:=self
  4667. else
  4668. if (objname^='IDISPATCH') then
  4669. interface_idispatch:=self;
  4670. if (childof=nil) and
  4671. (objecttype=odt_objcclass) and
  4672. (objname^='PROTOCOL') then
  4673. objc_protocoltype:=self;
  4674. if (objecttype=odt_javaclass) and
  4675. not(oo_is_formal in objectoptions) then
  4676. begin
  4677. if (objname^='JLOBJECT') then
  4678. java_jlobject:=self
  4679. else if (objname^='JLTHROWABLE') then
  4680. java_jlthrowable:=self
  4681. else if (objname^='FPCBASERECORDTYPE') then
  4682. java_fpcbaserecordtype:=self
  4683. else if (objname^='JLSTRING') then
  4684. java_jlstring:=self
  4685. else if (objname^='ANSISTRINGCLASS') then
  4686. java_ansistring:=self
  4687. else if (objname^='SHORTSTRINGCLASS') then
  4688. java_shortstring:=self
  4689. else if (objname^='JLENUM') then
  4690. java_jlenum:=self
  4691. else if (objname^='JUENUMSET') then
  4692. java_juenumset:=self
  4693. else if (objname^='FPCBITSET') then
  4694. java_jubitset:=self
  4695. else if (objname^='FPCBASEPROCVARTYPE') then
  4696. java_procvarbase:=self;
  4697. end;
  4698. writing_class_record_dbginfo:=false;
  4699. end;
  4700. destructor tobjectdef.destroy;
  4701. begin
  4702. if assigned(symtable) then
  4703. begin
  4704. symtable.free;
  4705. symtable:=nil;
  4706. end;
  4707. stringdispose(objextname);
  4708. stringdispose(iidstr);
  4709. if assigned(ImplementedInterfaces) then
  4710. begin
  4711. ImplementedInterfaces.free;
  4712. ImplementedInterfaces:=nil;
  4713. end;
  4714. if assigned(iidguid) then
  4715. begin
  4716. dispose(iidguid);
  4717. iidguid:=nil;
  4718. end;
  4719. if assigned(vmtentries) then
  4720. begin
  4721. resetvmtentries;
  4722. vmtentries.free;
  4723. vmtentries:=nil;
  4724. end;
  4725. if assigned(vmcallstaticinfo) then
  4726. begin
  4727. freemem(vmcallstaticinfo);
  4728. vmcallstaticinfo:=nil;
  4729. end;
  4730. inherited destroy;
  4731. end;
  4732. function tobjectdef.getcopy : tstoreddef;
  4733. var
  4734. i : longint;
  4735. begin
  4736. result:=tobjectdef.create(objecttype,objrealname^,childof);
  4737. { the constructor allocates a symtable which we release to avoid memory leaks }
  4738. tobjectdef(result).symtable.free;
  4739. tobjectdef(result).symtable:=symtable.getcopy;
  4740. if assigned(objextname) then
  4741. tobjectdef(result).objextname:=stringdup(objextname^);
  4742. if assigned(import_lib) then
  4743. tobjectdef(result).import_lib:=stringdup(import_lib^);
  4744. tobjectdef(result).objectoptions:=objectoptions;
  4745. include(tobjectdef(result).defoptions,df_copied_def);
  4746. tobjectdef(result).extendeddef:=extendeddef;
  4747. if assigned(tcinitcode) then
  4748. tobjectdef(result).tcinitcode:=tcinitcode.getcopy;
  4749. tobjectdef(result).vmt_offset:=vmt_offset;
  4750. if assigned(iidguid) then
  4751. begin
  4752. new(tobjectdef(result).iidguid);
  4753. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  4754. end;
  4755. if assigned(iidstr) then
  4756. tobjectdef(result).iidstr:=stringdup(iidstr^);
  4757. tobjectdef(result).abstractcnt:=abstractcnt;
  4758. if assigned(ImplementedInterfaces) then
  4759. begin
  4760. for i:=0 to ImplementedInterfaces.count-1 do
  4761. tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
  4762. end;
  4763. if assigned(vmtentries) then
  4764. begin
  4765. tobjectdef(result).vmtentries:=TFPList.Create;
  4766. tobjectdef(result).copyvmtentries(self);
  4767. end;
  4768. end;
  4769. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  4770. var
  4771. i : longint;
  4772. vmtentry : pvmtentry;
  4773. ImplIntf : TImplementedInterface;
  4774. old_do_indirect_crc: boolean;
  4775. begin
  4776. { if class1 in unit A changes, and class2 in unit B inherits from it
  4777. (so unit B uses unit A), then unit B with class2 will be recompiled.
  4778. However, if there is also a class3 in unit C that only depends on
  4779. unit B, then unit C will not be recompiled because nothing changed
  4780. to the interface of unit B. Nevertheless, unit C can indirectly
  4781. depend on unit A via derefs, and these must be updated -> the
  4782. indirect crc keeps track of such changes. }
  4783. old_do_indirect_crc:=ppufile.do_indirect_crc;
  4784. ppufile.do_indirect_crc:=true;
  4785. inherited ppuwrite(ppufile);
  4786. ppufile.putbyte(byte(objecttype));
  4787. if assigned(objextname) then
  4788. ppufile.putstring(objextname^)
  4789. else
  4790. ppufile.putstring('');
  4791. ppufile.putasizeint(tObjectSymtable(symtable).datasize);
  4792. ppufile.putword(tObjectSymtable(symtable).paddingsize);
  4793. ppufile.putbyte(byte(tObjectSymtable(symtable).fieldalignment));
  4794. ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignment));
  4795. ppufile.putlongint(vmt_offset);
  4796. ppufile.putderef(childofderef);
  4797. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  4798. begin
  4799. ppufile.putguid(iidguid^);
  4800. ppufile.putstring(iidstr^);
  4801. end;
  4802. ppufile.putlongint(abstractcnt);
  4803. if objecttype=odt_helper then
  4804. ppufile.putderef(extendeddefderef);
  4805. ppufile.putlongint(vmtentries.count);
  4806. for i:=0 to vmtentries.count-1 do
  4807. begin
  4808. vmtentry:=pvmtentry(vmtentries[i]);
  4809. ppufile.putderef(vmtentry^.procdefderef);
  4810. ppufile.putbyte(byte(vmtentry^.visibility));
  4811. end;
  4812. if assigned(ImplementedInterfaces) then
  4813. begin
  4814. ppufile.putlongint(ImplementedInterfaces.Count);
  4815. for i:=0 to ImplementedInterfaces.Count-1 do
  4816. begin
  4817. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  4818. ppufile.putderef(ImplIntf.intfdefderef);
  4819. ppufile.putlongint(ImplIntf.Ioffset);
  4820. end;
  4821. end;
  4822. if df_copied_def in defoptions then
  4823. ppufile.putderef(cloneddefderef);
  4824. ppufile.writeentry(ibobjectdef);
  4825. if not(df_copied_def in defoptions) then
  4826. tObjectSymtable(symtable).ppuwrite(ppufile);
  4827. ppufile.do_indirect_crc:=old_do_indirect_crc;
  4828. end;
  4829. function tobjectdef.GetTypeName:string;
  4830. begin
  4831. { in this case we will go in endless recursion, because then }
  4832. { there is no tsym associated yet with the def. It can occur }
  4833. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  4834. { instead of the actual type name }
  4835. if not assigned(typesym) then
  4836. result:='<Currently Parsed Class>'
  4837. else
  4838. result:=typesymbolprettyname;
  4839. end;
  4840. procedure tobjectdef.buildderef;
  4841. var
  4842. i : longint;
  4843. vmtentry : pvmtentry;
  4844. begin
  4845. inherited buildderef;
  4846. childofderef.build(childof);
  4847. if df_copied_def in defoptions then
  4848. cloneddefderef.build(symtable.defowner)
  4849. else
  4850. tstoredsymtable(symtable).buildderef;
  4851. if objecttype=odt_helper then
  4852. extendeddefderef.build(extendeddef);
  4853. for i:=0 to vmtentries.count-1 do
  4854. begin
  4855. vmtentry:=pvmtentry(vmtentries[i]);
  4856. vmtentry^.procdefderef.build(vmtentry^.procdef);
  4857. end;
  4858. if assigned(ImplementedInterfaces) then
  4859. begin
  4860. for i:=0 to ImplementedInterfaces.count-1 do
  4861. TImplementedInterface(ImplementedInterfaces[i]).buildderef;
  4862. end;
  4863. end;
  4864. procedure tobjectdef.deref;
  4865. var
  4866. i : longint;
  4867. vmtentry : pvmtentry;
  4868. begin
  4869. inherited deref;
  4870. childof:=tobjectdef(childofderef.resolve);
  4871. if df_copied_def in defoptions then
  4872. begin
  4873. cloneddef:=tobjectdef(cloneddefderef.resolve);
  4874. symtable:=cloneddef.symtable.getcopy;
  4875. end
  4876. else
  4877. tstoredsymtable(symtable).deref;
  4878. if objecttype=odt_helper then
  4879. extendeddef:=tdef(extendeddefderef.resolve);
  4880. for i:=0 to vmtentries.count-1 do
  4881. begin
  4882. vmtentry:=pvmtentry(vmtentries[i]);
  4883. vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve);
  4884. end;
  4885. if assigned(ImplementedInterfaces) then
  4886. begin
  4887. for i:=0 to ImplementedInterfaces.count-1 do
  4888. TImplementedInterface(ImplementedInterfaces[i]).deref;
  4889. end;
  4890. end;
  4891. procedure create_class_helper_for_procdef(def: tobject; arg: pointer);
  4892. var
  4893. pd: tprocdef absolute def;
  4894. st: tsymtable;
  4895. psym: tsym;
  4896. nname: TIDString;
  4897. begin
  4898. if (tdef(def).typ<>procdef) then
  4899. exit;
  4900. { pd.owner = objcclass symtable -> defowner = objcclassdef ->
  4901. owner = symtable in which objcclassdef is defined
  4902. }
  4903. st:=pd.owner.defowner.owner;
  4904. nname:=class_helper_prefix+tprocsym(pd.procsym).name;
  4905. { check for an existing procsym with our special name }
  4906. psym:=tsym(st.find(nname));
  4907. if not assigned(psym) then
  4908. begin
  4909. psym:=tprocsym.create(nname);
  4910. { avoid warning about this symbol being unused }
  4911. psym.IncRefCount;
  4912. { don't check for duplicates:
  4913. a) we checked above
  4914. b) in case we are in the implementation section of a unit, this
  4915. will also check for this symbol in the interface section
  4916. (since you normally cannot have symbols with the same name
  4917. both interface and implementation), and it's possible to
  4918. have class helpers for the same class in the interface and
  4919. in the implementation, and they cannot be merged since only
  4920. the once in the interface must be saved to the ppu/visible
  4921. from other units }
  4922. st.insert(psym,false);
  4923. end
  4924. else if (psym.typ<>procsym) then
  4925. internalerror(2009111501);
  4926. { add ourselves to this special procsym }
  4927. tprocsym(psym).procdeflist.add(def);
  4928. end;
  4929. procedure tobjectdef.buildderefimpl;
  4930. begin
  4931. inherited buildderefimpl;
  4932. if not (df_copied_def in defoptions) then
  4933. tstoredsymtable(symtable).buildderefimpl;
  4934. end;
  4935. procedure tobjectdef.derefimpl;
  4936. begin
  4937. inherited derefimpl;
  4938. if not (df_copied_def in defoptions) then
  4939. tstoredsymtable(symtable).derefimpl;
  4940. { the procdefs are not owned by the class helper procsyms, so they
  4941. are not stored/restored either -> re-add them here }
  4942. if (objecttype=odt_objcclass) or
  4943. (oo_is_classhelper in objectoptions) then
  4944. symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
  4945. end;
  4946. procedure tobjectdef.resetvmtentries;
  4947. var
  4948. i : longint;
  4949. begin
  4950. for i:=0 to vmtentries.Count-1 do
  4951. Dispose(pvmtentry(vmtentries[i]));
  4952. vmtentries.clear;
  4953. end;
  4954. procedure tobjectdef.copyvmtentries(objdef:tobjectdef);
  4955. var
  4956. i : longint;
  4957. vmtentry : pvmtentry;
  4958. begin
  4959. resetvmtentries;
  4960. vmtentries.count:=objdef.vmtentries.count;
  4961. for i:=0 to objdef.vmtentries.count-1 do
  4962. begin
  4963. new(vmtentry);
  4964. vmtentry^:=pvmtentry(objdef.vmtentries[i])^;
  4965. vmtentries[i]:=vmtentry;
  4966. end;
  4967. end;
  4968. function tobjectdef.getparentdef:tdef;
  4969. begin
  4970. { TODO: Remove getparentdef hack}
  4971. { With 2 forward declared classes with the child class before the
  4972. parent class the child class is written earlier to the ppu. Leaving it
  4973. possible to have a reference to the parent class for property overriding,
  4974. but the parent class still has the childof not resolved yet (PFV) }
  4975. if childof=nil then
  4976. childof:=tobjectdef(childofderef.resolve);
  4977. result:=childof;
  4978. end;
  4979. procedure tobjectdef.prepareguid;
  4980. begin
  4981. { set up guid }
  4982. if not assigned(iidguid) then
  4983. begin
  4984. new(iidguid);
  4985. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  4986. end;
  4987. { setup iidstring }
  4988. if not assigned(iidstr) then
  4989. iidstr:=stringdup(''); { default is empty string }
  4990. end;
  4991. procedure tobjectdef.set_parent( c : tobjectdef);
  4992. begin
  4993. if assigned(childof) then
  4994. exit;
  4995. childof:=c;
  4996. if not assigned(c) then
  4997. exit;
  4998. { inherit options and status }
  4999. objectoptions:=objectoptions+(c.objectoptions*inherited_objectoptions);
  5000. { initially has the same number of abstract methods as the parent }
  5001. abstractcnt:=c.abstractcnt;
  5002. { add the data of the anchestor class/object }
  5003. if (objecttype in [odt_class,odt_object,odt_objcclass,odt_javaclass]) then
  5004. begin
  5005. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize+tObjectSymtable(c.symtable).datasize;
  5006. { inherit recordalignment }
  5007. tObjectSymtable(symtable).recordalignment:=tObjectSymtable(c.symtable).recordalignment;
  5008. { if both the parent and this record use C-alignment, also inherit
  5009. the current field alignment }
  5010. if (tObjectSymtable(c.symtable).usefieldalignment=C_alignment) and
  5011. (tObjectSymtable(symtable).usefieldalignment=C_alignment) then
  5012. tObjectSymtable(symtable).fieldalignment:=tObjectSymtable(c.symtable).fieldalignment;
  5013. { the padding is not inherited for Objective-C classes (maybe not
  5014. for cppclass either?) }
  5015. if objecttype=odt_objcclass then
  5016. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-tObjectSymtable(c.symtable).paddingsize;
  5017. if (oo_has_vmt in objectoptions) and
  5018. (oo_has_vmt in c.objectoptions) then
  5019. tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-sizeof(pint);
  5020. { if parent has a vmt field then the offset is the same for the child PM }
  5021. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  5022. begin
  5023. vmt_offset:=c.vmt_offset;
  5024. include(objectoptions,oo_has_vmt);
  5025. end;
  5026. end;
  5027. end;
  5028. procedure tobjectdef.insertvmt;
  5029. var
  5030. vs: tfieldvarsym;
  5031. begin
  5032. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  5033. exit;
  5034. if (oo_has_vmt in objectoptions) then
  5035. internalerror(12345)
  5036. else
  5037. begin
  5038. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,
  5039. tObjectSymtable(symtable).fieldalignment);
  5040. if (tf_requires_proper_alignment in target_info.flags) then
  5041. begin
  5042. { Align VMT pointer and whole object instance if target CPU requires alignment. }
  5043. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(pint));
  5044. tObjectSymtable(symtable).alignrecord(tObjectSymtable(symtable).datasize,sizeof(pint));
  5045. end;
  5046. vs:=tfieldvarsym.create('_vptr$'+objname^,vs_value,voidpointertype,[]);
  5047. hidesym(vs);
  5048. tObjectSymtable(symtable).insert(vs);
  5049. tObjectSymtable(symtable).addfield(vs,vis_hidden);
  5050. if (tObjectSymtable(symtable).usefieldalignment<>bit_alignment) then
  5051. vmt_offset:=vs.fieldoffset
  5052. else
  5053. vmt_offset:=vs.fieldoffset div 8;
  5054. include(objectoptions,oo_has_vmt);
  5055. end;
  5056. end;
  5057. procedure tobjectdef.check_forwards;
  5058. begin
  5059. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol,odt_interfacejava]) then
  5060. inherited;
  5061. if (oo_is_forward in objectoptions) then
  5062. begin
  5063. { ok, in future, the forward can be resolved }
  5064. Message1(sym_e_class_forward_not_resolved,objrealname^);
  5065. exclude(objectoptions,oo_is_forward);
  5066. end;
  5067. end;
  5068. { true if prot implements d (or if they are equal) }
  5069. function is_related_interface_multiple(prot: tobjectdef; d : tdef) : boolean;
  5070. var
  5071. i : longint;
  5072. begin
  5073. { objcprotocols have multiple inheritance, all protocols from which
  5074. the current protocol inherits are stored in implementedinterfaces }
  5075. result:=prot=d;
  5076. if result then
  5077. exit;
  5078. for i:=0 to prot.ImplementedInterfaces.count-1 do
  5079. begin
  5080. result:=is_related_interface_multiple(TImplementedInterface(prot.ImplementedInterfaces[i]).intfdef,d);
  5081. if result then
  5082. exit;
  5083. end;
  5084. end;
  5085. { true, if self inherits from d (or if they are equal) }
  5086. function tobjectdef.is_related(d : tdef) : boolean;
  5087. var
  5088. realself,
  5089. hp : tobjectdef;
  5090. begin
  5091. if (d.typ=objectdef) then
  5092. d:=find_real_class_definition(tobjectdef(d),false);
  5093. realself:=find_real_class_definition(self,false);
  5094. if realself=d then
  5095. begin
  5096. is_related:=true;
  5097. exit;
  5098. end;
  5099. if (d.typ<>objectdef) then
  5100. begin
  5101. is_related:=false;
  5102. exit;
  5103. end;
  5104. { Objective-C protocols and Java interfaces can use multiple
  5105. inheritance }
  5106. if (realself.objecttype in [odt_objcprotocol,odt_interfacejava]) then
  5107. begin
  5108. is_related:=is_related_interface_multiple(realself,d);
  5109. exit
  5110. end;
  5111. { formally declared Objective-C and Java classes match Objective-C/Java
  5112. classes with the same name. In case of Java, the package must also
  5113. match (still required even though we looked up the real definitions
  5114. above, because these may be two different formal declarations that
  5115. cannot be resolved yet) }
  5116. if (realself.objecttype in [odt_objcclass,odt_javaclass]) and
  5117. (tobjectdef(d).objecttype=objecttype) and
  5118. ((oo_is_formal in objectoptions) or
  5119. (oo_is_formal in tobjectdef(d).objectoptions)) and
  5120. (objrealname^=tobjectdef(d).objrealname^) then
  5121. begin
  5122. { check package name for Java }
  5123. if objecttype=odt_objcclass then
  5124. is_related:=true
  5125. else
  5126. begin
  5127. is_related:=
  5128. assigned(import_lib)=assigned(tobjectdef(d).import_lib);
  5129. if is_related and
  5130. assigned(import_lib) then
  5131. is_related:=import_lib^=tobjectdef(d).import_lib^;
  5132. end;
  5133. exit;
  5134. end;
  5135. hp:=realself.childof;
  5136. while assigned(hp) do
  5137. begin
  5138. if hp=d then
  5139. begin
  5140. is_related:=true;
  5141. exit;
  5142. end;
  5143. hp:=hp.childof;
  5144. end;
  5145. is_related:=false;
  5146. end;
  5147. function tobjectdef.find_destructor: tprocdef;
  5148. var
  5149. objdef: tobjectdef;
  5150. begin
  5151. objdef:=self;
  5152. while assigned(objdef) do
  5153. begin
  5154. result:=objdef.find_procdef_bytype(potype_destructor);
  5155. if assigned(result) then
  5156. exit;
  5157. objdef:=objdef.childof;
  5158. end;
  5159. result:=nil;
  5160. end;
  5161. function tobjectdef.implements_any_interfaces: boolean;
  5162. begin
  5163. result := (ImplementedInterfaces.Count > 0) or
  5164. (assigned(childof) and childof.implements_any_interfaces);
  5165. end;
  5166. function tobjectdef.size : asizeint;
  5167. begin
  5168. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  5169. result:=sizeof(pint)
  5170. else
  5171. result:=tObjectSymtable(symtable).datasize;
  5172. end;
  5173. function tobjectdef.alignment:shortint;
  5174. begin
  5175. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava] then
  5176. alignment:=sizeof(pint)
  5177. else
  5178. alignment:=tObjectSymtable(symtable).recordalignment;
  5179. end;
  5180. function tobjectdef.vmtmethodoffset(index:longint):longint;
  5181. begin
  5182. { for offset of methods for classes, see rtl/inc/objpash.inc }
  5183. case objecttype of
  5184. odt_class:
  5185. { the +2*sizeof(pint) is size and -size }
  5186. vmtmethodoffset:=(index+10)*sizeof(pint)+2*sizeof(pint);
  5187. odt_helper,
  5188. odt_objcclass,
  5189. odt_objcprotocol:
  5190. vmtmethodoffset:=0;
  5191. odt_interfacecom,odt_interfacecorba,odt_dispinterface:
  5192. vmtmethodoffset:=index*sizeof(pint);
  5193. odt_javaclass,
  5194. odt_interfacejava:
  5195. { invalid }
  5196. vmtmethodoffset:=-1;
  5197. else
  5198. {$ifdef WITHDMT}
  5199. vmtmethodoffset:=(index+4)*sizeof(pint);
  5200. {$else WITHDMT}
  5201. vmtmethodoffset:=(index+3)*sizeof(pint);
  5202. {$endif WITHDMT}
  5203. end;
  5204. end;
  5205. function tobjectdef.vmt_mangledname : TSymStr;
  5206. begin
  5207. if not(oo_has_vmt in objectoptions) then
  5208. Message1(parser_n_object_has_no_vmt,objrealname^);
  5209. vmt_mangledname:=make_mangledname('VMT',owner,objname^);
  5210. end;
  5211. function tobjectdef.needs_inittable : boolean;
  5212. begin
  5213. case objecttype of
  5214. odt_helper,
  5215. odt_class :
  5216. needs_inittable:=false;
  5217. odt_dispinterface,
  5218. odt_interfacecom:
  5219. needs_inittable:=true;
  5220. odt_interfacecorba:
  5221. needs_inittable:=is_related(interface_iunknown);
  5222. odt_object:
  5223. needs_inittable:=tObjectSymtable(symtable).needs_init_final;
  5224. odt_cppclass,
  5225. odt_objcclass,
  5226. odt_objcprotocol,
  5227. odt_javaclass,
  5228. odt_interfacejava:
  5229. needs_inittable:=false;
  5230. else
  5231. internalerror(200108267);
  5232. end;
  5233. end;
  5234. function tobjectdef.needs_separate_initrtti : boolean;
  5235. begin
  5236. result:=not (objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  5237. end;
  5238. function tobjectdef.rtti_mangledname(rt: trttitype): string;
  5239. begin
  5240. if not(objecttype in [odt_objcclass,odt_objcprotocol]) then
  5241. result:=inherited rtti_mangledname(rt)
  5242. else
  5243. begin
  5244. { necessary in case of a dynamic array of nsobject, or
  5245. if an nsobject field appears in a record that needs
  5246. init/finalisation }
  5247. if rt=initrtti then
  5248. begin
  5249. result:=voidpointertype.rtti_mangledname(rt);
  5250. exit;
  5251. end;
  5252. if not(target_info.system in systems_objc_nfabi) then
  5253. begin
  5254. result:=target_asm.labelprefix;
  5255. case objecttype of
  5256. odt_objcclass:
  5257. begin
  5258. case rt of
  5259. objcclassrtti:
  5260. if not(oo_is_classhelper in objectoptions) then
  5261. result:=result+'_OBJC_CLASS_'
  5262. else
  5263. result:=result+'_OBJC_CATEGORY_';
  5264. objcmetartti:
  5265. if not(oo_is_classhelper in objectoptions) then
  5266. result:=result+'_OBJC_METACLASS_'
  5267. else
  5268. internalerror(2009111511);
  5269. else
  5270. internalerror(2009092302);
  5271. end;
  5272. end;
  5273. odt_objcprotocol:
  5274. result:=result+'_OBJC_PROTOCOL_';
  5275. end;
  5276. end
  5277. else
  5278. begin
  5279. case objecttype of
  5280. odt_objcclass:
  5281. begin
  5282. if (oo_is_classhelper in objectoptions) and
  5283. (rt<>objcclassrtti) then
  5284. internalerror(2009111512);
  5285. case rt of
  5286. objcclassrtti:
  5287. if not(oo_is_classhelper in objectoptions) then
  5288. result:='_OBJC_CLASS_$_'
  5289. else
  5290. result:='_OBJC_$_CATEGORY_';
  5291. objcmetartti:
  5292. result:='_OBJC_METACLASS_$_';
  5293. objcclassrortti:
  5294. result:=lower(target_asm.labelprefix)+'_OBJC_CLASS_RO_$_';
  5295. objcmetarortti:
  5296. result:=lower(target_asm.labelprefix)+'_OBJC_METACLASS_RO_$_';
  5297. else
  5298. internalerror(2009092303);
  5299. end;
  5300. end;
  5301. odt_objcprotocol:
  5302. begin
  5303. result:=lower(target_asm.labelprefix);
  5304. case rt of
  5305. objcclassrtti:
  5306. result:=result+'_OBJC_PROTOCOL_$_';
  5307. objcmetartti:
  5308. result:=result+'_OBJC_LABEL_PROTOCOL_$_';
  5309. else
  5310. internalerror(2009092501);
  5311. end;
  5312. end;
  5313. end;
  5314. end;
  5315. result:=result+objextname^;
  5316. end;
  5317. end;
  5318. function tobjectdef.members_need_inittable : boolean;
  5319. begin
  5320. members_need_inittable:=tObjectSymtable(symtable).needs_init_final;
  5321. end;
  5322. function tobjectdef.find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  5323. var
  5324. ImplIntf : TImplementedInterface;
  5325. i : longint;
  5326. begin
  5327. result:=nil;
  5328. if not assigned(ImplementedInterfaces) then
  5329. exit;
  5330. for i:=0 to ImplementedInterfaces.Count-1 do
  5331. begin
  5332. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  5333. if ImplIntf.intfdef=aintfdef then
  5334. begin
  5335. result:=ImplIntf;
  5336. exit;
  5337. end;
  5338. end;
  5339. end;
  5340. function tobjectdef.is_publishable : boolean;
  5341. begin
  5342. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface];
  5343. end;
  5344. function tobjectdef.get_next_dispid: longint;
  5345. begin
  5346. inc(fcurrent_dispid);
  5347. result:=fcurrent_dispid;
  5348. end;
  5349. function tobjectdef.search_enumerator_get: tprocdef;
  5350. begin
  5351. result:=inherited;
  5352. if not assigned(result) and assigned(childof) then
  5353. result:=childof.search_enumerator_get;
  5354. end;
  5355. function tobjectdef.search_enumerator_move: tprocdef;
  5356. begin
  5357. result:=inherited;
  5358. if not assigned(result) and assigned(childof) then
  5359. result:=childof.search_enumerator_move;
  5360. end;
  5361. function tobjectdef.search_enumerator_current: tsym;
  5362. begin
  5363. result:=inherited;
  5364. if not assigned(result) and assigned(childof) then
  5365. result:=childof.search_enumerator_current;
  5366. end;
  5367. procedure tobjectdef.register_created_classref_type;
  5368. begin
  5369. if not classref_created_in_current_module then
  5370. begin
  5371. classref_created_in_current_module:=true;
  5372. current_module.wpoinfo.addcreatedobjtypeforclassref(self);
  5373. end;
  5374. end;
  5375. procedure tobjectdef.register_created_object_type;
  5376. begin
  5377. if not created_in_current_module then
  5378. begin
  5379. created_in_current_module:=true;
  5380. current_module.wpoinfo.addcreatedobjtype(self);
  5381. end;
  5382. end;
  5383. procedure tobjectdef.register_maybe_created_object_type;
  5384. begin
  5385. { if we know it has been created for sure, no need
  5386. to also record that it maybe can be created in
  5387. this module
  5388. }
  5389. if not (created_in_current_module) and
  5390. not (maybe_created_in_current_module) then
  5391. begin
  5392. maybe_created_in_current_module:=true;
  5393. current_module.wpoinfo.addmaybecreatedbyclassref(self);
  5394. end;
  5395. end;
  5396. procedure tobjectdef.register_vmt_call(index: longint);
  5397. begin
  5398. if (is_object(self) or is_class(self)) then
  5399. current_module.wpoinfo.addcalledvmtentry(self,index);
  5400. end;
  5401. procedure check_and_finish_msg(data: tobject; arg: pointer);
  5402. var
  5403. def: tdef absolute data;
  5404. pd: tprocdef absolute data;
  5405. i,
  5406. paracount: longint;
  5407. begin
  5408. if (def.typ=procdef) then
  5409. begin
  5410. { add all messages also under a dummy name to the symtable in
  5411. which the objcclass/protocol/category is declared, so they can
  5412. be called via id.<name>
  5413. }
  5414. create_class_helper_for_procdef(pd,nil);
  5415. { we have to wait until now to set the mangled name because it
  5416. depends on the (possibly external) class name, which is defined
  5417. at the very end. }
  5418. if not(po_msgstr in pd.procoptions) then
  5419. begin
  5420. CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
  5421. { recover to avoid internalerror later on }
  5422. include(pd.procoptions,po_msgstr);
  5423. pd.messageinf.str:=stringdup('MissingDeclaration');
  5424. end;
  5425. { Mangled name is already set in case this is a copy of
  5426. another type. }
  5427. if not(po_has_mangledname in pd.procoptions) then
  5428. begin
  5429. { check whether the number of formal parameters is correct,
  5430. and whether they have valid Objective-C types }
  5431. paracount:=0;
  5432. for i:=1 to length(pd.messageinf.str^) do
  5433. if pd.messageinf.str^[i]=':' then
  5434. inc(paracount);
  5435. for i:=0 to pd.paras.count-1 do
  5436. if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
  5437. not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
  5438. dec(paracount);
  5439. if (paracount<>0) then
  5440. MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
  5441. pd.setmangledname(pd.objcmangledname);
  5442. end
  5443. else
  5444. { all checks already done }
  5445. exit;
  5446. if not(oo_is_external in pd.struct.objectoptions) then
  5447. begin
  5448. if (po_varargs in pd.procoptions) then
  5449. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external)
  5450. else
  5451. begin
  5452. { check for "array of const" parameters }
  5453. for i:=0 to pd.parast.symlist.count-1 do
  5454. begin
  5455. if (tsym(pd.parast.symlist[i]).typ=paravarsym) and
  5456. is_array_of_const(tparavarsym(pd.parast.symlist[i]).vardef) then
  5457. MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external);
  5458. end;
  5459. end;
  5460. end;
  5461. end;
  5462. end;
  5463. procedure mark_private_fields_used(data: tobject; arg: pointer);
  5464. var
  5465. sym: tsym absolute data;
  5466. begin
  5467. if (sym.typ=fieldvarsym) and
  5468. (tfieldvarsym(sym).visibility in [vis_private,vis_strictprivate]) then
  5469. sym.IncRefCount;
  5470. end;
  5471. procedure tobjectdef.finish_objc_data;
  5472. begin
  5473. self.symtable.DefList.foreachcall(@check_and_finish_msg,nil);
  5474. if (oo_is_external in objectoptions) then
  5475. self.symtable.SymList.ForEachCall(@mark_private_fields_used,nil);
  5476. end;
  5477. procedure verify_objc_vardef(data: tobject; arg: pointer);
  5478. var
  5479. sym: tabstractvarsym absolute data;
  5480. res: pboolean absolute arg;
  5481. founderrordef: tdef;
  5482. begin
  5483. if not(tsym(data).typ in [paravarsym,fieldvarsym]) then
  5484. exit;
  5485. if (sym.typ=paravarsym) and
  5486. ((vo_is_hidden_para in tparavarsym(sym).varoptions) or
  5487. is_array_of_const(tparavarsym(sym).vardef)) then
  5488. exit;
  5489. if not objcchecktype(sym.vardef,founderrordef) then
  5490. begin
  5491. MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  5492. res^:=false;
  5493. end;
  5494. end;
  5495. procedure verify_objc_procdef_paras(data: tobject; arg: pointer);
  5496. var
  5497. def: tdef absolute data;
  5498. res: pboolean absolute arg;
  5499. founderrordef: tdef;
  5500. begin
  5501. if (def.typ<>procdef) then
  5502. exit;
  5503. { check parameter types for validity }
  5504. tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg);
  5505. { check the result type for validity }
  5506. if not objcchecktype(tprocdef(def).returndef,founderrordef) then
  5507. begin
  5508. MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
  5509. res^:=false;
  5510. end;
  5511. end;
  5512. function tobjectdef.check_objc_types: boolean;
  5513. begin
  5514. { done in separate step from finish_objc_data, because when
  5515. finish_objc_data is called, not all forwarddefs have been resolved
  5516. yet and we need to know all types here }
  5517. result:=true;
  5518. self.symtable.symlist.foreachcall(@verify_objc_vardef,@result);
  5519. self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result);
  5520. end;
  5521. procedure do_cpp_import_info(data: tobject; arg: pointer);
  5522. var
  5523. def: tdef absolute data;
  5524. pd: tprocdef absolute data;
  5525. begin
  5526. if (def.typ=procdef) then
  5527. begin
  5528. pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname);
  5529. if (oo_is_external in pd.struct.objectoptions) then
  5530. begin
  5531. { copied from psub.read_proc }
  5532. if assigned(tobjectdef(pd.struct).import_lib) then
  5533. current_module.AddExternalImport(tobjectdef(pd.struct).import_lib^,pd.mangledname,pd.mangledname,0,false,false)
  5534. else
  5535. begin
  5536. { add import name to external list for DLL scanning }
  5537. if tf_has_dllscanner in target_info.flags then
  5538. current_module.dllscannerinputlist.Add(pd.mangledname,pd);
  5539. end;
  5540. end;
  5541. end;
  5542. end;
  5543. procedure tobjectdef.finish_cpp_data;
  5544. begin
  5545. self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
  5546. end;
  5547. {****************************************************************************
  5548. TImplementedInterface
  5549. ****************************************************************************}
  5550. function TImplementedInterface.GetIOffset: longint;
  5551. begin
  5552. if (fIOffset=-1) and
  5553. (IType in [etFieldValue,etFieldValueClass]) then
  5554. result:=tfieldvarsym(ImplementsField).fieldoffset
  5555. else
  5556. result:=fIOffset;
  5557. end;
  5558. constructor TImplementedInterface.create(aintf: tobjectdef);
  5559. begin
  5560. inherited create;
  5561. intfdef:=aintf;
  5562. IOffset:=-1;
  5563. IType:=etStandard;
  5564. NameMappings:=nil;
  5565. procdefs:=nil;
  5566. end;
  5567. constructor TImplementedInterface.create_deref(d:tderef);
  5568. begin
  5569. inherited create;
  5570. intfdef:=nil;
  5571. intfdefderef:=d;
  5572. IOffset:=-1;
  5573. IType:=etStandard;
  5574. NameMappings:=nil;
  5575. procdefs:=nil;
  5576. end;
  5577. destructor TImplementedInterface.destroy;
  5578. var
  5579. i : longint;
  5580. mappedname : pshortstring;
  5581. begin
  5582. if assigned(NameMappings) then
  5583. begin
  5584. for i:=0 to NameMappings.Count-1 do
  5585. begin
  5586. mappedname:=pshortstring(NameMappings[i]);
  5587. stringdispose(mappedname);
  5588. end;
  5589. NameMappings.free;
  5590. NameMappings:=nil;
  5591. end;
  5592. if assigned(procdefs) then
  5593. begin
  5594. procdefs.free;
  5595. procdefs:=nil;
  5596. end;
  5597. inherited destroy;
  5598. end;
  5599. procedure TImplementedInterface.buildderef;
  5600. begin
  5601. intfdefderef.build(intfdef);
  5602. end;
  5603. procedure TImplementedInterface.deref;
  5604. begin
  5605. intfdef:=tobjectdef(intfdefderef.resolve);
  5606. end;
  5607. procedure TImplementedInterface.AddMapping(const origname,newname: string);
  5608. begin
  5609. if not assigned(NameMappings) then
  5610. NameMappings:=TFPHashList.Create;
  5611. NameMappings.Add(origname,stringdup(newname));
  5612. end;
  5613. function TImplementedInterface.GetMapping(const origname: string):string;
  5614. var
  5615. mappedname : pshortstring;
  5616. begin
  5617. result:='';
  5618. if not assigned(NameMappings) then
  5619. exit;
  5620. mappedname:=PShortstring(NameMappings.Find(origname));
  5621. if assigned(mappedname) then
  5622. result:=mappedname^;
  5623. end;
  5624. procedure TImplementedInterface.AddImplProc(pd:tprocdef);
  5625. begin
  5626. if not assigned(procdefs) then
  5627. procdefs:=TFPObjectList.Create(false);
  5628. { duplicate entries must be stored, because multiple }
  5629. { interfaces can declare methods with the same name }
  5630. { and all of these get their own VMT entry }
  5631. procdefs.Add(pd);
  5632. end;
  5633. function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  5634. var
  5635. i : longint;
  5636. begin
  5637. result:=false;
  5638. { interfaces being implemented through delegation are not mergable (FK) }
  5639. if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) or not(assigned(MergingIntf.ProcDefs)) then
  5640. exit;
  5641. weight:=0;
  5642. { empty interface is mergeable }
  5643. if ProcDefs.Count=0 then
  5644. begin
  5645. result:=true;
  5646. exit;
  5647. end;
  5648. { The interface to merge must at least the number of
  5649. procedures of this interface }
  5650. if MergingIntf.ProcDefs.Count<ProcDefs.Count then
  5651. exit;
  5652. for i:=0 to ProcDefs.Count-1 do
  5653. begin
  5654. if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
  5655. exit;
  5656. end;
  5657. weight:=ProcDefs.Count;
  5658. result:=true;
  5659. end;
  5660. function TImplementedInterface.getcopy:TImplementedInterface;
  5661. begin
  5662. Result:=TImplementedInterface.Create(nil);
  5663. { 1) the procdefs list will be freed once for each copy
  5664. 2) since the procdefs list owns its elements, those will also be freed for each copy
  5665. 3) idem for the name mappings
  5666. }
  5667. { warning: this is completely wrong on so many levels...
  5668. Move(pointer(self)^,pointer(result)^,InstanceSize);
  5669. We need to make clean copies of the different fields
  5670. this is not implemented yet, and thus we generate an internal
  5671. error instead PM 2011-06-14 }
  5672. internalerror(2011061401);
  5673. end;
  5674. {****************************************************************************
  5675. TFORWARDDEF
  5676. ****************************************************************************}
  5677. constructor tforwarddef.create(const s:string;const pos:tfileposinfo);
  5678. begin
  5679. inherited create(forwarddef);
  5680. tosymname:=stringdup(s);
  5681. forwardpos:=pos;
  5682. end;
  5683. function tforwarddef.GetTypeName:string;
  5684. begin
  5685. GetTypeName:='unresolved forward to '+tosymname^;
  5686. end;
  5687. destructor tforwarddef.destroy;
  5688. begin
  5689. stringdispose(tosymname);
  5690. inherited destroy;
  5691. end;
  5692. function tforwarddef.getcopy:tstoreddef;
  5693. begin
  5694. result:=tforwarddef.create(tosymname^, forwardpos);
  5695. end;
  5696. {****************************************************************************
  5697. TUNDEFINEDDEF
  5698. ****************************************************************************}
  5699. constructor tundefineddef.create;
  5700. begin
  5701. inherited create(undefineddef);
  5702. end;
  5703. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  5704. begin
  5705. inherited ppuload(undefineddef,ppufile);
  5706. end;
  5707. function tundefineddef.GetTypeName:string;
  5708. begin
  5709. GetTypeName:='<undefined type>';
  5710. end;
  5711. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  5712. begin
  5713. inherited ppuwrite(ppufile);
  5714. ppufile.writeentry(ibundefineddef);
  5715. end;
  5716. {****************************************************************************
  5717. TERRORDEF
  5718. ****************************************************************************}
  5719. constructor terrordef.create;
  5720. begin
  5721. inherited create(errordef);
  5722. { prevent consecutive faults }
  5723. savesize:=1;
  5724. end;
  5725. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  5726. begin
  5727. { Can't write errordefs to ppu }
  5728. internalerror(200411063);
  5729. end;
  5730. function terrordef.GetTypeName:string;
  5731. begin
  5732. GetTypeName:='<erroneous type>';
  5733. end;
  5734. function terrordef.getmangledparaname:TSymStr;
  5735. begin
  5736. getmangledparaname:='error';
  5737. end;
  5738. {****************************************************************************
  5739. Definition Helpers
  5740. ****************************************************************************}
  5741. function is_interfacecom(def: tdef): boolean;
  5742. begin
  5743. is_interfacecom:=
  5744. assigned(def) and
  5745. (def.typ=objectdef) and
  5746. (tobjectdef(def).objecttype=odt_interfacecom);
  5747. end;
  5748. function is_interfacecom_or_dispinterface(def: tdef): boolean;
  5749. begin
  5750. is_interfacecom_or_dispinterface:=
  5751. assigned(def) and
  5752. (def.typ=objectdef) and
  5753. (tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface]);
  5754. end;
  5755. function is_any_interface_kind(def: tdef): boolean;
  5756. begin
  5757. result:=
  5758. assigned(def) and
  5759. (def.typ=objectdef) and
  5760. ((tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface,odt_interfacecorba,odt_interfacejava,odt_objcprotocol]) or
  5761. is_objccategory(def));
  5762. end;
  5763. function is_interfacecorba(def: tdef): boolean;
  5764. begin
  5765. is_interfacecorba:=
  5766. assigned(def) and
  5767. (def.typ=objectdef) and
  5768. (tobjectdef(def).objecttype=odt_interfacecorba);
  5769. end;
  5770. function is_interface(def: tdef): boolean;
  5771. begin
  5772. is_interface:=
  5773. assigned(def) and
  5774. (def.typ=objectdef) and
  5775. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  5776. end;
  5777. function is_dispinterface(def: tdef): boolean;
  5778. begin
  5779. result:=
  5780. assigned(def) and
  5781. (def.typ=objectdef) and
  5782. (tobjectdef(def).objecttype=odt_dispinterface);
  5783. end;
  5784. function is_class(def: tdef): boolean;
  5785. begin
  5786. is_class:=
  5787. assigned(def) and
  5788. (def.typ=objectdef) and
  5789. (tobjectdef(def).objecttype=odt_class);
  5790. end;
  5791. function is_object(def: tdef): boolean;
  5792. begin
  5793. is_object:=
  5794. assigned(def) and
  5795. (def.typ=objectdef) and
  5796. (tobjectdef(def).objecttype=odt_object);
  5797. end;
  5798. function is_cppclass(def: tdef): boolean;
  5799. begin
  5800. is_cppclass:=
  5801. assigned(def) and
  5802. (def.typ=objectdef) and
  5803. (tobjectdef(def).objecttype=odt_cppclass);
  5804. end;
  5805. function is_objcclass(def: tdef): boolean;
  5806. begin
  5807. is_objcclass:=
  5808. assigned(def) and
  5809. (def.typ=objectdef) and
  5810. (tobjectdef(def).objecttype=odt_objcclass);
  5811. end;
  5812. function is_objectpascal_helper(def: tdef): boolean;
  5813. begin
  5814. result:=
  5815. assigned(def) and
  5816. (def.typ=objectdef) and
  5817. (tobjectdef(def).objecttype=odt_helper);
  5818. end;
  5819. function is_objcclassref(def: tdef): boolean;
  5820. begin
  5821. is_objcclassref:=
  5822. assigned(def) and
  5823. (def.typ=classrefdef) and
  5824. is_objcclass(tclassrefdef(def).pointeddef);
  5825. end;
  5826. function is_objcprotocol(def: tdef): boolean;
  5827. begin
  5828. result:=
  5829. assigned(def) and
  5830. (def.typ=objectdef) and
  5831. (tobjectdef(def).objecttype=odt_objcprotocol);
  5832. end;
  5833. function is_objccategory(def: tdef): boolean;
  5834. begin
  5835. result:=
  5836. assigned(def) and
  5837. (def.typ=objectdef) and
  5838. { if used as a forward type }
  5839. ((tobjectdef(def).objecttype=odt_objccategory) or
  5840. { if used as after it has been resolved }
  5841. ((tobjectdef(def).objecttype=odt_objcclass) and
  5842. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5843. end;
  5844. function is_objc_class_or_protocol(def: tdef): boolean;
  5845. begin
  5846. result:=
  5847. assigned(def) and
  5848. (def.typ=objectdef) and
  5849. (tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]);
  5850. end;
  5851. function is_objc_protocol_or_category(def: tdef): boolean;
  5852. begin
  5853. result:=
  5854. assigned(def) and
  5855. (def.typ=objectdef) and
  5856. ((tobjectdef(def).objecttype = odt_objcprotocol) or
  5857. ((tobjectdef(def).objecttype = odt_objcclass) and
  5858. (oo_is_classhelper in tobjectdef(def).objectoptions)));
  5859. end;
  5860. function is_classhelper(def: tdef): boolean;
  5861. begin
  5862. result:=
  5863. is_objectpascal_helper(def) or
  5864. is_objccategory(def);
  5865. end;
  5866. function is_class_or_interface(def: tdef): boolean;
  5867. begin
  5868. result:=
  5869. assigned(def) and
  5870. (def.typ=objectdef) and
  5871. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  5872. end;
  5873. function is_class_or_interface_or_objc(def: tdef): boolean;
  5874. begin
  5875. result:=
  5876. assigned(def) and
  5877. (def.typ=objectdef) and
  5878. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]);
  5879. end;
  5880. function is_class_or_interface_or_objc_or_java(def: tdef): boolean;
  5881. begin
  5882. result:=
  5883. assigned(def) and
  5884. (def.typ=objectdef) and
  5885. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  5886. end;
  5887. function is_class_or_interface_or_dispinterface_or_objc_or_java(def: tdef): boolean;
  5888. begin
  5889. result:=
  5890. assigned(def) and
  5891. (def.typ=objectdef) and
  5892. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava]);
  5893. end;
  5894. function is_class_or_interface_or_object(def: tdef): boolean;
  5895. begin
  5896. result:=
  5897. assigned(def) and
  5898. (def.typ=objectdef) and
  5899. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_object]);
  5900. end;
  5901. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  5902. begin
  5903. result:=
  5904. assigned(def) and
  5905. (def.typ=objectdef) and
  5906. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  5907. end;
  5908. function is_implicit_pointer_object_type(def: tdef): boolean;
  5909. begin
  5910. result:=
  5911. assigned(def) and
  5912. (((def.typ=objectdef) and
  5913. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava])) or
  5914. ((target_info.system in systems_jvm) and
  5915. (def.typ=recorddef)));
  5916. end;
  5917. function is_class_or_object(def: tdef): boolean;
  5918. begin
  5919. result:=
  5920. assigned(def) and
  5921. (def.typ=objectdef) and
  5922. (tobjectdef(def).objecttype in [odt_class,odt_object]);
  5923. end;
  5924. function is_record(def: tdef): boolean;
  5925. begin
  5926. result:=
  5927. assigned(def) and
  5928. (def.typ=recorddef);
  5929. end;
  5930. function is_javaclass(def: tdef): boolean;
  5931. begin
  5932. result:=
  5933. assigned(def) and
  5934. (def.typ=objectdef) and
  5935. (tobjectdef(def).objecttype=odt_javaclass);
  5936. end;
  5937. function is_javaclassref(def: tdef): boolean;
  5938. begin
  5939. is_javaclassref:=
  5940. assigned(def) and
  5941. (def.typ=classrefdef) and
  5942. is_javaclass(tclassrefdef(def).pointeddef);
  5943. end;
  5944. function is_javainterface(def: tdef): boolean;
  5945. begin
  5946. result:=
  5947. assigned(def) and
  5948. (def.typ=objectdef) and
  5949. (tobjectdef(def).objecttype=odt_interfacejava);
  5950. end;
  5951. function is_java_class_or_interface(def: tdef): boolean;
  5952. begin
  5953. result:=
  5954. assigned(def) and
  5955. (def.typ=objectdef) and
  5956. (tobjectdef(def).objecttype in [odt_javaclass,odt_interfacejava]);
  5957. end;
  5958. procedure loadobjctypes;
  5959. begin
  5960. objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_CLASS',true).typedef);
  5961. objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER',true).typedef);
  5962. objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID',true).typedef);
  5963. objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL',true).typedef);
  5964. objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT',true).typedef);
  5965. end;
  5966. procedure maybeloadcocoatypes;
  5967. var
  5968. tsym: ttypesym;
  5969. begin
  5970. if assigned(objc_fastenumeration) then
  5971. exit;
  5972. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONPROTOCOL',false);
  5973. if assigned(tsym) then
  5974. objc_fastenumeration:=tobjectdef(tsym.typedef)
  5975. else
  5976. objc_fastenumeration:=nil;
  5977. tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONSTATE',false);
  5978. if assigned(tsym) then
  5979. objc_fastenumerationstate:=trecorddef(tsym.typedef)
  5980. else
  5981. objc_fastenumerationstate:=nil;
  5982. end;
  5983. function use_vectorfpu(def : tdef) : boolean;
  5984. begin
  5985. {$ifdef x86}
  5986. {$define use_vectorfpuimplemented}
  5987. use_vectorfpu:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  5988. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  5989. {$endif x86}
  5990. {$ifdef arm}
  5991. {$define use_vectorfpuimplemented}
  5992. use_vectorfpu:=(current_settings.fputype in vfp_scalar);
  5993. {$endif arm}
  5994. {$ifndef use_vectorfpuimplemented}
  5995. use_vectorfpu:=false;
  5996. {$endif}
  5997. end;
  5998. function getpointerdef(def: tdef): tpointerdef;
  5999. var
  6000. res: PHashSetItem;
  6001. oldsymtablestack: tsymtablestack;
  6002. begin
  6003. if not assigned(current_module) then
  6004. internalerror(2011071101);
  6005. res:=current_module.ptrdefs.FindOrAdd(@def,sizeof(def));
  6006. if not assigned(res^.Data) then
  6007. begin
  6008. { since these pointerdefs can be reused anywhere in the current
  6009. unit, add them to the global/staticsymtable }
  6010. oldsymtablestack:=symtablestack;
  6011. { do not simply push/pop current_module.localsymtable, because
  6012. that can have side-effects (e.g., it removes helpers) }
  6013. symtablestack:=nil;
  6014. res^.Data:=tpointerdef.create(def);
  6015. current_module.localsymtable.insertdef(tdef(res^.Data));
  6016. symtablestack:=oldsymtablestack;
  6017. end;
  6018. result:=tpointerdef(res^.Data);
  6019. end;
  6020. function getsingletonarraydef(def: tdef): tarraydef;
  6021. begin
  6022. result:=getarraydef(def,1);
  6023. end;
  6024. function getarraydef(def: tdef; elecount: asizeint): tarraydef;
  6025. var
  6026. res: PHashSetItem;
  6027. oldsymtablestack: tsymtablestack;
  6028. arrdesc: packed record
  6029. def: tdef;
  6030. elecount: asizeint;
  6031. end;
  6032. begin
  6033. if not assigned(current_module) then
  6034. internalerror(2011081301);
  6035. arrdesc.def:=def;
  6036. arrdesc.elecount:=elecount;
  6037. res:=current_module.arraydefs.FindOrAdd(@arrdesc,sizeof(arrdesc));
  6038. if not assigned(res^.Data) then
  6039. begin
  6040. { since these arraydef can be reused anywhere in the current
  6041. unit, add them to the global/staticsymtable }
  6042. oldsymtablestack:=symtablestack;
  6043. symtablestack:=nil;
  6044. res^.Data:=tarraydef.create(0,elecount-1,ptrsinttype);
  6045. tarraydef(res^.Data).elementdef:=def;
  6046. current_module.localsymtable.insertdef(tdef(res^.Data));
  6047. symtablestack:=oldsymtablestack;
  6048. end;
  6049. result:=tarraydef(res^.Data);
  6050. end;
  6051. end.