symdef.pas 238 KB

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