123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603660466056606660766086609661066116612661366146615661666176618661966206621662266236624662566266627662866296630663166326633663466356636663766386639664066416642664366446645664666476648664966506651665266536654665566566657665866596660666166626663666466656666666766686669667066716672667366746675667666776678667966806681668266836684668566866687668866896690669166926693669466956696669766986699670067016702670367046705670667076708670967106711671267136714671567166717671867196720672167226723672467256726672767286729673067316732673367346735673667376738673967406741674267436744674567466747674867496750675167526753675467556756675767586759676067616762676367646765676667676768676967706771677267736774677567766777677867796780678167826783678467856786678767886789679067916792679367946795679667976798679968006801680268036804680568066807680868096810681168126813681468156816681768186819682068216822682368246825682668276828682968306831683268336834683568366837683868396840684168426843684468456846684768486849685068516852685368546855685668576858685968606861686268636864686568666867686868696870687168726873687468756876687768786879688068816882688368846885688668876888688968906891689268936894689568966897689868996900690169026903690469056906690769086909691069116912691369146915691669176918691969206921692269236924692569266927692869296930693169326933693469356936693769386939694069416942694369446945694669476948694969506951695269536954695569566957695869596960696169626963696469656966696769686969697069716972697369746975697669776978697969806981698269836984698569866987698869896990699169926993699469956996699769986999700070017002700370047005700670077008700970107011701270137014701570167017701870197020702170227023702470257026702770287029703070317032703370347035703670377038703970407041704270437044704570467047704870497050705170527053705470557056705770587059706070617062706370647065706670677068706970707071707270737074707570767077707870797080708170827083708470857086708770887089709070917092709370947095709670977098709971007101710271037104710571067107710871097110711171127113711471157116711771187119712071217122712371247125712671277128712971307131713271337134713571367137713871397140714171427143714471457146714771487149715071517152715371547155715671577158715971607161716271637164716571667167716871697170717171727173717471757176717771787179718071817182718371847185718671877188718971907191719271937194719571967197719871997200720172027203720472057206720772087209721072117212721372147215721672177218721972207221722272237224722572267227722872297230723172327233723472357236723772387239724072417242724372447245724672477248724972507251725272537254725572567257725872597260726172627263726472657266726772687269727072717272727372747275727672777278727972807281728272837284728572867287728872897290729172927293729472957296729772987299730073017302730373047305730673077308730973107311731273137314731573167317731873197320732173227323732473257326732773287329733073317332733373347335733673377338733973407341734273437344734573467347734873497350735173527353735473557356735773587359736073617362736373647365736673677368736973707371737273737374737573767377737873797380738173827383738473857386738773887389739073917392739373947395739673977398739974007401740274037404740574067407740874097410741174127413741474157416741774187419742074217422742374247425742674277428742974307431743274337434743574367437743874397440744174427443744474457446744774487449745074517452745374547455745674577458745974607461746274637464746574667467746874697470747174727473747474757476747774787479748074817482748374847485748674877488748974907491749274937494749574967497749874997500750175027503750475057506750775087509751075117512751375147515751675177518751975207521752275237524752575267527752875297530753175327533753475357536753775387539754075417542754375447545754675477548754975507551755275537554755575567557755875597560756175627563756475657566756775687569757075717572757375747575757675777578757975807581758275837584758575867587758875897590759175927593759475957596759775987599760076017602760376047605760676077608760976107611761276137614761576167617761876197620762176227623762476257626762776287629763076317632763376347635763676377638763976407641764276437644764576467647764876497650765176527653765476557656765776587659766076617662766376647665766676677668766976707671767276737674767576767677767876797680768176827683768476857686768776887689769076917692769376947695769676977698769977007701770277037704770577067707770877097710771177127713771477157716771777187719772077217722772377247725772677277728772977307731773277337734773577367737773877397740774177427743774477457746774777487749775077517752775377547755775677577758775977607761776277637764776577667767776877697770777177727773777477757776777777787779778077817782778377847785778677877788778977907791779277937794779577967797779877997800780178027803780478057806780778087809781078117812781378147815781678177818781978207821782278237824782578267827782878297830783178327833783478357836783778387839784078417842784378447845784678477848784978507851785278537854785578567857785878597860786178627863786478657866786778687869787078717872787378747875787678777878787978807881788278837884788578867887788878897890789178927893789478957896789778987899790079017902790379047905790679077908790979107911791279137914791579167917791879197920792179227923792479257926792779287929793079317932793379347935793679377938793979407941794279437944794579467947794879497950795179527953795479557956795779587959796079617962796379647965796679677968796979707971797279737974797579767977797879797980798179827983798479857986798779887989799079917992799379947995799679977998799980008001800280038004800580068007800880098010801180128013801480158016801780188019802080218022802380248025802680278028802980308031803280338034803580368037803880398040804180428043804480458046804780488049805080518052805380548055805680578058805980608061806280638064806580668067806880698070807180728073807480758076807780788079808080818082808380848085808680878088808980908091809280938094809580968097809880998100810181028103810481058106810781088109811081118112811381148115811681178118811981208121812281238124812581268127812881298130813181328133813481358136813781388139814081418142814381448145814681478148814981508151815281538154815581568157815881598160816181628163816481658166816781688169817081718172817381748175817681778178817981808181818281838184818581868187818881898190819181928193819481958196819781988199820082018202820382048205820682078208820982108211821282138214821582168217821882198220822182228223822482258226822782288229823082318232823382348235823682378238823982408241824282438244824582468247824882498250825182528253825482558256825782588259826082618262826382648265826682678268826982708271827282738274827582768277827882798280828182828283828482858286828782888289829082918292829382948295829682978298829983008301830283038304830583068307830883098310831183128313831483158316831783188319832083218322832383248325832683278328832983308331833283338334833583368337833883398340834183428343834483458346834783488349835083518352835383548355835683578358835983608361836283638364836583668367836883698370837183728373837483758376837783788379838083818382838383848385838683878388838983908391839283938394839583968397839883998400840184028403840484058406840784088409841084118412841384148415841684178418841984208421842284238424842584268427842884298430843184328433843484358436843784388439844084418442844384448445844684478448844984508451845284538454845584568457845884598460846184628463846484658466846784688469847084718472847384748475847684778478847984808481848284838484848584868487848884898490849184928493849484958496849784988499850085018502850385048505850685078508850985108511851285138514851585168517851885198520852185228523852485258526852785288529853085318532853385348535853685378538853985408541854285438544854585468547854885498550855185528553855485558556855785588559856085618562856385648565856685678568856985708571857285738574857585768577857885798580858185828583858485858586858785888589859085918592859385948595859685978598859986008601860286038604860586068607860886098610861186128613861486158616861786188619862086218622862386248625862686278628862986308631863286338634863586368637863886398640864186428643864486458646864786488649865086518652865386548655865686578658865986608661866286638664866586668667866886698670867186728673867486758676867786788679868086818682868386848685868686878688868986908691869286938694869586968697869886998700870187028703870487058706870787088709871087118712871387148715871687178718871987208721872287238724872587268727872887298730873187328733873487358736873787388739874087418742874387448745874687478748874987508751875287538754875587568757875887598760876187628763876487658766876787688769877087718772877387748775877687778778877987808781878287838784878587868787878887898790879187928793879487958796879787988799880088018802880388048805880688078808880988108811881288138814881588168817881888198820882188228823882488258826882788288829883088318832883388348835883688378838883988408841884288438844884588468847884888498850885188528853885488558856885788588859886088618862886388648865886688678868886988708871887288738874887588768877887888798880888188828883888488858886888788888889889088918892889388948895889688978898889989008901890289038904890589068907890889098910891189128913891489158916891789188919892089218922892389248925892689278928892989308931893289338934893589368937893889398940894189428943894489458946894789488949895089518952895389548955895689578958895989608961896289638964896589668967896889698970897189728973897489758976897789788979898089818982898389848985898689878988898989908991899289938994899589968997899889999000900190029003900490059006900790089009901090119012901390149015901690179018901990209021902290239024902590269027902890299030903190329033903490359036903790389039904090419042904390449045904690479048904990509051905290539054905590569057905890599060906190629063906490659066906790689069907090719072907390749075907690779078907990809081908290839084908590869087908890899090909190929093909490959096909790989099910091019102910391049105910691079108910991109111911291139114911591169117911891199120912191229123912491259126912791289129913091319132913391349135913691379138913991409141914291439144914591469147914891499150915191529153915491559156915791589159916091619162916391649165916691679168916991709171917291739174917591769177917891799180918191829183918491859186918791889189919091919192919391949195919691979198919992009201920292039204920592069207920892099210921192129213921492159216921792189219922092219222922392249225922692279228922992309231923292339234923592369237923892399240924192429243924492459246924792489249925092519252925392549255925692579258925992609261926292639264926592669267926892699270927192729273927492759276927792789279928092819282928392849285928692879288928992909291929292939294929592969297929892999300930193029303930493059306930793089309931093119312931393149315931693179318931993209321932293239324932593269327932893299330933193329333933493359336933793389339934093419342934393449345934693479348934993509351935293539354935593569357935893599360936193629363936493659366936793689369937093719372937393749375937693779378937993809381938293839384938593869387938893899390939193929393939493959396939793989399940094019402940394049405940694079408940994109411941294139414941594169417941894199420942194229423942494259426942794289429943094319432943394349435943694379438943994409441944294439444944594469447944894499450945194529453945494559456945794589459946094619462946394649465946694679468946994709471947294739474947594769477947894799480948194829483948494859486948794889489949094919492949394949495949694979498949995009501950295039504950595069507950895099510951195129513951495159516951795189519952095219522952395249525952695279528952995309531953295339534953595369537953895399540954195429543954495459546954795489549955095519552955395549555955695579558955995609561956295639564956595669567956895699570957195729573957495759576957795789579958095819582958395849585958695879588958995909591959295939594959595969597959895999600960196029603960496059606960796089609961096119612961396149615961696179618961996209621962296239624962596269627962896299630963196329633963496359636963796389639964096419642964396449645964696479648964996509651965296539654965596569657965896599660966196629663966496659666966796689669967096719672967396749675967696779678967996809681968296839684968596869687968896899690969196929693969496959696969796989699970097019702970397049705970697079708970997109711971297139714971597169717971897199720972197229723972497259726972797289729973097319732973397349735973697379738973997409741974297439744974597469747974897499750975197529753975497559756975797589759976097619762976397649765976697679768976997709771977297739774977597769777977897799780978197829783978497859786978797889789979097919792979397949795979697979798979998009801980298039804980598069807980898099810981198129813981498159816981798189819982098219822982398249825982698279828982998309831983298339834983598369837983898399840984198429843984498459846984798489849985098519852985398549855985698579858985998609861986298639864986598669867986898699870987198729873987498759876987798789879988098819882988398849885988698879888988998909891989298939894989598969897989898999900990199029903990499059906990799089909991099119912991399149915991699179918991999209921992299239924992599269927992899299930993199329933993499359936993799389939994099419942994399449945994699479948994999509951995299539954995599569957995899599960996199629963996499659966996799689969997099719972997399749975997699779978997999809981998299839984998599869987998899899990999199929993999499959996999799989999100001000110002100031000410005100061000710008100091001010011100121001310014100151001610017100181001910020100211002210023100241002510026100271002810029100301003110032100331003410035100361003710038100391004010041100421004310044100451004610047100481004910050100511005210053100541005510056100571005810059100601006110062100631006410065100661006710068100691007010071100721007310074100751007610077100781007910080100811008210083100841008510086100871008810089100901009110092100931009410095100961009710098100991010010101101021010310104101051010610107101081010910110101111011210113101141011510116101171011810119101201012110122101231012410125101261012710128101291013010131101321013310134101351013610137101381013910140101411014210143101441014510146101471014810149101501015110152101531015410155101561015710158101591016010161101621016310164101651016610167101681016910170101711017210173101741017510176101771017810179101801018110182101831018410185101861018710188101891019010191101921019310194101951019610197101981019910200102011020210203102041020510206102071020810209102101021110212102131021410215102161021710218102191022010221102221022310224102251022610227102281022910230102311023210233102341023510236102371023810239102401024110242102431024410245102461024710248102491025010251102521025310254102551025610257102581025910260102611026210263102641026510266102671026810269102701027110272102731027410275102761027710278102791028010281102821028310284102851028610287102881028910290102911029210293102941029510296102971029810299103001030110302103031030410305103061030710308103091031010311103121031310314103151031610317103181031910320103211032210323103241032510326103271032810329103301033110332103331033410335103361033710338103391034010341103421034310344103451034610347103481034910350103511035210353103541035510356103571035810359103601036110362103631036410365103661036710368103691037010371103721037310374103751037610377103781037910380103811038210383103841038510386103871038810389103901039110392103931039410395103961039710398103991040010401104021040310404104051040610407104081040910410104111041210413104141041510416104171041810419104201042110422104231042410425104261042710428104291043010431104321043310434104351043610437104381043910440104411044210443104441044510446104471044810449104501045110452104531045410455104561045710458104591046010461104621046310464104651046610467104681046910470104711047210473104741047510476104771047810479104801048110482104831048410485104861048710488104891049010491104921049310494104951049610497104981049910500105011050210503105041050510506105071050810509105101051110512105131051410515105161051710518105191052010521105221052310524105251052610527105281052910530105311053210533105341053510536105371053810539105401054110542105431054410545105461054710548105491055010551105521055310554105551055610557105581055910560105611056210563105641056510566105671056810569105701057110572105731057410575105761057710578105791058010581105821058310584105851058610587105881058910590105911059210593105941059510596105971059810599106001060110602106031060410605106061060710608106091061010611106121061310614106151061610617106181061910620106211062210623106241062510626106271062810629106301063110632106331063410635106361063710638106391064010641106421064310644106451064610647106481064910650106511065210653106541065510656106571065810659106601066110662106631066410665106661066710668106691067010671106721067310674106751067610677106781067910680106811068210683106841068510686106871068810689106901069110692106931069410695106961069710698106991070010701107021070310704107051070610707107081070910710107111071210713107141071510716107171071810719107201072110722107231072410725107261072710728107291073010731107321073310734107351073610737107381073910740107411074210743107441074510746107471074810749107501075110752107531075410755107561075710758107591076010761107621076310764107651076610767107681076910770107711077210773107741077510776107771077810779107801078110782107831078410785107861078710788107891079010791107921079310794107951079610797107981079910800108011080210803108041080510806108071080810809108101081110812108131081410815108161081710818108191082010821108221082310824108251082610827108281082910830108311083210833108341083510836108371083810839108401084110842108431084410845108461084710848108491085010851108521085310854108551085610857108581085910860108611086210863108641086510866108671086810869108701087110872108731087410875108761087710878108791088010881108821088310884108851088610887108881088910890108911089210893108941089510896108971089810899109001090110902109031090410905109061090710908109091091010911109121091310914109151091610917109181091910920109211092210923109241092510926109271092810929109301093110932109331093410935109361093710938109391094010941109421094310944109451094610947109481094910950109511095210953109541095510956109571095810959109601096110962109631096410965109661096710968109691097010971109721097310974109751097610977109781097910980109811098210983109841098510986109871098810989109901099110992109931099410995109961099710998109991100011001110021100311004110051100611007110081100911010110111101211013110141101511016110171101811019110201102111022110231102411025110261102711028110291103011031110321103311034110351103611037110381103911040110411104211043110441104511046110471104811049110501105111052110531105411055110561105711058110591106011061110621106311064110651106611067110681106911070110711107211073110741107511076110771107811079110801108111082110831108411085110861108711088110891109011091110921109311094110951109611097110981109911100111011110211103111041110511106111071110811109111101111111112111131111411115111161111711118111191112011121111221112311124111251112611127111281112911130111311113211133111341113511136111371113811139111401114111142111431114411145111461114711148111491115011151111521115311154111551115611157111581115911160111611116211163111641116511166111671116811169111701117111172111731117411175111761117711178111791118011181111821118311184111851118611187111881118911190111911119211193111941119511196111971119811199112001120111202112031120411205112061120711208112091121011211112121121311214112151121611217112181121911220112211122211223112241122511226112271122811229112301123111232112331123411235112361123711238112391124011241112421124311244112451124611247112481124911250112511125211253112541125511256112571125811259112601126111262112631126411265112661126711268112691127011271112721127311274112751127611277112781127911280112811128211283112841128511286112871128811289112901129111292112931129411295112961129711298112991130011301113021130311304113051130611307113081130911310113111131211313113141131511316113171131811319113201132111322113231132411325113261132711328113291133011331113321133311334113351133611337113381133911340113411134211343113441134511346113471134811349113501135111352113531135411355113561135711358113591136011361113621136311364113651136611367113681136911370113711137211373113741137511376113771137811379113801138111382113831138411385113861138711388113891139011391113921139311394113951139611397113981139911400114011140211403114041140511406114071140811409114101141111412114131141411415114161141711418114191142011421114221142311424114251142611427114281142911430114311143211433114341143511436114371143811439114401144111442114431144411445114461144711448114491145011451114521145311454114551145611457114581145911460114611146211463114641146511466114671146811469114701147111472114731147411475114761147711478114791148011481114821148311484114851148611487114881148911490114911149211493114941149511496114971149811499115001150111502115031150411505115061150711508115091151011511115121151311514115151151611517115181151911520115211152211523115241152511526115271152811529115301153111532115331153411535115361153711538115391154011541115421154311544115451154611547115481154911550115511155211553115541155511556115571155811559115601156111562115631156411565115661156711568115691157011571115721157311574115751157611577115781157911580115811158211583115841158511586115871158811589115901159111592115931159411595115961159711598115991160011601116021160311604116051160611607116081160911610116111161211613116141161511616116171161811619116201162111622116231162411625116261162711628116291163011631116321163311634116351163611637116381163911640116411164211643116441164511646116471164811649116501165111652116531165411655116561165711658116591166011661116621166311664116651166611667116681166911670116711167211673116741167511676116771167811679116801168111682116831168411685116861168711688116891169011691116921169311694116951169611697116981169911700117011170211703117041170511706117071170811709117101171111712117131171411715117161171711718117191172011721117221172311724117251172611727117281172911730117311173211733117341173511736117371173811739117401174111742117431174411745117461174711748117491175011751117521175311754117551175611757117581175911760117611176211763117641176511766117671176811769117701177111772117731177411775117761177711778117791178011781117821178311784117851178611787117881178911790117911179211793117941179511796117971179811799118001180111802118031180411805118061180711808118091181011811118121181311814118151181611817118181181911820118211182211823118241182511826118271182811829118301183111832118331183411835118361183711838118391184011841118421184311844118451184611847118481184911850118511185211853118541185511856118571185811859118601186111862118631186411865118661186711868118691187011871118721187311874118751187611877118781187911880118811188211883118841188511886118871188811889118901189111892118931189411895118961189711898118991190011901119021190311904119051190611907119081190911910119111191211913119141191511916119171191811919119201192111922119231192411925119261192711928119291193011931119321193311934119351193611937119381193911940119411194211943119441194511946119471194811949119501195111952119531195411955119561195711958119591196011961119621196311964119651196611967119681196911970119711197211973119741197511976119771197811979119801198111982119831198411985119861198711988119891199011991119921199311994119951199611997119981199912000120011200212003120041200512006120071200812009120101201112012120131201412015120161201712018120191202012021120221202312024120251202612027120281202912030120311203212033120341203512036120371203812039120401204112042120431204412045120461204712048120491205012051120521205312054120551205612057120581205912060120611206212063120641206512066120671206812069120701207112072120731207412075120761207712078120791208012081120821208312084120851208612087120881208912090120911209212093120941209512096120971209812099121001210112102121031210412105121061210712108121091211012111121121211312114121151211612117121181211912120121211212212123121241212512126121271212812129121301213112132121331213412135121361213712138121391214012141121421214312144121451214612147121481214912150121511215212153121541215512156121571215812159121601216112162121631216412165121661216712168121691217012171121721217312174121751217612177121781217912180121811218212183121841218512186121871218812189121901219112192121931219412195121961219712198121991220012201122021220312204122051220612207122081220912210122111221212213122141221512216122171221812219122201222112222122231222412225122261222712228122291223012231122321223312234122351223612237122381223912240122411224212243122441224512246122471224812249122501225112252122531225412255122561225712258122591226012261122621226312264122651226612267122681226912270122711227212273122741227512276122771227812279122801228112282122831228412285122861228712288122891229012291122921229312294122951229612297122981229912300123011230212303123041230512306123071230812309123101231112312123131231412315123161231712318123191232012321123221232312324123251232612327123281232912330123311233212333123341233512336123371233812339123401234112342123431234412345123461234712348123491235012351123521235312354123551235612357123581235912360123611236212363123641236512366123671236812369123701237112372123731237412375123761237712378123791238012381123821238312384123851238612387123881238912390123911239212393123941239512396123971239812399124001240112402124031240412405124061240712408124091241012411124121241312414124151241612417124181241912420124211242212423124241242512426124271242812429124301243112432124331243412435124361243712438124391244012441124421244312444124451244612447124481244912450124511245212453124541245512456124571245812459124601246112462124631246412465124661246712468124691247012471124721247312474124751247612477124781247912480124811248212483124841248512486124871248812489124901249112492124931249412495124961249712498124991250012501125021250312504125051250612507125081250912510125111251212513125141251512516125171251812519125201252112522125231252412525125261252712528125291253012531125321253312534125351253612537125381253912540125411254212543125441254512546125471254812549125501255112552125531255412555125561255712558125591256012561125621256312564125651256612567125681256912570125711257212573125741257512576125771257812579125801258112582125831258412585125861258712588125891259012591125921259312594125951259612597125981259912600126011260212603126041260512606126071260812609126101261112612126131261412615126161261712618126191262012621126221262312624126251262612627126281262912630126311263212633126341263512636126371263812639126401264112642126431264412645126461264712648126491265012651126521265312654126551265612657126581265912660126611266212663126641266512666126671266812669126701267112672126731267412675126761267712678126791268012681126821268312684126851268612687126881268912690126911269212693126941269512696126971269812699127001270112702127031270412705127061270712708127091271012711127121271312714127151271612717127181271912720127211272212723127241272512726127271272812729127301273112732127331273412735127361273712738127391274012741127421274312744127451274612747127481274912750127511275212753127541275512756127571275812759127601276112762127631276412765127661276712768127691277012771127721277312774127751277612777127781277912780127811278212783127841278512786127871278812789127901279112792127931279412795127961279712798127991280012801128021280312804128051280612807128081280912810128111281212813128141281512816128171281812819128201282112822128231282412825128261282712828128291283012831128321283312834128351283612837128381283912840128411284212843128441284512846128471284812849128501285112852128531285412855128561285712858128591286012861128621286312864128651286612867128681286912870128711287212873128741287512876128771287812879128801288112882128831288412885128861288712888128891289012891128921289312894128951289612897128981289912900129011290212903129041290512906129071290812909129101291112912129131291412915129161291712918129191292012921129221292312924129251292612927129281292912930129311293212933129341293512936129371293812939129401294112942129431294412945129461294712948129491295012951129521295312954129551295612957129581295912960129611296212963129641296512966129671296812969129701297112972129731297412975129761297712978129791298012981129821298312984129851298612987129881298912990129911299212993129941299512996129971299812999130001300113002130031300413005130061300713008130091301013011130121301313014130151301613017130181301913020130211302213023130241302513026130271302813029130301303113032130331303413035130361303713038130391304013041130421304313044130451304613047130481304913050130511305213053130541305513056130571305813059130601306113062130631306413065130661306713068130691307013071130721307313074130751307613077130781307913080130811308213083130841308513086130871308813089130901309113092130931309413095130961309713098130991310013101131021310313104131051310613107131081310913110131111311213113131141311513116131171311813119131201312113122131231312413125131261312713128131291313013131131321313313134131351313613137131381313913140131411314213143131441314513146131471314813149131501315113152131531315413155131561315713158131591316013161131621316313164131651316613167131681316913170131711317213173131741317513176131771317813179131801318113182131831318413185131861318713188131891319013191131921319313194131951319613197131981319913200132011320213203132041320513206132071320813209132101321113212132131321413215132161321713218132191322013221132221322313224132251322613227132281322913230132311323213233132341323513236132371323813239132401324113242132431324413245132461324713248132491325013251132521325313254132551325613257132581325913260132611326213263132641326513266132671326813269132701327113272132731327413275132761327713278132791328013281132821328313284132851328613287132881328913290132911329213293132941329513296132971329813299133001330113302133031330413305133061330713308133091331013311133121331313314133151331613317133181331913320133211332213323133241332513326133271332813329133301333113332133331333413335133361333713338133391334013341133421334313344133451334613347133481334913350133511335213353133541335513356133571335813359133601336113362133631336413365133661336713368133691337013371133721337313374133751337613377133781337913380133811338213383133841338513386133871338813389133901339113392133931339413395133961339713398133991340013401134021340313404134051340613407134081340913410134111341213413134141341513416134171341813419134201342113422134231342413425134261342713428134291343013431134321343313434134351343613437134381343913440134411344213443134441344513446134471344813449134501345113452134531345413455134561345713458134591346013461134621346313464134651346613467134681346913470134711347213473134741347513476134771347813479134801348113482134831348413485134861348713488134891349013491134921349313494134951349613497134981349913500135011350213503135041350513506135071350813509135101351113512135131351413515135161351713518135191352013521135221352313524135251352613527135281352913530135311353213533135341353513536135371353813539135401354113542135431354413545135461354713548135491355013551135521355313554135551355613557135581355913560135611356213563135641356513566135671356813569135701357113572135731357413575135761357713578135791358013581135821358313584135851358613587135881358913590135911359213593135941359513596135971359813599136001360113602136031360413605136061360713608136091361013611136121361313614136151361613617136181361913620136211362213623136241362513626136271362813629136301363113632136331363413635136361363713638136391364013641136421364313644136451364613647136481364913650136511365213653136541365513656136571365813659136601366113662136631366413665136661366713668136691367013671136721367313674136751367613677136781367913680136811368213683136841368513686136871368813689136901369113692136931369413695136961369713698136991370013701137021370313704137051370613707137081370913710137111371213713137141371513716137171371813719137201372113722137231372413725137261372713728137291373013731137321373313734137351373613737137381373913740137411374213743137441374513746137471374813749137501375113752137531375413755137561375713758137591376013761137621376313764137651376613767137681376913770137711377213773137741377513776137771377813779137801378113782137831378413785137861378713788137891379013791137921379313794137951379613797137981379913800138011380213803138041380513806138071380813809138101381113812138131381413815138161381713818138191382013821138221382313824138251382613827138281382913830138311383213833138341383513836138371383813839138401384113842138431384413845138461384713848138491385013851138521385313854138551385613857138581385913860138611386213863138641386513866138671386813869138701387113872138731387413875138761387713878138791388013881138821388313884138851388613887138881388913890138911389213893138941389513896138971389813899139001390113902139031390413905139061390713908139091391013911139121391313914139151391613917139181391913920139211392213923139241392513926139271392813929139301393113932139331393413935139361393713938139391394013941139421394313944139451394613947139481394913950139511395213953139541395513956139571395813959139601396113962139631396413965139661396713968139691397013971139721397313974139751397613977139781397913980139811398213983139841398513986139871398813989139901399113992139931399413995139961399713998139991400014001140021400314004140051400614007140081400914010140111401214013140141401514016140171401814019140201402114022140231402414025140261402714028140291403014031140321403314034140351403614037140381403914040140411404214043140441404514046140471404814049140501405114052140531405414055140561405714058140591406014061140621406314064140651406614067140681406914070140711407214073140741407514076140771407814079140801408114082140831408414085140861408714088140891409014091140921409314094140951409614097140981409914100141011410214103141041410514106141071410814109141101411114112141131411414115141161411714118141191412014121141221412314124141251412614127141281412914130141311413214133141341413514136141371413814139141401414114142141431414414145141461414714148141491415014151141521415314154141551415614157141581415914160141611416214163141641416514166141671416814169141701417114172141731417414175141761417714178141791418014181141821418314184141851418614187141881418914190141911419214193141941419514196141971419814199142001420114202142031420414205142061420714208142091421014211142121421314214142151421614217142181421914220142211422214223142241422514226142271422814229142301423114232142331423414235142361423714238142391424014241142421424314244142451424614247142481424914250142511425214253142541425514256142571425814259142601426114262142631426414265142661426714268142691427014271142721427314274142751427614277142781427914280142811428214283142841428514286142871428814289142901429114292142931429414295142961429714298142991430014301143021430314304143051430614307143081430914310143111431214313143141431514316143171431814319143201432114322143231432414325143261432714328143291433014331143321433314334143351433614337143381433914340143411434214343143441434514346143471434814349143501435114352143531435414355143561435714358143591436014361143621436314364143651436614367143681436914370143711437214373143741437514376143771437814379143801438114382143831438414385143861438714388143891439014391143921439314394143951439614397143981439914400144011440214403144041440514406144071440814409144101441114412144131441414415144161441714418144191442014421144221442314424144251442614427144281442914430144311443214433144341443514436144371443814439144401444114442144431444414445144461444714448144491445014451144521445314454144551445614457144581445914460144611446214463144641446514466144671446814469144701447114472144731447414475144761447714478144791448014481144821448314484144851448614487144881448914490144911449214493144941449514496144971449814499145001450114502145031450414505145061450714508145091451014511145121451314514145151451614517145181451914520145211452214523145241452514526145271452814529145301453114532145331453414535145361453714538145391454014541145421454314544145451454614547145481454914550145511455214553145541455514556145571455814559145601456114562145631456414565145661456714568145691457014571145721457314574145751457614577145781457914580145811458214583145841458514586145871458814589145901459114592145931459414595145961459714598145991460014601146021460314604146051460614607146081460914610146111461214613146141461514616146171461814619146201462114622146231462414625146261462714628146291463014631146321463314634146351463614637146381463914640146411464214643146441464514646146471464814649146501465114652146531465414655146561465714658146591466014661146621466314664146651466614667146681466914670146711467214673146741467514676146771467814679146801468114682146831468414685146861468714688146891469014691146921469314694146951469614697146981469914700147011470214703147041470514706147071470814709147101471114712147131471414715147161471714718147191472014721147221472314724147251472614727147281472914730147311473214733147341473514736147371473814739147401474114742147431474414745147461474714748147491475014751147521475314754147551475614757147581475914760147611476214763147641476514766147671476814769147701477114772147731477414775147761477714778147791478014781147821478314784147851478614787147881478914790147911479214793147941479514796147971479814799148001480114802148031480414805148061480714808148091481014811148121481314814148151481614817148181481914820148211482214823148241482514826148271482814829148301483114832148331483414835148361483714838148391484014841148421484314844148451484614847148481484914850148511485214853148541485514856148571485814859148601486114862148631486414865148661486714868148691487014871148721487314874148751487614877148781487914880148811488214883148841488514886148871488814889148901489114892148931489414895148961489714898148991490014901149021490314904149051490614907149081490914910149111491214913149141491514916149171491814919149201492114922149231492414925149261492714928149291493014931149321493314934149351493614937149381493914940149411494214943149441494514946149471494814949149501495114952149531495414955149561495714958149591496014961149621496314964149651496614967149681496914970149711497214973149741497514976149771497814979149801498114982149831498414985149861498714988149891499014991149921499314994149951499614997149981499915000150011500215003150041500515006150071500815009150101501115012150131501415015150161501715018150191502015021150221502315024150251502615027150281502915030150311503215033150341503515036150371503815039150401504115042150431504415045150461504715048150491505015051150521505315054150551505615057150581505915060150611506215063150641506515066150671506815069150701507115072150731507415075150761507715078150791508015081150821508315084150851508615087150881508915090150911509215093150941509515096150971509815099151001510115102151031510415105151061510715108151091511015111151121511315114151151511615117151181511915120151211512215123151241512515126151271512815129151301513115132151331513415135151361513715138151391514015141151421514315144151451514615147151481514915150151511515215153151541515515156151571515815159151601516115162151631516415165151661516715168151691517015171151721517315174151751517615177151781517915180151811518215183151841518515186151871518815189151901519115192151931519415195151961519715198151991520015201152021520315204152051520615207152081520915210152111521215213152141521515216152171521815219152201522115222152231522415225152261522715228152291523015231152321523315234152351523615237152381523915240152411524215243152441524515246152471524815249152501525115252152531525415255152561525715258152591526015261152621526315264152651526615267152681526915270152711527215273152741527515276152771527815279152801528115282152831528415285152861528715288152891529015291152921529315294152951529615297152981529915300153011530215303153041530515306153071530815309153101531115312153131531415315153161531715318153191532015321153221532315324153251532615327153281532915330153311533215333153341533515336153371533815339153401534115342153431534415345153461534715348153491535015351153521535315354153551535615357153581535915360153611536215363153641536515366153671536815369153701537115372153731537415375153761537715378153791538015381153821538315384153851538615387153881538915390153911539215393153941539515396153971539815399154001540115402154031540415405154061540715408154091541015411154121541315414154151541615417154181541915420154211542215423154241542515426154271542815429154301543115432154331543415435154361543715438154391544015441154421544315444154451544615447154481544915450154511545215453154541545515456154571545815459154601546115462154631546415465154661546715468154691547015471154721547315474154751547615477154781547915480154811548215483154841548515486154871548815489154901549115492154931549415495154961549715498154991550015501155021550315504155051550615507155081550915510155111551215513155141551515516155171551815519155201552115522155231552415525155261552715528155291553015531155321553315534155351553615537155381553915540155411554215543155441554515546155471554815549155501555115552155531555415555155561555715558155591556015561155621556315564155651556615567155681556915570155711557215573155741557515576155771557815579155801558115582155831558415585155861558715588155891559015591155921559315594155951559615597155981559915600156011560215603156041560515606156071560815609156101561115612156131561415615156161561715618156191562015621156221562315624156251562615627156281562915630156311563215633156341563515636156371563815639156401564115642156431564415645156461564715648156491565015651156521565315654156551565615657156581565915660156611566215663156641566515666156671566815669156701567115672156731567415675156761567715678156791568015681156821568315684156851568615687156881568915690156911569215693156941569515696156971569815699157001570115702157031570415705157061570715708157091571015711157121571315714157151571615717157181571915720157211572215723157241572515726157271572815729157301573115732157331573415735157361573715738157391574015741157421574315744157451574615747157481574915750157511575215753157541575515756157571575815759157601576115762157631576415765157661576715768157691577015771157721577315774157751577615777157781577915780157811578215783157841578515786157871578815789157901579115792157931579415795157961579715798157991580015801158021580315804158051580615807158081580915810158111581215813158141581515816158171581815819158201582115822158231582415825158261582715828158291583015831158321583315834158351583615837158381583915840158411584215843158441584515846158471584815849158501585115852158531585415855158561585715858158591586015861158621586315864158651586615867158681586915870158711587215873158741587515876158771587815879158801588115882158831588415885158861588715888158891589015891158921589315894158951589615897158981589915900159011590215903159041590515906159071590815909159101591115912159131591415915159161591715918159191592015921159221592315924159251592615927159281592915930159311593215933159341593515936159371593815939159401594115942159431594415945159461594715948159491595015951159521595315954159551595615957159581595915960159611596215963159641596515966159671596815969159701597115972159731597415975159761597715978159791598015981159821598315984159851598615987159881598915990159911599215993159941599515996159971599815999160001600116002160031600416005160061600716008160091601016011160121601316014160151601616017160181601916020160211602216023160241602516026160271602816029160301603116032160331603416035160361603716038160391604016041160421604316044160451604616047160481604916050160511605216053160541605516056160571605816059160601606116062160631606416065160661606716068160691607016071160721607316074160751607616077160781607916080160811608216083160841608516086160871608816089160901609116092160931609416095160961609716098160991610016101161021610316104161051610616107161081610916110161111611216113161141611516116161171611816119161201612116122161231612416125161261612716128161291613016131161321613316134161351613616137161381613916140161411614216143161441614516146161471614816149161501615116152161531615416155161561615716158161591616016161161621616316164161651616616167161681616916170161711617216173161741617516176161771617816179161801618116182161831618416185161861618716188161891619016191161921619316194161951619616197161981619916200162011620216203162041620516206162071620816209162101621116212162131621416215162161621716218162191622016221162221622316224162251622616227162281622916230162311623216233162341623516236162371623816239162401624116242162431624416245162461624716248162491625016251162521625316254162551625616257162581625916260162611626216263162641626516266162671626816269162701627116272162731627416275162761627716278162791628016281162821628316284162851628616287162881628916290162911629216293162941629516296162971629816299163001630116302163031630416305163061630716308163091631016311163121631316314163151631616317163181631916320163211632216323163241632516326163271632816329163301633116332163331633416335163361633716338163391634016341163421634316344163451634616347163481634916350163511635216353163541635516356163571635816359163601636116362163631636416365163661636716368163691637016371163721637316374163751637616377163781637916380163811638216383163841638516386163871638816389163901639116392163931639416395163961639716398163991640016401164021640316404164051640616407164081640916410164111641216413164141641516416164171641816419164201642116422164231642416425164261642716428164291643016431164321643316434164351643616437164381643916440164411644216443164441644516446164471644816449164501645116452164531645416455164561645716458164591646016461164621646316464164651646616467164681646916470164711647216473164741647516476164771647816479164801648116482164831648416485164861648716488164891649016491164921649316494164951649616497164981649916500165011650216503165041650516506165071650816509165101651116512165131651416515165161651716518165191652016521165221652316524165251652616527165281652916530165311653216533165341653516536165371653816539165401654116542165431654416545165461654716548165491655016551165521655316554165551655616557165581655916560165611656216563165641656516566165671656816569165701657116572165731657416575165761657716578165791658016581165821658316584165851658616587165881658916590165911659216593165941659516596165971659816599166001660116602166031660416605166061660716608166091661016611166121661316614166151661616617166181661916620166211662216623166241662516626166271662816629166301663116632166331663416635166361663716638166391664016641166421664316644166451664616647166481664916650166511665216653166541665516656166571665816659166601666116662166631666416665166661666716668166691667016671166721667316674166751667616677166781667916680166811668216683166841668516686166871668816689166901669116692166931669416695166961669716698166991670016701167021670316704167051670616707167081670916710167111671216713167141671516716167171671816719167201672116722167231672416725167261672716728167291673016731167321673316734167351673616737167381673916740167411674216743167441674516746167471674816749167501675116752167531675416755167561675716758167591676016761167621676316764167651676616767167681676916770167711677216773167741677516776167771677816779167801678116782167831678416785167861678716788167891679016791167921679316794167951679616797167981679916800168011680216803168041680516806168071680816809168101681116812168131681416815168161681716818168191682016821168221682316824168251682616827168281682916830168311683216833168341683516836168371683816839168401684116842168431684416845168461684716848168491685016851168521685316854168551685616857168581685916860168611686216863168641686516866168671686816869168701687116872168731687416875168761687716878168791688016881168821688316884168851688616887168881688916890168911689216893168941689516896168971689816899169001690116902169031690416905169061690716908169091691016911169121691316914169151691616917169181691916920169211692216923169241692516926169271692816929169301693116932169331693416935169361693716938169391694016941169421694316944169451694616947169481694916950169511695216953169541695516956169571695816959169601696116962169631696416965169661696716968169691697016971169721697316974169751697616977169781697916980169811698216983169841698516986169871698816989169901699116992169931699416995169961699716998169991700017001170021700317004170051700617007170081700917010170111701217013170141701517016170171701817019170201702117022170231702417025170261702717028170291703017031170321703317034170351703617037170381703917040170411704217043170441704517046170471704817049170501705117052170531705417055170561705717058170591706017061170621706317064170651706617067170681706917070170711707217073170741707517076170771707817079170801708117082170831708417085170861708717088170891709017091170921709317094170951709617097170981709917100171011710217103171041710517106171071710817109171101711117112171131711417115171161711717118171191712017121171221712317124171251712617127171281712917130171311713217133171341713517136171371713817139171401714117142171431714417145171461714717148171491715017151171521715317154171551715617157171581715917160171611716217163171641716517166171671716817169171701717117172171731717417175171761717717178171791718017181171821718317184171851718617187171881718917190171911719217193171941719517196171971719817199172001720117202172031720417205172061720717208172091721017211172121721317214172151721617217172181721917220172211722217223172241722517226172271722817229172301723117232172331723417235172361723717238172391724017241172421724317244172451724617247172481724917250172511725217253172541725517256172571725817259172601726117262172631726417265172661726717268172691727017271172721727317274172751727617277172781727917280172811728217283172841728517286172871728817289172901729117292172931729417295172961729717298172991730017301173021730317304173051730617307173081730917310173111731217313173141731517316173171731817319173201732117322173231732417325173261732717328173291733017331173321733317334173351733617337173381733917340173411734217343173441734517346173471734817349173501735117352173531735417355173561735717358173591736017361173621736317364173651736617367173681736917370173711737217373173741737517376173771737817379173801738117382173831738417385173861738717388173891739017391173921739317394173951739617397173981739917400174011740217403174041740517406174071740817409174101741117412174131741417415174161741717418174191742017421174221742317424174251742617427174281742917430174311743217433174341743517436174371743817439174401744117442174431744417445174461744717448174491745017451174521745317454174551745617457174581745917460174611746217463174641746517466174671746817469174701747117472174731747417475174761747717478174791748017481174821748317484174851748617487174881748917490174911749217493174941749517496174971749817499175001750117502175031750417505175061750717508175091751017511175121751317514175151751617517175181751917520175211752217523175241752517526175271752817529175301753117532175331753417535175361753717538175391754017541175421754317544175451754617547175481754917550175511755217553175541755517556175571755817559175601756117562175631756417565175661756717568175691757017571175721757317574175751757617577175781757917580175811758217583175841758517586175871758817589175901759117592175931759417595175961759717598175991760017601176021760317604176051760617607176081760917610176111761217613176141761517616176171761817619176201762117622176231762417625176261762717628176291763017631176321763317634176351763617637176381763917640176411764217643176441764517646176471764817649176501765117652176531765417655176561765717658176591766017661176621766317664176651766617667176681766917670176711767217673176741767517676176771767817679176801768117682176831768417685176861768717688176891769017691176921769317694176951769617697176981769917700177011770217703177041770517706177071770817709177101771117712177131771417715177161771717718177191772017721177221772317724177251772617727177281772917730177311773217733177341773517736177371773817739177401774117742177431774417745177461774717748177491775017751177521775317754177551775617757177581775917760177611776217763177641776517766177671776817769177701777117772177731777417775177761777717778177791778017781177821778317784177851778617787177881778917790177911779217793177941779517796177971779817799178001780117802178031780417805178061780717808178091781017811178121781317814178151781617817178181781917820178211782217823178241782517826178271782817829178301783117832178331783417835178361783717838178391784017841178421784317844178451784617847178481784917850178511785217853178541785517856178571785817859178601786117862178631786417865178661786717868178691787017871178721787317874178751787617877178781787917880178811788217883178841788517886178871788817889178901789117892178931789417895178961789717898178991790017901179021790317904179051790617907179081790917910179111791217913179141791517916179171791817919179201792117922179231792417925179261792717928179291793017931179321793317934179351793617937179381793917940179411794217943179441794517946179471794817949179501795117952179531795417955179561795717958179591796017961179621796317964179651796617967179681796917970179711797217973179741797517976179771797817979179801798117982179831798417985179861798717988179891799017991179921799317994179951799617997179981799918000180011800218003180041800518006180071800818009180101801118012180131801418015180161801718018180191802018021180221802318024180251802618027180281802918030180311803218033180341803518036180371803818039180401804118042180431804418045180461804718048180491805018051180521805318054180551805618057180581805918060180611806218063180641806518066180671806818069180701807118072180731807418075180761807718078180791808018081180821808318084180851808618087180881808918090180911809218093180941809518096180971809818099181001810118102181031810418105181061810718108181091811018111181121811318114181151811618117181181811918120181211812218123181241812518126181271812818129181301813118132181331813418135181361813718138181391814018141181421814318144181451814618147181481814918150181511815218153181541815518156181571815818159181601816118162181631816418165181661816718168181691817018171181721817318174181751817618177181781817918180181811818218183181841818518186181871818818189181901819118192181931819418195181961819718198181991820018201182021820318204182051820618207182081820918210182111821218213182141821518216182171821818219182201822118222182231822418225182261822718228182291823018231182321823318234182351823618237182381823918240182411824218243182441824518246182471824818249182501825118252182531825418255182561825718258182591826018261182621826318264182651826618267182681826918270182711827218273182741827518276182771827818279182801828118282182831828418285182861828718288182891829018291182921829318294182951829618297182981829918300183011830218303183041830518306183071830818309183101831118312183131831418315183161831718318183191832018321183221832318324183251832618327183281832918330183311833218333183341833518336183371833818339183401834118342183431834418345183461834718348183491835018351183521835318354183551835618357183581835918360183611836218363183641836518366183671836818369183701837118372183731837418375183761837718378183791838018381183821838318384183851838618387183881838918390183911839218393183941839518396183971839818399184001840118402184031840418405184061840718408184091841018411184121841318414184151841618417184181841918420184211842218423184241842518426184271842818429184301843118432184331843418435184361843718438184391844018441184421844318444184451844618447184481844918450184511845218453184541845518456184571845818459184601846118462184631846418465184661846718468184691847018471184721847318474184751847618477184781847918480184811848218483184841848518486184871848818489184901849118492184931849418495184961849718498184991850018501185021850318504185051850618507185081850918510185111851218513185141851518516185171851818519185201852118522185231852418525185261852718528185291853018531185321853318534185351853618537185381853918540185411854218543185441854518546185471854818549185501855118552185531855418555185561855718558185591856018561185621856318564185651856618567185681856918570185711857218573185741857518576185771857818579185801858118582185831858418585185861858718588185891859018591185921859318594185951859618597185981859918600186011860218603186041860518606186071860818609186101861118612186131861418615186161861718618186191862018621186221862318624186251862618627186281862918630186311863218633186341863518636186371863818639186401864118642186431864418645186461864718648186491865018651186521865318654186551865618657186581865918660186611866218663186641866518666186671866818669186701867118672186731867418675186761867718678186791868018681186821868318684186851868618687186881868918690186911869218693186941869518696186971869818699187001870118702187031870418705187061870718708187091871018711187121871318714187151871618717187181871918720187211872218723187241872518726187271872818729187301873118732187331873418735187361873718738187391874018741187421874318744187451874618747187481874918750187511875218753187541875518756187571875818759187601876118762187631876418765187661876718768187691877018771187721877318774187751877618777187781877918780187811878218783187841878518786187871878818789187901879118792187931879418795187961879718798187991880018801188021880318804188051880618807188081880918810188111881218813188141881518816188171881818819188201882118822188231882418825188261882718828188291883018831188321883318834188351883618837188381883918840188411884218843188441884518846188471884818849188501885118852188531885418855188561885718858188591886018861188621886318864188651886618867188681886918870188711887218873188741887518876188771887818879188801888118882188831888418885188861888718888188891889018891188921889318894188951889618897188981889918900189011890218903189041890518906189071890818909189101891118912189131891418915189161891718918189191892018921189221892318924189251892618927189281892918930189311893218933189341893518936189371893818939189401894118942189431894418945189461894718948189491895018951189521895318954189551895618957189581895918960189611896218963189641896518966189671896818969189701897118972189731897418975189761897718978189791898018981189821898318984189851898618987189881898918990189911899218993189941899518996189971899818999190001900119002190031900419005190061900719008190091901019011190121901319014190151901619017190181901919020190211902219023190241902519026190271902819029190301903119032190331903419035190361903719038190391904019041190421904319044190451904619047190481904919050190511905219053190541905519056190571905819059190601906119062190631906419065190661906719068190691907019071190721907319074190751907619077190781907919080190811908219083190841908519086190871908819089190901909119092190931909419095190961909719098190991910019101191021910319104191051910619107191081910919110191111911219113191141911519116191171911819119191201912119122191231912419125191261912719128191291913019131191321913319134191351913619137191381913919140191411914219143191441914519146191471914819149191501915119152191531915419155191561915719158191591916019161191621916319164191651916619167191681916919170191711917219173191741917519176191771917819179191801918119182191831918419185191861918719188191891919019191191921919319194191951919619197191981919919200192011920219203192041920519206192071920819209192101921119212192131921419215192161921719218192191922019221192221922319224192251922619227192281922919230192311923219233192341923519236192371923819239192401924119242192431924419245192461924719248192491925019251192521925319254192551925619257192581925919260192611926219263192641926519266192671926819269192701927119272192731927419275192761927719278192791928019281192821928319284192851928619287192881928919290192911929219293192941929519296192971929819299193001930119302193031930419305193061930719308193091931019311193121931319314193151931619317193181931919320193211932219323193241932519326193271932819329193301933119332193331933419335193361933719338193391934019341193421934319344193451934619347193481934919350193511935219353193541935519356193571935819359193601936119362193631936419365193661936719368193691937019371193721937319374193751937619377193781937919380193811938219383193841938519386193871938819389193901939119392193931939419395193961939719398193991940019401194021940319404194051940619407194081940919410194111941219413194141941519416194171941819419194201942119422194231942419425194261942719428194291943019431194321943319434194351943619437194381943919440194411944219443194441944519446194471944819449194501945119452194531945419455194561945719458194591946019461194621946319464194651946619467194681946919470194711947219473194741947519476194771947819479194801948119482194831948419485194861948719488194891949019491194921949319494194951949619497194981949919500195011950219503195041950519506195071950819509195101951119512195131951419515195161951719518195191952019521195221952319524195251952619527195281952919530195311953219533195341953519536195371953819539195401954119542195431954419545195461954719548195491955019551195521955319554195551955619557195581955919560195611956219563195641956519566195671956819569195701957119572195731957419575195761957719578195791958019581195821958319584195851958619587195881958919590195911959219593195941959519596195971959819599196001960119602196031960419605196061960719608196091961019611196121961319614196151961619617196181961919620196211962219623196241962519626196271962819629196301963119632196331963419635196361963719638196391964019641196421964319644196451964619647196481964919650196511965219653196541965519656196571965819659196601966119662196631966419665196661966719668196691967019671196721967319674196751967619677196781967919680196811968219683196841968519686196871968819689196901969119692196931969419695196961969719698196991970019701197021970319704197051970619707197081970919710197111971219713197141971519716197171971819719197201972119722197231972419725197261972719728197291973019731197321973319734197351973619737197381973919740197411974219743197441974519746197471974819749197501975119752197531975419755197561975719758197591976019761197621976319764197651976619767197681976919770197711977219773197741977519776197771977819779197801978119782197831978419785197861978719788197891979019791197921979319794197951979619797197981979919800198011980219803198041980519806198071980819809198101981119812198131981419815198161981719818198191982019821198221982319824198251982619827198281982919830198311983219833198341983519836198371983819839198401984119842198431984419845198461984719848198491985019851198521985319854198551985619857198581985919860198611986219863198641986519866198671986819869198701987119872198731987419875198761987719878198791988019881198821988319884198851988619887198881988919890198911989219893198941989519896198971989819899199001990119902199031990419905199061990719908199091991019911199121991319914199151991619917199181991919920199211992219923199241992519926199271992819929199301993119932199331993419935199361993719938199391994019941199421994319944199451994619947199481994919950199511995219953199541995519956199571995819959199601996119962199631996419965199661996719968199691997019971199721997319974199751997619977199781997919980199811998219983199841998519986199871998819989199901999119992199931999419995199961999719998199992000020001200022000320004200052000620007200082000920010200112001220013200142001520016200172001820019200202002120022200232002420025200262002720028200292003020031200322003320034200352003620037200382003920040200412004220043200442004520046200472004820049200502005120052200532005420055200562005720058200592006020061200622006320064200652006620067200682006920070200712007220073200742007520076200772007820079200802008120082200832008420085200862008720088200892009020091200922009320094200952009620097200982009920100201012010220103201042010520106201072010820109201102011120112201132011420115201162011720118201192012020121201222012320124201252012620127201282012920130201312013220133201342013520136201372013820139201402014120142201432014420145201462014720148201492015020151201522015320154201552015620157201582015920160201612016220163201642016520166201672016820169201702017120172201732017420175201762017720178201792018020181201822018320184201852018620187201882018920190201912019220193201942019520196201972019820199202002020120202202032020420205202062020720208202092021020211202122021320214202152021620217202182021920220202212022220223202242022520226202272022820229202302023120232202332023420235202362023720238202392024020241202422024320244202452024620247202482024920250202512025220253202542025520256202572025820259202602026120262202632026420265202662026720268202692027020271202722027320274202752027620277202782027920280202812028220283202842028520286202872028820289202902029120292202932029420295202962029720298202992030020301203022030320304203052030620307203082030920310203112031220313203142031520316203172031820319203202032120322203232032420325203262032720328203292033020331203322033320334203352033620337203382033920340203412034220343203442034520346203472034820349203502035120352203532035420355203562035720358203592036020361203622036320364203652036620367203682036920370203712037220373203742037520376203772037820379203802038120382203832038420385203862038720388203892039020391203922039320394203952039620397203982039920400204012040220403204042040520406204072040820409204102041120412204132041420415204162041720418204192042020421204222042320424204252042620427204282042920430204312043220433204342043520436204372043820439204402044120442204432044420445204462044720448204492045020451204522045320454204552045620457204582045920460204612046220463204642046520466204672046820469204702047120472204732047420475204762047720478204792048020481204822048320484204852048620487204882048920490204912049220493204942049520496204972049820499205002050120502205032050420505205062050720508205092051020511205122051320514205152051620517205182051920520205212052220523205242052520526205272052820529205302053120532205332053420535205362053720538205392054020541205422054320544205452054620547205482054920550205512055220553205542055520556205572055820559205602056120562205632056420565205662056720568205692057020571205722057320574205752057620577205782057920580205812058220583205842058520586205872058820589205902059120592205932059420595205962059720598205992060020601206022060320604206052060620607206082060920610206112061220613206142061520616206172061820619206202062120622206232062420625206262062720628206292063020631206322063320634206352063620637206382063920640206412064220643206442064520646206472064820649206502065120652206532065420655206562065720658206592066020661206622066320664206652066620667206682066920670206712067220673206742067520676206772067820679206802068120682206832068420685206862068720688206892069020691206922069320694206952069620697206982069920700207012070220703207042070520706207072070820709207102071120712207132071420715207162071720718207192072020721207222072320724207252072620727207282072920730207312073220733207342073520736207372073820739207402074120742207432074420745207462074720748207492075020751207522075320754207552075620757207582075920760207612076220763207642076520766207672076820769207702077120772207732077420775207762077720778207792078020781207822078320784207852078620787207882078920790207912079220793207942079520796207972079820799208002080120802208032080420805208062080720808208092081020811208122081320814208152081620817208182081920820208212082220823208242082520826208272082820829208302083120832208332083420835208362083720838208392084020841208422084320844208452084620847208482084920850208512085220853208542085520856208572085820859208602086120862208632086420865208662086720868208692087020871208722087320874208752087620877208782087920880208812088220883208842088520886208872088820889208902089120892208932089420895208962089720898208992090020901209022090320904209052090620907209082090920910209112091220913209142091520916209172091820919209202092120922209232092420925209262092720928209292093020931209322093320934209352093620937209382093920940209412094220943209442094520946209472094820949209502095120952209532095420955209562095720958209592096020961209622096320964209652096620967209682096920970209712097220973209742097520976209772097820979209802098120982209832098420985209862098720988209892099020991209922099320994209952099620997209982099921000210012100221003210042100521006210072100821009210102101121012210132101421015210162101721018210192102021021210222102321024210252102621027210282102921030210312103221033210342103521036210372103821039210402104121042210432104421045210462104721048210492105021051210522105321054210552105621057210582105921060210612106221063210642106521066210672106821069210702107121072210732107421075210762107721078210792108021081210822108321084210852108621087210882108921090210912109221093210942109521096210972109821099211002110121102211032110421105211062110721108211092111021111211122111321114211152111621117211182111921120211212112221123211242112521126211272112821129211302113121132211332113421135211362113721138211392114021141211422114321144211452114621147211482114921150211512115221153211542115521156211572115821159211602116121162211632116421165211662116721168211692117021171211722117321174211752117621177211782117921180211812118221183211842118521186211872118821189211902119121192211932119421195211962119721198211992120021201212022120321204212052120621207212082120921210212112121221213212142121521216212172121821219212202122121222212232122421225212262122721228212292123021231212322123321234212352123621237212382123921240212412124221243212442124521246212472124821249212502125121252212532125421255212562125721258212592126021261212622126321264212652126621267212682126921270212712127221273212742127521276212772127821279212802128121282212832128421285212862128721288212892129021291212922129321294212952129621297212982129921300213012130221303213042130521306213072130821309213102131121312213132131421315213162131721318213192132021321213222132321324213252132621327213282132921330213312133221333213342133521336213372133821339213402134121342213432134421345213462134721348213492135021351213522135321354213552135621357213582135921360213612136221363213642136521366213672136821369213702137121372213732137421375213762137721378213792138021381213822138321384213852138621387213882138921390213912139221393213942139521396213972139821399214002140121402214032140421405214062140721408214092141021411214122141321414214152141621417214182141921420214212142221423214242142521426214272142821429214302143121432214332143421435214362143721438214392144021441214422144321444214452144621447214482144921450214512145221453214542145521456214572145821459214602146121462214632146421465214662146721468214692147021471214722147321474214752147621477214782147921480214812148221483214842148521486214872148821489214902149121492214932149421495214962149721498214992150021501215022150321504215052150621507215082150921510215112151221513215142151521516215172151821519215202152121522215232152421525215262152721528215292153021531215322153321534215352153621537215382153921540215412154221543215442154521546215472154821549215502155121552215532155421555215562155721558215592156021561215622156321564215652156621567215682156921570215712157221573215742157521576215772157821579215802158121582215832158421585215862158721588215892159021591215922159321594215952159621597215982159921600216012160221603216042160521606216072160821609216102161121612216132161421615216162161721618216192162021621216222162321624216252162621627216282162921630216312163221633216342163521636216372163821639216402164121642216432164421645216462164721648216492165021651216522165321654216552165621657216582165921660216612166221663216642166521666216672166821669216702167121672216732167421675216762167721678216792168021681216822168321684216852168621687216882168921690216912169221693216942169521696216972169821699217002170121702217032170421705217062170721708217092171021711217122171321714217152171621717217182171921720217212172221723217242172521726217272172821729217302173121732217332173421735217362173721738217392174021741217422174321744217452174621747217482174921750217512175221753217542175521756217572175821759217602176121762217632176421765217662176721768217692177021771217722177321774217752177621777217782177921780217812178221783217842178521786217872178821789217902179121792217932179421795217962179721798217992180021801218022180321804218052180621807218082180921810218112181221813218142181521816218172181821819218202182121822218232182421825218262182721828218292183021831218322183321834218352183621837218382183921840218412184221843218442184521846218472184821849218502185121852218532185421855218562185721858218592186021861218622186321864218652186621867218682186921870218712187221873218742187521876218772187821879218802188121882218832188421885218862188721888218892189021891218922189321894218952189621897218982189921900219012190221903219042190521906219072190821909219102191121912219132191421915219162191721918219192192021921219222192321924219252192621927219282192921930219312193221933219342193521936219372193821939219402194121942219432194421945219462194721948219492195021951219522195321954219552195621957219582195921960219612196221963219642196521966219672196821969219702197121972219732197421975219762197721978219792198021981219822198321984219852198621987219882198921990219912199221993219942199521996219972199821999220002200122002220032200422005220062200722008220092201022011220122201322014220152201622017220182201922020220212202222023220242202522026220272202822029220302203122032220332203422035220362203722038220392204022041220422204322044220452204622047220482204922050220512205222053220542205522056220572205822059220602206122062220632206422065220662206722068220692207022071220722207322074220752207622077220782207922080220812208222083220842208522086220872208822089220902209122092220932209422095220962209722098220992210022101221022210322104221052210622107221082210922110221112211222113221142211522116221172211822119221202212122122221232212422125221262212722128221292213022131221322213322134221352213622137221382213922140221412214222143221442214522146221472214822149221502215122152221532215422155221562215722158221592216022161221622216322164221652216622167221682216922170221712217222173221742217522176221772217822179221802218122182221832218422185221862218722188221892219022191221922219322194221952219622197221982219922200222012220222203222042220522206222072220822209222102221122212222132221422215222162221722218222192222022221222222222322224222252222622227222282222922230222312223222233222342223522236222372223822239222402224122242222432224422245222462224722248222492225022251222522225322254222552225622257222582225922260222612226222263222642226522266222672226822269222702227122272222732227422275222762227722278222792228022281222822228322284222852228622287222882228922290222912229222293222942229522296222972229822299223002230122302223032230422305223062230722308223092231022311223122231322314223152231622317223182231922320223212232222323223242232522326223272232822329223302233122332223332233422335223362233722338223392234022341223422234322344223452234622347223482234922350223512235222353223542235522356223572235822359223602236122362223632236422365223662236722368223692237022371223722237322374223752237622377223782237922380223812238222383223842238522386223872238822389223902239122392223932239422395223962239722398223992240022401224022240322404224052240622407224082240922410224112241222413224142241522416224172241822419224202242122422224232242422425224262242722428224292243022431224322243322434224352243622437224382243922440224412244222443224442244522446224472244822449224502245122452224532245422455224562245722458224592246022461224622246322464224652246622467224682246922470224712247222473224742247522476224772247822479224802248122482224832248422485224862248722488224892249022491224922249322494224952249622497224982249922500225012250222503225042250522506225072250822509225102251122512225132251422515225162251722518225192252022521225222252322524225252252622527225282252922530225312253222533225342253522536225372253822539225402254122542225432254422545225462254722548225492255022551225522255322554225552255622557225582255922560225612256222563225642256522566225672256822569225702257122572225732257422575225762257722578225792258022581225822258322584225852258622587225882258922590225912259222593225942259522596225972259822599226002260122602226032260422605226062260722608226092261022611226122261322614226152261622617226182261922620226212262222623226242262522626226272262822629226302263122632226332263422635226362263722638226392264022641226422264322644226452264622647226482264922650226512265222653226542265522656226572265822659226602266122662226632266422665226662266722668226692267022671226722267322674226752267622677226782267922680226812268222683226842268522686226872268822689226902269122692226932269422695226962269722698226992270022701227022270322704227052270622707227082270922710227112271222713227142271522716227172271822719227202272122722227232272422725227262272722728227292273022731227322273322734227352273622737227382273922740227412274222743227442274522746227472274822749227502275122752227532275422755227562275722758227592276022761227622276322764227652276622767227682276922770227712277222773227742277522776227772277822779227802278122782227832278422785227862278722788227892279022791227922279322794227952279622797227982279922800228012280222803228042280522806228072280822809228102281122812228132281422815228162281722818228192282022821228222282322824228252282622827228282282922830228312283222833228342283522836228372283822839228402284122842228432284422845228462284722848228492285022851228522285322854228552285622857228582285922860228612286222863228642286522866228672286822869228702287122872228732287422875228762287722878228792288022881228822288322884228852288622887228882288922890228912289222893228942289522896228972289822899229002290122902229032290422905229062290722908229092291022911229122291322914229152291622917229182291922920229212292222923229242292522926229272292822929229302293122932229332293422935229362293722938229392294022941229422294322944229452294622947229482294922950229512295222953229542295522956229572295822959229602296122962229632296422965229662296722968229692297022971229722297322974229752297622977229782297922980229812298222983229842298522986229872298822989229902299122992229932299422995229962299722998229992300023001230022300323004230052300623007230082300923010230112301223013230142301523016230172301823019230202302123022230232302423025230262302723028230292303023031230322303323034230352303623037230382303923040230412304223043230442304523046230472304823049230502305123052230532305423055230562305723058230592306023061230622306323064230652306623067230682306923070230712307223073230742307523076230772307823079230802308123082230832308423085230862308723088230892309023091230922309323094230952309623097230982309923100231012310223103231042310523106231072310823109231102311123112231132311423115231162311723118231192312023121231222312323124231252312623127231282312923130231312313223133231342313523136231372313823139231402314123142231432314423145231462314723148231492315023151231522315323154231552315623157231582315923160231612316223163231642316523166231672316823169231702317123172231732317423175231762317723178231792318023181231822318323184231852318623187231882318923190231912319223193231942319523196231972319823199232002320123202232032320423205232062320723208232092321023211232122321323214232152321623217232182321923220232212322223223232242322523226232272322823229232302323123232232332323423235232362323723238232392324023241232422324323244232452324623247232482324923250232512325223253232542325523256232572325823259232602326123262232632326423265232662326723268232692327023271232722327323274232752327623277232782327923280232812328223283232842328523286232872328823289232902329123292232932329423295232962329723298232992330023301233022330323304233052330623307233082330923310233112331223313233142331523316233172331823319233202332123322233232332423325233262332723328233292333023331233322333323334233352333623337233382333923340233412334223343233442334523346233472334823349233502335123352233532335423355233562335723358233592336023361233622336323364233652336623367233682336923370233712337223373233742337523376233772337823379233802338123382233832338423385233862338723388233892339023391233922339323394233952339623397233982339923400234012340223403234042340523406234072340823409234102341123412234132341423415234162341723418234192342023421234222342323424234252342623427234282342923430234312343223433234342343523436234372343823439234402344123442234432344423445234462344723448234492345023451234522345323454234552345623457234582345923460234612346223463234642346523466234672346823469234702347123472234732347423475234762347723478234792348023481234822348323484234852348623487234882348923490234912349223493234942349523496234972349823499235002350123502235032350423505235062350723508235092351023511235122351323514235152351623517235182351923520235212352223523235242352523526235272352823529235302353123532235332353423535235362353723538235392354023541235422354323544235452354623547235482354923550235512355223553235542355523556235572355823559235602356123562235632356423565235662356723568235692357023571235722357323574235752357623577235782357923580235812358223583235842358523586235872358823589235902359123592235932359423595235962359723598235992360023601236022360323604236052360623607236082360923610236112361223613236142361523616236172361823619236202362123622236232362423625236262362723628236292363023631236322363323634236352363623637236382363923640236412364223643236442364523646236472364823649236502365123652236532365423655236562365723658236592366023661236622366323664236652366623667236682366923670236712367223673236742367523676236772367823679236802368123682236832368423685236862368723688236892369023691236922369323694236952369623697236982369923700237012370223703237042370523706237072370823709237102371123712237132371423715237162371723718237192372023721237222372323724237252372623727237282372923730237312373223733237342373523736237372373823739237402374123742237432374423745237462374723748237492375023751237522375323754237552375623757237582375923760237612376223763237642376523766237672376823769237702377123772237732377423775237762377723778237792378023781237822378323784237852378623787237882378923790237912379223793237942379523796237972379823799238002380123802238032380423805238062380723808238092381023811238122381323814238152381623817238182381923820238212382223823238242382523826238272382823829238302383123832238332383423835238362383723838238392384023841238422384323844238452384623847238482384923850238512385223853238542385523856238572385823859238602386123862238632386423865238662386723868238692387023871238722387323874238752387623877238782387923880238812388223883238842388523886238872388823889238902389123892238932389423895238962389723898238992390023901239022390323904239052390623907239082390923910239112391223913239142391523916239172391823919239202392123922239232392423925239262392723928239292393023931239322393323934239352393623937239382393923940239412394223943239442394523946239472394823949239502395123952239532395423955239562395723958239592396023961239622396323964239652396623967239682396923970239712397223973239742397523976239772397823979239802398123982239832398423985239862398723988239892399023991239922399323994239952399623997239982399924000240012400224003240042400524006240072400824009240102401124012240132401424015240162401724018240192402024021240222402324024240252402624027240282402924030240312403224033240342403524036240372403824039240402404124042240432404424045240462404724048240492405024051240522405324054240552405624057240582405924060240612406224063240642406524066240672406824069240702407124072240732407424075240762407724078240792408024081240822408324084240852408624087240882408924090240912409224093240942409524096240972409824099241002410124102241032410424105241062410724108241092411024111241122411324114241152411624117241182411924120241212412224123241242412524126241272412824129241302413124132241332413424135241362413724138241392414024141241422414324144241452414624147241482414924150241512415224153241542415524156241572415824159241602416124162241632416424165241662416724168241692417024171241722417324174241752417624177241782417924180241812418224183241842418524186241872418824189241902419124192241932419424195241962419724198241992420024201242022420324204242052420624207242082420924210242112421224213242142421524216242172421824219242202422124222242232422424225242262422724228242292423024231242322423324234242352423624237242382423924240242412424224243242442424524246242472424824249242502425124252242532425424255242562425724258242592426024261242622426324264242652426624267242682426924270242712427224273242742427524276242772427824279242802428124282242832428424285242862428724288242892429024291242922429324294242952429624297242982429924300243012430224303243042430524306243072430824309243102431124312243132431424315243162431724318243192432024321243222432324324243252432624327243282432924330243312433224333243342433524336243372433824339243402434124342243432434424345243462434724348243492435024351243522435324354243552435624357243582435924360243612436224363243642436524366243672436824369243702437124372243732437424375243762437724378243792438024381243822438324384243852438624387243882438924390243912439224393243942439524396243972439824399244002440124402244032440424405244062440724408244092441024411244122441324414244152441624417244182441924420244212442224423244242442524426244272442824429244302443124432244332443424435244362443724438244392444024441244422444324444244452444624447244482444924450244512445224453244542445524456244572445824459244602446124462244632446424465244662446724468244692447024471244722447324474244752447624477244782447924480244812448224483244842448524486244872448824489244902449124492244932449424495244962449724498244992450024501245022450324504245052450624507245082450924510245112451224513245142451524516245172451824519245202452124522245232452424525245262452724528245292453024531245322453324534245352453624537245382453924540245412454224543245442454524546245472454824549245502455124552245532455424555245562455724558245592456024561245622456324564245652456624567245682456924570245712457224573245742457524576245772457824579245802458124582245832458424585245862458724588245892459024591245922459324594245952459624597245982459924600246012460224603246042460524606246072460824609246102461124612246132461424615246162461724618246192462024621246222462324624246252462624627246282462924630246312463224633246342463524636246372463824639246402464124642246432464424645246462464724648246492465024651246522465324654246552465624657246582465924660246612466224663246642466524666246672466824669246702467124672246732467424675246762467724678246792468024681246822468324684246852468624687246882468924690246912469224693246942469524696246972469824699247002470124702247032470424705247062470724708247092471024711247122471324714247152471624717247182471924720247212472224723247242472524726247272472824729247302473124732247332473424735247362473724738247392474024741247422474324744247452474624747247482474924750247512475224753247542475524756247572475824759247602476124762247632476424765247662476724768247692477024771247722477324774247752477624777247782477924780247812478224783247842478524786247872478824789247902479124792247932479424795247962479724798247992480024801248022480324804248052480624807248082480924810248112481224813248142481524816248172481824819248202482124822248232482424825248262482724828248292483024831248322483324834248352483624837248382483924840248412484224843248442484524846248472484824849248502485124852248532485424855248562485724858248592486024861248622486324864248652486624867248682486924870248712487224873248742487524876248772487824879248802488124882248832488424885248862488724888248892489024891248922489324894248952489624897248982489924900249012490224903249042490524906249072490824909249102491124912249132491424915249162491724918249192492024921249222492324924249252492624927249282492924930249312493224933249342493524936249372493824939249402494124942249432494424945249462494724948249492495024951249522495324954249552495624957249582495924960249612496224963249642496524966249672496824969249702497124972249732497424975249762497724978249792498024981249822498324984249852498624987249882498924990249912499224993249942499524996249972499824999250002500125002250032500425005250062500725008250092501025011250122501325014250152501625017250182501925020250212502225023250242502525026250272502825029250302503125032250332503425035250362503725038250392504025041250422504325044250452504625047250482504925050250512505225053250542505525056250572505825059250602506125062250632506425065250662506725068250692507025071250722507325074250752507625077250782507925080250812508225083250842508525086250872508825089250902509125092250932509425095250962509725098250992510025101251022510325104251052510625107251082510925110251112511225113251142511525116251172511825119251202512125122251232512425125251262512725128251292513025131251322513325134251352513625137251382513925140251412514225143251442514525146251472514825149251502515125152251532515425155251562515725158251592516025161251622516325164251652516625167251682516925170251712517225173251742517525176251772517825179251802518125182251832518425185251862518725188251892519025191251922519325194251952519625197251982519925200252012520225203252042520525206252072520825209252102521125212252132521425215252162521725218252192522025221252222522325224252252522625227252282522925230252312523225233252342523525236252372523825239252402524125242252432524425245252462524725248252492525025251252522525325254252552525625257252582525925260252612526225263252642526525266252672526825269252702527125272252732527425275252762527725278252792528025281252822528325284252852528625287252882528925290252912529225293252942529525296252972529825299253002530125302253032530425305253062530725308253092531025311253122531325314253152531625317253182531925320253212532225323253242532525326253272532825329253302533125332253332533425335253362533725338253392534025341253422534325344253452534625347253482534925350253512535225353253542535525356253572535825359253602536125362253632536425365253662536725368253692537025371253722537325374253752537625377253782537925380253812538225383253842538525386253872538825389253902539125392253932539425395253962539725398253992540025401254022540325404254052540625407254082540925410254112541225413254142541525416254172541825419254202542125422254232542425425254262542725428254292543025431254322543325434254352543625437254382543925440254412544225443254442544525446254472544825449254502545125452254532545425455254562545725458254592546025461254622546325464254652546625467254682546925470254712547225473254742547525476254772547825479254802548125482254832548425485254862548725488254892549025491254922549325494254952549625497254982549925500255012550225503255042550525506255072550825509255102551125512255132551425515255162551725518255192552025521255222552325524255252552625527255282552925530255312553225533255342553525536255372553825539255402554125542255432554425545255462554725548255492555025551255522555325554255552555625557255582555925560255612556225563255642556525566255672556825569255702557125572255732557425575255762557725578255792558025581255822558325584255852558625587255882558925590255912559225593255942559525596255972559825599256002560125602256032560425605256062560725608256092561025611256122561325614256152561625617256182561925620256212562225623256242562525626256272562825629256302563125632256332563425635256362563725638256392564025641256422564325644256452564625647256482564925650256512565225653256542565525656256572565825659256602566125662256632566425665256662566725668256692567025671256722567325674256752567625677256782567925680256812568225683256842568525686256872568825689256902569125692256932569425695256962569725698256992570025701257022570325704257052570625707257082570925710257112571225713257142571525716257172571825719257202572125722257232572425725257262572725728257292573025731257322573325734257352573625737257382573925740257412574225743257442574525746257472574825749257502575125752257532575425755257562575725758257592576025761257622576325764257652576625767257682576925770257712577225773257742577525776257772577825779257802578125782257832578425785257862578725788257892579025791257922579325794257952579625797257982579925800258012580225803258042580525806258072580825809258102581125812258132581425815258162581725818258192582025821258222582325824258252582625827258282582925830258312583225833258342583525836258372583825839258402584125842258432584425845258462584725848258492585025851258522585325854258552585625857258582585925860258612586225863258642586525866258672586825869258702587125872258732587425875258762587725878258792588025881258822588325884258852588625887258882588925890258912589225893258942589525896258972589825899259002590125902259032590425905259062590725908259092591025911259122591325914259152591625917259182591925920259212592225923259242592525926259272592825929259302593125932259332593425935259362593725938259392594025941259422594325944259452594625947259482594925950259512595225953259542595525956259572595825959259602596125962259632596425965259662596725968259692597025971259722597325974259752597625977259782597925980259812598225983259842598525986259872598825989259902599125992259932599425995259962599725998259992600026001260022600326004260052600626007260082600926010260112601226013260142601526016260172601826019260202602126022260232602426025260262602726028260292603026031260322603326034260352603626037260382603926040260412604226043260442604526046260472604826049260502605126052260532605426055260562605726058260592606026061260622606326064260652606626067260682606926070260712607226073260742607526076260772607826079260802608126082260832608426085260862608726088260892609026091260922609326094260952609626097260982609926100261012610226103261042610526106261072610826109261102611126112261132611426115261162611726118261192612026121261222612326124261252612626127261282612926130261312613226133261342613526136261372613826139261402614126142261432614426145261462614726148261492615026151261522615326154261552615626157261582615926160261612616226163261642616526166261672616826169261702617126172261732617426175261762617726178261792618026181261822618326184261852618626187261882618926190261912619226193261942619526196261972619826199262002620126202262032620426205262062620726208262092621026211262122621326214262152621626217262182621926220262212622226223262242622526226262272622826229262302623126232262332623426235262362623726238262392624026241262422624326244262452624626247262482624926250262512625226253262542625526256262572625826259262602626126262262632626426265262662626726268262692627026271262722627326274262752627626277262782627926280262812628226283262842628526286262872628826289262902629126292262932629426295262962629726298262992630026301263022630326304263052630626307263082630926310263112631226313263142631526316263172631826319263202632126322263232632426325263262632726328263292633026331263322633326334263352633626337263382633926340263412634226343263442634526346263472634826349263502635126352263532635426355263562635726358263592636026361263622636326364263652636626367263682636926370263712637226373263742637526376263772637826379263802638126382263832638426385263862638726388263892639026391263922639326394263952639626397263982639926400264012640226403264042640526406264072640826409264102641126412264132641426415264162641726418264192642026421264222642326424264252642626427264282642926430264312643226433264342643526436264372643826439264402644126442264432644426445264462644726448264492645026451264522645326454264552645626457264582645926460264612646226463264642646526466264672646826469264702647126472264732647426475264762647726478264792648026481264822648326484264852648626487264882648926490264912649226493264942649526496264972649826499265002650126502265032650426505265062650726508265092651026511265122651326514265152651626517265182651926520265212652226523265242652526526265272652826529265302653126532265332653426535265362653726538265392654026541265422654326544265452654626547265482654926550265512655226553265542655526556265572655826559265602656126562265632656426565265662656726568265692657026571265722657326574265752657626577265782657926580265812658226583265842658526586265872658826589265902659126592265932659426595265962659726598265992660026601266022660326604266052660626607266082660926610266112661226613266142661526616266172661826619266202662126622266232662426625266262662726628266292663026631266322663326634266352663626637266382663926640266412664226643266442664526646266472664826649266502665126652266532665426655266562665726658266592666026661266622666326664266652666626667266682666926670266712667226673266742667526676266772667826679266802668126682266832668426685266862668726688266892669026691266922669326694266952669626697266982669926700267012670226703267042670526706267072670826709267102671126712267132671426715267162671726718267192672026721267222672326724267252672626727267282672926730267312673226733267342673526736267372673826739267402674126742267432674426745267462674726748267492675026751267522675326754267552675626757267582675926760267612676226763267642676526766267672676826769267702677126772267732677426775267762677726778267792678026781267822678326784267852678626787267882678926790267912679226793267942679526796267972679826799268002680126802268032680426805268062680726808268092681026811268122681326814268152681626817268182681926820268212682226823268242682526826268272682826829268302683126832268332683426835268362683726838268392684026841268422684326844268452684626847268482684926850268512685226853268542685526856268572685826859268602686126862268632686426865268662686726868268692687026871268722687326874268752687626877268782687926880268812688226883268842688526886268872688826889268902689126892268932689426895268962689726898268992690026901269022690326904269052690626907269082690926910269112691226913269142691526916269172691826919269202692126922269232692426925269262692726928269292693026931269322693326934269352693626937269382693926940269412694226943269442694526946269472694826949269502695126952269532695426955269562695726958269592696026961269622696326964269652696626967269682696926970269712697226973269742697526976269772697826979269802698126982269832698426985269862698726988269892699026991269922699326994269952699626997269982699927000270012700227003270042700527006270072700827009270102701127012270132701427015270162701727018270192702027021270222702327024270252702627027270282702927030270312703227033270342703527036270372703827039270402704127042270432704427045270462704727048270492705027051270522705327054270552705627057270582705927060270612706227063270642706527066270672706827069270702707127072270732707427075270762707727078270792708027081270822708327084270852708627087270882708927090270912709227093270942709527096270972709827099271002710127102271032710427105271062710727108271092711027111271122711327114271152711627117271182711927120271212712227123271242712527126271272712827129271302713127132271332713427135271362713727138271392714027141271422714327144271452714627147271482714927150271512715227153271542715527156271572715827159271602716127162271632716427165271662716727168271692717027171271722717327174271752717627177271782717927180271812718227183271842718527186271872718827189271902719127192271932719427195271962719727198271992720027201272022720327204272052720627207272082720927210272112721227213272142721527216272172721827219272202722127222272232722427225272262722727228272292723027231272322723327234272352723627237272382723927240272412724227243272442724527246272472724827249272502725127252272532725427255272562725727258272592726027261272622726327264272652726627267272682726927270272712727227273272742727527276272772727827279272802728127282272832728427285272862728727288272892729027291272922729327294272952729627297272982729927300273012730227303273042730527306273072730827309273102731127312273132731427315273162731727318273192732027321273222732327324273252732627327273282732927330273312733227333273342733527336273372733827339273402734127342273432734427345273462734727348273492735027351273522735327354273552735627357273582735927360273612736227363273642736527366273672736827369273702737127372273732737427375273762737727378273792738027381273822738327384273852738627387273882738927390273912739227393273942739527396273972739827399274002740127402274032740427405274062740727408274092741027411274122741327414274152741627417274182741927420274212742227423274242742527426274272742827429274302743127432274332743427435274362743727438274392744027441274422744327444274452744627447274482744927450274512745227453274542745527456274572745827459274602746127462274632746427465274662746727468274692747027471274722747327474274752747627477274782747927480274812748227483274842748527486274872748827489274902749127492274932749427495274962749727498274992750027501275022750327504275052750627507275082750927510275112751227513275142751527516275172751827519275202752127522275232752427525275262752727528275292753027531275322753327534275352753627537275382753927540275412754227543275442754527546275472754827549275502755127552275532755427555275562755727558275592756027561275622756327564275652756627567275682756927570275712757227573275742757527576275772757827579275802758127582275832758427585275862758727588275892759027591275922759327594275952759627597275982759927600276012760227603276042760527606276072760827609276102761127612276132761427615276162761727618276192762027621276222762327624276252762627627276282762927630276312763227633276342763527636276372763827639276402764127642276432764427645276462764727648276492765027651276522765327654276552765627657276582765927660276612766227663276642766527666276672766827669276702767127672276732767427675276762767727678276792768027681276822768327684276852768627687276882768927690276912769227693276942769527696276972769827699277002770127702277032770427705277062770727708277092771027711277122771327714277152771627717277182771927720277212772227723277242772527726277272772827729277302773127732277332773427735277362773727738277392774027741277422774327744277452774627747277482774927750277512775227753277542775527756277572775827759277602776127762277632776427765277662776727768277692777027771277722777327774277752777627777277782777927780277812778227783277842778527786277872778827789277902779127792277932779427795277962779727798277992780027801278022780327804278052780627807278082780927810278112781227813278142781527816278172781827819278202782127822278232782427825278262782727828278292783027831278322783327834278352783627837278382783927840278412784227843278442784527846278472784827849278502785127852278532785427855278562785727858278592786027861278622786327864278652786627867278682786927870278712787227873278742787527876278772787827879278802788127882278832788427885278862788727888278892789027891278922789327894278952789627897278982789927900279012790227903279042790527906279072790827909279102791127912279132791427915279162791727918279192792027921279222792327924279252792627927279282792927930279312793227933279342793527936279372793827939279402794127942279432794427945279462794727948279492795027951279522795327954279552795627957279582795927960279612796227963279642796527966279672796827969279702797127972279732797427975279762797727978279792798027981279822798327984279852798627987279882798927990279912799227993279942799527996279972799827999280002800128002280032800428005280062800728008280092801028011280122801328014280152801628017280182801928020280212802228023280242802528026280272802828029280302803128032280332803428035280362803728038280392804028041280422804328044280452804628047280482804928050280512805228053280542805528056280572805828059280602806128062280632806428065280662806728068280692807028071280722807328074280752807628077280782807928080280812808228083280842808528086280872808828089280902809128092280932809428095280962809728098280992810028101281022810328104281052810628107281082810928110281112811228113281142811528116281172811828119281202812128122281232812428125281262812728128281292813028131281322813328134281352813628137281382813928140281412814228143281442814528146281472814828149281502815128152281532815428155281562815728158281592816028161281622816328164281652816628167281682816928170281712817228173281742817528176281772817828179281802818128182281832818428185281862818728188281892819028191281922819328194281952819628197281982819928200282012820228203282042820528206282072820828209282102821128212282132821428215282162821728218282192822028221282222822328224282252822628227282282822928230282312823228233282342823528236282372823828239282402824128242282432824428245282462824728248282492825028251282522825328254282552825628257282582825928260282612826228263282642826528266282672826828269282702827128272282732827428275282762827728278282792828028281282822828328284282852828628287282882828928290282912829228293282942829528296282972829828299283002830128302283032830428305283062830728308283092831028311283122831328314283152831628317283182831928320283212832228323283242832528326283272832828329283302833128332283332833428335283362833728338283392834028341283422834328344283452834628347283482834928350283512835228353283542835528356283572835828359283602836128362283632836428365283662836728368283692837028371283722837328374283752837628377283782837928380283812838228383283842838528386283872838828389283902839128392283932839428395283962839728398283992840028401284022840328404284052840628407284082840928410284112841228413284142841528416284172841828419284202842128422284232842428425284262842728428284292843028431284322843328434284352843628437284382843928440284412844228443284442844528446284472844828449284502845128452284532845428455284562845728458284592846028461284622846328464284652846628467284682846928470284712847228473284742847528476284772847828479284802848128482284832848428485284862848728488284892849028491284922849328494284952849628497284982849928500285012850228503285042850528506285072850828509285102851128512285132851428515285162851728518285192852028521285222852328524285252852628527285282852928530285312853228533285342853528536285372853828539285402854128542285432854428545285462854728548285492855028551285522855328554285552855628557285582855928560285612856228563285642856528566285672856828569285702857128572285732857428575285762857728578285792858028581285822858328584285852858628587285882858928590285912859228593285942859528596285972859828599286002860128602286032860428605286062860728608286092861028611286122861328614286152861628617286182861928620286212862228623286242862528626286272862828629286302863128632286332863428635286362863728638286392864028641286422864328644286452864628647286482864928650286512865228653286542865528656286572865828659286602866128662286632866428665286662866728668286692867028671286722867328674286752867628677286782867928680286812868228683286842868528686286872868828689286902869128692286932869428695286962869728698286992870028701287022870328704287052870628707287082870928710287112871228713287142871528716287172871828719287202872128722287232872428725287262872728728287292873028731287322873328734287352873628737287382873928740287412874228743287442874528746287472874828749287502875128752287532875428755287562875728758287592876028761287622876328764287652876628767287682876928770287712877228773287742877528776287772877828779287802878128782287832878428785287862878728788287892879028791287922879328794287952879628797287982879928800288012880228803288042880528806288072880828809288102881128812288132881428815288162881728818288192882028821288222882328824288252882628827288282882928830288312883228833288342883528836288372883828839288402884128842288432884428845288462884728848288492885028851288522885328854288552885628857288582885928860288612886228863288642886528866288672886828869288702887128872288732887428875288762887728878288792888028881288822888328884288852888628887288882888928890288912889228893288942889528896288972889828899289002890128902289032890428905289062890728908289092891028911289122891328914289152891628917289182891928920289212892228923289242892528926289272892828929289302893128932289332893428935289362893728938289392894028941289422894328944289452894628947289482894928950289512895228953289542895528956289572895828959289602896128962289632896428965289662896728968289692897028971289722897328974289752897628977289782897928980289812898228983289842898528986289872898828989289902899128992289932899428995289962899728998289992900029001290022900329004290052900629007290082900929010290112901229013290142901529016290172901829019290202902129022290232902429025290262902729028290292903029031290322903329034290352903629037290382903929040290412904229043290442904529046290472904829049290502905129052290532905429055290562905729058290592906029061290622906329064290652906629067290682906929070290712907229073290742907529076290772907829079290802908129082290832908429085290862908729088290892909029091290922909329094290952909629097290982909929100291012910229103291042910529106291072910829109291102911129112291132911429115291162911729118291192912029121291222912329124291252912629127291282912929130291312913229133291342913529136291372913829139291402914129142291432914429145291462914729148291492915029151291522915329154291552915629157291582915929160291612916229163291642916529166291672916829169291702917129172291732917429175291762917729178291792918029181291822918329184291852918629187291882918929190291912919229193291942919529196291972919829199292002920129202292032920429205292062920729208292092921029211292122921329214292152921629217292182921929220292212922229223292242922529226292272922829229292302923129232292332923429235292362923729238292392924029241292422924329244292452924629247292482924929250292512925229253292542925529256292572925829259292602926129262292632926429265292662926729268292692927029271292722927329274292752927629277292782927929280292812928229283292842928529286292872928829289292902929129292292932929429295292962929729298292992930029301293022930329304293052930629307293082930929310293112931229313293142931529316293172931829319293202932129322293232932429325293262932729328293292933029331293322933329334293352933629337293382933929340293412934229343293442934529346293472934829349293502935129352293532935429355293562935729358293592936029361293622936329364293652936629367293682936929370293712937229373293742937529376293772937829379293802938129382293832938429385293862938729388293892939029391293922939329394293952939629397293982939929400294012940229403294042940529406294072940829409294102941129412294132941429415294162941729418294192942029421294222942329424294252942629427294282942929430294312943229433294342943529436294372943829439294402944129442294432944429445294462944729448294492945029451294522945329454294552945629457294582945929460294612946229463294642946529466294672946829469294702947129472294732947429475294762947729478294792948029481294822948329484294852948629487294882948929490294912949229493294942949529496294972949829499295002950129502295032950429505295062950729508295092951029511295122951329514295152951629517295182951929520295212952229523295242952529526295272952829529295302953129532295332953429535295362953729538295392954029541295422954329544295452954629547295482954929550295512955229553295542955529556295572955829559295602956129562295632956429565295662956729568295692957029571295722957329574295752957629577295782957929580295812958229583295842958529586295872958829589295902959129592295932959429595295962959729598295992960029601296022960329604296052960629607296082960929610296112961229613296142961529616296172961829619296202962129622296232962429625296262962729628296292963029631296322963329634296352963629637296382963929640296412964229643296442964529646296472964829649296502965129652296532965429655296562965729658296592966029661296622966329664296652966629667296682966929670296712967229673296742967529676296772967829679296802968129682296832968429685296862968729688296892969029691296922969329694296952969629697296982969929700297012970229703297042970529706297072970829709297102971129712297132971429715297162971729718297192972029721297222972329724297252972629727297282972929730297312973229733297342973529736297372973829739297402974129742297432974429745297462974729748297492975029751297522975329754297552975629757297582975929760297612976229763297642976529766297672976829769297702977129772297732977429775297762977729778297792978029781297822978329784297852978629787297882978929790297912979229793297942979529796297972979829799298002980129802298032980429805298062980729808298092981029811298122981329814298152981629817298182981929820298212982229823298242982529826298272982829829298302983129832298332983429835298362983729838298392984029841298422984329844298452984629847298482984929850298512985229853298542985529856298572985829859298602986129862298632986429865298662986729868298692987029871298722987329874298752987629877298782987929880298812988229883298842988529886298872988829889298902989129892298932989429895298962989729898298992990029901299022990329904299052990629907299082990929910299112991229913299142991529916299172991829919299202992129922299232992429925299262992729928299292993029931299322993329934299352993629937299382993929940299412994229943299442994529946299472994829949299502995129952299532995429955299562995729958299592996029961299622996329964299652996629967299682996929970299712997229973299742997529976299772997829979299802998129982299832998429985299862998729988299892999029991299922999329994299952999629997299982999930000300013000230003300043000530006300073000830009300103001130012300133001430015300163001730018300193002030021300223002330024300253002630027300283002930030300313003230033300343003530036300373003830039300403004130042300433004430045300463004730048300493005030051300523005330054300553005630057300583005930060300613006230063300643006530066300673006830069300703007130072300733007430075300763007730078300793008030081300823008330084300853008630087300883008930090300913009230093300943009530096300973009830099301003010130102301033010430105301063010730108301093011030111301123011330114301153011630117301183011930120301213012230123301243012530126301273012830129301303013130132301333013430135301363013730138301393014030141301423014330144301453014630147301483014930150301513015230153301543015530156301573015830159301603016130162301633016430165301663016730168301693017030171301723017330174301753017630177301783017930180301813018230183301843018530186301873018830189301903019130192301933019430195301963019730198301993020030201302023020330204302053020630207302083020930210302113021230213302143021530216302173021830219302203022130222302233022430225302263022730228302293023030231302323023330234302353023630237302383023930240302413024230243302443024530246 |
- {
- This file is part of the Free Component Library
- Pascal resolver
- Copyright (c) 2020 Mattias Gaertner [email protected]
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************
- Abstract:
- Resolves references by setting TPasElement.CustomData as TResolvedReference.
- Creates search scopes for elements with sub identifiers by setting
- TPasElement.CustomData as TPasScope: unit, program, library, interface,
- implementation, procs
- Works:
- - built-in types as TPasUnresolvedSymbolRef: longint, int64, string, pointer, ...
- - references in statements, error if not found
- - interface and implementation types, vars, const
- - params, local types, vars, const
- - nested procedures
- - nested forward procs, nested must be resolved before proc body
- - program/library/implementation forward procs
- - search in used units
- - unitname.identifier
- - alias types, 'type a=b'
- - type alias type 'type a=type b'
- - choose the most compatible overloaded procedure
- - while..do
- - repeat..until
- - if..then..else
- - binary operators
- - case..of
- - check duplicate values
- - try..finally..except, on, else, raise
- - for loop
- - fail to write a loop var inside the loop
- - spot duplicates
- - type cast base types
- - char
- - ord(), chr()
- - record
- - variants
- - const param makes children const too
- - const TRecordValues
- - function default(record type): record
- - advanced records:
- - $modeswitch AdvancedRecords
- - visibility public, private, strict private
- - sub type
- - const, var, class var
- - function/procedure/class function/class procedure
- - property, class property, default property
- - constructor
- - RTTI
- - class:
- - forward declaration
- - instance.a
- - find ancestor, search in ancestors
- - virtual, abstract, override
- - method body
- - Self
- - inherited
- - property
- - read var, read function
- - write var, write function
- - stored function
- - defaultexpr
- - is and as operator
- - nil
- - constructor result type, rrfNewInstance
- - destructor call type: rrfFreeInstance
- - type cast
- - class of
- - class method, property, var, const
- - class-of.constructor
- - class-of typecast upwards/downwards
- - class-of option to allow is-operator
- - typecast Self in class method upwards/downwards
- - property with params
- - default property
- - visibility, override: warn and fix if lower
- - events, proc type of object
- - sealed
- - $M+ / $TYPEINFO use visPublished as default visibility
- - note: constructing class with abstract method
- - with..do
- - enums - TPasEnumType, TPasEnumValue
- - propagate to parent scopes
- - function ord(): integer
- - function low(ordinal): ordinal
- - function high(ordinal): ordinal
- - function pred(ordinal): ordinal
- - function high(ordinal): ordinal
- - cast integer to enum, enum to integer
- - $ScopedEnums
- - sets - TPasSetType
- - set of char
- - set of integer
- - set of boolean
- - set of enum
- - ranges 'a'..'z' 2..5
- - operators: +, -, *, ><, <=, >=
- - in-operator
- - assign operators: +=, -=, *=
- - include(), exclude()
- - typed const: check expr type
- - function length(const array or string): integer
- - procedure setlength(var array or string; newlength: integer)
- - ranges TPasRangeType
- - procedure exit, procedure exit(const function result)
- - check if types only refer types+const
- - check const expression types, e.g. bark on "const c:string=3;"
- - procedure inc/dec(var ordinal; decr: ordinal = 1)
- - function Assigned(Pointer or Class or Class-Of): boolean
- - arrays TPasArrayType
- - TPasEnumType, char, integer, range
- - low, high, length, setlength, assigned
- - function concat(array1,array2,...): array
- - function copy(array): array, copy(a,start), copy(a,start,end)
- - insert(item; var array; index: integer)
- - delete(var array; start, count: integer)
- - element
- - multi dimensional
- - const
- - open array, override, pass array literal, pass var
- - type cast array to arrays with same dimensions and compatible element type
- - static array range checking
- - const array of char = string
- - a:=[...] // assignation using constant array
- - a:=[[...],[...]]
- - a:=[...]+[...] a+[] []+a modeswitch arrayoperators
- - delphi: var a: dynarray = []; // square bracket initialization
- - check if var initexpr fits vartype: var a: type = expr;
- - built-in functions high, low for range types
- - procedure type
- - call
- - as function result
- - as parameter
- - Delphi without @
- - @@ operator
- - FPC equal and not equal
- - "is nested"
- - bark on arguments access mismatch
- - function without params: mark if call or address, rrfImplicitCallWithoutParams
- - procedure break, procedure continue
- - built-in functions pred, succ for range type and enums
- - untyped parameters
- - built-in procedure str(const boolean|integer|enumvalue|classinstance,var s: string)
- - built-in procedure writestr(var s: string; Args: arguments...); varargs
- - pointer TPasPointerType
- - nil, assigned(), typecast, class, classref, dynarray, procvar
- - forward declaration
- - cycle detection
- - TypedPointer^, (@Some)^
- - = operator: TypedPointer, @Some, UntypedPointer
- - TypedPointer:=TypedPointer
- - TypedPointer:=@Some
- - pointer[index], (@i)[index]
- - dispose(pointerofrecord), new(pointerofrecord)
- - $PointerMath on|off
- - emit hints
- - platform, deprecated, experimental, library, unimplemented
- - hiding ancestor method
- - hiding other unit identifier
- - dotted unitnames
- - eval:
- - nil, true, false
- - range checking:
- - integer ranges
- - boolean ranges
- - enum ranges
- - char ranges
- - +, -, *, div, mod, /, shl, shr, or, and, xor, in, ^^, ><
- - =, <>, <, <=, >, >=
- - ord(), low(), high(), pred(), succ(), length()
- - string[index]
- - call(param)
- - a:=value
- - arr[index]
- - resourcestrings
- - custom ranges
- - enum: low(), high(), pred(), succ(), ord(), rg(int), int(rg), enum:=rg,
- rg:=rg, rg1:=rg2, rg:=enum, =, <>, in
- array[rg], low(array), high(array)
- - for..in..do :
- - type boolean, char, byte, shortint, word, smallint, longword, longint
- - type enum range, char range, integer range
- - type/var set of: enum, enum range, integer, integer range, char, char range
- - array var
- - function: enumerator
- - class
- - var modifier 'absolute'
- - Assert(bool[,string])
- - interfaces
- - $interfaces com|corba|default
- - root interface for com: delphi: IInterface, objfpc: IUnknown
- - method resolution
- - delegation via property implements: intftype, classtype
- - IntfVar as IntfType, intfvar as classtype, ObjVar as IntfType
- - IntfVar is IntfType, intfvar is classtype, ObjVar is IntfType
- - intftype(ObjVar), classtype(IntfVar)
- - default property
- - visibility public
- - $M+
- - class interfaces, check duplicates
- - assigned()
- - IntfVar:=nil, IntfVar:=IntfVar, IntfVar:=ObjVar, ObjVar:=IntfVar
- - IntfVar=IntfVar2
- - currency
- - eval type TResEvalCurrency
- - eval +, -, *, /, ^^
- - float*currency and currency*float computes to currency
- - type alias type overloads
- - $writeableconst off $J-
- - $warn identifier ON|off|error|default
- - anonymous methods:
- - assign in proc and program begin and initialization p:=procedure begin end
- - pass as arg doit(procedure begin end)
- - modifiers assembler varargs cdecl
- - typecast
- - with
- - self
- - built-in procedure Val(const s: string; var e: enumtype; out Code: integertype);
- - intrinsic functions Lo and Hi, depending on $mode (ObjFPC or Delphi):
- - In $MODE DELPHI:
- function Lo/Hi(i: <any integer type>): Byte
- - In $MODE OBJFPC:
- function Lo/Hi(i: Byte/ShortInt/Word/SmallInt): Byte
- function Lo/Hi(i: LongWord/LongInt/UIntSingle/IntSingle): Word
- function Lo/Hi(i: QWord/Int64/UIntDouble/IntDouble): LongWord
- - helpers:
- - class
- - record
- - type helper for simple type variables
- - InterfaceHelpers for fast gathering of helpers from uses sections
- - "inherited" and "inherited name" for Delphi and ObjFPC
- - for i in typehelped
- - nested: type, const, class var
- - visibility
- - property
- - helper method, Self as var argument
- - generics
- - array of const
- - attributes
- ToDo:
- - operator overload
- - operator enumerator
- - binaryexpr
- - advanced records
- - Include/Exclude for set of int/char/bool
- - error if property method resolution is not used
- - $H-hintpos$H+
- - $pop, $push
- - $RTTI inherited|explicit
- - range checking:
- - property defaultvalue
- - IntSet:=[-1]
- - CharSet:=[#13]
- - proc: check if forward and impl default values match
- - call array of proc without ()
- - generics, nested param lists
- - object
- - futures
- - TPasFileType
- - labels
- - $zerobasedstrings on|off
- - FOR_LOOP_VAR_VARPAR passing a loop var to a var parameter gives a warning
- - FOR_VARIABLE warning if using a global var as loop var
- - COMPARISON_FALSE COMPARISON_TRUE Comparison always evaluates to False
- - USE_BEFORE_DEF Variable '%s' might not have been initialized
- - FOR_LOOP_VAR_UNDEF FOR-Loop variable '%s' may be undefined after loop
- - TYPEINFO_IMPLICITLY_ADDED Published caused RTTI ($M+) to be added to type '%s'
- - IMPLICIT_STRING_CAST Implicit string cast from '%s' to '%s'
- - IMPLICIT_STRING_CAST_LOSS Implicit string cast with potential data loss from '%s' to '%s'
- - off by default: EXPLICIT_STRING_CAST Explicit string cast from '%s' to '%s'
- - off by default: EXPLICIT_STRING_CAST_LOSS Explicit string cast with potential data loss from '%s' to '%s'
- - IMPLICIT_INTEGER_CAST_LOSS Implicit integer cast with potential data loss from '%s' to '%s'
- - IMPLICIT_CONVERSION_LOSS Implicit conversion may lose significant digits from '%s' to '%s'
- - COMBINING_SIGNED_UNSIGNED64 Combining signed type and unsigned 64-bit type - treated as an unsigned type
- -
- Debug flags: -d<x>
- VerbosePasResolver
- Notes:
- Functions and function types without parameters:
- property P read f; // use function f, not its result
- f. // implicit resolve f once if param less function or function type
- f[] // implicit resolve f once if a param less function or function type
- @f; use function f, not its result
- @p.f; @ operator applies to f, not p
- @f(); @ operator applies to result of f
- f(); use f's result
- FuncVar:=Func; if mode=objfpc: incompatible
- if mode=delphi: implicit addr of function f
- if f=g then : can implicit resolve each side once
- p(f), f as var parameter: can implicit
- }
- unit PasResolver;
- {$i fcl-passrc.inc}
- {$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
- {$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
- interface
- uses
- {$ifdef pas2js}
- js,
- {$IFDEF NODEJS}
- Node.FS,
- {$ENDIF}
- {$endif}
- Classes, SysUtils, Math, Types, contnrs,
- PasTree, PScanner, PParser, PasResolveEval;
- const
- ParserMaxEmbeddedColumn = 2048;
- ParserMaxEmbeddedRow = $7fffffff div ParserMaxEmbeddedColumn;
- po_Resolver = [
- po_ResolveStandardTypes,
- po_NoOverloadedProcs,
- po_KeepClassForward,
- po_ArrayRangeExpr,
- po_CheckCondFunction];
- type
- TResolverBaseType = (
- btNone, // undefined
- btCustom, // provided by descendant resolver
- btContext, // any source declared type with LoTypeEl/HiTypeEl
- btModule,
- btUntyped, // TPasArgument without ArgType
- btChar, // char
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar, // ansichar
- {$endif}
- btWideChar, // widechar
- btString, // string
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiString, // ansistring
- btShortString, // shortstring
- btRawByteString, // rawbytestring
- {$endif}
- btWideString, // widestring
- btUnicodeString,// unicodestring
- btSingle, // single 1.5E-45..3.4E38, digits 7-8, bytes 4
- btDouble, // double 5.0E-324..1.7E308, digits 15-16, bytes 8
- btExtended, // extended platform, double or 1.9E-4932..1.1E4932, digits 19-20, bytes 10
- btCExtended, // cextended
- btCurrency, // as int64 div 10000, float, not ordinal
- btBoolean, // boolean
- btByteBool, // bytebool true=not zero
- btWordBool, // wordbool true=not zero
- btLongBool, // longbool true=not zero
- {$ifdef HasInt64}
- btQWordBool, // qwordbool true=not zero
- {$endif}
- btByte, // byte 0..255
- btShortInt, // shortint -128..127
- btWord, // word unsigned 2 bytes
- btSmallInt, // smallint signed 2 bytes
- btUIntSingle, // unsigned integer range of single 22bit
- btIntSingle, // integer range of single 23bit
- btLongWord, // longword unsigned 4 bytes
- btLongint, // longint signed 4 bytes
- btUIntDouble, // unsigned integer range of double 52bit
- btIntDouble, // integer range of double 53bit
- {$ifdef HasInt64}
- btQWord, // qword 0..18446744073709551615, bytes 8
- btInt64, // int64 -9223372036854775808..9223372036854775807, bytes 8
- btComp, // as Int64, not ordinal
- {$endif}
- btPointer, // pointer or canonical pointer (e.g. @something)
- {$ifdef fpc}
- btFile, // file
- btText, // text
- btVariant, // variant
- {$endif}
- btNil, // nil = pointer, class, procedure, method, ...
- btProc, // TPasProcedure
- btBuiltInProc, // TPasUnresolvedSymbolRef with CustomData is TResElDataBuiltInProc
- btArrayProperty,// IdentEl is TPasProperty with Args.Count>0, LoTypeEl=nil
- btSet, // set of '', see SubType
- btArrayLit, // [] array literal (TParamsExpr, TArrayValues, TBinaryExpr), see SubType
- btArrayOrSet, // [] can be set or array literal, see SubType
- btRange // a..b see SubType
- );
- TResolveBaseTypes = set of TResolverBaseType;
- const
- btIntMax = {$ifdef HasInt64}btInt64{$else}btIntDouble{$endif};
- btUIntMax = {$ifdef HasInt64}btQWord{$else}btUIntDouble{$endif};
- btAllInteger = [btByte,btShortInt,btWord,btSmallInt,btIntSingle,btUIntSingle,
- btLongWord,btLongint,btIntDouble,btUIntDouble
- {$ifdef HasInt64}
- ,btQWord,btInt64,btComp
- {$endif}];
- btAllIntegerNoQWord = btAllInteger{$ifdef HasInt64}-[btQWord]{$endif};
- btAllSignedInteger = [btShortInt,btSmallInt,btIntSingle,btLongint,btIntDouble
- {$ifdef HasInt64}
- ,btInt64,btComp
- {$endif}];
- btAllChars = [btChar,{$ifdef FPC_HAS_CPSTRING}btAnsiChar,{$endif}btWideChar];
- btAllStrings = [btString,
- {$ifdef FPC_HAS_CPSTRING}btAnsiString,btShortString,btRawByteString,{$endif}
- btWideString,btUnicodeString];
- btAllStringAndChars = btAllStrings+btAllChars;
- btAllStringPointer = [btString,
- {$ifdef FPC_HAS_CPSTRING}btAnsiString,btRawByteString,{$endif}
- btWideString,btUnicodeString];
- btAllFloats = [btSingle,btDouble,
- btExtended,btCExtended,btCurrency];
- btAllBooleans = [btBoolean,btByteBool,btWordBool,btLongBool
- {$ifdef HasInt64},btQWordBool{$endif}];
- btArrayRangeTypes = btAllChars+btAllBooleans+btAllInteger;
- btAllRanges = btArrayRangeTypes+[btRange];
- btAllWithSubType = [btSet, btArrayLit, btArrayOrSet, btRange];
- btAllIntrinsicTypes = btAllInteger+btAllStringAndChars+btAllFloats+btAllBooleans;
- btAllFPCTypes = [
- btChar,
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar,
- {$endif}
- btWideChar,
- btString,
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiString,
- btShortString,
- btRawByteString,
- {$endif}
- btWideString,
- btUnicodeString,
- btSingle,
- btDouble,
- btExtended,
- btCExtended,
- btCurrency,
- btBoolean,
- btByteBool,
- btWordBool,
- btLongBool,
- {$ifdef HasInt64}
- btQWordBool,
- {$endif}
- btByte,
- btShortInt,
- btWord,
- btSmallInt,
- btLongWord,
- btLongint,
- {$ifdef HasInt64}
- btQWord,
- btInt64,
- btComp,
- {$endif}
- btPointer
- {$ifdef fpc}
- ,btFile,
- btText,
- btVariant
- {$endif}
- ];
- ResBaseTypeNames: array[TResolverBaseType] of string =(
- 'None',
- 'Custom',
- 'Context',
- 'Module',
- 'Untyped',
- 'Char',
- {$ifdef FPC_HAS_CPSTRING}
- 'AnsiChar',
- {$endif}
- 'WideChar',
- 'String',
- {$ifdef FPC_HAS_CPSTRING}
- 'AnsiString',
- 'ShortString',
- 'RawByteString',
- {$endif}
- 'WideString',
- 'UnicodeString',
- 'Single',
- 'Double',
- 'Extended',
- 'CExtended',
- 'Currency',
- 'Boolean',
- 'ByteBool',
- 'WordBool',
- 'LongBool',
- {$ifdef HasInt64}
- 'QWordBool',
- {$endif}
- 'Byte',
- 'ShortInt',
- 'Word',
- 'SmallInt',
- 'UIntSingle',
- 'IntSingle',
- 'LongWord',
- 'Longint',
- 'UIntDouble',
- 'IntDouble',
- {$ifdef HasInt64}
- 'QWord',
- 'Int64',
- 'Comp',
- {$endif}
- 'Pointer',
- {$ifdef fpc}
- 'File',
- 'Text',
- 'Variant',
- {$endif}
- 'Nil',
- 'Procedure/Function',
- 'BuiltInProc',
- 'array property',
- 'set',
- 'array',
- 'set or array literal',
- 'range..'
- );
- type
- TResolverBuiltInProc = (
- bfCustom,
- bfLength,
- bfSetLength,
- bfInclude,
- bfExclude,
- bfBreak,
- bfContinue,
- bfExit,
- bfInc,
- bfDec,
- bfAssigned,
- bfChr,
- bfOrd,
- bfLow,
- bfHigh,
- bfPred,
- bfSucc,
- bfStrProc,
- bfStrFunc,
- bfWriteStr,
- bfVal,
- bfLo,
- bfHi,
- bfConcatArray,
- bfConcatString,
- bfCopyArray,
- bfInsertArray,
- bfDeleteArray,
- bfTypeInfo,
- bfGetTypeKind,
- bfAssert,
- bfNew,
- bfDispose,
- bfDefault
- );
- TResolverBuiltInProcs = set of TResolverBuiltInProc;
- const
- ResolverBuiltInProcNames: array[TResolverBuiltInProc] of string = (
- 'Custom',
- 'Length',
- 'SetLength',
- 'Include',
- 'Exclude',
- 'Break',
- 'Continue',
- 'Exit',
- 'Inc',
- 'Dec',
- 'Assigned',
- 'Chr',
- 'Ord',
- 'Low',
- 'High',
- 'Pred',
- 'Succ',
- 'Str',
- 'Str',
- 'WriteStr',
- 'Val',
- 'Lo',
- 'Hi',
- 'Concat',
- 'Concat',
- 'Copy',
- 'Insert',
- 'Delete',
- 'TypeInfo',
- 'GetTypeKind',
- 'Assert',
- 'New',
- 'Dispose',
- 'Default'
- );
- bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)];
- const
- ResolverResultVar = 'Result';
- {$IFDEF CheckPasTreeRefCount}
- RefIdInferenceParamsExpr = 'InferenceParamsExpr';
- {$ENDIF}
- type
- {$ifdef pas2js}
- TPasResIterate = procedure(Item, Arg: pointer) of object;
- { TPasResHashList }
- TPasResHashList = class
- private
- FItems: TJSObject;
- public
- constructor Create; reintroduce;
- procedure Add(const aName: string; Item: Pointer);
- function Find(const aName: string): Pointer;
- procedure ForEachCall(const Proc: TPasResIterate; Arg: Pointer);
- procedure Clear;
- procedure Remove(const aName: string);
- end;
- {$else}
- TPasResHashList = TFPHashList;
- {$endif}
- type
- { EPasResolve }
- EPasResolve = class(Exception)
- private
- FPasElement: TPasElement;
- procedure SetPasElement(AValue: TPasElement);
- public
- Id: TMaxPrecInt;
- MsgType: TMessageType;
- MsgNumber: integer;
- MsgPattern: String;
- Args: TMessageArgs;
- SourcePos: TPasSourcePos;
- destructor Destroy; override;
- property PasElement: TPasElement read FPasElement write SetPasElement; // can be nil!
- end;
- type
- { TUnresolvedPendingRef }
- TUnresolvedPendingRef = class(TPasUnresolvedSymbolRef)
- public
- Element: TPasType; // TPasClassOfType or TPasPointerType
- end;
- { TPasSpecializeTypeData - CustomData of TPasSpecializeType
- for the generic type see TPasSpecializeType(Element).DestType }
- TPasSpecializeTypeData = Class(TResolveData)
- public
- SpecializedType: TPasGenericType;
- end;
- TPRSpecializeStep = (
- prssNone,
- prssInterfaceBuilding,
- prssInterfaceFinished,
- prssImplementationBuilding,
- prssImplementationFinished
- );
- { TPRSpecializedItem }
- TPRSpecializedItem = class
- private
- FSpecializedEl: TPasElement;
- public
- GenericEl: TPasElement;
- Index: integer;
- Step: TPRSpecializeStep; // how much of the specialized element has been created
- FirstSpecialize: TPasElement;
- Params: TPasTypeArray;
- SpecializedConstraints: TPasElementArray;
- destructor Destroy; override;
- property SpecializedEl: TPasElement read FSpecializedEl;
- end;
- { TPRSpecializedTypeItem }
- TPRSpecializedTypeItem = class(TPRSpecializedItem)
- private
- FSpecializedType: TPasGenericType;
- procedure SetSpecializedType(AValue: TPasGenericType);
- public
- HeaderScope: TObject; // TPasScope
- ImplProcs: TFPList; // list of TPasProcedure
- destructor Destroy; override;
- property SpecializedType: TPasGenericType read FSpecializedType write SetSpecializedType;
- end;
- { TPRSpecializedProcItem }
- TPRSpecializedProcItem = class(TPRSpecializedItem)
- private
- FSpecializedProc: TPasProcedure;
- procedure SetSpecializedProc(const AValue: TPasProcedure);
- public
- ImplProc: TPasProcedure; // <>SpecializedProc, can be nil
- destructor Destroy; override;
- property SpecializedProc: TPasProcedure read FSpecializedProc write SetSpecializedProc;
- end;
- TPSRefAccess = (
- psraNone,
- psraRead,
- psraWrite,
- psraReadWrite,
- psraWriteRead,
- psraTypeInfo
- );
- { TPasScopeReference }
- TPasScopeReference = class
- private
- FElement: TPasElement;
- procedure SetElement(const AValue: TPasElement);
- public
- {$IFDEF VerbosePasResolver}
- Owner: TObject;
- {$ENDIF}
- Access: TPSRefAccess;
- NextSameName: TPasScopeReference;
- destructor Destroy; override;
- property Element: TPasElement read FElement write SetElement;
- end;
- TPasScope = class;
- { TPasScopeReferences - used by TPasAnalyzer to store references of a proc or initialization section }
- TPasScopeReferences = class
- private
- FScope: TPasScope;
- procedure OnClearItem(Item, Dummy: pointer);
- procedure OnCollectItem(Item, aList: pointer);
- public
- References: TPasResHashList; // hash list of TPasScopeReference
- constructor Create(aScope: TPasScope);
- destructor Destroy; override;
- procedure Clear;
- function Add(El: TPasElement; Access: TPSRefAccess): TPasScopeReference;
- function Find(const aName: string): TPasScopeReference;
- function GetList: TFPList;
- property Scope: TPasScope read FScope;
- end;
- TIterateScopeElement = procedure(El: TPasElement; ElScope, StartScope: TPasScope;
- Data: Pointer; var Abort: boolean) of object;
- { TPasScope -
- Elements like TPasClassType use TPasScope descendants as CustomData for
- their sub identifiers.
- TPasResolver.Scopes has a stack of TPasScope for searching identifiers.
- }
- TPasScope = Class(TResolveData)
- public
- VisibilityContext: TPasElement; // used to check if the current context
- // is allowed to access a private/protected element
- class function IsStoredInElement: boolean; virtual;
- class function FreeOnPop: boolean; virtual;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); virtual;
- procedure WriteIdentifiers(Prefix: string); virtual;
- end;
- TPasScopeClass = class of TPasScope;
- TPasScopeArray = array of TPasScope;
- TPasModuleScopeFlag = (
- pmsfAssertSearched, // assert constructors searched
- pmsfRangeErrorNeeded, // somewhere is range checking on
- pmsfRangeErrorSearched // ERangeError constructor searched
- );
- TPasModuleScopeFlags = set of TPasModuleScopeFlag;
- { TPasModuleScope }
- TPasModuleScope = class(TPasScope)
- private
- FAssertClass: TPasClassType;
- FAssertDefConstructor: TPasConstructor;
- FAssertMsgConstructor: TPasConstructor;
- FRangeErrorClass: TPasClassType;
- FRangeErrorConstructor: TPasConstructor;
- FSystemTVarRec: TPasRecordType;
- procedure SetAssertClass(const AValue: TPasClassType);
- procedure SetAssertDefConstructor(const AValue: TPasConstructor);
- procedure SetAssertMsgConstructor(const AValue: TPasConstructor);
- procedure SetRangeErrorClass(const AValue: TPasClassType);
- procedure SetRangeErrorConstructor(const AValue: TPasConstructor);
- procedure SetSystemTVarRec(const AValue: TPasRecordType);
- public
- FirstName: string; // the 'unit1' in 'unit1', or 'ns' in 'ns.unit1'
- PendingResolvers: TFPList; // list of TPasResolver waiting for the unit interface
- Flags: TPasModuleScopeFlags;
- BoolSwitches: TBoolSwitches;
- constructor Create; override;
- destructor Destroy; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- property AssertClass: TPasClassType read FAssertClass write SetAssertClass;
- property AssertDefConstructor: TPasConstructor read FAssertDefConstructor write SetAssertDefConstructor;
- property AssertMsgConstructor: TPasConstructor read FAssertMsgConstructor write SetAssertMsgConstructor;
- property RangeErrorClass: TPasClassType read FRangeErrorClass write SetRangeErrorClass;
- property RangeErrorConstructor: TPasConstructor read FRangeErrorConstructor write SetRangeErrorConstructor;
- property SystemTVarRec: TPasRecordType read FSystemTVarRec write SetSystemTVarRec;
- end;
- TPasModuleScopeClass = class of TPasModuleScope;
- TPasIdentifierKind = (
- pikNone, // not yet initialized
- pikBaseType, // e.g. longint
- pikBuiltInProc, // e.g. High(), SetLength()
- pikSimple, // simple vars, consts, types, enums
- pikProc, // may need parameter list with round brackets
- pikNamespace
- );
- TPasIdentifierKinds = set of TPasIdentifierKind;
- { TPasIdentifier }
- TPasIdentifier = Class(TObject)
- private
- FElement: TPasElement;
- procedure SetElement(AValue: TPasElement);
- public
- {$IFDEF VerbosePasResolver}
- Owner: TObject;
- {$ENDIF}
- Identifier: String;
- NextSameIdentifier: TPasIdentifier; // next identifier with same name
- Kind: TPasIdentifierKind;
- destructor Destroy; override;
- property Element: TPasElement read FElement write SetElement;
- end;
- TPasIdentifierArray = array of TPasIdentifier;
- { TPasIdentifierScope - elements with a list of sub identifiers }
- TPasIdentifierScope = Class(TPasScope)
- private
- FItems: TPasResHashList; // hashlist of TPasIdentifier
- procedure InternalAdd(Item: TPasIdentifier);
- procedure OnClearItem(Item, Dummy: pointer);
- procedure OnCollectItem(Item, List: pointer);
- protected
- procedure OnWriteItem(Item, Dummy: pointer);
- public
- constructor Create; override;
- destructor Destroy; override;
- procedure ClearIdentifiers(FreeItems: boolean);
- function FindLocalIdentifier(const Identifier: String): TPasIdentifier; inline;
- function FindIdentifier(const Identifier: String): TPasIdentifier; virtual;
- function RemoveLocalIdentifier(El: TPasElement): boolean; virtual;
- function AddIdentifier(const Identifier: String; El: TPasElement;
- const Kind: TPasIdentifierKind): TPasIdentifier; virtual;
- function FindElement(const aName: string): TPasElement;
- procedure IterateLocalElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean);
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- procedure WriteLocalIdentifiers(Prefix: string); virtual;
- function GetLocalIdentifiers: TFPList; virtual;
- end;
- TPasIdentifierScopeArray = array of TPasIdentifierScope;
- { TPasDefaultScope - root scope }
- TPasDefaultScope = class(TPasIdentifierScope)
- public
- class function IsStoredInElement: boolean; override;
- end;
- { TPasIterateFilterData }
- TPasIterateFilterData = record
- OnIterate: TIterateScopeElement;
- Data: Pointer;
- end;
- PPasIterateFilterData = ^TPasIterateFilterData;
- { TPRHelperEntry }
- TPRHelperEntry = class
- public
- Added: integer; // Added is bigger when it was added later to the list
- HelperForType: TPasType; // alias resolved
- Helper: TPasClassType;
- end;
- TPRHelperEntryArray = array of TPRHelperEntry;
- { TPasSectionScope - e.g. interface, implementation, program, library }
- TPasSectionScope = Class(TPasIdentifierScope)
- private
- procedure OnInternalIterate(El: TPasElement; ElScope, StartScope: TPasScope;
- Data: Pointer; var Abort: boolean);
- public
- UsesScopes: TFPList; // list of TPasSectionScope
- UsesFinished: boolean;
- Finished: boolean;
- BoolSwitches: TBoolSwitches;
- ModeSwitches: TModeSwitches;
- Helpers: TPRHelperEntryArray; // only created for interface. Sorted ascending ComparePRHelperEntries
- constructor Create; override;
- destructor Destroy; override;
- function FindIdentifier(const Identifier: String): TPasIdentifier; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- end;
- TPasSectionScopeClass = class of TPasSectionScope;
- { TPasInitialFinalizationScope - e.g. TInitializationSection, TFinalizationSection }
- TPasInitialFinalizationScope = Class(TPasScope)
- public
- References: TPasScopeReferences; // created by TPasAnalyzer, not used by resolver
- function AddReference(El: TPasElement; Access: TPSRefAccess): TPasScopeReference;
- destructor Destroy; override;
- end;
- TPasInitialFinalizationScopeClass = class of TPasInitialFinalizationScope;
- { TPasEnumTypeScope }
- TPasEnumTypeScope = Class(TPasIdentifierScope)
- public
- CanonicalSet: TPasSetType;
- destructor Destroy; override;
- end;
- { TPasGenericParamsScope - used during parsing TPasGenericTemplateType(s) }
- TPasGenericParamsScope = Class(TPasIdentifierScope)
- public
- GenericType: TPasGenericType;
- end;
- TPSGenericStep = (
- psgsNone,
- psgsInterfaceParsed,
- psgsImplementationParsed
- );
- { TPasGenericScope }
- TPasGenericScope = Class(TPasIdentifierScope)
- public
- // for generic type:
- SpecializedItems: TObjectList; // list of TPRSpecializedItem
- GenericStep: TPSGenericStep; // how much of the generic was parsed
- // for specialized type:
- SpecializedFromItem: TPRSpecializedItem;
- destructor Destroy; override;
- end;
- { TPasArrayScope }
- TPasArrayScope = Class(TPasGenericScope)
- public
- end;
- TPasArrayScopeClass = class of TPasArrayScope;
- { TPasProcTypeScope }
- TPasProcTypeScope = Class(TPasGenericScope)
- public
- end;
- TPasProcTypeScopeClass = class of TPasProcTypeScope;
- { TPasClassOrRecordScope }
- TPasClassOrRecordScope = Class(TPasGenericScope)
- public
- DefaultProperty: TPasProperty;
- ClassConstructor: TPasClassConstructor;
- ClassDestructor: TPasClassDestructor;
- end;
- { TPasRecordScope }
- TPasRecordScope = Class(TPasClassOrRecordScope)
- end;
- TPasRecordScopeClass = class of TPasRecordScope;
- TPasClassScopeFlag = (
- pcsfAncestorResolved,
- pcsfSealed,
- pcsfPublished // default visibility is published due to $M directive
- );
- TPasClassScopeFlags = set of TPasClassScopeFlag;
- { TPasClassIntfMap }
- TPasClassIntfMap = class
- public
- Element: TPasElement;
- Intf: TPasClassType;
- Procs: TFPList;// maps Interface-member-index to TPasProcedure
- AncestorMap: TPasClassIntfMap;// AncestorMap.Element=Element, AncestorMap.Intf=DirectAncestor
- destructor Destroy; override;
- end;
- { TPasClassScope }
- TPasClassScope = Class(TPasClassOrRecordScope)
- public
- AncestorScope: TPasClassScope;
- CanonicalClassOf: TPasClassOfType;
- DirectAncestor: TPasType; // TPasClassType or TPasAliasType, see GetPasClassAncestor
- // Note: TPasClassType.AncestorType might be nil and DirectAncestor is "TObject"
- Flags: TPasClassScopeFlags;
- AbstractProcs: TArrayOfPasProcedure;
- Interfaces: TFPList; // list corresponds to TPasClassType(Element).Interfaces,
- // elements: TPasProperty for 'implements', or TPasClassIntfMap
- destructor Destroy; override;
- end;
- TPasClassScopeClass = class of TPasClassScope;
- { TPasGroupScope }
- TPasGroupScope = Class(TPasIdentifierScope)
- public
- Scopes: TPasIdentifierScopeArray;
- Count: integer;
- OnlyTypeMembers: boolean;
- procedure Add(Scope: TPasIdentifierScope);
- destructor Destroy; override;
- function GetFirstNonHelperScope: TPasIdentifierScope;
- class function IsStoredInElement: boolean; override;
- function FindAncestorIdentifier(const Identifier: String): TPasIdentifier;
- function FindAncestorElement(const Identifier: String): TPasElement;
- function FindIdentifier(const Identifier: String): TPasIdentifier; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- end;
- TPasProcedureScopeFlag = (
- ppsfIsGroupOverload, // mode objfpc: one overload is enough for all procs in same scope
- ppsfIsSpecialized
- );
- TPasProcedureScopeFlags = set of TPasProcedureScopeFlag;
- { TPasProcedureScope }
- TPasProcedureScope = Class(TPasGenericScope)
- public
- DeclarationProc: TPasProcedure; // the corresponding forward declaration
- ImplProc: TPasProcedure; // the corresponding proc with Body
- OverriddenProc: TPasProcedure; // the ancestor proc with same signature
- ClassRecScope: TPasClassOrRecordScope;
- GroupScope: TPasGroupScope; // set during parsing a method body
- NestedMembersScope: TPasGroupScope; // set during parsing a method body of a nested class
- SelfArg: TPasArgument;
- Flags: TPasProcedureScopeFlags;
- BoolSwitches: TBoolSwitches; // if Body<>nil then body start, otherwise when FinishProc
- ModeSwitches: TModeSwitches; // at proc start
- function FindIdentifier(const Identifier: String): TPasIdentifier; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- function GetSelfScope: TPasProcedureScope; // get the next parent procscope with a classcope
- procedure WriteIdentifiers(Prefix: string); override;
- destructor Destroy; override;
- public
- References: TPasScopeReferences; // created by TPasAnalyzer in DeclarationProc
- function AddReference(El: TPasElement; Access: TPSRefAccess): TPasScopeReference;
- function GetReferences: TFPList;
- end;
- TPasProcedureScopeClass = class of TPasProcedureScope;
- { TPasPropertyScope }
- TPasPropertyScope = Class(TPasIdentifierScope)
- public
- AncestorProp: TPasProperty; { if TPasProperty(Element).VarType=nil this is an override
- otherwise it is a redeclaration }
- destructor Destroy; override;
- end;
- { TPasExceptOnScope }
- TPasExceptOnScope = Class(TPasIdentifierScope)
- end;
- TPasWithScope = class;
- TPasWithExprScopeFlag = (
- wesfNeedTmpVar,
- wesfOnlyTypeMembers,
- wesfIsClassOf,
- wesfConstParent // not writable
- );
- TPasWithExprScopeFlags = set of TPasWithExprScopeFlag;
- { TPasWithExprScope }
- TPasWithExprScope = Class(TPasScope)
- public
- WithScope: TPasWithScope; // owner
- Index: integer;
- Expr: TPasExpr;
- Scope: TPasGroupScope;
- ClassRecScope: TPasClassOrRecordScope;
- Flags: TPasWithExprScopeFlags;
- class function IsStoredInElement: boolean; override;
- class function FreeOnPop: boolean; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- destructor Destroy; override;
- end;
- TPasWithExprScopeClass = class of TPasWithExprScope;
- { TPasWithScope }
- TPasWithScope = Class(TPasScope)
- public
- // Element is the TPasImplWithDo
- ExpressionScopes: TObjectList; // list of TPasWithExprScope
- constructor Create; override;
- destructor Destroy; override;
- end;
- { TPasForLoopScope }
- TPasForLoopScope = Class(TPasScope)
- public
- GetEnumerator: TPasFunction;
- MoveNext: TPasFunction;
- Current: TPasProperty;
- end;
- { TPasSubExprScope - base class for sub scopes aka dotted scopes }
- TPasSubExprScope = Class(TPasIdentifierScope)
- public
- class function IsStoredInElement: boolean; override;
- end;
- { TPasDotBaseScope }
- TPasDotBaseScope = Class(TPasSubExprScope)
- public
- GroupScope: TPasGroupScope;
- OnlyTypeMembers: boolean; // true=only class var/procs, false=default=all
- ConstParent: boolean;
- function FindIdentifier(const Identifier: String): TPasIdentifier; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- destructor Destroy; override;
- end;
- { TPasModuleDotScope - scope for searching unitname.<identifier> }
- TPasModuleDotScope = Class(TPasDotBaseScope)
- private
- FModule: TPasModule;
- procedure OnInternalIterate(El: TPasElement; ElScope, StartScope: TPasScope;
- Data: Pointer; var Abort: boolean);
- procedure SetModule(AValue: TPasModule);
- public
- ImplementationScope: TPasSectionScope;
- InterfaceScope: TPasSectionScope;
- SystemScope: TPasDefaultScope;
- destructor Destroy; override;
- function FindIdentifier(const Identifier: String): TPasIdentifier; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- property Module: TPasModule read FModule write SetModule;
- end;
- { TPasDotEnumTypeScope - used for EnumType.EnumValue }
- TPasDotEnumTypeScope = Class(TPasDotBaseScope)
- public
- EnumScope: TPasEnumTypeScope;
- function FindIdentifier(const Identifier: String): TPasIdentifier; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- end;
- { TPasDotClassOrRecordScope }
- TPasDotClassOrRecordScope = Class(TPasDotBaseScope)
- public
- ClassRecScope: TPasClassOrRecordScope;
- end;
- { TPasDotClassScope - used for aClass.subidentifier }
- TPasDotClassScope = Class(TPasDotClassOrRecordScope)
- public
- IsClassOf: boolean; // true if aClassOf.
- end;
- { TPasInheritedScope - used for inherited; and inherited Name() }
- TPasInheritedScope = Class(TPasDotClassOrRecordScope)
- public
- AncestorScope: TPasClassScope;
- function FindIdentifier(const Identifier: String): TPasIdentifier; override;
- procedure IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); override;
- procedure WriteIdentifiers(Prefix: string); override;
- end;
- { TPasDotHelperScope }
- TPasDotHelperScope = class(TPasDotBaseScope)
- end;
- TResolvedReferenceFlag = (
- rrfDotScope, // found reference via a dot scope (TPasDotBaseScope)
- rrfImplicitCallWithoutParams, // a TPrimitiveExpr is an implicit call without params
- rrfNoImplicitCallWithoutParams, // a TPrimitiveExpr is not an implicit call
- rrfNewInstance, // constructor call (without it call constructor as normal method)
- rrfFreeInstance, // destructor call (without it call destructor as normal method)
- rrfVMT, // use VMT for call
- rrfConstInherited // parent is const and this child is too
- );
- TResolvedReferenceFlags = set of TResolvedReferenceFlag;
- type
- { TResolvedRefContext }
- TResolvedRefContext = Class
- end;
- TResolvedRefAccess = (
- rraNone,
- rraRead, // expression is read
- rraAssign, // expression is LHS assign
- rraReadAndAssign, // expression is LHS +=, -=, *=, /=
- rraVarParam, // expression is passed to a var parameter
- rraOutParam, // expression is passed to an out parameter
- rraParamToUnknownProc // used as param, before knowing what overladed proc to call,
- // will later be changed to rraRead, rraVarParam, rraOutParam
- );
- TPRResolveVarAccesses = set of TResolvedRefAccess;
- const
- rraAllRead = [rraRead,rraReadAndAssign,rraVarParam];
- rraAllWrite = [rraAssign,rraReadAndAssign,rraVarParam,rraOutParam];
- ResolvedToPSRefAccess: array[TResolvedRefAccess] of TPSRefAccess = (
- psraNone, // rraNone
- psraRead, // rraRead
- psraWrite, // rraAssign
- psraReadWrite, // rraReadAndAssign
- psraReadWrite, // rraVarParam
- psraWrite, // rraOutParam
- psraNone // rraParamToUnknownProc
- );
- type
- { TResolvedReference - CustomData for normal references }
- TResolvedReference = Class(TResolveData)
- private
- FDeclaration: TPasElement;
- procedure SetDeclaration(AValue: TPasElement);
- public
- Flags: TResolvedReferenceFlags;
- Access: TResolvedRefAccess;
- Context: TResolvedRefContext;
- WithExprScope: TPasWithExprScope;// if set, this reference used a With-block expression.
- destructor Destroy; override;
- property Declaration: TPasElement read FDeclaration write SetDeclaration;
- end;
- { TResolvedRefCtxConstructor - constructed type of a newinstance reference }
- TResolvedRefCtxConstructor = Class(TResolvedRefContext)
- public
- Typ: TPasType;
- end;
- { TResolvedRefCtxAttrProc - constructor of an attribute }
- TResolvedRefCtxAttrProc = Class(TResolvedRefContext)
- public
- Proc: TPasConstructor;
- end;
- TPasResolverResultFlag = (
- rrfReadable,
- rrfWritable,
- rrfAssignable, // not writable in general, e.g. aString[1]:=
- rrfCanBeStatement
- );
- TPasResolverResultFlags = set of TPasResolverResultFlag;
- type
- { TPasResolverResult }
- TPasResolverResult = record
- BaseType: TResolverBaseType;
- SubType: TResolverBaseType; // for btSet, btArrayLit, btArrayOrSet, btRange
- IdentEl: TPasElement; // if set then this specific identifier is the value, can be a type
- LoTypeEl: TPasType; // can be nil for const expression, all alias resolved
- HiTypeEl: TPasType; // same as LoTypeEl, except alias types are not resolved
- ExprEl: TPasExpr;
- Flags: TPasResolverResultFlags;
- end;
- PPasResolverResult = ^TPasResolverResult;
- TPasResolverResultArray = array of TPasResolverResult;
- type
- TPasResolverComputeFlag = (
- rcSetReferenceFlags, // set flags of references while computing type, used by Resolve* methods
- rcNoImplicitProc, // do not call a function without params, includes rcNoImplicitProcType
- rcNoImplicitProcType, // do not call a proc type without params
- rcConstant, // resolve a constant expression, error if not computable
- rcType, // resolve a type expression
- rcCall // resolve result type of a function call
- );
- TPasResolverComputeFlags = set of TPasResolverComputeFlag;
- TResElDataBuiltInSymbol = Class(TResolveData)
- public
- end;
- { TResElDataBaseType - CustomData for compiler built-in types (TPasUnresolvedSymbolRef), e.g. longint }
- TResElDataBaseType = Class(TResElDataBuiltInSymbol)
- public
- BaseType: TResolverBaseType;
- end;
- TResElDataBaseTypeClass = class of TResElDataBaseType;
- TResElDataBuiltInProc = Class;
- TOnGetCallCompatibility = function(Proc: TResElDataBuiltInProc;
- Exp: TPasExpr; RaiseOnError: boolean): integer of object;
- TOnGetCallResult = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
- out ResolvedEl: TPasResolverResult) of object;
- TOnEvalBIFunction = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
- Flags: TResEvalFlags; out Evaluated: TResEvalValue) of object;
- TOnFinishParamsExpr = procedure(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr) of object;
- TBuiltInProcFlag = (
- bipfCanBeStatement // a call is enough for a simple statement
- );
- TBuiltInProcFlags = set of TBuiltInProcFlag;
- { TResElDataBuiltInProc - TPasUnresolvedSymbolRef(aType).CustomData for compiler built-in procs like 'length' }
- TResElDataBuiltInProc = Class(TResElDataBuiltInSymbol)
- public
- Proc: TPasUnresolvedSymbolRef;
- Signature: string;
- BuiltIn: TResolverBuiltInProc;
- GetCallCompatibility: TOnGetCallCompatibility;
- GetCallResult: TOnGetCallResult;
- Eval: TOnEvalBIFunction;
- FinishParamsExpression: TOnFinishParamsExpr;
- Flags: TBuiltInProcFlags;
- destructor Destroy; override;
- end;
- { TPRFindData }
- TPRFindData = record
- ErrorPosEl: TPasElement;
- Found: TPasElement;
- ElScope: TPasScope; // Where Found was found
- StartScope: TPasScope; // where the search started
- SkipGenerics: boolean;
- end;
- PPRFindData = ^TPRFindData;
- TPRFindGenericData = record
- Find: TPRFindData;
- TemplateCount: integer;
- end;
- PPRFindGenericData = ^TPRFindGenericData;
- TPasResolverOption = (
- proFixCaseOfOverrides, // fix Name of overriding proc/property to the overriden proc/property
- proClassPropertyNonStatic, // class property accessors can be non static
- proPropertyAsVarParam, // allows to pass a property as a var/out argument
- proClassOfIs, // class-of supports is and as operator
- proExtClassInstanceNoTypeMembers, // class members of external class cannot be accessed by instance
- proOpenAsDynArrays, // open arrays work like dynamic arrays
- //ToDo: proStaticArrayCopy, // copy works with static arrays, returning a dynamic array
- //ToDo: proStaticArrayConcat, // concat works with static arrays, returning a dynamic array
- proProcTypeWithoutIsNested, // proc types can use nested procs without 'is nested'
- proMethodAddrAsPointer, // can assign @method to a pointer
- proSafecallAllowsDefault // allow assigning a default calling convention to a SafeCall proc
- );
- TPasResolverOptions = set of TPasResolverOption;
- { TPasResolverHub }
- TPasResolverHub = class
- private
- FOwner: TObject;
- public
- FinishedInterfaceCount: integer;
- constructor Create(TheOwner: TObject); virtual;
- procedure Reset; virtual;
- property Owner: TObject read FOwner;
- end;
- TPasResolverHubClass = class of TPasResolverHub;
- TPasResolverStep = (
- prsInit,
- prsParsing,
- prsFinishingModule,
- prsFinishedModule
- );
- TPasResolverSteps = set of TPasResolverStep;
- TPRResolveAlias = (
- prraNone, // do not resolve alias
- prraSimple, // resolve alias, but not type alias
- prraAlias // resolve alias and type alias
- );
- TPRProcTypeDescFlag = (
- prptdUseName, // add name if available
- prptdAddPaths, // add full paths to types
- prptdResolveSimpleAlias
- );
- TPRProcTypeDescFlags = set of TPRProcTypeDescFlag;
- TPRParentParams = record
- InlineSpec: TInlineSpecializeExpr;
- Params: TParamsExpr;
- end;
- TPRTemplateCompOp = (
- prtcoAssignToTempl,
- prtcoAssignFromTempl,
- prtcoEqual
- );
- { TPasResolver }
- TPasResolver = Class(TPasTreeContainer)
- private
- type
- TResolveDataListKind = (lkBuiltIn,lkModule);
- function GetBaseTypes(bt: TResolverBaseType): TPasUnresolvedSymbolRef; inline;
- function GetScopes(Index: integer): TPasScope; inline;
- private
- FActiveHelpers: TPRHelperEntryArray; // sorted ascending ComparePRHelperEntries
- FAnonymousElTypePostfix: String;
- FBaseTypeChar: TResolverBaseType;
- FBaseTypeExtended: TResolverBaseType;
- FBaseTypeLength: TResolverBaseType;
- FBaseTypes: array[TResolverBaseType] of TPasUnresolvedSymbolRef;
- FBaseTypeString: TResolverBaseType;
- FBuiltInProcs: array[TResolverBuiltInProc] of TResElDataBuiltInProc;
- FDefaultNameSpace: String;
- FDefaultScope: TPasDefaultScope;
- FDynArrayMaxIndex: TMaxPrecInt;
- FDynArrayMinIndex: TMaxPrecInt;
- FFinishedInterfaceIndex: integer;
- FHub: TPasResolverHub;
- FLastCreatedData: array[TResolveDataListKind] of TResolveData;
- FLastElement: TPasElement;
- FLastMsg: string;
- FLastMsgArgs: TMessageArgs;
- FLastMsgElement: TPasElement;
- FLastMsgId: TMaxPrecInt;
- FLastMsgNumber: integer;
- FLastMsgPattern: string;
- FLastMsgType: TMessageType;
- FLastSourcePos: TPasSourcePos;
- FOptions: TPasResolverOptions;
- FPendingForwardProcs: TFPList; // list of TPasElement needed to check for forward procs
- FRootElement: TPasModule;
- FScopeClass_Array: TPasArrayScopeClass;
- FScopeClass_Class: TPasClassScopeClass;
- FScopeClass_InitialFinalization: TPasInitialFinalizationScopeClass;
- FScopeClass_Module: TPasModuleScopeClass;
- FScopeClass_Proc: TPasProcedureScopeClass;
- FScopeClass_ProcType: TPasProcTypeScopeClass;
- FScopeClass_Record: TPasRecordScopeClass;
- FScopeClass_Section: TPasSectionScopeClass;
- FScopeClass_WithExpr: TPasWithExprScopeClass;
- FScopeCount: integer;
- FScopes: TPasScopeArray; // stack of scopes
- FStep: TPasResolverStep;
- FStoreSrcColumns: boolean;
- FStashScopeCount: integer;
- FStashScopes: TPasScopeArray; // stack of scopes
- FTopScope: TPasScope;
- procedure ClearResolveDataList(Kind: TResolveDataListKind);
- function GetBaseTypeNames(bt: TResolverBaseType): string;
- function GetBuiltInProcs(bp: TResolverBuiltInProc): TResElDataBuiltInProc;
- protected
- const
- cExact = 0;
- cGenericExact = cExact+1;
- cAliasExact = cGenericExact+1;
- cCompatible = cAliasExact+1;
- cIntToIntConversion = ord(High(TResolverBaseType));
- cFloatToFloatConversion = 2*cIntToIntConversion;
- cTypeConversion = cExact+10000; // e.g. TObject to Pointer
- cLossyConversion = cExact+100000;
- cIntToFloatConversion = cExact+400000; // int to float is worse than bigint to smallint
- cIncompatible = High(integer);
- var
- cTGUIDToString: integer;
- cStringToTGUID: integer;
- cInterfaceToTGUID: integer;
- cInterfaceToString: integer;
- type
- TFindCallElData = record
- Params: TParamsExpr;
- TemplCnt: integer;
- Found: TPasElement; // TPasProcedure or TPasUnresolvedSymbolRef(built in proc) or TPasType (typecast)
- LastProc: TPasProcedure;
- ElScope, StartScope: TPasScope;
- Distance: integer; // compatibility distance
- Count: integer;
- List: TFPList; // if not nil then collect all found elements here
- end;
- PFindCallElData = ^TFindCallElData;
- TFindProcKind = (
- fpkProcDeclaration, // search declaration for a body
- fpkProc, // check overloads for a proc
- fpkMethod // check overloads for a method
- );
- TFindProcData = record
- Proc: TPasProcedure;
- Args: TFPList; // List of TPasArgument objects
- Kind: TFindProcKind;
- FoundOverloadModifier: boolean;
- FoundInSameScope: integer;
- Found: TPasProcedure;
- ElScope, StartScope: TPasScope;
- FoundNonProc: TPasElement;
- end;
- PFindProcData = ^TFindProcData;
- procedure OnFindFirst_PreferNoParams(El: TPasElement; ElScope, StartScope: TPasScope;
- FindFirstElementData: Pointer; var Abort: boolean); virtual;
- procedure OnFindFirst(El: TPasElement; ElScope, StartScope: TPasScope;
- FindFirstElementData: Pointer; var Abort: boolean); virtual;
- procedure OnFindFirst_GenericEl(El: TPasElement; ElScope, StartScope: TPasScope;
- FindFirstGenericData: Pointer; var Abort: boolean); virtual;
- procedure OnFindCallElements(El: TPasElement; ElScope, StartScope: TPasScope;
- FindCallElData: Pointer; var Abort: boolean); virtual; // find candidates for Name(params)
- procedure OnFindProc(El: TPasElement; ElScope, StartScope: TPasScope;
- FindProcData: Pointer; var Abort: boolean); virtual;
- procedure OnFindProcDeclaration(El: TPasElement; ElScope, StartScope: TPasScope;
- FindProcData: Pointer; var Abort: boolean); virtual;
- function IsSameProcContext(ProcParentA, ProcParentB: TPasElement): boolean;
- function FindProcSameSignature(const ProcName: string; Proc: TPasProcedure;
- Scope: TPasIdentifierScope; OnlyLocal: boolean): TPasProcedure;
- protected
- procedure SetCurrentParser(AValue: TPasParser); override;
- procedure ScannerWarnDirective(Sender: TObject; Identifier: string;
- State: TWarnMsgState; var Handled: boolean); virtual;
- procedure SetRootElement(const AValue: TPasModule); virtual;
- procedure CheckTopScope(ExpectedClass: TPasScopeClass; AllowDescendants: boolean = false);
- function AddIdentifier(Scope: TPasIdentifierScope;
- const aName: String; El: TPasElement;
- const Kind: TPasIdentifierKind): TPasIdentifier; virtual;
- procedure AddModule(El: TPasModule); virtual;
- procedure AddSection(El: TPasSection); virtual;
- procedure AddInitialFinalizationSection(El: TPasImplBlock); virtual;
- procedure AddType(El: TPasType); virtual;
- procedure AddArrayType(El: TPasArrayType; TypeParams: TFPList); virtual;
- procedure AddRecordType(El: TPasRecordType; TypeParams: TFPList); virtual;
- procedure AddClassType(El: TPasClassType; TypeParams: TFPList); virtual;
- procedure AddVariable(El: TPasVariable); virtual;
- procedure AddResourceString(El: TPasResString); virtual;
- procedure AddExportSymbol(El: TPasExportSymbol); virtual;
- procedure AddEnumType(El: TPasEnumType); virtual;
- procedure AddEnumValue(El: TPasEnumValue); virtual;
- procedure AddProperty(El: TPasProperty); virtual;
- procedure AddProcedureType(El: TPasProcedureType; TypeParams: TFPList); virtual;
- procedure AddProcedure(El: TPasProcedure; TypeParams: TFPList); virtual;
- procedure AddProcedureBody(El: TProcedureBody); virtual;
- procedure AddArgument(El: TPasArgument); virtual;
- procedure AddFunctionResult(El: TPasResultElement); virtual;
- procedure AddGenericTemplateType(El: TPasGenericTemplateType); virtual;
- procedure AddExceptOn(El: TPasImplExceptOn); virtual;
- procedure AddWithDo(El: TPasImplWithDo); virtual;
- procedure ResolveImplBlock(Block: TPasImplBlock); virtual;
- procedure ResolveImplElement(El: TPasImplElement); virtual;
- procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf); virtual;
- procedure ResolveImplLabelMark(Mark: TPasImplLabelMark); virtual;
- procedure ResolveImplWithDo(El: TPasImplWithDo); virtual;
- procedure ResolveImplAsm(El: TPasImplAsmStatement); virtual;
- procedure ResolveImplAssign(El: TPasImplAssign); virtual;
- procedure ResolveImplSimple(El: TPasImplSimple); virtual;
- procedure ResolveImplRaise(El: TPasImplRaise); virtual;
- procedure ResolveExpr(El: TPasExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveStatementConditionExpr(El: TPasExpr); virtual;
- procedure ResolveNameExpr(El: TPasExpr; const aName: string; Access: TResolvedRefAccess); virtual;
- procedure ResolveInherited(El: TInheritedExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveInheritedName(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveBinaryExpr(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveSubIdent(El: TBinaryExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveParamsExprParams(Params: TParamsExpr); virtual;
- procedure ResolveFuncParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveFuncParamsExprName(NameExpr: TPasExpr; TemplParams: TFPList;
- Params: TParamsExpr; Access: TResolvedRefAccess; CallName: string = ''); virtual;
- procedure ResolveArrayParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveArrayParamsExprName(NameExpr: TPasExpr; Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveArrayParamsArgs(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess); virtual;
- function ResolveBracketOperatorClassOrRec(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult;
- Access: TResolvedRefAccess): boolean; virtual;
- procedure ResolveSetParamsExpr(Params: TParamsExpr); virtual;
- procedure ResolveArrayValues(El: TArrayValues); virtual;
- procedure ResolveRecordValues(El: TRecordValues); virtual;
- procedure ResolveInlineSpecializeExpr(El: TInlineSpecializeExpr; Access: TResolvedRefAccess); virtual;
- function ResolveAccessor(Expr: TPasExpr): TPasElement;
- procedure SetResolvedRefAccess(Expr: TPasExpr; Ref: TResolvedReference;
- Access: TResolvedRefAccess); virtual;
- procedure AccessExpr(Expr: TPasExpr; Access: TResolvedRefAccess);
- function MarkArrayExpr(Expr: TParamsExpr; ArrayType: TPasArrayType): boolean; virtual;
- procedure MarkArrayExprRecursive(Expr: TPasExpr; ArrType: TPasArrayType); virtual;
- procedure FinishModule(CurModule: TPasModule); virtual;
- procedure FinishUsesClause; virtual;
- procedure FinishSection(Section: TPasSection); virtual;
- procedure FinishInterfaceSection(Section: TPasSection); virtual;
- procedure FinishTypeSection(El: TPasElement); virtual;
- procedure FinishTypeSectionEl(El: TPasType); virtual;
- procedure FinishTypeDef(El: TPasType); virtual;
- procedure FinishEnumType(El: TPasEnumType); virtual;
- procedure FinishSetType(El: TPasSetType); virtual;
- procedure FinishSubElementType(Parent: TPasElement; El: TPasType); virtual;
- procedure FinishRangeType(El: TPasRangeType); virtual;
- procedure FinishConstRangeExpr(RangeExpr: TBinaryExpr;
- out LeftResolved, RightResolved: TPasResolverResult);
- procedure FinishRecordType(El: TPasRecordType); virtual;
- procedure FinishClassType(El: TPasClassType); virtual;
- procedure FinishClassOfType(El: TPasClassOfType); virtual;
- procedure FinishPointerType(El: TPasPointerType); virtual;
- procedure FinishArrayType(El: TPasArrayType); virtual;
- procedure FinishAliasType(El: TPasAliasType); virtual;
- procedure FinishGenericTemplateType(El: TPasGenericTemplateType); virtual;
- procedure FinishSpecializeType(El: TPasSpecializeType); virtual;
- procedure FinishResourcestring(El: TPasResString); virtual;
- procedure FinishProcedure(Proc: TPasProcedure); virtual;
- procedure FinishProcedureType(El: TPasProcedureType); virtual;
- procedure FinishMethodDeclHeader(Proc: TPasProcedure); virtual;
- procedure FinishMethodImplHeader(ImplProc: TPasProcedure); virtual;
- procedure FinishExceptOnExpr; virtual;
- procedure FinishExceptOnStatement; virtual;
- procedure FinishWithDo(El: TPasImplWithDo); virtual;
- procedure FinishForLoopHeader(Loop: TPasImplForLoop); virtual;
- procedure FinishDeclaration(El: TPasElement); virtual;
- procedure FinishVariable(El: TPasVariable); virtual;
- procedure FinishProperty(PropEl: TPasProperty); virtual;
- procedure FinishArgument(El: TPasArgument); virtual;
- procedure FinishAncestors(aClass: TPasClassType); virtual;
- procedure FinishMethodResolution(El: TPasMethodResolution); virtual;
- procedure FinishAttributes(El: TPasAttributes); virtual;
- procedure FinishExportSymbol(El: TPasExportSymbol); virtual;
- procedure FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); virtual;
- procedure FinishPropertyParamAccess(Params: TParamsExpr;
- Prop: TPasProperty); virtual;
- procedure FinishCallArgAccess(Expr: TPasExpr; Access: TResolvedRefAccess); virtual;
- procedure FinishInitialFinalization(El: TPasImplBlock); virtual;
- procedure EmitTypeHints(PosEl: TPasElement; aType: TPasType); virtual;
- function EmitElementHints(PosEl, El: TPasElement): boolean; virtual;
- procedure StoreScannerFlagsInProc(ProcScope: TPasProcedureScope);
- procedure ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope: TPasProcedureScope);
- function CreateClassIntfMap(El: TPasClassType; Index: integer): TPasClassIntfMap;
- procedure CheckConditionExpr(El: TPasExpr; const ResolvedEl: TPasResolverResult); virtual;
- procedure CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure;
- IsOverride: boolean // override or class intf implementation
- );
- procedure CheckPointerCycle(El: TPasPointerType);
- procedure CheckGenericTemplateTypes(El: TPasGenericType); virtual;
- procedure ComputeUnaryNot(El: TUnaryExpr; var ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags); virtual;
- procedure ComputeBinaryExpr(Bin: TBinaryExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeBinaryExprRes(Bin: TBinaryExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- var LeftResolved, RightResolved: TPasResolverResult); virtual;
- function ComputeAddStringRes(
- const LeftResolved, RightResolved: TPasResolverResult; ExprEl: TPasExpr;
- out ResolvedEl: TPasResolverResult): boolean; virtual;
- procedure ComputeArgumentAndExpr(
- Arg: TPasArgument; out ArgResolved: TPasResolverResult;
- Expr: TPasExpr; out ExprResolved: TPasResolverResult;
- SetReferenceFlags: boolean);
- procedure ComputeArgumentExpr(const ArgResolved: TPasResolverResult;
- Access: TArgumentAccess; Expr: TPasExpr; out ExprResolved: TPasResolverResult;
- SetReferenceFlags: boolean);
- procedure ComputeArrayParams(Params: TParamsExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeArrayParams_Class(Params: TParamsExpr;
- var ResolvedEl: TPasResolverResult; ClassOrRecScope: TPasClassOrRecordScope;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement); virtual;
- procedure ComputeFuncParams(Params: TParamsExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeTypeCast(ToLoType, ToHiType: TPasType;
- Param: TPasExpr; const ParamResolved: TPasResolverResult;
- out ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags); virtual;
- procedure ComputeSetParams(Params: TParamsExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeDereference(El: TUnaryExpr; var ResolvedEl: TPasResolverResult);
- procedure ComputeArrayValuesExpectedType(El: TArrayValues; out ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil);
- procedure ComputeRecordValues(El: TRecordValues; out ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil);
- procedure CheckIsClass(El: TPasElement; const ResolvedEl: TPasResolverResult);
- function CheckTypeCastClassInstanceToClass(
- const FromClassRes, ToClassRes: TPasResolverResult;
- ErrorEl: TPasElement): integer; virtual; // type cast not related classes
- procedure CheckSetLitElCompatible(Left, Right: TPasExpr;
- const LHS, RHS: TPasResolverResult);
- function CheckIsOrdinal(const ResolvedEl: TPasResolverResult;
- ErrorEl: TPasElement; RaiseOnError: boolean): boolean;
- procedure CombineArrayLitElTypes(Left, Right: TPasExpr;
- var LHS: TPasResolverResult; const RHS: TPasResolverResult);
- procedure ConvertRangeToElement(var ResolvedEl: TPasResolverResult);
- function IsCharLiteral(const Value: string; ErrorPos: TPasElement): TResolverBaseType; virtual;
- function CheckForIn(Loop: TPasImplForLoop;
- const VarResolved, InResolved: TPasResolverResult): boolean; virtual;
- function CheckForInClassOrRec(Loop: TPasImplForLoop;
- const VarResolved, InResolved: TPasResolverResult): boolean; virtual;
- function CheckBuiltInMinParamCount(Proc: TResElDataBuiltInProc; Expr: TPasExpr;
- MinCount: integer; RaiseOnError: boolean): boolean;
- function CheckBuiltInMaxParamCount(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
- MaxCount: integer; RaiseOnError: boolean; Signature: string = ''): integer;
- function CheckRaiseTypeArgNo(id: TMaxPrecInt; ArgNo: integer; Param: TPasExpr;
- const ParamResolved: TPasResolverResult; Expected: string; RaiseOnError: boolean): integer;
- function FindUsedUnitnameInSection(const aName: string; Section: TPasSection): TPasModule;
- function FindUsedUnitname(const aName: string; aMod: TPasModule): TPasModule;
- procedure FinishAssertCall(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function FindSystemIdentifier(const aUnitName, aName: string;
- ErrorEl: TPasElement): TPasElement; virtual;
- function FindSystemClassType(const aUnitName, aClassName: string;
- ErrorEl: TPasElement): TPasClassType; virtual;
- function FindSystemClassTypeAndConstructor(const aUnitName, aClassName: string;
- out aClass: TPasClassType; out aConstructor: TPasConstructor;
- ErrorEl: TPasElement): boolean; virtual;
- procedure FindAssertExceptionConstructors(ErrorEl: TPasElement); virtual;
- procedure FindRangeErrorConstructors(ErrorEl: TPasElement); virtual;
- function FindTVarRec(ErrorEl: TPasElement): TPasRecordType; virtual;
- function GetTVarRec(El: TPasArrayType): TPasRecordType; virtual;
- function FindDefaultConstructor(aClass: TPasClassType): TPasConstructor; virtual;
- function GetTypeInfoParamType(Param: TPasExpr;
- out ParamResolved: TPasResolverResult; LoType: boolean): TPasType; virtual; // returns type of param in typeinfo(param)
- protected
- // constant evaluation
- fExprEvaluator: TResExprEvaluator;
- procedure OnExprEvalLog(Sender: TResExprEvaluator; const id: TMaxPrecInt;
- MsgType: TMessageType; MsgNumber: integer; const Fmt: String;
- Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif}; PosEl: TPasElement); virtual;
- function OnExprEvalIdentifier(Sender: TResExprEvaluator;
- Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
- function OnExprEvalParams(Sender: TResExprEvaluator;
- Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
- procedure OnRangeCheckEl(Sender: TResExprEvaluator; El: TPasElement;
- var MsgType: TMessageType); virtual;
- function EvalBaseTypeCast(Params: TParamsExpr; bt: TResolverBaseType): TResEvalvalue;
- protected
- // generic/specialize
- type
- TScopeStashState = record
- ScopeCount: integer;
- StashCount: integer;
- end;
- procedure AddGenericTemplateIdentifiers(GenericTemplateTypes: TFPList;
- Scope: TPasIdentifierScope);
- procedure AddSpecializedTemplateIdentifiers(GenericTemplateTypes: TFPList;
- SpecializedItem: TPRSpecializedItem; Scope: TPasIdentifierScope;
- CheckConstraints: boolean);
- function CreateInferenceTypesForCall(Params: TParamsExpr;
- TargetProc: TPasProcedure): TFPList;
- function CheckGenericConstraintFitsParam(ParamType: TPasType;
- SpecializedItem: TPRSpecializedItem; // set to specialize constraints
- TemplType: TPasGenericTemplateType; ConEl: TPasElement;
- Operation: TPRTemplateCompOp;
- ErrorPos: TPasElement // can be nil to get a compatibility Result
- ): integer;
- function CheckTemplateFitsParam(ParamType: TPasType;
- GenTempl: TPasGenericTemplateType;
- SpecializedItem: TPRSpecializedItem; // set to specialize constraints
- Operation: TPRTemplateCompOp;
- ErrorPos: TPasElement // can be nil to get a compatibility Result
- ): integer;
- function CheckTemplateFitsParamRes(GenTempl: TPasGenericTemplateType;
- const ResolvedEl: TPasResolverResult;
- Operation: TPRTemplateCompOp;
- ErrorPos: TPasElement // can be nil to get a compatibility Result
- ): integer;
- procedure CheckTemplateFitsTemplate(ParamTemplType,
- GenTempl: TPasGenericTemplateType; ErrorPos: TPasElement);
- function CreateSpecializedItem(El: TPasElement; GenericEl: TPasElement;
- const ParamsResolved: TPasTypeArray): TPRSpecializedItem; virtual;
- function CreateSpecializedTypeName(Item: TPRSpecializedItem): string; virtual;
- procedure InitSpecializeScopes(El: TPasElement; out State: TScopeStashState); virtual;
- procedure RestoreSpecializeScopes(const State: TScopeStashState); virtual;
- procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem); virtual;
- procedure SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem); virtual;
- procedure SpecializeMembers(GenMembersType, SpecMembersType: TPasMembersType); virtual;
- procedure SpecializeMembersImpl(GenericType, SpecType: TPasMembersType;
- SpecializedItem: TPRSpecializedTypeItem); virtual;
- procedure SpecializeGenImplProc(GenDeclProc, SpecDeclProc: TPasProcedure;
- SpecializedItem: TPRSpecializedItem); virtual;
- procedure SpecializeElement(GenEl, SpecEl: TPasElement);
- procedure SpecializePasElementProperties(GenEl, SpecEl: TPasElement);
- procedure SpecializeVariable(GenEl, SpecEl: TPasVariable; Finish: boolean);
- procedure SpecializeConst(GenEl, SpecEl: TPasConst);
- procedure SpecializeProperty(GenEl, SpecEl: TPasProperty);
- function SpecializeTypeRef(GenEl, SpecEl: TPasElement; GenTypeRef: TPasType): TPasType;
- procedure SpecializeElType(GenEl, SpecEl: TPasElement;
- GenElType: TPasType; var SpecElType: TPasType);
- procedure SpecializeElExpr(GenEl, SpecEl: TPasElement;
- GenElExpr: TPasExpr; var SpecElExpr: TPasExpr);
- procedure SpecializeElImplEl(GenEl, SpecEl: TPasElement;
- GenImplEl: TPasImplElement; var SpecImplEl: TPasImplElement);
- procedure SpecializeElImplAlias(GenEl, SpecEl: TPasImplBlock;
- GenImplAlias: TPasImplElement; var SpecImplAlias: TPasImplElement
- {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
- procedure SpecializeElList(GenEl, SpecEl: TPasElement;
- GenList, SpecList: TFPList; AllowReferences: boolean
- {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
- procedure SpecializeElArray(GenEl, SpecEl: TPasElement;
- GenList: TPasElementArray; var SpecList: TPasElementArray; AllowReferences: boolean
- {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
- procedure SpecializeProcedure(GenEl, SpecEl: TPasProcedure; SpecializedItem: TPRSpecializedItem); virtual;
- procedure SpecializeOperator(GenEl, SpecEl: TPasOperator);
- procedure SpecializeProcedureType(GenEl, SpecEl: TPasProcedureType; SpecializedItem: TPRSpecializedItem);
- procedure SpecializeProcedureBody(GenEl, SpecEl: TProcedureBody);
- procedure SpecializeDeclarations(GenEl, SpecEl: TPasDeclarations);
- procedure SpecializeSpecializeType(GenEl, SpecEl: TPasSpecializeType);
- procedure SpecializeGenericTemplateType(GenEl, SpecEl: TPasGenericTemplateType);
- procedure SpecializeArgument(GenEl, SpecEl: TPasArgument);
- procedure SpecializeImplBlock(GenEl, SpecEl: TPasImplBlock);
- procedure SpecializeImplAsmStatement(GenEl, SpecEl: TPasImplAsmStatement);
- procedure SpecializeImplRepeatUntil(GenEl, SpecEl: TPasImplRepeatUntil);
- procedure SpecializeImplIfElse(GenEl, SpecEl: TPasImplIfElse);
- procedure SpecializeImplWhileDo(GenEl, SpecEl: TPasImplWhileDo);
- procedure SpecializeImplWithDo(GenEl, SpecEl: TPasImplWithDo);
- procedure SpecializeImplCaseOf(GenEl, SpecEl: TPasImplCaseOf);
- procedure SpecializeImplCaseStatement(GenEl, SpecEl: TPasImplCaseStatement);
- procedure SpecializeImplAssign(GenEl, SpecEl: TPasImplAssign);
- procedure SpecializeImplSimple(GenEl, SpecEl: TPasImplSimple);
- procedure SpecializeImplForLoop(GenEl, SpecEl: TPasImplForLoop);
- procedure SpecializeImplTry(GenEl, SpecEl: TPasImplTry);
- procedure SpecializeImplExceptOn(GenEl, SpecEl: TPasImplExceptOn);
- procedure SpecializeImplRaise(GenEl, SpecEl: TPasImplRaise);
- procedure SpecializeExpr(GenEl, SpecEl: TPasExpr);
- procedure SpecializeExprArray(GenEl, SpecEl: TPasElement;
- GenArray: TPasExprArray; var SpecArray: TPasExprArray);
- procedure SpecializePrimitiveExpr(GenEl, SpecEl: TPrimitiveExpr);
- procedure SpecializeUnaryExpr(GenEl, SpecEl: TUnaryExpr);
- procedure SpecializeBinaryExpr(GenEl, SpecEl: TBinaryExpr);
- procedure SpecializeBoolConstExpr(GenEl, SpecEl: TBoolConstExpr);
- procedure SpecializeParamsExpr(GenEl, SpecEl: TParamsExpr);
- procedure SpecializeRecordValues(GenEl, SpecEl: TRecordValues);
- procedure SpecializeArrayValues(GenEl, SpecEl: TArrayValues);
- procedure SpecializeInlineSpecializeExpr(GenEl, SpecEl: TInlineSpecializeExpr);
- procedure SpecializeProcedureExpr(GenEl, SpecEl: TProcedureExpr);
- procedure SpecializeResString(GenEl, SpecEl: TPasResString);
- procedure SpecializeAliasType(GenEl, SpecEl: TPasAliasType);
- procedure SpecializePointerType(GenEl, SpecEl: TPasPointerType);
- procedure SpecializeRangeType(GenEl, SpecEl: TPasRangeType);
- procedure SpecializeArrayType(GenEl, SpecEl: TPasArrayType; SpecializedItem: TPRSpecializedTypeItem);
- procedure SpecializeRecordType(GenEl, SpecEl: TPasRecordType; SpecializedItem: TPRSpecializedTypeItem);
- procedure SpecializeClassType(GenEl, SpecEl: TPasClassType; SpecializedItem: TPRSpecializedTypeItem);
- procedure SpecializeEnumValue(GenEl, SpecEl: TPasEnumValue);
- procedure SpecializeEnumType(GenEl, SpecEl: TPasEnumType);
- procedure SpecializeSetType(GenEl, SpecEl: TPasSetType);
- procedure SpecializeVariant(GenEl, SpecEl: TPasVariant);
- procedure SpecializeStringType(GenEl, SpecEl: TPasStringType);
- procedure SpecializeAttributes(GenEl, SpecEl: TPasAttributes);
- procedure SpecializeMethodResolution(GenEl, SpecEl: TPasMethodResolution);
- protected
- // custom types (added by descendant resolvers)
- function CheckAssignCompatibilityCustom(
- const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean; var Handled: boolean): integer; virtual;
- function CheckEqualCompatibilityCustomType(
- const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): integer; virtual;
- protected
- // built-in functions
- function BI_Length_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Length_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_Length_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_SetLength_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_SetLength_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_InExclude_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_InExclude_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_Break_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- function BI_Continue_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- function BI_Exit_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- function BI_IncDec_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_IncDec_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_Assigned_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Assigned_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_Assigned_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_Chr_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Chr_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_Chr_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_Ord_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Ord_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_Ord_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_LowHigh_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_LowHigh_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_LowHigh_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_PredSucc_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_PredSucc_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_PredSucc_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_Str_CheckParam(IsFunc: boolean; Param: TPasExpr;
- const ParamResolved: TPasResolverResult; ArgNo: integer;
- RaiseOnError: boolean): integer;
- function BI_StrProc_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_StrProc_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_StrFunc_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_StrFunc_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_StrFunc_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_WriteStrProc_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_WriteStrProc_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_Val_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Val_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_LoHi_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_LoHi_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_LoHi_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_ConcatArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_ConcatArray_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- function BI_ConcatString_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_ConcatString_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_ConcatString_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_CopyArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_CopyArray_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- function BI_InsertArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_InsertArray_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_DeleteArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_DeleteArray_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_TypeInfo_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- function BI_GetTypeKind_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_GetTypeKind_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_GetTypeKind_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- function BI_Assert_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Assert_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_New_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_New_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_Dispose_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Dispose_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function BI_Default_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Default_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_Default_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue); virtual;
- public
- constructor Create;
- destructor Destroy; override;
- procedure Clear; virtual; // does not free built-in identifiers
- // overrides of TPasTreeContainer
- function CreateElement(AClass: TPTreeElement; const AName: String;
- AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
- overload; override;
- function CreateElement(AClass: TPTreeElement; const AName: String;
- AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASrcPos: TPasSourcePos; TypeParams: TFPList = nil): TPasElement;
- overload; override;
- function FindModule(const AName: String; NameExpr, InFileExpr: TPasExpr): TPasModule; override;
- function FindUnit(const AName, InFilename: String;
- NameExpr, InFileExpr: TPasExpr): TPasModule; virtual; abstract;
- function FindElement(const aName: String): TPasElement; override; // used by TPasParser
- function FindElementFor(const aName: String; AParent: TPasElement; TypeParamCount: integer): TPasElement; override; // used by TPasParser
- function FindElementWithoutParams(const AName: String; ErrorPosEl: TPasElement;
- NoProcsWithArgs, NoGenerics: boolean): TPasElement;
- function FindElementWithoutParams(const AName: String; out Data: TPRFindData;
- ErrorPosEl: TPasElement; NoProcsWithArgs, NoGenerics: boolean): TPasElement;
- function FindFirstEl(const AName: String; out Data: TPRFindData;
- ErrorPosEl: TPasElement): TPasElement;
- procedure FindLongestUnitName(var El: TPasElement; Expr: TPasExpr);
- function FindGenericEl(const AName: string; TemplateCount: integer;
- out Find: TPRFindData; ErrorPosEl: TPasElement): TPasElement; virtual;
- procedure IterateElements(const aName: string;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); virtual;
- procedure CheckFoundElement(const FindData: TPRFindData;
- Ref: TResolvedReference); virtual;
- procedure CheckFoundElementVisibility(const FindData: TPRFindData;
- Ref: TResolvedReference); virtual;
- function GetVisibilityContext: TPasElement;
- procedure BeginScope(ScopeType: TPasScopeType; El: TPasElement); override;
- procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override;
- procedure FinishTypeAlias(var NewType: TPasType); override;
- function IsUnitIntfFinished(AModule: TPasModule): boolean;
- procedure NotifyPendingUsedInterfaces; virtual;
- function GetPendingUsedInterface(Section: TPasSection): TPasUsesUnit;
- function CheckPendingUsedInterface(Section: TPasSection): boolean; override;
- procedure UsedInterfacesFinished(Section: TPasSection); virtual;
- function NeedArrayValues(El: TPasElement): boolean; override;
- function GetDefaultClassVisibility(AClass: TPasClassType
- ): TPasMemberVisibility; override;
- procedure ModeChanged(Sender: TObject; NewMode: TModeSwitch;
- Before: boolean; var Handled: boolean); override;
- // built in types and functions
- procedure ClearBuiltInIdentifiers; virtual;
- procedure AddObjFPCBuiltInIdentifiers(
- const TheBaseTypes: TResolveBaseTypes = btAllFPCTypes;
- const TheBaseProcs: TResolverBuiltInProcs = bfAllStandardProcs); virtual;
- function AddBaseType(const aName: string; Typ: TResolverBaseType): TResElDataBaseType;
- function AddCustomBaseType(const aName: string; aClass: TResElDataBaseTypeClass): TPasUnresolvedSymbolRef;
- function IsBaseType(aType: TPasType; BaseType: TResolverBaseType; ResolveAlias: boolean = false): boolean;
- function AddBuiltInProc(const aName: string; Signature: string;
- const GetCallCompatibility: TOnGetCallCompatibility;
- const GetCallResult: TOnGetCallResult;
- const EvalConst: TOnEvalBIFunction = nil;
- const FinishParamsExpr: TOnFinishParamsExpr = nil;
- const BuiltIn: TResolverBuiltInProc = bfCustom;
- const Flags: TBuiltInProcFlags = []): TResElDataBuiltInProc;
- // add extra TResolveData (E.CustomData) to free list
- procedure AddResolveData(El: TPasElement; Data: TResolveData;
- Kind: TResolveDataListKind);
- function CreateReference(DeclEl, RefEl: TPasElement;
- Access: TResolvedRefAccess;
- FindData: PPRFindData = nil): TResolvedReference; virtual;
- // scopes
- function GetLocalScope: TPasScope; inline;
- function GetParentLocalScope: TPasScope; inline;
- function CreateScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; virtual;
- function CreateGroupScope(HiType: TPasType; WithTopHelpers: boolean = true): TPasGroupScope; virtual;
- procedure GroupScope_AddTypeAndAncestors(Scope: TPasGroupScope; HiType: TPasType; WithTopHelpers: boolean = true);
- procedure PopScope;
- procedure PopWithScope(El: TPasImplWithDo);
- procedure PopGenericParamScope(El: TPasGenericType); virtual;
- procedure PushScope(Scope: TPasScope); overload;
- function PushScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; overload;
- function PushGroupScope(HiType: TPasType): TPasGroupScope;
- function PushModuleDotScope(aModule: TPasModule): TPasModuleDotScope;
- function PushClassDotScope(var CurClassType: TPasClassType; WithTopHelpers: boolean = true): TPasDotClassScope;
- function PushRecordDotScope(CurRecordType: TPasRecordType): TPasDotClassOrRecordScope;
- function PushInheritedScope(ClassOrRec: TPasMembersType;
- WithTopHelpers: boolean; AncestorScope: TPasClassScope): TPasInheritedScope;
- function PushEnumDotScope(HiType: TPasType; EnumLoType: TPasEnumType): TPasDotEnumTypeScope;
- function PushHelperDotScope(HiType: TPasType): TPasDotBaseScope;
- function PushTemplateDotScope(TemplType: TPasGenericTemplateType; ErrorEl: TPasElement): TPasDotBaseScope;
- function PushDotScope(HiType: TPasType): TPasDotBaseScope;
- function PushWithExprScope(Expr: TPasExpr): TPasWithExprScope;
- function StashScopes(NewScopeCnt: integer): integer; // returns old StashDepth
- function StashSubExprScopes: integer; // returns old StashDepth
- procedure RestoreStashedScopes(StashDepth: integer);
- procedure DeleteScope(Index: integer); virtual;
- procedure InsertScope(Scope: TPasScope; Index: integer); virtual;
- function GetCurrentProcScope(ErrorEl: TPasElement): TPasProcedureScope;
- function GetProcScope(El: TPasElement): TPasProcedureScope;
- function GetCurrentSelfScope(ErrorEl: TPasElement): TPasProcedureScope;
- function GetSelfScope(El: TPasElement): TPasProcedureScope;
- procedure AddHelper(Helper: TPasClassType; var List: TPRHelperEntryArray);
- procedure AddActiveHelper(Helper: TPasClassType); virtual;
- // log and messages
- class function MangleSourceLineNumber(Line, Column: integer): integer;
- class procedure UnmangleSourceLineNumber(LineNumber: integer;
- out Line, Column: integer);
- class function GetDbgSourcePosStr(El: TPasElement): string;
- function GetElementSourcePosStr(El: TPasElement): string;
- procedure SetLastMsg(const id: TMaxPrecInt; MsgType: TMessageType; MsgNumber: integer;
- Const Fmt : String; Args : Array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- PosEl: TPasElement);
- procedure LogMsg(const id: TMaxPrecInt; MsgType: TMessageType; MsgNumber: integer;
- const Fmt: String; Args: Array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- PosEl: TPasElement); overload;
- class function GetWarnIdentifierNumbers(Identifier: string;
- out MsgNumbers: TIntegerDynArray): boolean; virtual;
- procedure GetIncompatibleTypeDesc(const GotType, ExpType: TPasResolverResult;
- out GotDesc, ExpDesc: String); overload;
- procedure GetIncompatibleTypeDesc(const GotType, ExpType: TPasType;
- out GotDesc, ExpDesc: String); overload;
- procedure GetIncompatibleProcParamsDesc(GotType, ExpType: TPasProcedureType;
- out GotDesc, ExpDesc: string);
- procedure RaiseMsg(const Id: TMaxPrecInt; MsgNumber: integer; const Fmt: String;
- Args: Array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- ErrorPosEl: TPasElement); virtual;
- procedure RaiseNotYetImplemented(id: TMaxPrecInt; El: TPasElement; Msg: string = ''); virtual;
- procedure RaiseInternalError(id: TMaxPrecInt; const Msg: string = '');
- procedure RaiseInvalidScopeForElement(id: TMaxPrecInt; El: TPasElement; const Msg: string = '');
- procedure RaiseIdentifierNotFound(id: TMaxPrecInt; Identifier: string; El: TPasElement);
- procedure RaiseXExpectedButYFound(id: TMaxPrecInt; const X,Y: string; El: TPasElement);
- procedure RaiseXExpectedButTypeYFound(id: TMaxPrecInt; const X: string; Y: TPasType; El: TPasElement);
- procedure RaiseContextXExpectedButYFound(id: TMaxPrecInt; const C,X,Y: string; El: TPasElement);
- procedure RaiseContextXInvalidY(id: TMaxPrecInt; const X,Y: string; El: TPasElement);
- procedure RaiseConstantExprExp(id: TMaxPrecInt; ErrorEl: TPasElement);
- procedure RaiseVarExpected(id: TMaxPrecInt; ErrorEl: TPasElement; IdentEl: TPasElement);
- procedure RaiseRangeCheck(id: TMaxPrecInt; ErrorEl: TPasElement);
- procedure RaiseIncompatibleTypeDesc(id: TMaxPrecInt; MsgNumber: integer;
- const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- const GotDesc, ExpDesc: String; ErrorEl: TPasElement);
- procedure RaiseIncompatibleType(id: TMaxPrecInt; MsgNumber: integer;
- const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- GotType, ExpType: TPasType; ErrorEl: TPasElement);
- procedure RaiseIncompatibleTypeRes(id: TMaxPrecInt; MsgNumber: integer;
- const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- const GotType, ExpType: TPasResolverResult;
- ErrorEl: TPasElement);
- procedure RaiseHelpersCannotBeUsedAsType(id: TMaxPrecInt; ErrorEl: TPasElement);
- procedure RaiseInvalidProcTypeModifier(id: TMaxPrecInt; ProcType: TPasProcedureType;
- ptm: TProcTypeModifier; ErrorEl: TPasElement);
- procedure RaiseInvalidProcModifier(id: TMaxPrecInt; Proc: TPasProcedure;
- pm: TProcedureModifier; ErrorEl: TPasElement);
- procedure WriteScopes;
- procedure WriteScopesShort(Title: string);
- // find value and type of an element
- procedure ComputeElement(El: TPasElement; out ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil);
- procedure ComputeResultElement(El: TPasResultElement; out ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil); virtual;
- function Eval(Expr: TPasExpr; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue; overload;
- function Eval(const Value: TPasResolverResult; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue; overload;
- // checking compatibilility
- function IsSameType(TypeA, TypeB: TPasType; ResolveAlias: TPRResolveAlias): boolean; // check if it is exactly the same
- function HasExactType(const ResolvedEl: TPasResolverResult): boolean; // false if HiTypeEl was guessed, e.g. 1 guessed a btLongint
- function IndexOfGenericParam(Params: TPasExprArray): integer;
- procedure CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
- ErrorEl: TPasElement);
- function CheckCallProcCompatibility(ProcType: TPasProcedureType;
- Params: TParamsExpr; RaiseOnError: boolean; SetReferenceFlags: boolean = false): integer;
- function CheckCallPropertyCompatibility(PropEl: TPasProperty;
- Params: TParamsExpr; RaiseOnError: boolean): integer;
- function CheckCallArrayCompatibility(ArrayEl: TPasArrayType;
- Params: TParamsExpr; RaiseOnError: boolean; EmitHints: boolean = false): integer;
- function CheckParamCompatibility(Expr: TPasExpr; Param: TPasArgument;
- ParamNo: integer; RaiseOnError: boolean; SetReferenceFlags: boolean = false): integer;
- function CheckParamResCompatibility(Expr: TPasExpr; const ExprResolved,
- ParamResolved: TPasResolverResult; ParamNo: integer; RaiseOnError: boolean;
- SetReferenceFlags: boolean): integer;
- function CheckAssignCompatibilityUserType(
- const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): integer;
- function CheckAssignCompatibilityArrayType(
- const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): integer;
- function CheckAssignCompatibilityPointerType(LTypeEl, RTypeEl: TPasType;
- ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer;
- function CheckEqualCompatibilityUserType(
- const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): integer; virtual; // LHS.BaseType=btContext=RHS.BaseType and both rrfReadable
- function CheckTypeCast(El: TPasType; Params: TParamsExpr; RaiseOnError: boolean): integer;
- function CheckTypeCastRes(const FromResolved, ToResolved: TPasResolverResult;
- ErrorEl: TPasElement; RaiseOnError: boolean): integer; virtual;
- function CheckTypeCastArray(FromType, ToType: TPasArrayType;
- ErrorEl: TPasElement; RaiseOnError: boolean): integer;
- function CheckSrcIsADstType(
- const ResolvedSrcType, ResolvedDestType: TPasResolverResult): integer;
- function CheckClassIsClass(SrcType, DestType: TPasType): integer; virtual;
- function CheckClassesAreRelated(TypeA, TypeB: TPasType): integer;
- function CheckAssignCompatibilityClasses(LType, RType: TPasClassType): integer; virtual; // not related classes
- function GetClassImplementsIntf(ClassEl, Intf: TPasClassType): TPasClassType;
- function CheckProcOverloadCompatibility(Proc1, Proc2: TPasProcedure): boolean;
- function CheckProcTypeCompatibility(Proc1, Proc2: TPasProcedureType;
- IsAssign: boolean; ErrorEl: TPasElement; RaiseOnIncompatible: boolean): boolean;
- function CheckProcArgCompatibility(Arg1, Arg2: TPasArgument): integer;
- function CheckElTypeCompatibility(Arg1, Arg2: TPasType;
- ResolveAlias: TPRResolveAlias): integer;
- function CheckCanBeLHS(const ResolvedEl: TPasResolverResult;
- ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean;
- function CheckAssignCompatibility(const LHS, RHS: TPasElement;
- RaiseOnIncompatible: boolean = true; ErrorEl: TPasElement = nil): integer;
- procedure CheckAssignExprRange(const LeftResolved: TPasResolverResult; RHS: TPasExpr);
- procedure CheckAssignExprRangeToCustom(const LeftResolved: TPasResolverResult;
- RValue: TResEvalValue; RHS: TPasExpr); virtual;
- function CheckAssignResCompatibility(const LHS, RHS: TPasResolverResult;
- ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer;
- function CheckEqualElCompatibility(Left, Right: TPasElement;
- ErrorEl: TPasElement; RaiseOnIncompatible: boolean;
- SetReferenceFlags: boolean = false): integer;
- function CheckEqualResCompatibility(const LHS, RHS: TPasResolverResult;
- LErrorEl: TPasElement; RaiseOnIncompatible: boolean;
- RErrorEl: TPasElement = nil): integer;
- function IsVariableConst(El, PosEl: TPasElement; RaiseIfConst: boolean): boolean; virtual;
- function ResolvedElCanBeVarParam(const ResolvedEl: TPasResolverResult;
- PosEl: TPasElement; RaiseIfConst: boolean = true): boolean;
- function ResolvedElIsClassOrRecordInstance(const ResolvedEl: TPasResolverResult): boolean;
- // utility functions
- function GetResolver(El: TPasElement): TPasResolver;
- function ElHasModeSwitch(El: TPasElement; ms: TModeSwitch): boolean;
- function GetElModeSwitches(El: TPasElement): TModeSwitches;
- function ElHasBoolSwitch(El: TPasElement; bs: TBoolSwitch): boolean;
- function GetElBoolSwitches(El: TPasElement): TBoolSwitches;
- function GetProcTypeDescription(ProcType: TPasProcedureType;
- Flags: TPRProcTypeDescFlags = [prptdUseName,prptdResolveSimpleAlias]): string;
- function GetResolverResultDescription(const T: TPasResolverResult; OnlyType: boolean = false): string;
- function GetTypeDescription(aType: TPasType; AddPath: boolean = false): string;
- function GetTypeDescription(const R: TPasResolverResult; AddPath: boolean = false): string; virtual;
- function GetBaseDescription(const R: TPasResolverResult; AddPath: boolean = false): string; virtual;
- function GetProcFirstImplEl(Proc: TPasProcedure): TPasImplElement;
- function GetProcTemplateTypes(Proc: TPasProcedure): TFPList; // list of TPasGenericTemplateType
- function GetProcName(Proc: TPasProcedure; WithTemplates: boolean = true): string;
- function GetPasPropertyAncestor(El: TPasProperty; WithRedeclarations: boolean = false): TPasProperty;
- function GetPasPropertyType(El: TPasProperty): TPasType;
- function GetPasPropertyArgs(El: TPasProperty): TFPList;
- function GetPasPropertyGetter(El: TPasProperty): TPasElement;
- function GetPasPropertySetter(El: TPasProperty): TPasElement;
- function GetPasPropertyIndex(El: TPasProperty): TPasExpr;
- function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
- function GetPasPropertyDefaultExpr(El: TPasProperty): TPasExpr;
- function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
- function GetPasClassForward(ClassEl: TPasClassType): TPasClassType;
- function GetParentProcBody(El: TPasElement): TProcedureBody;
- function ProcHasImplElements(Proc: TPasProcedure): boolean; virtual;
- function IndexOfImplementedInterface(ClassEl: TPasClassType; aType: TPasType): integer;
- function GetLoop(El: TPasElement): TPasImplElement;
- function ResolveAliasType(aType: TPasType; SkipTypeAlias: boolean = true): TPasType;
- function ResolveAliasTypeEl(El: TPasElement): TPasType; inline;
- function ExprIsAddrTarget(El: TPasExpr): boolean;
- function IsNameExpr(El: TPasExpr): boolean; inline; // TPrimitiveExpr with Kind=pekIdent
- function GetNameExprValue(El: TPasExpr): string; // TPrimitiveExpr with Kind=pekIdent
- function GetNextDottedExpr(El: TPasExpr): TPasExpr;
- function GetLeftMostExpr(El: TPasExpr): TPasExpr;
- function GetRightMostExpr(El: TPasExpr): TPasExpr;
- procedure GetParamsOfNameExpr(El: TPasExpr; out ParentParams: TPRParentParams);
- function GetInlineSpecOfNameExpr(El: TPasExpr): TInlineSpecializeExpr;
- function GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
- function GetPathStart(El: TPasExpr): TPasExpr;
- function GetPathEndIdent(El: TPasExpr; AllowCall: boolean): TPasExpr;
- function GetNewInstanceExpr(El: TPasExpr): TPasExpr;
- function ParentNeedsExprResult(El: TPasExpr): boolean;
- function GetReference_ConstructorType(Ref: TResolvedReference; Expr: TPasExpr): TPasResolverResult;
- function GetParamsValueRef(Params: TParamsExpr): TResolvedReference;
- function GetSetType(const ResolvedSet: TPasResolverResult): TPasSetType;
- function IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean = true): boolean;
- function IsOpenArray(TypeEl: TPasType): boolean;
- function IsDynOrOpenArray(TypeEl: TPasType): boolean;
- function IsArrayOfConst(TypeEl: TPasType): boolean;
- function GetArrayElType(ArrType: TPasArrayType): TPasType;
- function IsVarInit(Expr: TPasExpr): boolean;
- function IsEmptyArrayExpr(const ResolvedEl: TPasResolverResult): boolean;
- function IsClassMethod(El: TPasElement): boolean;
- function IsClassField(El: TPasElement): boolean;
- function GetFunctionType(El: TPasElement): TPasFunctionType;
- function MethodIsStatic(El: TPasProcedure): boolean; // does not check if El is a method
- function IsMethod(El: TPasProcedure): boolean;
- function IsMethod_SelfIsClass(El: TPasElement): boolean;
- function IsHelperMethod(El: TPasElement): boolean; virtual;
- function IsHelper(El: TPasElement): boolean;
- function IsExternalClass_Name(aClass: TPasClassType; const ExtName: string): boolean;
- function IsProcedureType(const ResolvedEl: TPasResolverResult; HasValue: boolean): boolean;
- function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
- function IsArrayExpr(Expr: TParamsExpr): TPasArrayType;
- function IsArrayOperatorAdd(Expr: TPasExpr): boolean;
- function IsTypeCast(Params: TParamsExpr): boolean;
- function IsGenericTemplType(const ResolvedEl: TPasResolverResult): boolean;
- function GetTypeParameterCount(aType: TPasGenericType): integer;
- function GetGenericConstraintKeyword(El: TPasElement): TToken;
- function GetGenericConstraintErrorEl(ConstraintEl, TemplType: TPasElement): TPasElement;
- function GetSpecializedEl(El: TPasElement; GenericEl: TPasElement;
- Params: TFPList): TPasElement; virtual;
- procedure FinishGenericClassOrRecIntf(Scope: TPasGenericScope); virtual;
- procedure FinishSpecializations(Scope: TPasGenericScope); virtual;
- procedure CheckPendingForwardProcs(El: TPasElement); virtual;
- function IsSpecialized(El: TPasGenericType): boolean; overload;
- function IsFullySpecialized(El: TPasGenericType): boolean; overload;
- function IsFullySpecialized(Proc: TPasProcedure): boolean; overload;
- function IsInterfaceType(const ResolvedEl: TPasResolverResult;
- IntfType: TPasClassInterfaceType): boolean; overload;
- function IsInterfaceType(TypeEl: TPasType; IntfType: TPasClassInterfaceType): boolean; overload;
- function IsTGUID(RecTypeEl: TPasRecordType): boolean; virtual;
- function IsTGUIDString(const ResolvedEl: TPasResolverResult): boolean; virtual;
- function IsCustomAttribute(El: TPasElement): boolean; virtual;
- function IsSystemUnit(El: TPasModule): boolean; virtual;
- function GetAttributeCallsEl(El: TPasElement): TPasExprArray; virtual;
- function GetAttributeCalls(Members: TFPList; Index: integer): TPasExprArray; virtual;
- function ProcNeedsParams(El: TPasProcedureType): boolean;
- function ProcHasSelf(El: TPasProcedure): boolean; // returns false for local procs
- procedure CreateProcSelfArg(Proc: TPasProcedure); virtual;
- function IsProcOverride(AncestorProc, DescendantProc: TPasProcedure): boolean;
- function GetTopLvlProc(El: TPasElement): TPasProcedure;
- function GetParentProc(El: TPasElement; GetDeclProc: boolean): TPasProcedure;
- function GetRangeLength(RangeExpr: TPasExpr): TMaxPrecInt;
- function EvalRangeLimit(RangeExpr: TPasExpr; Flags: TResEvalFlags;
- EvalLow: boolean; ErrorEl: TPasElement): TResEvalValue; virtual; // compute low() or high()
- function EvalTypeRange(Decl: TPasType; Flags: TResEvalFlags): TResEvalValue; virtual; // compute low() and high()
- function HasTypeInfo(El: TPasType): boolean; virtual;
- function GetActualBaseType(bt: TResolverBaseType): TResolverBaseType; virtual;
- function GetCombinedBoolean(Bool1, Bool2: TResolverBaseType; ErrorEl: TPasElement): TResolverBaseType; virtual;
- function GetCombinedInt(const Int1, Int2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
- procedure GetIntegerProps(bt: TResolverBaseType; out Precision: word; out Signed: boolean);
- function GetIntegerRange(bt: TResolverBaseType; out MinVal, MaxVal: TMaxPrecInt): boolean;
- function GetIntegerBaseType(Precision: word; Signed: boolean; ErrorEl: TPasElement): TResolverBaseType;
- function GetSmallestIntegerBaseType(MinVal, MaxVal: TMaxPrecInt): TResolverBaseType; // returns BaseTypeExtended if too big
- function GetCombinedChar(const Char1, Char2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
- function GetCombinedString(const Str1, Str2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
- function GetCombinedBaseType(const A, B: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
- function IsElementSkipped(El: TPasElement): boolean; virtual;
- function FindLocalBuiltInSymbol(El: TPasElement): TPasElement; virtual;
- function GetFirstSection(WithUnitImpl: boolean): TPasSection;
- function GetLastSection: TPasSection;
- function GetParentSection(El: TPasElement): TPasSection;
- function FindUsedUnitInSection(aMod: TPasModule; Section: TPasSection): TPasUsesUnit;
- function FirstSectionUsesUnit(aModule: TPasModule): boolean;
- function ImplementationUsesUnit(aModule: TPasModule; NotInIntf: boolean = true): boolean;
- function GetShiftAndMaskForLoHiFunc(BaseType: TResolverBaseType;
- isLoFunc: Boolean; out Mask: LongWord): Integer;
- public
- property Hub: TPasResolverHub read FHub write FHub;
- // options
- property Options: TPasResolverOptions read FOptions write FOptions;
- property AnonymousElTypePostfix: String read FAnonymousElTypePostfix
- write FAnonymousElTypePostfix; // default empty, if set, anonymous element types are named ArrayName+Postfix and added to declarations
- property BaseTypes[bt: TResolverBaseType]: TPasUnresolvedSymbolRef read GetBaseTypes;
- property BaseTypeNames[bt: TResolverBaseType]: string read GetBaseTypeNames;
- property BaseTypeChar: TResolverBaseType read FBaseTypeChar write FBaseTypeChar;
- property BaseTypeExtended: TResolverBaseType read FBaseTypeExtended write FBaseTypeExtended;
- property BaseTypeString: TResolverBaseType read FBaseTypeString write FBaseTypeString;
- property BaseTypeLength: TResolverBaseType read FBaseTypeLength write FBaseTypeLength;
- property BuiltInProcs[bp: TResolverBuiltInProc]: TResElDataBuiltInProc read GetBuiltInProcs;
- property ExprEvaluator: TResExprEvaluator read fExprEvaluator;
- property DynArrayMinIndex: TMaxPrecInt read FDynArrayMinIndex write FDynArrayMinIndex;
- property DynArrayMaxIndex: TMaxPrecInt read FDynArrayMaxIndex write FDynArrayMaxIndex;
- property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; {
- If true Line and Column is mangled together in TPasElement.SourceLineNumber.
- Use method UnmangleSourceLineNumber to extract. }
- // parsed values
- property DefaultNameSpace: String read FDefaultNameSpace;
- property RootElement: TPasModule read FRootElement write SetRootElement;
- property Step: TPasResolverStep read FStep;
- property ActiveHelpers: TPRHelperEntryArray read FActiveHelpers;
- property FinishedInterfaceIndex: integer read FFinishedInterfaceIndex;
- // scopes
- property Scopes[Index: integer]: TPasScope read GetScopes;
- property ScopeCount: integer read FScopeCount;
- property TopScope: TPasScope read FTopScope;
- property DefaultScope: TPasDefaultScope read FDefaultScope write FDefaultScope;
- property ScopeClass_Array: TPasArrayScopeClass read FScopeClass_Array write FScopeClass_Array;
- property ScopeClass_Class: TPasClassScopeClass read FScopeClass_Class write FScopeClass_Class;
- property ScopeClass_InitialFinalization: TPasInitialFinalizationScopeClass read FScopeClass_InitialFinalization write FScopeClass_InitialFinalization;
- property ScopeClass_Module: TPasModuleScopeClass read FScopeClass_Module write FScopeClass_Module;
- property ScopeClass_Procedure: TPasProcedureScopeClass read FScopeClass_Proc write FScopeClass_Proc;
- property ScopeClass_ProcType: TPasProcTypeScopeClass read FScopeClass_ProcType write FScopeClass_ProcType;
- property ScopeClass_Record: TPasRecordScopeClass read FScopeClass_Record write FScopeClass_Record;
- property ScopeClass_Section: TPasSectionScopeClass read FScopeClass_Section write FScopeClass_Section;
- property ScopeClass_WithExpr: TPasWithExprScopeClass read FScopeClass_WithExpr write FScopeClass_WithExpr;
- // last element
- property LastElement: TPasElement read FLastElement;
- property LastMsg: string read FLastMsg write FLastMsg;
- property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs;
- property LastMsgElement: TPasElement read FLastMsgElement write FLastMsgElement;
- property LastMsgId: TMaxPrecInt read FLastMsgId write FLastMsgId;
- property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber;
- property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern;
- property LastMsgType: TMessageType read FLastMsgType write FLastMsgType;
- property LastSourcePos: TPasSourcePos read FLastSourcePos write FLastSourcePos;
- end;
- function GetTreeDbg(El: TPasElement; Indent: integer = 0): string;
- function GetResolverResultDbg(const T: TPasResolverResult): string;
- function GetClassAncestorsDbg(El: TPasClassType): string;
- function ResolverResultFlagsToStr(const Flags: TPasResolverResultFlags): string;
- function GetElementTypeName(El: TPasElement): string; overload;
- function GetElementTypeName(C: TPasElementBaseClass): string; overload;
- function GetElementDbgPath(El: TPasElement): string; overload;
- function ResolveSimpleAliasType(aType: TPasType): TPasType;
- procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; IdentEl: TPasElement;
- LoTypeEl, HiTypeEl: TPasType; Flags: TPasResolverResultFlags); overload;
- procedure SetResolverTypeExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; LoTypeEl, HiTypeEl: TPasType;
- Flags: TPasResolverResultFlags); overload;
- procedure SetResolverValueExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; LoTypeEl, HiTypeEl: TPasType; ExprEl: TPasExpr;
- Flags: TPasResolverResultFlags); overload;
- function ProcNeedsImplProc(Proc: TPasProcedure): boolean;
- function ProcNeedsBody(Proc: TPasProcedure): boolean;
- function ProcHasGroupOverload(Proc: TPasProcedure): boolean;
- procedure ClearHelperList(var List: TPRHelperEntryArray);
- function ChompDottedIdentifier(const Identifier: string): string;
- function FirstDottedIdentifier(const Identifier: string): string; // without <>
- function LastDottedIdentifier(const Identifier: string): string; // without <>
- function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
- function GetFirstDotPos(const Identifier: string): integer;
- function GetLastDotPos(const Identifier: string): integer;
- {$IF FPC_FULLVERSION<30101}
- function IsValidIdent(const Ident: string; AllowDots: Boolean = False; StrictDots: Boolean = False): Boolean;
- {$ENDIF}
- function DotExprToName(Expr: TPasExpr): string;
- function NoNil(o: TObject): TObject;
- function dbgs(const Flags: TPasResolverComputeFlags): string; overload;
- function dbgs(const a: TResolvedRefAccess): string; overload;
- function dbgs(const Flags: TResolvedReferenceFlags): string; overload;
- function dbgs(const a: TPSRefAccess): string; overload;
- implementation
- function GetTreeDbg(El: TPasElement; Indent: integer): string;
- procedure LineBreak(SubIndent: integer);
- begin
- Inc(Indent,SubIndent);
- Result:=Result+LineEnding+StringOfChar(' ',Indent);
- end;
- var
- i, l: Integer;
- begin
- if El=nil then exit('nil');
- Result:=El.Name+':'+El.ClassName+'=';
- if El is TPasExpr then
- begin
- if El.ClassType<>TBinaryExpr then
- Result:=Result+OpcodeStrings[TPasExpr(El).OpCode];
- if El.ClassType=TUnaryExpr then
- Result:=Result+GetTreeDbg(TUnaryExpr(El).Operand,Indent)
- else if El.ClassType=TBinaryExpr then
- Result:=Result+'Left={'+GetTreeDbg(TBinaryExpr(El).left,Indent)+'}'
- +OpcodeStrings[TPasExpr(El).OpCode]
- +'Right={'+GetTreeDbg(TBinaryExpr(El).right,Indent)+'}'
- else if El.ClassType=TPrimitiveExpr then
- Result:=Result+TPrimitiveExpr(El).Value
- else if El.ClassType=TBoolConstExpr then
- Result:=Result+BoolToStr(TBoolConstExpr(El).Value,'true','false')
- else if El.ClassType=TNilExpr then
- Result:=Result+'nil'
- else if El.ClassType=TInheritedExpr then
- Result:=Result+'inherited'
- else if El.ClassType=TSelfExpr then
- Result:=Result+'Self'
- else if El.ClassType=TParamsExpr then
- begin
- LineBreak(2);
- Result:=Result+GetTreeDbg(TParamsExpr(El).Value,Indent)+'(';
- l:=length(TParamsExpr(El).Params);
- if l>0 then
- begin
- inc(Indent,2);
- for i:=0 to l-1 do
- begin
- LineBreak(0);
- Result:=Result+GetTreeDbg(TParamsExpr(El).Params[i],Indent);
- if i<l-1 then
- Result:=Result+','
- end;
- dec(Indent,2);
- end;
- Result:=Result+')';
- end
- else if El.ClassType=TRecordValues then
- begin
- Result:=Result+'(';
- l:=length(TRecordValues(El).Fields);
- if l>0 then
- begin
- inc(Indent,2);
- for i:=0 to l-1 do
- begin
- LineBreak(0);
- Result:=Result+TRecordValues(El).Fields[i].Name+':'
- +GetTreeDbg(TRecordValues(El).Fields[i].ValueExp,Indent);
- if i<l-1 then
- Result:=Result+','
- end;
- dec(Indent,2);
- end;
- Result:=Result+')';
- end
- else if El.ClassType=TArrayValues then
- begin
- Result:=Result+'[';
- l:=length(TArrayValues(El).Values);
- if l>0 then
- begin
- inc(Indent,2);
- for i:=0 to l-1 do
- begin
- LineBreak(0);
- Result:=Result+GetTreeDbg(TArrayValues(El).Values[i],Indent);
- if i<l-1 then
- Result:=Result+','
- end;
- dec(Indent,2);
- end;
- Result:=Result+']';
- end;
- end
- else if El is TPasProcedure then
- begin
- Result:=Result+GetTreeDbg(TPasProcedure(El).ProcType,Indent);
- end
- else if El is TPasProcedureType then
- begin
- if TPasProcedureType(El).IsReferenceTo then
- Result:=Result+' '+ProcTypeModifiers[ptmIsNested];
- Result:=Result+'(';
- l:=TPasProcedureType(El).Args.Count;
- if l>0 then
- begin
- inc(Indent,2);
- for i:=0 to l-1 do
- begin
- LineBreak(0);
- Result:=Result+GetTreeDbg(TPasArgument(TPasProcedureType(El).Args[i]),Indent);
- if i<l-1 then
- Result:=Result+';'
- end;
- dec(Indent,2);
- end;
- Result:=Result+')';
- if (El is TPasProcedure) and (TPasProcedure(El).ProcType is TPasFunctionType) then
- Result:=Result+':'+GetTreeDbg(TPasFunctionType(TPasProcedure(El).ProcType).ResultEl,Indent);
- if TPasProcedureType(El).IsOfObject then
- Result:=Result+' '+ProcTypeModifiers[ptmOfObject];
- if TPasProcedureType(El).IsNested then
- Result:=Result+' '+ProcTypeModifiers[ptmIsNested];
- if cCallingConventions[TPasProcedureType(El).CallingConvention]<>'' then
- Result:=Result+'; '+cCallingConventions[TPasProcedureType(El).CallingConvention];
- end
- else if El.ClassType=TPasResultElement then
- Result:=Result+GetTreeDbg(TPasResultElement(El).ResultType,Indent)
- else if El.ClassType=TPasArgument then
- begin
- if AccessNames[TPasArgument(El).Access]<>'' then
- Result:=Result+AccessNames[TPasArgument(El).Access];
- if TPasArgument(El).ArgType=nil then
- Result:=Result+'untyped'
- else
- Result:=Result+GetTreeDbg(TPasArgument(El).ArgType,Indent);
- end
- else if El.ClassType=TPasUnresolvedSymbolRef then
- begin
- if El.CustomData is TResElDataBuiltInProc then
- Result:=Result+TResElDataBuiltInProc(TPasUnresolvedSymbolRef(El).CustomData).Signature;
- end;
- end;
- function GetResolverResultDbg(const T: TPasResolverResult): string;
- var
- HiTypeEl: TPasType;
- begin
- Result:='[bt='+ResBaseTypeNames[T.BaseType];
- if T.SubType<>btNone then
- Result:=Result+' Sub='+ResBaseTypeNames[T.SubType];
- Result:=Result
- +' Ident='+GetObjName(T.IdentEl);
- HiTypeEl:=ResolveSimpleAliasType(T.HiTypeEl);
- if HiTypeEl<>T.LoTypeEl then
- Result:=Result+' LoType='+GetObjName(T.LoTypeEl)+' HiTypeEl='+GetObjName(HiTypeEl)
- else
- Result:=Result+' Type='+GetObjName(T.LoTypeEl);
- Result:=Result
- +' Expr='+GetObjName(T.ExprEl)
- +' Flags='+ResolverResultFlagsToStr(T.Flags)
- +']';
- end;
- function GetClassAncestorsDbg(El: TPasClassType): string;
- function GetClassDesc(C: TPasClassType): string;
- var
- Module: TPasModule;
- begin
- if C.IsExternal then
- Result:='class external '
- else
- Result:='class ';
- Module:=C.GetModule;
- if Module<>nil then
- Result:=Result+Module.Name+'.';
- Result:=Result+GetElementDbgPath(C);
- end;
- var
- Scope, AncestorScope: TPasClassScope;
- AncestorEl: TPasClassType;
- begin
- if El=nil then exit('nil');
- Result:=GetClassDesc(El);
- if El.CustomData is TPasClassScope then
- begin
- Scope:=TPasClassScope(El.CustomData);
- AncestorScope:=Scope.AncestorScope;
- while AncestorScope<>nil do
- begin
- Result:=Result+LineEnding+' ';
- AncestorEl:=NoNil(AncestorScope.Element) as TPasClassType;
- Result:=Result+GetClassDesc(AncestorEl);
- AncestorScope:=AncestorScope.AncestorScope;
- end;
- end;
- end;
- function ResolverResultFlagsToStr(const Flags: TPasResolverResultFlags): string;
- var
- f: TPasResolverResultFlag;
- s: string;
- begin
- Result:='';
- for f in Flags do
- begin
- if Result<>'' then Result:=Result+',';
- str(f,s);
- Result:=Result+s;
- end;
- Result:='['+Result+']';
- end;
- function GetElementTypeName(El: TPasElement): string;
- var
- C: TClass;
- begin
- if El=nil then
- exit('?');
- C:=El.ClassType;
- if C=TPrimitiveExpr then
- Result:=ExprKindNames[TPrimitiveExpr(El).Kind]
- else if C=TUnaryExpr then
- Result:='unary '+OpcodeStrings[TUnaryExpr(El).OpCode]
- else if C=TBinaryExpr then
- Result:=ExprKindNames[TBinaryExpr(El).Kind]
- else if C=TPasClassType then
- Result:=ObjKindNames[TPasClassType(El).ObjKind]
- else if C=TPasUnresolvedSymbolRef then
- Result:=El.Name
- else
- begin
- Result:=GetElementTypeName(TPasElementBaseClass(C));
- if Result='' then
- Result:=El.ElementTypeName;
- end;
- end;
- function GetElementTypeName(C: TPasElementBaseClass): string;
- begin
- if C=nil then
- exit('nil');
- if C=TPrimitiveExpr then
- Result:='primitive expression'
- else if C=TUnaryExpr then
- Result:='unary expression'
- else if C=TBinaryExpr then
- Result:='binary expression'
- else if C=TBoolConstExpr then
- Result:='boolean const'
- else if C=TNilExpr then
- Result:='nil'
- else if C=TPasAliasType then
- Result:='alias'
- else if C=TPasPointerType then
- Result:='pointer'
- else if C=TPasTypeAliasType then
- Result:='type alias'
- else if C=TPasClassOfType then
- Result:='class of'
- else if C=TPasSpecializeType then
- Result:='specialize'
- else if C=TInlineSpecializeExpr then
- Result:='inline-specialize'
- else if C=TPasRangeType then
- Result:='range'
- else if C=TPasArrayType then
- Result:='array'
- else if C=TPasFileType then
- Result:='file'
- else if C=TPasEnumValue then
- Result:='enum value'
- else if C=TPasEnumType then
- Result:='enum type'
- else if C=TPasSetType then
- Result:='set'
- else if C=TPasRecordType then
- Result:='record'
- else if C=TPasClassType then
- Result:='class'
- else if C=TPasArgument then
- Result:='parameter'
- else if C=TPasProcedureType then
- Result:='procedural type'
- else if C=TPasResultElement then
- Result:='function result'
- else if C=TPasFunctionType then
- Result:='functional type'
- else if C=TPasStringType then
- Result:='string[]'
- else if C=TPasVariable then
- Result:='var'
- else if C=TPasExportSymbol then
- Result:='export'
- else if C=TPasConst then
- Result:='const'
- else if C=TPasProperty then
- Result:='property'
- else if C=TPasProcedure then
- Result:='procedure'
- else if C=TPasFunction then
- Result:='function'
- else if C=TPasOperator then
- Result:='operator'
- else if C=TPasClassOperator then
- Result:='class operator'
- else if C=TPasConstructor then
- Result:='constructor'
- else if C=TPasClassConstructor then
- Result:='class constructor'
- else if C=TPasDestructor then
- Result:='destructor'
- else if C=TPasClassDestructor then
- Result:='class destructor'
- else if C=TPasClassProcedure then
- Result:='class procedure'
- else if C=TPasClassFunction then
- Result:='class function'
- else if C=TPasAnonymousProcedure then
- Result:='anonymous procedure'
- else if C=TPasAnonymousFunction then
- Result:='anonymous function'
- else if C=TPasMethodResolution then
- Result:='method resolution'
- else if C=TInterfaceSection then
- Result:='interfacesection'
- else if C=TImplementationSection then
- Result:='implementation'
- else if C=TProgramSection then
- Result:='program section'
- else if C=TLibrarySection then
- Result:='library section'
- else
- Result:=C.ClassName;
- end;
- function GetElementDbgPath(El: TPasElement): string;
- begin
- if El=nil then exit('nil');
- Result:='';
- while El<>nil do
- begin
- if Result<>'' then Result:='.'+Result;
- if El.Name<>'' then
- Result:=El.Name+Result
- else
- Result:=GetElementTypeName(El)+Result;
- El:=El.Parent;
- end;
- end;
- function ResolveSimpleAliasType(aType: TPasType): TPasType;
- var
- C: TClass;
- begin
- while aType<>nil do
- begin
- C:=aType.ClassType;
- if (C=TPasAliasType) then
- aType:=TPasAliasType(aType).DestType
- else if (C=TPasClassType) and TPasClassType(aType).IsForward
- and (aType.CustomData is TResolvedReference) then
- aType:=NoNil(TResolvedReference(aType.CustomData).Declaration) as TPasType
- else
- exit(aType);
- end;
- Result:=nil;
- end;
- procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; IdentEl: TPasElement; LoTypeEl,
- HiTypeEl: TPasType; Flags: TPasResolverResultFlags);
- begin
- if IdentEl is TPasExpr then
- raise Exception.Create('20170729101017');
- ResolvedType.BaseType:=BaseType;
- ResolvedType.SubType:=btNone;
- ResolvedType.IdentEl:=IdentEl;
- ResolvedType.HiTypeEl:=HiTypeEl;
- ResolvedType.LoTypeEl:=LoTypeEl;
- ResolvedType.ExprEl:=nil;
- ResolvedType.Flags:=Flags;
- end;
- procedure SetResolverTypeExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; LoTypeEl, HiTypeEl: TPasType;
- Flags: TPasResolverResultFlags);
- begin
- ResolvedType.BaseType:=BaseType;
- ResolvedType.SubType:=btNone;
- ResolvedType.IdentEl:=nil;
- ResolvedType.HiTypeEl:=HiTypeEl;
- ResolvedType.LoTypeEl:=LoTypeEl;
- ResolvedType.ExprEl:=nil;
- ResolvedType.Flags:=Flags;
- end;
- procedure SetResolverValueExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; LoTypeEl, HiTypeEl: TPasType; ExprEl: TPasExpr;
- Flags: TPasResolverResultFlags);
- begin
- ResolvedType.BaseType:=BaseType;
- ResolvedType.SubType:=btNone;
- ResolvedType.IdentEl:=nil;
- ResolvedType.HiTypeEl:=HiTypeEl;
- ResolvedType.LoTypeEl:=LoTypeEl;
- ResolvedType.ExprEl:=ExprEl;
- ResolvedType.Flags:=Flags;
- end;
- function ProcNeedsImplProc(Proc: TPasProcedure): boolean;
- begin
- Result:=true;
- if Proc.IsExternal then exit(false);
- if Proc.IsForward then exit;
- if Proc.Parent.ClassType=TInterfaceSection then exit;
- if Proc.Parent.ClassType=TPasClassType then
- begin
- // a method declaration
- if not Proc.IsAbstract then exit;
- end;
- Result:=false;
- end;
- function ProcNeedsBody(Proc: TPasProcedure): boolean;
- var
- C: TClass;
- begin
- if Proc.IsForward or Proc.IsExternal then exit(false);
- C:=Proc.Parent.ClassType;
- if (C=TInterfaceSection) or C.InheritsFrom(TPasClassType) then exit(false);
- Result:=true;
- end;
- function ProcHasGroupOverload(Proc: TPasProcedure): boolean;
- var
- Data: TObject;
- begin
- if Proc.IsOverload then
- exit(true);
- Data:=Proc.CustomData;
- Result:=(Data is TPasProcedureScope)
- and (ppsfIsGroupOverload in TPasProcedureScope(Data).Flags);
- end;
- procedure ClearHelperList(var List: TPRHelperEntryArray);
- var
- i: Integer;
- begin
- if length(List)=0 then exit;
- for i:=0 to length(List)-1 do
- TPRHelperEntry(List[i]).Free;
- List:=nil;
- end;
- function ChompDottedIdentifier(const Identifier: string): string;
- var
- p, Lvl: Integer;
- begin
- Result:=Identifier;
- p:=length(Identifier);
- Lvl:=0;
- while (p>0) do
- begin
- case Identifier[p] of
- '.': if Lvl=0 then break;
- '>': inc(Lvl);
- '<': dec(Lvl);
- end;
- dec(p);
- end;
- Result:=LeftStr(Identifier,p-1);
- end;
- function FirstDottedIdentifier(const Identifier: string): string;
- var
- p, l: SizeInt;
- begin
- p:=1;
- l:=length(Identifier);
- repeat
- if p>l then
- exit(Identifier)
- else if Identifier[p] in ['<','.'] then
- exit(LeftStr(Identifier,p-1))
- else
- inc(p);
- until false;
- end;
- function LastDottedIdentifier(const Identifier: string): string;
- var
- p, Lvl, EndP: Integer;
- begin
- p:=length(Identifier);
- EndP:=p;
- Lvl:=0;
- while (p>0) do
- begin
- case Identifier[p] of
- '.': if Lvl=0 then break;
- '>': inc(Lvl);
- '<':
- begin
- dec(Lvl);
- EndP:=p-1;
- end;
- end;
- dec(p);
- end;
- Result:=copy(Identifier,p+1,EndP-p);
- end;
- function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
- var
- l: Integer;
- begin
- l:=length(Prefix);
- if (l>length(Identifier))
- or (CompareText(Prefix,LeftStr(Identifier,l))<>0) then
- exit(false);
- Result:=(length(Identifier)=l) or (Identifier[l+1]='.');
- end;
- function GetFirstDotPos(const Identifier: string): integer;
- var
- l: SizeInt;
- Lvl: Integer;
- begin
- Result:=1;
- l:=length(Identifier);
- Lvl:=0;
- repeat
- if Result>l then
- exit(-1);
- case Identifier[Result] of
- '.': if Lvl=0 then exit;
- '<': inc(Lvl);
- '>': dec(Lvl);
- end;
- inc(Result);
- until false;
- end;
- function GetLastDotPos(const Identifier: string): integer;
- var
- Lvl: Integer;
- begin
- Result:=length(Identifier);
- Lvl:=0;
- while (Result>0) do
- begin
- case Identifier[Result] of
- '.': if Lvl=0 then exit;
- '>': inc(Lvl);
- '<': dec(Lvl);
- end;
- dec(Result);
- end;
- end;
- function DotExprToName(Expr: TPasExpr): string;
- var
- C: TClass;
- Prim: TPrimitiveExpr;
- Bin: TBinaryExpr;
- s: String;
- begin
- Result:='';
- if Expr=nil then exit;
- C:=Expr.ClassType;
- if C=TPrimitiveExpr then
- begin
- Prim:=TPrimitiveExpr(Expr);
- case Prim.Kind of
- pekIdent,pekString: Result:=Prim.Value;
- pekSelf: Result:='Self';
- else
- EPasResolve.Create('[20180309155400] DotExprToName '+GetObjName(Prim)+' '+ExprKindNames[Prim.Kind]);
- end;
- end
- else if C=TBinaryExpr then
- begin
- Bin:=TBinaryExpr(Expr);
- if Bin.OpCode=eopSubIdent then
- begin
- Result:=DotExprToName(Bin.left);
- if Result='' then exit;
- s:=DotExprToName(Bin.right);
- if s='' then exit('');
- Result:=Result+'.'+s;
- end;
- end;
- end;
- function NoNil(o: TObject): TObject;
- begin
- if o=nil then
- raise Exception.Create('');
- Result:=o;
- end;
- {$IF FPC_FULLVERSION<30101}
- function IsValidIdent(const Ident: string; AllowDots: Boolean;
- StrictDots: Boolean): Boolean;
- const
- Alpha = ['A'..'Z', 'a'..'z', '_'];
- AlphaNum = Alpha + ['0'..'9'];
- Dot = '.';
- var
- First: Boolean;
- I, Len: Integer;
- begin
- Len := Length(Ident);
- if Len < 1 then
- Exit(False);
- First := True;
- for I := 1 to Len do
- begin
- if First then
- begin
- Result := Ident[I] in Alpha;
- First := False;
- end
- else if AllowDots and (Ident[I] = Dot) then
- begin
- if StrictDots then
- begin
- Result := I < Len;
- First := True;
- end;
- end
- else
- Result := Ident[I] in AlphaNum;
- if not Result then
- Break;
- end;
- end;
- {$ENDIF}
- function dbgs(const Flags: TPasResolverComputeFlags): string;
- var
- s: string;
- f: TPasResolverComputeFlag;
- begin
- Result:='';
- for f in Flags do
- if f in Flags then
- begin
- if Result<>'' then Result:=Result+',';
- str(f,s);
- Result:=Result+s;
- end;
- Result:='['+Result+']';
- end;
- function dbgs(const a: TResolvedRefAccess): string;
- begin
- str(a,Result);
- end;
- function dbgs(const Flags: TResolvedReferenceFlags): string;
- var
- s: string;
- f: TResolvedReferenceFlag;
- begin
- Result:='';
- for f in Flags do
- if f in Flags then
- begin
- if Result<>'' then Result:=Result+',';
- str(f,s);
- Result:=Result+s;
- end;
- Result:='['+Result+']';
- end;
- function dbgs(const a: TPSRefAccess): string;
- begin
- str(a,Result);
- end;
- { TPasResolverHub }
- constructor TPasResolverHub.Create(TheOwner: TObject);
- begin
- FOwner:=TheOwner;
- end;
- procedure TPasResolverHub.Reset;
- begin
- FinishedInterfaceCount:=0;
- end;
- { TPRSpecializedItem }
- destructor TPRSpecializedItem.Destroy;
- var
- i: Integer;
- begin
- for i:=0 to length(SpecializedConstraints)-1 do
- SpecializedConstraints[i].Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- SetLength(SpecializedConstraints,0);
- inherited Destroy;
- end;
- { TPRSpecializedTypeItem }
- procedure TPRSpecializedTypeItem.SetSpecializedType(AValue: TPasGenericType);
- begin
- if FSpecializedType=AValue then Exit;
- if FSpecializedType<>nil then
- FSpecializedType.Release{$IFDEF CheckPasTreeRefCount}('TPRSpecializedTypeItem.SpecializedType'){$ENDIF};
- FSpecializedEl:=AValue;
- FSpecializedType:=AValue;
- if FSpecializedType<>nil then
- FSpecializedType.AddRef{$IFDEF CheckPasTreeRefCount}('TPRSpecializedTypeItem.SpecializedType'){$ENDIF};
- end;
- destructor TPRSpecializedTypeItem.Destroy;
- var
- i: Integer;
- begin
- if ImplProcs<>nil then
- begin
- for i:=0 to ImplProcs.Count-1 do
- TPasElement(ImplProcs[i]).Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- ImplProcs.Free;
- ImplProcs:=nil;
- end;
- HeaderScope.Free;
- HeaderScope:=nil;
- SpecializedType:=nil;
- inherited Destroy;
- end;
- { TPRSpecializedProcItem }
- procedure TPRSpecializedProcItem.SetSpecializedProc(const AValue: TPasProcedure
- );
- begin
- if FSpecializedProc=AValue then Exit;
- if FSpecializedProc<>nil then
- FSpecializedProc.Release{$IFDEF CheckPasTreeRefCount}('TPRSpecializedProcItem.SpecializedProc'){$ENDIF};
- FSpecializedEl:=AValue;
- FSpecializedProc:=AValue;
- if FSpecializedProc<>nil then
- FSpecializedProc.AddRef{$IFDEF CheckPasTreeRefCount}('TPRSpecializedProcItem.SpecializedProc'){$ENDIF};
- end;
- destructor TPRSpecializedProcItem.Destroy;
- begin
- if ImplProc<>nil then
- begin
- ImplProc.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- ImplProc:=nil;
- end;
- SpecializedProc:=nil;
- inherited Destroy;
- end;
- { TPasGenericScope }
- destructor TPasGenericScope.Destroy;
- begin
- if SpecializedItems<>nil then
- begin
- SpecializedItems.Free;
- SpecializedItems:=nil;
- end;
- inherited Destroy;
- end;
- { TPasInheritedScope }
- function TPasInheritedScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- var
- aClassScope: TPasClassScope;
- begin
- Result:=inherited FindIdentifier(Identifier);
- if Result<>nil then exit;
- aClassScope:=AncestorScope;
- while aClassScope<>nil do
- begin
- Result:=aClassScope.FindIdentifier(Identifier);
- if Result<>nil then exit;
- aClassScope:=aClassScope.AncestorScope;
- end;
- end;
- procedure TPasInheritedScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- var
- aClassScope: TPasClassScope;
- begin
- inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- if Abort then exit;
- aClassScope:=AncestorScope;
- while aClassScope<>nil do
- begin
- aClassScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- if Abort then exit;
- aClassScope:=aClassScope.AncestorScope;
- end;
- end;
- procedure TPasInheritedScope.WriteIdentifiers(Prefix: string);
- var
- aClassScope: TPasClassScope;
- begin
- inherited WriteIdentifiers(Prefix);
- aClassScope:=AncestorScope;
- while aClassScope<>nil do
- begin
- aClassScope.WriteIdentifiers(Prefix);
- aClassScope:=aClassScope.AncestorScope;
- end;
- end;
- { TPasDotEnumTypeScope }
- function TPasDotEnumTypeScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=EnumScope.FindLocalIdentifier(Identifier);
- if Result<>nil then exit;
- Result:=inherited FindIdentifier(Identifier);
- end;
- procedure TPasDotEnumTypeScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- begin
- EnumScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- if Abort then exit;
- inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- end;
- procedure TPasDotEnumTypeScope.WriteIdentifiers(Prefix: string);
- begin
- EnumScope.WriteIdentifiers(Prefix);
- inherited WriteIdentifiers(Prefix);
- end;
- { TPasGroupScope }
- procedure TPasGroupScope.Add(Scope: TPasIdentifierScope);
- var
- i: Integer;
- begin
- for i:=0 to Count-1 do
- if Scopes[i]=Scope then exit; // already added
- if Scope.FreeOnPop then
- raise Exception.Create('TPasGroupScope.Add '+GetObjName(Scope)+' '+GetObjName(Scope.Element));
- if Count=length(Scopes) then
- SetLength(Scopes,Count*2+4);
- Scopes[Count]:=Scope;
- inc(Count);
- end;
- destructor TPasGroupScope.Destroy;
- begin
- Scopes:=nil;
- Count:=0;
- inherited Destroy;
- end;
- function TPasGroupScope.GetFirstNonHelperScope: TPasIdentifierScope;
- var
- i: Integer;
- Scope: TPasIdentifierScope;
- begin
- for i:=0 to Count-1 do
- begin
- Scope:=Scopes[i];
- if (Scope.ClassType<>TPasClassScope)
- or (TPasClassType(Scope.Element).HelperForType=nil) then
- exit(Scope);
- end;
- Result:=nil;
- end;
- class function TPasGroupScope.IsStoredInElement: boolean;
- begin
- Result:=false;
- end;
- function TPasGroupScope.FindAncestorIdentifier(const Identifier: String
- ): TPasIdentifier;
- var
- i: Integer;
- begin
- for i:=1 to Count-1 do
- begin
- Result:=Scopes[i].FindIdentifier(Identifier);
- if Result<>nil then exit;
- end;
- Result:=nil;
- end;
- function TPasGroupScope.FindAncestorElement(const Identifier: String
- ): TPasElement;
- var
- Item: TPasIdentifier;
- begin
- Item:=FindAncestorIdentifier(Identifier);
- if Item<>nil then
- Result:=Item.Element
- else
- Result:=nil;
- end;
- function TPasGroupScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- var
- i: Integer;
- begin
- for i:=0 to Count-1 do
- begin
- Result:=Scopes[i].FindIdentifier(Identifier);
- if Result<>nil then exit;
- end;
- Result:=nil;
- end;
- procedure TPasGroupScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- var
- i: Integer;
- begin
- for i:=0 to Count-1 do
- begin
- Scopes[i].IterateElements(aName,StartScope,OnIterateElement,Data,Abort);
- if Abort then exit;
- end;
- end;
- procedure TPasGroupScope.WriteIdentifiers(Prefix: string);
- var
- i: Integer;
- begin
- for i:=0 to Count-1 do
- Scopes[i].WriteIdentifiers(Prefix+'Group['+IntToStr(i)+'/'+IntToStr(Count)+']');
- end;
- {$ifdef pas2js}
- { TPasResHashList }
- constructor TPasResHashList.Create;
- begin
- FItems:=TJSObject.new;
- end;
- procedure TPasResHashList.Add(const aName: string; Item: Pointer);
- begin
- FItems['%'+aName]:=Item;
- end;
- function TPasResHashList.Find(const aName: string): Pointer;
- begin
- if FItems.hasOwnProperty('%'+aName) then
- Result:=Pointer(FItems['%'+aName])
- else
- Result:=nil;
- end;
- procedure TPasResHashList.ForEachCall(const Proc: TPasResIterate; Arg: Pointer);
- var
- key: string;
- begin
- for key in FItems do
- if FItems.hasOwnProperty(key) then
- Proc(Pointer(FItems[key]),Arg);
- end;
- procedure TPasResHashList.Clear;
- begin
- FItems:=TJSObject.new;
- end;
- procedure TPasResHashList.Remove(const aName: string);
- begin
- if FItems.hasOwnProperty('%'+aName) then
- JSDelete(FItems,'%'+aName);
- end;
- {$endif}
- { TResElDataBuiltInProc }
- destructor TResElDataBuiltInProc.Destroy;
- begin
- ReleaseAndNil(TPasElement(Proc){$IFDEF CheckPasTreeRefCount},'TResElDataBuiltInProc.Proc'{$ENDIF});
- inherited Destroy;
- end;
- { TPasClassIntfMap }
- destructor TPasClassIntfMap.Destroy;
- begin
- Element:=nil;
- Intf:=nil;
- FreeAndNil(Procs);
- FreeAndNil(AncestorMap);
- inherited Destroy;
- end;
- { TPasInitialFinalizationScope }
- function TPasInitialFinalizationScope.AddReference(El: TPasElement;
- Access: TPSRefAccess): TPasScopeReference;
- begin
- if References=nil then
- References:=TPasScopeReferences.Create(Self);
- Result:=References.Add(El,Access);
- end;
- destructor TPasInitialFinalizationScope.Destroy;
- begin
- FreeAndNil(References);
- inherited Destroy;
- end;
- { TPasScopeReference }
- procedure TPasScopeReference.SetElement(const AValue: TPasElement);
- begin
- if FElement=AValue then Exit;
- if FElement<>nil then
- FElement.Release{$IFDEF CheckPasTreeRefCount}('TPasScopeReference.SetElement'){$ENDIF};
- FElement:=AValue;
- if FElement<>nil then
- FElement.AddRef{$IFDEF CheckPasTreeRefCount}('TPasScopeReference.SetElement'){$ENDIF};
- end;
- destructor TPasScopeReference.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasProcScopeReference.Destroy START ',ClassName,' "',GetObjName(Element),'"');
- {$ENDIF}
- Element:=nil;
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasProcScopeReference.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TPasScopeReferences }
- procedure TPasScopeReferences.OnClearItem(Item, Dummy: pointer);
- var
- Ref: TPasScopeReference absolute Item;
- Ref2: TPasScopeReference;
- begin
- if Dummy=nil then ;
- //writeln('TPasProcedureScope.OnClearReferenceItem ',GetObjName(Ref.Element));
- while Ref<>nil do
- begin
- Ref2:=Ref;
- Ref:=Ref.NextSameName;
- Ref2.Free;
- end;
- end;
- procedure TPasScopeReferences.OnCollectItem(Item, aList: pointer);
- var
- Ref: TPasScopeReference absolute Item;
- List: TFPList absolute aList;
- begin
- while Ref<>nil do
- begin
- List.Add(Ref);
- Ref:=Ref.NextSameName;
- end;
- end;
- constructor TPasScopeReferences.Create(aScope: TPasScope);
- begin
- References:=TPasResHashList.Create;
- FScope:=aScope;
- end;
- destructor TPasScopeReferences.Destroy;
- begin
- Clear;
- {$ifdef pas2js}
- References:=nil;
- {$else}
- FreeAndNil(References);
- {$endif}
- inherited Destroy;
- end;
- procedure TPasScopeReferences.Clear;
- begin
- if References=nil then exit;
- References.ForEachCall(@OnClearItem,nil);
- References.Clear;
- end;
- function TPasScopeReferences.Add(El: TPasElement; Access: TPSRefAccess
- ): TPasScopeReference;
- var
- LoName: String;
- OldItem, Item, LastItem: TPasScopeReference;
- begin
- LoName:=lowercase(El.Name);
- OldItem:=TPasScopeReference(References.Find(LoName));
- Item:=OldItem;
- LastItem:=nil;
- while Item<>nil do
- begin
- if Item.Element=El then
- begin
- // already marked as used -> combine access
- case Access of
- psraNone: ;
- psraRead:
- case Item.Access of
- psraNone: Item.Access:=Access;
- //psraRead: ;
- psraWrite: Item.Access:=psraWriteRead;
- //psraReadWrite: ;
- //psraWriteRead: ;
- //psraTypeInfo: ;
- end;
- psraWrite:
- case Item.Access of
- psraNone: Item.Access:=Access;
- psraRead: Item.Access:=psraReadWrite;
- //psraWrite: ;
- //psraReadWrite: ;
- //psraWriteRead: ;
- //psraTypeInfo: ;
- end;
- psraReadWrite:
- case Item.Access of
- psraNone: Item.Access:=Access;
- psraRead: Item.Access:=psraReadWrite;
- psraWrite: Item.Access:=psraWriteRead;
- //psraReadWrite: ;
- //psraWriteRead: ;
- //psraTypeInfo: ;
- end;
- psraWriteRead:
- case Item.Access of
- psraNone: Item.Access:=Access;
- psraRead: Item.Access:=psraReadWrite;
- psraWrite: Item.Access:=psraWriteRead;
- //psraReadWrite: ;
- //psraWriteRead: ;
- //psraTypeInfo: ;
- end;
- psraTypeInfo: Item.Access:=psraTypeInfo;
- else
- raise EPasResolve.Create(GetObjName(El)+' unknown Access');
- end;
- exit(Item);
- end;
- LastItem:=Item;
- Item:=Item.NextSameName;
- end;
- // new reference
- Item:=TPasScopeReference.Create;
- Item.Element:=El;
- Item.Access:=Access;
- if LastItem=nil then
- begin
- References.Add(LoName,Item);
- {$IFDEF VerbosePCUFiler}
- if TPasScopeReference(References.Find(LoName))<>Item then
- raise EPasResolve.Create('20180219230028');
- {$ENDIF}
- end
- else
- LastItem.NextSameName:=Item;
- Result:=Item;
- end;
- function TPasScopeReferences.Find(const aName: string): TPasScopeReference;
- var
- LoName: String;
- begin
- if References=nil then exit(nil);
- LoName:=lowercase(aName);
- Result:=TPasScopeReference(References.Find(LoName));
- end;
- function TPasScopeReferences.GetList: TFPList;
- begin
- Result:=TFPList.Create;
- if References=nil then exit;
- References.ForEachCall(@OnCollectItem,Result);
- end;
- { TPasPropertyScope }
- destructor TPasPropertyScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasPropertyScope.Destroy START ',ClassName);
- {$ENDIF}
- AncestorProp:=nil;
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasPropertyScope.Destroy END',ClassName);
- {$ENDIF}
- end;
- { TPasEnumTypeScope }
- destructor TPasEnumTypeScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasEnumTypeScope.Destroy START ',ClassName);
- {$ENDIF}
- ReleaseAndNil(TPasElement(CanonicalSet){$IFDEF CheckPasTreeRefCount},'TPasEnumTypeScope.CanonicalSet'{$ENDIF});
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasEnumTypeScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TPasDotBaseScope }
- function TPasDotBaseScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=GroupScope.FindIdentifier(Identifier);
- end;
- procedure TPasDotBaseScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- begin
- GroupScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- end;
- procedure TPasDotBaseScope.WriteIdentifiers(Prefix: string);
- begin
- GroupScope.WriteIdentifiers(Prefix);
- end;
- destructor TPasDotBaseScope.Destroy;
- begin
- FreeAndNil(GroupScope);
- inherited Destroy;
- end;
- { TPasWithExprScope }
- class function TPasWithExprScope.IsStoredInElement: boolean;
- begin
- Result:=false;
- end;
- class function TPasWithExprScope.FreeOnPop: boolean;
- begin
- Result:=false;
- end;
- procedure TPasWithExprScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- begin
- Scope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- end;
- procedure TPasWithExprScope.WriteIdentifiers(Prefix: string);
- begin
- {AllowWriteln}
- writeln(Prefix+'WithExpr: '+GetTreeDbg(Expr,length(Prefix)));
- Scope.WriteIdentifiers(Prefix);
- {AllowWriteln-}
- end;
- destructor TPasWithExprScope.Destroy;
- begin
- FreeAndNil(Scope);
- inherited Destroy;
- end;
- { TPasWithScope }
- constructor TPasWithScope.Create;
- begin
- inherited Create;
- ExpressionScopes:=TObjectList.Create(true);
- end;
- destructor TPasWithScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasWithScope.Destroy START ',ClassName);
- {$ENDIF}
- FreeAndNil(ExpressionScopes);
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasWithScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TPasProcedureScope }
- function TPasProcedureScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=inherited FindIdentifier(Identifier);
- if (Result<>nil) or (GroupScope=nil) then exit;
- Result:=GroupScope.FindIdentifier(Identifier);
- end;
- procedure TPasProcedureScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- begin
- inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- if Abort then exit;
- if GroupScope=nil then exit;
- GroupScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- end;
- function TPasProcedureScope.GetSelfScope: TPasProcedureScope;
- var
- Proc: TPasProcedure;
- El: TPasElement;
- begin
- Result:=Self;
- repeat
- if Result.ClassRecScope<>nil then exit;
- Proc:=TPasProcedure(Result.Element);
- El:=Proc.Parent;
- repeat
- if El=nil then exit(nil);
- if El is TProcedureBody then break;
- El:=El.Parent;
- until false;
- Proc:=El.Parent as TPasProcedure;
- Result:=TPasProcedureScope(Proc.CustomData);
- until false;
- end;
- procedure TPasProcedureScope.WriteIdentifiers(Prefix: string);
- begin
- inherited WriteIdentifiers(Prefix);
- if GroupScope<>nil then
- GroupScope.WriteIdentifiers(Prefix+'GS ');
- end;
- destructor TPasProcedureScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasProcedureScope.Destroy START ',ClassName);
- {$ENDIF}
- FreeAndNil(References);
- FreeAndNil(GroupScope);
- NestedMembersScope:=nil; // NestedMembersScope is auto freed
- inherited Destroy;
- ReleaseAndNil(TPasElement(SelfArg){$IFDEF CheckPasTreeRefCount},'TPasProcedureScope.SelfArg'{$ENDIF});
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasProcedureScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- function TPasProcedureScope.AddReference(El: TPasElement; Access: TPSRefAccess
- ): TPasScopeReference;
- begin
- if References=nil then
- References:=TPasScopeReferences.Create(Self);
- Result:=References.Add(El,Access);
- end;
- function TPasProcedureScope.GetReferences: TFPList;
- begin
- if References=nil then
- Result:=TFPList.Create
- else
- Result:=References.GetList;
- end;
- { TPasClassScope }
- destructor TPasClassScope.Destroy;
- var
- i: Integer;
- o: TObject;
- begin
- if Interfaces<>nil then
- begin
- for i:=0 to Interfaces.Count-1 do
- begin
- o:=TObject(Interfaces[i]);
- if o=nil then
- else if o is TPasProperty then
- else if o is TPasClassIntfMap then
- o.Free
- else
- raise Exception.Create('[20180322132757] '+GetElementDbgPath(Element)+' i='+IntToStr(i)+' '+GetObjName(o));
- end;
- FreeAndNil(Interfaces);
- end;
- if CanonicalClassOf<>nil then
- begin
- CanonicalClassOf.Parent:=nil;
- ReleaseAndNil(TPasElement(CanonicalClassOf){$IFDEF CheckPasTreeRefCount},'TPasClassScope.CanonicalClassOf'{$ENDIF});
- end;
- inherited Destroy;
- end;
- { TPasIdentifier }
- procedure TPasIdentifier.SetElement(AValue: TPasElement);
- begin
- if FElement=AValue then Exit;
- if Element<>nil then
- Element.Release{$IFDEF CheckPasTreeRefCount}('TPasIdentifier.SetElement'){$ENDIF};
- FElement:=AValue;
- if Element<>nil then
- Element.AddRef{$IFDEF CheckPasTreeRefCount}('TPasIdentifier.SetElement'){$ENDIF};
- end;
- destructor TPasIdentifier.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasIdentifier.Destroy START ',ClassName,' "',Identifier,'"');
- {$ENDIF}
- Element:=nil;
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasIdentifier.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { EPasResolve }
- procedure EPasResolve.SetPasElement(AValue: TPasElement);
- var
- Old: TPasElement;
- begin
- if FPasElement=AValue then Exit;
- Old:=FPasElement;
- if Old<>nil then
- begin
- Old:=nil;
- PasElement.Release{$IFDEF CheckPasTreeRefCount}('EPasResolve.SetPasElement'){$ENDIF};
- end;
- FPasElement:=AValue;
- if PasElement<>nil then
- PasElement.AddRef{$IFDEF CheckPasTreeRefCount}('EPasResolve.SetPasElement'){$ENDIF};
- end;
- destructor EPasResolve.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('EPasResolve.Destroy START ',ClassName);
- {$ENDIF}
- PasElement:=nil;
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('EPasResolve.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TResolvedReference }
- procedure TResolvedReference.SetDeclaration(AValue: TPasElement);
- begin
- if FDeclaration=AValue then Exit;
- if Declaration<>nil then
- Declaration.Release{$IFDEF CheckPasTreeRefCount}('TResolvedReference.SetDeclaration'){$ENDIF};
- FDeclaration:=AValue;
- if Declaration<>nil then
- Declaration.AddRef{$IFDEF CheckPasTreeRefCount}('TResolvedReference.SetDeclaration'){$ENDIF};
- end;
- destructor TResolvedReference.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TResolvedReference.Destroy START ',ClassName);
- {$ENDIF}
- Declaration:=nil;
- FreeAndNil(Context);
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TResolvedReference.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TPasSubExprScope }
- class function TPasSubExprScope.IsStoredInElement: boolean;
- begin
- Result:=false;
- end;
- { TPasModuleDotScope }
- procedure TPasModuleDotScope.OnInternalIterate(El: TPasElement; ElScope,
- StartScope: TPasScope; Data: Pointer; var Abort: boolean);
- var
- FilterData: PPasIterateFilterData absolute Data;
- begin
- if (El.ClassType=TPasModule) or (El.ClassType=TPasUsesUnit) then
- exit; // skip used units
- // call the original iterator
- FilterData^.OnIterate(El,ElScope,StartScope,FilterData^.Data,Abort);
- end;
- procedure TPasModuleDotScope.SetModule(AValue: TPasModule);
- begin
- if FModule=AValue then Exit;
- if Module<>nil then
- Module.Release{$IFDEF CheckPasTreeRefCount}('TPasModuleDotScope.SetModule'){$ENDIF};
- FModule:=AValue;
- if Module<>nil then
- Module.AddRef{$IFDEF CheckPasTreeRefCount}('TPasModuleDotScope.SetModule'){$ENDIF};
- end;
- destructor TPasModuleDotScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasSubModuleScope.Destroy START ',ClassName);
- {$ENDIF}
- Module:=nil;
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasSubModuleScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- function TPasModuleDotScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- function Find(Scope: TPasIdentifierScope): boolean;
- var
- Found: TPasIdentifier;
- C: TClass;
- begin
- if Scope=nil then exit(false);
- Found:=Scope.FindLocalIdentifier(Identifier);
- FindIdentifier:=Found;
- if Found=nil then exit(false);
- C:=Found.Element.ClassType;
- Result:=(C<>TPasModule) and (C<>TPasUsesUnit);
- end;
- begin
- Result:=nil;
- if Find(ImplementationScope) then exit;
- if Find(InterfaceScope) then exit;
- Find(SystemScope);
- end;
- procedure TPasModuleDotScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- var
- FilterData: TPasIterateFilterData;
- function Iterate(Scope: TPasIdentifierScope): boolean;
- begin
- if Scope=nil then exit(false);
- Scope.IterateLocalElements(aName,StartScope,@OnInternalIterate,@FilterData,Abort);
- Result:=Abort;
- end;
- begin
- FilterData.OnIterate:=OnIterateElement;
- FilterData.Data:=Data;
- if Iterate(ImplementationScope) then exit;
- if Iterate(InterfaceScope) then exit;
- Iterate(SystemScope);
- end;
- procedure TPasModuleDotScope.WriteIdentifiers(Prefix: string);
- begin
- if ImplementationScope<>nil then
- ImplementationScope.WriteIdentifiers(Prefix+' ');
- if InterfaceScope<>nil then
- InterfaceScope.WriteIdentifiers(Prefix+' ');
- if SystemScope<>nil then
- SystemScope.WriteIdentifiers(Prefix+' ');
- end;
- { TPasSectionScope }
- procedure TPasSectionScope.OnInternalIterate(El: TPasElement; ElScope,
- StartScope: TPasScope; Data: Pointer; var Abort: boolean);
- var
- FilterData: PPasIterateFilterData absolute Data;
- begin
- if (El.ClassType=TPasModule) or (El.ClassType=TPasUsesUnit) then
- exit; // skip used units
- // call the original iterator
- FilterData^.OnIterate(El,ElScope,StartScope,FilterData^.Data,Abort);
- end;
- constructor TPasSectionScope.Create;
- begin
- inherited Create;
- UsesScopes:=TFPList.Create;
- end;
- destructor TPasSectionScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasSectionScope.Destroy START ',ClassName);
- {$ENDIF}
- ClearHelperList(Helpers);
- FreeAndNil(UsesScopes);
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasSectionScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- function TPasSectionScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- var
- i: Integer;
- UsesScope: TPasIdentifierScope;
- C: TClass;
- begin
- Result:=inherited FindIdentifier(Identifier);
- if Result<>nil then
- exit;
- for i:=UsesScopes.Count-1 downto 0 do
- begin
- UsesScope:=TPasIdentifierScope(UsesScopes[i]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasSectionScope.FindIdentifier "',Identifier,'" in used unit ',GetObjName(UsesScope.Element));
- {$ENDIF}
- Result:=UsesScope.FindLocalIdentifier(Identifier);
- if Result<>nil then
- begin
- C:=Result.Element.ClassType;
- if (C<>TPasModule) and (C<>TPasUsesUnit) then
- exit;
- end;
- end;
- end;
- procedure TPasSectionScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- var
- i: Integer;
- UsesScope: TPasSectionScope;
- FilterData: TPasIterateFilterData;
- begin
- inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- if Abort then exit;
- FilterData.OnIterate:=OnIterateElement;
- FilterData.Data:=Data;
- for i:=UsesScopes.Count-1 downto 0 do
- begin
- UsesScope:=TPasSectionScope(UsesScopes[i]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasSectionScope.IterateElements "',aName,'" in used unit ',UsesScope.Element.ParentPath,':',GetObjName(UsesScope.Element));
- {$ENDIF}
- UsesScope.IterateLocalElements(aName,StartScope,@OnInternalIterate,@FilterData,Abort);
- if Abort then exit;
- end;
- end;
- procedure TPasSectionScope.WriteIdentifiers(Prefix: string);
- var
- i: Integer;
- UsesScope: TPasIdentifierScope;
- SubPrefix: String;
- begin
- {AllowWriteln}
- inherited WriteIdentifiers(Prefix);
- SubPrefix:=Prefix+' ';
- for i:=UsesScopes.Count-1 downto 0 do
- begin
- UsesScope:=TPasIdentifierScope(UsesScopes[i]);
- writeln(Prefix+' Uses: '+GetObjName(UsesScope.Element)+' "'+UsesScope.Element.GetModule.Name+'"');
- UsesScope.FItems.ForEachCall(@OnWriteItem,Pointer(SubPrefix));
- end;
- {AllowWriteln-}
- end;
- { TPasModuleScope }
- procedure TPasModuleScope.SetAssertClass(const AValue: TPasClassType);
- begin
- if FAssertClass=AValue then Exit;
- if FAssertClass<>nil then
- FAssertClass.Release{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetAssertClass'){$ENDIF};
- FAssertClass:=AValue;
- if FAssertClass<>nil then
- FAssertClass.AddRef{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetAssertClass'){$ENDIF};
- end;
- procedure TPasModuleScope.SetAssertDefConstructor(const AValue: TPasConstructor
- );
- begin
- if FAssertDefConstructor=AValue then Exit;
- if FAssertDefConstructor<>nil then
- FAssertDefConstructor.Release{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetAssertDefConstructor'){$ENDIF};
- FAssertDefConstructor:=AValue;
- if FAssertDefConstructor<>nil then
- FAssertDefConstructor.AddRef{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetAssertDefConstructor'){$ENDIF};
- end;
- procedure TPasModuleScope.SetAssertMsgConstructor(const AValue: TPasConstructor
- );
- begin
- if FAssertMsgConstructor=AValue then Exit;
- if FAssertMsgConstructor<>nil then
- FAssertMsgConstructor.Release{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetAssertMsgConstructor'){$ENDIF};
- FAssertMsgConstructor:=AValue;
- if FAssertMsgConstructor<>nil then
- FAssertMsgConstructor.AddRef{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetAssertMsgConstructor'){$ENDIF};
- end;
- procedure TPasModuleScope.SetRangeErrorClass(const AValue: TPasClassType);
- begin
- if FRangeErrorClass=AValue then Exit;
- if FRangeErrorClass<>nil then
- FRangeErrorClass.Release{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetRangeErrorClass'){$ENDIF};
- FRangeErrorClass:=AValue;
- if FRangeErrorClass<>nil then
- FRangeErrorClass.AddRef{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetRangeErrorClass'){$ENDIF};
- end;
- procedure TPasModuleScope.SetRangeErrorConstructor(const AValue: TPasConstructor
- );
- begin
- if FRangeErrorConstructor=AValue then Exit;
- if FRangeErrorConstructor<>nil then
- FRangeErrorConstructor.Release{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetRangeErrorConstructor'){$ENDIF};
- FRangeErrorConstructor:=AValue;
- if FRangeErrorConstructor<>nil then
- FRangeErrorConstructor.AddRef{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetRangeErrorConstructor'){$ENDIF};
- end;
- procedure TPasModuleScope.SetSystemTVarRec(const AValue: TPasRecordType);
- begin
- if FSystemTVarRec=AValue then Exit;
- if FSystemTVarRec<>nil then
- FSystemTVarRec.Release{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetSystemTVarRec'){$ENDIF};
- FSystemTVarRec:=AValue;
- if FSystemTVarRec<>nil then
- FSystemTVarRec.AddRef{$IFDEF CheckPasTreeRefCount}('TPasModuleScope.SetSystemTVarRec'){$ENDIF};
- end;
- constructor TPasModuleScope.Create;
- begin
- inherited Create;
- PendingResolvers:=TFPList.Create;
- end;
- destructor TPasModuleScope.Destroy;
- begin
- AssertClass:=nil;
- AssertDefConstructor:=nil;
- AssertMsgConstructor:=nil;
- RangeErrorClass:=nil;
- RangeErrorConstructor:=nil;
- SystemTVarRec:=nil;
- FreeAndNil(PendingResolvers);
- inherited Destroy;
- end;
- procedure TPasModuleScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- begin
- if CompareText(aName,FirstName)<>0 then exit;
- OnIterateElement(Element,Self,StartScope,Data,Abort);
- end;
- { TPasDefaultScope }
- class function TPasDefaultScope.IsStoredInElement: boolean;
- begin
- Result:=false;
- end;
- { TPasScope }
- class function TPasScope.IsStoredInElement: boolean;
- begin
- Result:=true;
- end;
- class function TPasScope.FreeOnPop: boolean;
- begin
- Result:=not IsStoredInElement;
- end;
- procedure TPasScope.IterateElements(const aName: string; StartScope: TPasScope;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean);
- begin
- if aName='' then ;
- if StartScope=nil then ;
- if Data=nil then ;
- if OnIterateElement=nil then ;
- if Abort then ;
- end;
- procedure TPasScope.WriteIdentifiers(Prefix: string);
- begin
- {AllowWriteln}
- writeln(Prefix,'(',ClassName,') Element: ',GetObjName(Element));
- {AllowWriteln-}
- end;
- { TPasIdentifierScope }
- // inline
- function TPasIdentifierScope.FindLocalIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=TPasIdentifier(FItems.Find(lowercase(Identifier)));
- end;
- procedure TPasIdentifierScope.OnClearItem(Item, Dummy: pointer);
- var
- PasIdentifier: TPasIdentifier absolute Item;
- Ident: TPasIdentifier;
- begin
- if Dummy=nil then ;
- //writeln('TPasIdentifierScope.OnClearItem ',PasIdentifier.Identifier+':'+PasIdentifier.ClassName);
- while PasIdentifier<>nil do
- begin
- Ident:=PasIdentifier;
- PasIdentifier:=PasIdentifier.NextSameIdentifier;
- Ident.Free;
- end;
- end;
- procedure TPasIdentifierScope.OnCollectItem(Item, List: pointer);
- var
- PasIdentifier: TPasIdentifier absolute Item;
- FPList: TFPList absolute List;
- begin
- FPList.Add(PasIdentifier);
- end;
- procedure TPasIdentifierScope.OnWriteItem(Item, Dummy: pointer);
- var
- PasIdentifier: TPasIdentifier absolute Item;
- Prefix: String;
- begin
- {AllowWriteln}
- Prefix:=String(Dummy);
- while PasIdentifier<>nil do
- begin
- writeln(Prefix,'Identifier="',PasIdentifier.Identifier,'" Element=',GetObjName(PasIdentifier.Element));
- PasIdentifier:=PasIdentifier.NextSameIdentifier;
- end;
- {AllowWriteln-}
- end;
- procedure TPasIdentifierScope.InternalAdd(Item: TPasIdentifier);
- var
- OldItem: TPasIdentifier;
- LoName: string;
- {$ifdef pas2js}
- {$ELSE}
- Index: Integer;
- {$ENDIF}
- begin
- LoName:=lowercase(Item.Identifier);
- {$ifdef pas2js}
- OldItem:=TPasIdentifier(FItems.Find(LoName));
- if OldItem<>nil then
- begin
- // insert LIFO - last in, first out
- Item.NextSameIdentifier:=OldItem;
- end;
- FItems.Add(LoName,Item);
- {$IFDEF VerbosePasResolver}
- if Item.Owner<>nil then
- raise Exception.Create('20160925184110');
- Item.Owner:=Self;
- {$ENDIF}
- {$IFDEF VerbosePasResolver}
- if FindIdentifier(Item.Identifier)<>Item then
- raise Exception.Create('20181018173201');
- {$ENDIF}
- {$else}
- Index:=FItems.FindIndexOf(LoName);
- {$IFDEF VerbosePasResolver}
- if Item.Owner<>nil then
- raise Exception.Create('20160925184110');
- Item.Owner:=Self;
- {$ENDIF}
- //writeln(' Index=',Index);
- if Index>=0 then
- begin
- // insert LIFO - last in, first out
- OldItem:=TPasIdentifier(FItems.List^[Index].Data);
- {$IFDEF VerbosePasResolver}
- if lowercase(OldItem.Identifier)<>LoName then
- raise Exception.Create('20160925183438');
- {$ENDIF}
- Item.NextSameIdentifier:=OldItem;
- FItems.List^[Index].Data:=Item;
- end
- else
- begin
- FItems.Add(LoName, Item);
- {$IFDEF VerbosePasResolver}
- if FindIdentifier(Item.Identifier)<>Item then
- raise Exception.Create('20160925183849');
- {$ENDIF}
- end;
- {$endif}
- end;
- constructor TPasIdentifierScope.Create;
- begin
- FItems:=TPasResHashList.Create;
- end;
- destructor TPasIdentifierScope.Destroy;
- begin
- ClearIdentifiers(true);
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasIdentifierScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- procedure TPasIdentifierScope.ClearIdentifiers(FreeItems: boolean);
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasIdentifierScope.Clear START ',ClassName);
- {$ENDIF}
- FItems.ForEachCall(@OnClearItem,nil);
- {$ifdef pas2js}
- if FreeItems then
- FItems:=nil
- else
- FItems.Clear;
- {$else}
- FItems.Clear;
- if FreeItems then
- FreeAndNil(FItems);
- {$endif}
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasIdentifierScope.Clear END ',ClassName);
- {$ENDIF}
- end;
- function TPasIdentifierScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=FindLocalIdentifier(Identifier);
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if (Result<>nil) and (Result.Owner<>Self) then
- begin
- writeln('TPasIdentifierScope.FindIdentifier Result.Owner<>Self Owner='+GetObjName(Result.Owner));
- raise Exception.Create('20160925184159');
- end;
- {AllowWriteln-}
- {$ENDIF}
- end;
- function TPasIdentifierScope.RemoveLocalIdentifier(El: TPasElement): boolean;
- var
- Identifier, PrevIdentifier: TPasIdentifier;
- LoName: string;
- begin
- LoName:=lowercase(El.Name);
- Identifier:=TPasIdentifier(FItems.Find(LoName));
- FindLocalIdentifier(El.Name);
- PrevIdentifier:=nil;
- Result:=false;
- while Identifier<>nil do
- begin
- {$IFDEF VerbosePasResolver}
- if (Identifier.Owner<>Self) then
- raise Exception.Create('20160925184159');
- {$ENDIF}
- if Identifier.Element=El then
- begin
- if PrevIdentifier<>nil then
- begin
- PrevIdentifier.NextSameIdentifier:=Identifier.NextSameIdentifier;
- Identifier.Free;
- Identifier:=PrevIdentifier.NextSameIdentifier;
- end
- else
- begin
- FItems.Remove({$ifdef pas2js}LoName{$else}Identifier{$endif});
- PrevIdentifier:=Identifier;
- Identifier:=Identifier.NextSameIdentifier;
- PrevIdentifier.Free;
- PrevIdentifier:=nil;
- if Identifier<>nil then
- FItems.Add(LoName,Identifier);
- end;
- Result:=true;
- continue;
- end;
- PrevIdentifier:=Identifier;
- Identifier:=Identifier.NextSameIdentifier;
- end;
- end;
- function TPasIdentifierScope.AddIdentifier(const Identifier: String;
- El: TPasElement; const Kind: TPasIdentifierKind): TPasIdentifier;
- var
- Item: TPasIdentifier;
- begin
- //writeln('TPasIdentifierScope.AddIdentifier Identifier="',Identifier,'" El=',GetObjName(El));
- Item:=TPasIdentifier.Create;
- Item.Identifier:=Identifier;
- Item.Element:=El;
- Item.Kind:=Kind;
- InternalAdd(Item);
- //writeln('TPasIdentifierScope.AddIdentifier END');
- Result:=Item;
- end;
- function TPasIdentifierScope.FindElement(const aName: string): TPasElement;
- var
- Item: TPasIdentifier;
- begin
- //writeln('TPasIdentifierScope.FindElement "',aName,'"');
- Item:=FindIdentifier(aName);
- if Item=nil then
- Result:=nil
- else
- Result:=Item.Element;
- //writeln('TPasIdentifierScope.FindElement Found="',GetObjName(Result),'"');
- end;
- procedure TPasIdentifierScope.IterateLocalElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- var
- Item: TPasIdentifier;
- {$IFDEF VerbosePasResolver}
- OldElement: TPasElement;
- {$ENDIF}
- begin
- Item:=FindLocalIdentifier(aName);
- while Item<>nil do
- begin
- //writeln('TPasIdentifierScope.IterateLocalElements ',ClassName,' ',Item.Identifier,' ',GetObjName(Item.Element));
- {$IFDEF VerbosePasResolver}
- OldElement:=Item.Element;
- {$ENDIF}
- OnIterateElement(Item.Element,Self,StartScope,Data,Abort);
- {$IFDEF VerbosePasResolver}
- if OldElement<>Item.Element then
- raise Exception.Create('20160925183503');
- {$ENDIF}
- if Abort then exit;
- Item:=Item.NextSameIdentifier;
- end;
- end;
- procedure TPasIdentifierScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- begin
- IterateLocalElements(aName,StartScope,OnIterateElement,Data,Abort);
- end;
- procedure TPasIdentifierScope.WriteIdentifiers(Prefix: string);
- begin
- inherited WriteIdentifiers(Prefix);
- WriteLocalIdentifiers(Prefix+' ');
- end;
- procedure TPasIdentifierScope.WriteLocalIdentifiers(Prefix: string);
- begin
- FItems.ForEachCall(@OnWriteItem,Pointer(Prefix));
- end;
- function TPasIdentifierScope.GetLocalIdentifiers: TFPList;
- begin
- Result:=TFPList.Create;
- FItems.ForEachCall(@OnCollectItem,Result);
- end;
- { TPasResolver }
- // inline
- function TPasResolver.GetBaseTypes(bt: TResolverBaseType
- ): TPasUnresolvedSymbolRef;
- begin
- Result:=FBaseTypes[bt];
- end;
- // inline
- function TPasResolver.GetScopes(Index: integer): TPasScope;
- begin
- Result:=FScopes[Index];
- end;
- // inline
- function TPasResolver.IsNameExpr(El: TPasExpr): boolean;
- begin
- Result:=(El.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent);
- end;
- // inline
- function TPasResolver.IsGenericTemplType(const ResolvedEl: TPasResolverResult
- ): boolean;
- begin
- Result:=(ResolvedEl.BaseType=btContext)
- and (ResolvedEl.LoTypeEl.ClassType=TPasGenericTemplateType);
- end;
- // inline
- function TPasResolver.GetLocalScope: TPasScope;
- begin
- Result:=TopScope;
- if Result.ClassType=TPasGroupScope then
- Result:=TPasGroupScope(Result).Scopes[0];
- end;
- // inline
- function TPasResolver.GetParentLocalScope: TPasScope;
- begin
- Result:=Scopes[ScopeCount-2];
- if Result.ClassType=TPasGroupScope then
- Result:=TPasGroupScope(Result).Scopes[0];
- end;
- function TPasResolver.GetNameExprValue(El: TPasExpr): string;
- begin
- if El=nil then
- Result:=''
- else if El.ClassType=TPrimitiveExpr then
- begin
- if TPrimitiveExpr(El).Kind=pekIdent then
- Result:=TPrimitiveExpr(El).Value
- else
- Result:='';
- end
- else
- Result:='';
- end;
- function TPasResolver.GetNextDottedExpr(El: TPasExpr): TPasExpr;
- // returns TPrimitiveExpr (Kind=pekIdent)
- var
- Bin: TBinaryExpr;
- C: TClass;
- begin
- Result:=nil;
- if El=nil then exit;
- repeat
- if not (El.Parent is TBinaryExpr) then exit;
- Bin:=TBinaryExpr(El.Parent);
- if Bin.OpCode<>eopSubIdent then exit;
- if El=Bin.right then
- El:=Bin
- else
- begin
- El:=Bin.right;
- // find left most
- repeat
- C:=El.ClassType;
- if C=TPrimitiveExpr then
- begin
- if TPrimitiveExpr(El).Kind<>pekIdent then
- RaiseNotYetImplemented(20170502163825,El);
- exit(El);
- end
- else if C=TBinaryExpr then
- begin
- if TBinaryExpr(El).OpCode<>eopSubIdent then
- RaiseNotYetImplemented(20170502163718,El);
- El:=TBinaryExpr(El).left;
- end
- else if C=TParamsExpr then
- begin
- if not (TParamsExpr(El).Kind in [pekFuncParams,pekArrayParams]) then
- RaiseNotYetImplemented(20170502163908,El);
- El:=TParamsExpr(El).Value;
- end;
- until El=nil;
- RaiseNotYetImplemented(20170502163953,Bin);
- end;
- until false;
- end;
- function TPasResolver.GetLeftMostExpr(El: TPasExpr): TPasExpr;
- var
- C: TClass;
- begin
- Result:=El;
- while Result<>nil do
- begin
- El:=Result;
- C:=Result.ClassType;
- if C=TBinaryExpr then
- begin
- if TBinaryExpr(Result).OpCode<>eopSubIdent then
- exit;
- Result:=TBinaryExpr(Result).left;
- end
- else if C=TParamsExpr then
- begin
- if not (TParamsExpr(Result).Kind in [pekFuncParams,pekArrayParams]) then
- exit;
- Result:=TParamsExpr(Result).Value;
- end
- else
- exit;
- end;
- end;
- function TPasResolver.GetRightMostExpr(El: TPasExpr): TPasExpr;
- var
- C: TClass;
- begin
- Result:=El;
- while Result<>nil do
- begin
- El:=Result;
- C:=Result.ClassType;
- if C=TBinaryExpr then
- begin
- if TBinaryExpr(Result).OpCode<>eopSubIdent then
- exit;
- Result:=TBinaryExpr(Result).right;
- end
- else
- exit;
- end;
- end;
- procedure TPasResolver.GetParamsOfNameExpr(El: TPasExpr; out
- ParentParams: TPRParentParams);
- // Checks if El is the name expression of a call or array access
- // For example: a.b.El() a.El[]
- // Note: TPasParser guarantees that there is at most one TBinaryExpr
- // and one TInlineSpecializeExpr between El and TParamsExpr
- var
- Parent: TPasElement;
- Bin: TBinaryExpr;
- Params: TParamsExpr;
- InlineSpec: TInlineSpecializeExpr;
- begin
- ParentParams.InlineSpec:=nil;
- ParentParams.Params:=nil;
- if not IsNameExpr(El) then exit;
- Parent:=El.Parent;
- if Parent=nil then exit;
- if Parent.ClassType=TInlineSpecializeExpr then
- begin
- InlineSpec:=TInlineSpecializeExpr(Parent);
- if InlineSpec.NameExpr<>El then exit;
- ParentParams.InlineSpec:=InlineSpec;
- El:=InlineSpec;
- Parent:=El.Parent;
- if Parent=nil then exit;
- end;
- if Parent.ClassType=TBinaryExpr then
- begin
- Bin:=TBinaryExpr(Parent);
- if (Bin.OpCode<>eopSubIdent) or (Bin.right<>El) then
- exit;
- El:=Bin;
- Parent:=El.Parent;
- end;
- if Parent.ClassType<>TParamsExpr then exit;
- Params:=TParamsExpr(Parent);
- if Params.Value<>El then exit;
- if not (Params.Kind in [pekFuncParams,pekArrayParams]) then exit;
- ParentParams.Params:=Params;
- end;
- function TPasResolver.GetInlineSpecOfNameExpr(El: TPasExpr
- ): TInlineSpecializeExpr;
- var
- Parent: TPasElement;
- begin
- Result:=nil;
- if not IsNameExpr(El) then exit;
- Parent:=El.Parent;
- if Parent=nil then exit;
- if Parent is TBinaryExpr then
- begin
- if (TBinaryExpr(Parent).OpCode<>eopSubIdent)
- or (TBinaryExpr(Parent).right<>El) then
- exit;
- El:=TBinaryExpr(Parent); // continue
- Parent:=El.Parent;
- end;
- if Parent.ClassType<>TInlineSpecializeExpr then exit;
- Result:=TInlineSpecializeExpr(Parent);
- if Result.NameExpr<>El then
- Result:=nil;
- end;
- function TPasResolver.GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
- var
- Value: TResEvalValue;
- begin
- if not (InFileExpr is TPrimitiveExpr) then
- RaiseXExpectedButYFound(20180221234828,'string literal',GetElementTypeName(InFileExpr),InFileExpr);
- Value:=ExprEvaluator.Eval(TPrimitiveExpr(InFileExpr),[refConst]);
- try
- if (Value=nil) then
- RaiseXExpectedButYFound(20180222000004,'string literal',GetElementTypeName(InFileExpr),InFileExpr);
- case Value.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- Result:=ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,InFileExpr);
- revkUnicodeString:
- Result:=UTF8Encode(TResEvalUTF16(Value).S);
- {$else}
- revkUnicodeString:
- Result:=TResEvalUTF16(Value).S;
- {$endif}
- else
- RaiseXExpectedButYFound(20180222000122,'string literal',Value.AsDebugString,InFileExpr);
- end;
- finally
- ReleaseEvalValue(Value);
- end;
- end;
- function TPasResolver.GetPathStart(El: TPasExpr): TPasExpr;
- // get leftmost name element (e.g. TPrimitiveExpr)
- // nil if not found
- var
- C: TClass;
- begin
- Result:=nil;
- while El<>nil do
- begin
- C:=El.ClassType;
- if C=TPrimitiveExpr then
- exit(El)
- else if C=TBinaryExpr then
- begin
- if TBinaryExpr(El).OpCode=eopSubIdent then
- El:=TBinaryExpr(El).left
- else
- exit;
- end
- else if C=TParamsExpr then
- El:=TParamsExpr(El).Value
- else
- exit;
- end;
- end;
- function TPasResolver.GetPathEndIdent(El: TPasExpr; AllowCall: boolean
- ): TPasExpr;
- // a -> a
- // a.b -> b
- // a.b() -> b
- // a()() -> nil
- // a[] -> nil
- var
- Bin: TBinaryExpr;
- begin
- Result:=nil;
- if AllowCall and (El is TParamsExpr) then
- El:=TParamsExpr(El).Value;
- while El is TBinaryExpr do
- begin
- Bin:=TBinaryExpr(El);
- if Bin.OpCode=eopSubIdent then
- El:=Bin.right
- else
- exit(nil);
- end;
- if (El is TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent) then
- Result:=El;
- end;
- function TPasResolver.GetNewInstanceExpr(El: TPasExpr): TPasExpr;
- // if the expression is a constructor newinstance call,
- // return the element referring the constructor
- // else nil
- var
- C: TClass;
- begin
- Result:=nil;
- while El<>nil do
- begin
- if (El.CustomData is TResolvedReference)
- and (rrfNewInstance in TResolvedReference(El.CustomData).Flags) then
- exit(El);
- C:=El.ClassType;
- if C=TBinaryExpr then
- begin
- if TBinaryExpr(El).OpCode=eopSubIdent then
- El:=TBinaryExpr(El).right
- else
- exit;
- end
- else if C=TParamsExpr then
- El:=TParamsExpr(El).Value
- else
- exit;
- end;
- end;
- procedure TPasResolver.ClearResolveDataList(Kind: TResolveDataListKind);
- var
- El: TPasElement;
- RData: TResolveData;
- begin
- // clear CustomData
- while FLastCreatedData[Kind]<>nil do
- begin
- RData:=FLastCreatedData[Kind];
- El:=RData.Element;
- El.CustomData:=nil;
- FLastCreatedData[Kind]:=RData.Next;
- RData.Free;
- end;
- end;
- function TPasResolver.GetBaseTypeNames(bt: TResolverBaseType): string;
- begin
- if FBaseTypes[bt]<>nil then
- Result:=FBaseTypes[bt].Name
- else
- Result:=ResBaseTypeNames[bt];
- end;
- function TPasResolver.GetBuiltInProcs(bp: TResolverBuiltInProc
- ): TResElDataBuiltInProc;
- begin
- Result:=FBuiltInProcs[bp];
- end;
- procedure TPasResolver.SetRootElement(const AValue: TPasModule);
- begin
- if FRootElement=AValue then Exit;
- FRootElement:=AValue;
- end;
- procedure TPasResolver.OnFindFirst_PreferNoParams(El: TPasElement; ElScope,
- StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean);
- var
- Data: PPRFindData absolute FindFirstElementData;
- ok: Boolean;
- Proc: TPasProcedure;
- Templates: TFPList;
- begin
- ok:=true;
- if (El is TPasProcedure) then
- begin
- Proc:=TPasProcedure(El);
- if Data^.SkipGenerics then
- begin
- Templates:=GetProcTemplateTypes(Proc);
- if (Templates<>nil) and (Templates.Count>0) then
- ok:=false;
- end;
- if ok and ProcNeedsParams(Proc.ProcType) then
- // found a proc, but it needs parameters -> remember the first and continue
- ok:=false;
- end
- else if Data^.SkipGenerics then
- begin
- if El is TPasGenericType then
- begin
- if GetTypeParameterCount(TPasGenericType(El))>0 then
- ok:=false;
- end;
- end;
- if ok or (Data^.Found=nil) then
- begin
- Data^.Found:=El;
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- end;
- if ok then
- Abort:=true;
- end;
- procedure TPasResolver.OnFindFirst(El: TPasElement; ElScope,
- StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean);
- var
- Data: PPRFindData absolute FindFirstElementData;
- begin
- Data^.Found:=El;
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- Abort:=true;
- end;
- procedure TPasResolver.OnFindFirst_GenericEl(El: TPasElement; ElScope,
- StartScope: TPasScope; FindFirstGenericData: Pointer; var Abort: boolean);
- var
- Data: PPRFindGenericData absolute FindFirstGenericData;
- GenericTemplateTypes: TFPList;
- begin
- if El is TPasGenericType then
- GenericTemplateTypes:=TPasGenericType(El).GenericTemplateTypes
- else if El is TPasProcedure then
- GenericTemplateTypes:=GetProcTemplateTypes(TPasProcedure(El))
- else
- exit;
- if GenericTemplateTypes=nil then exit;
- if GenericTemplateTypes.Count<>Data^.TemplateCount then
- exit;
- Data^.Find.Found:=El;
- Data^.Find.ElScope:=ElScope;
- Data^.Find.StartScope:=StartScope;
- Abort:=true;
- end;
- procedure TPasResolver.OnFindCallElements(El: TPasElement; ElScope,
- StartScope: TPasScope; FindCallElData: Pointer; var Abort: boolean);
- var
- Data: PFindCallElData absolute FindCallElData;
- Proc, PrevProc: TPasProcedure;
- Distance: integer;
- BuiltInProc: TResElDataBuiltInProc;
- CandidateFound: Boolean;
- VarType, TypeEl: TPasType;
- C: TClass;
- ProcScope: TPasProcedureScope;
- Templates: TFPList;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements START --------- ',GetObjName(El),' at ',GetElementSourcePosStr(El));
- {$ENDIF}
- CandidateFound:=false;
- if (El is TPasProcedure) then
- begin
- // identifier is a proc
- Proc:=TPasProcedure(El);
- PrevProc:=nil;
- if Data^.Found=Proc then
- begin
- // this proc was already found. This happens when this is the forward
- // declaration or a previously found implementation.
- exit;
- end;
- ProcScope:=Proc.CustomData as TPasProcedureScope;
- if ProcScope.DeclarationProc<>nil then
- begin
- // this proc has a forward declaration -> use that instead
- Proc:=ProcScope.DeclarationProc;
- El:=Proc;
- end;
- if Data^.Found is TPasProcedure then
- begin
- // there is already a previous proc
- PrevProc:=TPasProcedure(Data^.Found);
- if msDelphi in TPasProcedureScope(Data^.LastProc.CustomData).ModeSwitches then
- begin
- if (not Data^.LastProc.IsOverload) or (not Proc.IsOverload) then
- begin
- Abort:=true;
- exit;
- end;
- end
- else
- begin
- // mode objfpc
- if IsSameProcContext(Proc.Parent,Data^.LastProc.Parent) then
- // mode objfpc: procs in same context have implicit overload
- else
- begin
- // mode objfpc, different context
- if not ProcHasGroupOverload(Data^.LastProc) then
- begin
- Abort:=true;
- exit;
- end;
- end;
- end;
- if (Data^.Distance=cExact) and (PrevProc.Parent<>Proc.Parent)
- and (PrevProc.Parent.ClassType=TPasClassType) then
- begin
- // there was already a perfect proc in a descendant
- Abort:=true;
- exit;
- end;
- // check if previous found proc is override of found proc
- if IsProcOverride(Proc,PrevProc) then
- begin
- // previous found proc is override of found proc -> skip
- exit;
- end;
- end;
- if (msDelphi in ProcScope.ModeSwitches) and not Proc.IsOverload then
- Abort:=true; // stop searching after this proc
- CandidateFound:=true;
- if Data^.TemplCnt>0 then
- begin
- // proc must have templates
- Templates:=GetProcTemplateTypes(Proc);
- if (Templates=nil) or (Templates.Count<>Data^.TemplCnt) then
- Distance:=cIncompatible
- else
- Distance:=CheckCallProcCompatibility(Proc.ProcType,Data^.Params,false);
- end
- else
- Distance:=CheckCallProcCompatibility(Proc.ProcType,Data^.Params,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Proc Distance=',Distance,
- ' Data^.Found=',Data^.Found<>nil,' Data^.Distance=',Data^.Distance,
- ' Signature={',GetProcTypeDescription(Proc.ProcType,[prptdUseName,prptdAddPaths]),'}',
- ' Abort=',Abort);
- {$ENDIF}
- Data^.LastProc:=Proc;
- end
- else if El is TPasType then
- begin
- TypeEl:=ResolveAliasType(TPasType(El));
- C:=TypeEl.ClassType;
- if Data^.TemplCnt<>0 then
- begin
- if (not C.InheritsFrom(TPasGenericType))
- or (GetTypeParameterCount(TPasGenericType(TypeEl))<>Data^.TemplCnt)
- then
- exit;
- end;
- if C=TPasUnresolvedSymbolRef then
- begin
- if TypeEl.CustomData.ClassType=TResElDataBuiltInProc then
- begin
- // call of built-in proc
- BuiltInProc:=TResElDataBuiltInProc(TypeEl.CustomData);
- if (BuiltInProc.BuiltIn in [bfStrProc,bfStrFunc])
- and ((BuiltInProc.BuiltIn=bfStrProc) = ParentNeedsExprResult(Data^.Params)) then
- begin
- // str function can only be used within an expression
- // str procedure can only be used outside an expression
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements BuiltInProc=',El.Name,' skip');
- {$ENDIF}
- exit;
- end;
- Distance:=BuiltInProc.GetCallCompatibility(BuiltInProc,Data^.Params,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements BuiltInProc=',El.Name,' Distance=',Distance);
- {$ENDIF}
- CandidateFound:=true;
- end
- else if TypeEl.CustomData is TResElDataBaseType then
- begin
- // type cast to base type
- Abort:=true; // can't be overloaded
- if Data^.Found<>nil then exit;
- Distance:=CheckTypeCast(TPasType(El),Data^.Params,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Base type cast=',El.Name,' Distance=',Distance);
- {$ENDIF}
- CandidateFound:=true;
- end;
- end
- else if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasPointerType)
- or (C=TPasRecordType)
- or (C=TPasEnumType)
- or (C=TPasProcedureType)
- or (C=TPasFunctionType)
- or (C=TPasArrayType)
- or (C=TPasRangeType)
- or (C=TPasGenericTemplateType) then
- begin
- // type cast to user type
- Abort:=true; // can't be overloaded
- if Data^.Found<>nil then exit;
- Distance:=CheckTypeCast(TPasType(El),Data^.Params,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements type cast to "',GetObjName(El),'" Distance=',Distance);
- {$ENDIF}
- CandidateFound:=true;
- end;
- end
- else if El is TPasVariable then
- begin
- Abort:=true; // can't be overloaded
- if Data^.Found<>nil then exit;
- if Data^.TemplCnt<>0 then exit;
- if El.ClassType=TPasProperty then
- VarType:=GetPasPropertyType(TPasProperty(El))
- else
- VarType:=TPasVariable(El).VarType;
- VarType:=ResolveAliasType(VarType);
- if VarType is TPasProcedureType then
- begin
- Distance:=CheckCallProcCompatibility(TPasProcedureType(VarType),Data^.Params,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements call var of proctype=',El.Name,' Distance=',Distance);
- {$ENDIF}
- CandidateFound:=true;
- end;
- end
- else if El.ClassType=TPasArgument then
- begin
- Abort:=true; // can't be overloaded
- if Data^.Found<>nil then exit;
- if Data^.TemplCnt<>0 then exit;
- VarType:=ResolveAliasType(TPasArgument(El).ArgType);
- if VarType is TPasProcedureType then
- begin
- Distance:=CheckCallProcCompatibility(TPasProcedureType(VarType),Data^.Params,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements call arg of proctype=',El.Name,' Distance=',Distance);
- {$ENDIF}
- CandidateFound:=true;
- end;
- end;
- if not CandidateFound then
- begin
- // El does not support the () operator
- Abort:=true;
- if Data^.Found=nil then
- begin
- // El is the first element found -> raise error
- // ToDo: use the ( as error position
- RaiseMsg(20170216151525,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['(',El.ElementTypeName],Data^.Params);
- end;
- exit;
- end;
- // El is a candidate (might be incompatible)
- if (Data^.Found=nil)
- or ((Data^.Distance=cIncompatible) and (Distance<cIncompatible)) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Found first candidate Distance=',Distance);
- {$ENDIF}
- Data^.Found:=El;
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- Data^.Distance:=Distance;
- Data^.Count:=1;
- if Data^.List<>nil then
- begin
- Data^.List.Clear;
- Data^.List.Add(El);
- end;
- end
- else if Distance=cIncompatible then
- // another candidate, but it is incompatible -> ignore
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Found another candidate, but it is incompatible -> ignore')
- {$ENDIF}
- else if (Data^.Distance=Distance)
- or ((Distance>=cLossyConversion) and (Data^.Distance>=cLossyConversion)
- and ((Distance>=cIntToFloatConversion)=(Data^.Distance>=cIntToFloatConversion))) then
- begin
- // found another similar compatible one -> collect
- // Note: cLossyConversion is better than cIntToFloatConversion, not similar
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Found another candidate Distance=',Distance,' OldDistance=',Data^.Distance);
- {$ENDIF}
- inc(Data^.Count);
- if (Data^.List<>nil) then
- begin
- if (Data^.List.IndexOf(El)>=0) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Found El twice: ',GetTreeDbg(El),
- ' ',GetElementSourcePosStr(El),
- ' PrevElScope=',GetObjName(Data^.ElScope),' ',GetTreeDbg(Data^.ElScope.Element),
- ' ElScope=',GetObjName(ElScope),' ',GetTreeDbg(ElScope.Element)
- );
- {$ENDIF}
- RaiseInternalError(20160924230805);
- end;
- Data^.List.Add(El);
- end;
- end
- else if (Distance<Data^.Distance) then
- begin
- // found a better one
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Found a better candidate Distance=',Distance,' Data^.Distance=',Data^.Distance);
- {$ENDIF}
- if (Distance<cLossyConversion)
- or ((Distance>=cIntToFloatConversion)<>(Data^.Distance>=cIntToFloatConversion)) then
- begin
- // found a good one
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Found a good candidate Distance=',Distance,' Data^.Distance=',Data^.Distance);
- {$ENDIF}
- Data^.Count:=1;
- if Data^.List<>nil then
- Data^.List.Clear;
- end
- else
- begin
- // found another lossy one
- // -> collect them
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Found another lossy candidate Distance=',Distance,' Data^.Distance=',Data^.Distance);
- {$ENDIF}
- inc(Data^.Count);
- end;
- Data^.Found:=El;
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- Data^.Distance:=Distance;
- if Data^.List<>nil then
- Data^.List.Add(El);
- end
- else
- begin
- // found a worse one
- end;
- end;
- procedure TPasResolver.OnFindProc(El: TPasElement; ElScope,
- StartScope: TPasScope; FindProcData: Pointer; var Abort: boolean);
- var
- Data: PFindProcData absolute FindProcData;
- Proc: TPasProcedure;
- Store, SameScope: Boolean;
- ProcScope: TPasProcedureScope;
- CurResolver: TPasResolver;
- procedure CountProcInSameScope;
- begin
- inc(Data^.FoundInSameScope);
- if Proc.IsOverload then
- Data^.FoundOverloadModifier:=true;
- end;
- begin
- //writeln('TPasResolver.OnFindProc START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc);
- if not (El is TPasProcedure) then
- begin
- // identifier is not a proc
- if (El is TPasVariable) then
- begin
- if TPasVariable(El).Visibility=visStrictPrivate then
- exit; // not visible
- if (TPasVariable(El).Visibility=visPrivate)
- and (El.GetModule<>StartScope.Element.GetModule) then
- exit; // not visible
- end;
- Data^.FoundNonProc:=El;
- Abort:=true;
- if (El.CustomData is TResElDataBuiltInProc) then
- begin
- if Data^.FoundOverloadModifier or Data^.Proc.IsOverload then
- exit; // no hint
- end;
- case Data^.Kind of
- fpkProc:
- // proc hides a non proc
- if (Data^.Proc.GetModule=El.GetModule) then
- // forbidden within same module
- RaiseMsg(20170216151649,nDuplicateIdentifier,sDuplicateIdentifier,
- [El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType)
- else
- begin
- // give a hint
- if Data^.Proc.Parent is TPasMembersType then
- begin
- if El.Visibility=visStrictPrivate then
- else if (El.Visibility=visPrivate) and (El.GetModule<>Data^.Proc.GetModule) then
- else
- LogMsg(20171118205344,mtHint,nFunctionHidesIdentifier_NonProc,sFunctionHidesIdentifier,
- [GetElementSourcePosStr(El)],Data^.Proc.ProcType);
- end;
- end;
- fpkMethod:
- // method hides a non proc
- begin
- ProcScope:=TPasProcedureScope(Data^.Proc.CustomData);
- CurResolver:=ProcScope.Owner as TPasResolver;
- if msDelphi in CurResolver.CurrentParser.CurrentModeswitches then
- // ok in delphi
- else
- RaiseMsg(20171118232543,nDuplicateIdentifier,sDuplicateIdentifier,
- [El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType);
- end;
- end;
- exit;
- end;
- // identifier is a proc
- Proc:=TPasProcedure(El);
- if El=Data^.Proc then
- begin
- // found itself -> this is normal when searching for overloads
- CountProcInSameScope;
- exit;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindProc ',GetTreeDbg(El,2));
- {$ENDIF}
- Store:=CheckProcOverloadCompatibility(Data^.Proc,Proc);
- case Data^.Kind of
- fpkProc:
- SameScope:=Data^.Proc.GetModule=Proc.GetModule;
- fpkMethod:
- SameScope:=Data^.Proc.Parent=Proc.Parent;
- else
- // use OnFindProcDeclaration instead
- RaiseNotYetImplemented(20191010123525,Data^.Proc);
- end;
- if SameScope then
- begin
- // same scope
- if (msObjfpc in CurrentParser.CurrentModeswitches) then
- begin
- if ProcHasGroupOverload(Data^.Proc) then
- Include(TPasProcedureScope(Proc.CustomData).Flags,ppsfIsGroupOverload)
- else if ProcHasGroupOverload(Proc) then
- Include(TPasProcedureScope(Data^.Proc.CustomData).Flags,ppsfIsGroupOverload);
- end;
- if Store then
- begin
- // same scope, same signature
- // Note: forward declaration was already handled in FinishProcedureHeader
- RaiseMsg(20171118221821,nDuplicateIdentifier,sDuplicateIdentifier,
- [Proc.Name,GetElementSourcePosStr(Proc)],Data^.Proc.ProcType);
- end
- else
- begin
- // same scope, different signature
- if (msDelphi in CurrentParser.CurrentModeswitches) then
- begin
- // Delphi does not allow different procs without 'overload' in a scope
- if not Proc.IsOverload then
- RaiseMsg(20171118222112,nPreviousDeclMissesOverload,sPreviousDeclMissesOverload,
- [Proc.Name,GetElementSourcePosStr(Proc)],Data^.Proc.ProcType)
- else if not Data^.Proc.IsOverload then
- RaiseMsg(20171118222147,nOverloadedProcMissesOverload,sOverloadedProcMissesOverload,
- [GetElementSourcePosStr(Proc)],Data^.Proc.ProcType);
- end
- else
- begin
- // ObjFPC allows different procs without 'overload' modifier
- end;
- CountProcInSameScope;
- end;
- end
- else
- begin
- // different scopes
- if Data^.Proc.IsOverride then
- else if Data^.Proc.IsReintroduced then
- else
- begin
- if Store
- or ((Data^.FoundInSameScope=1) // missing 'overload' hints only for the first proc in a scope
- and not ProcHasGroupOverload(Data^.Proc)) then
- begin
- if (Data^.Kind=fpkMethod) and (Proc.IsVirtual or Proc.IsOverride) then
- // give a hint, that method hides a virtual method in ancestor
- LogMsg(20170216151712,mtWarning,nMethodHidesMethodOfBaseType,
- sMethodHidesMethodOfBaseType,
- [Data^.Proc.Name,Proc.Parent.Name,GetElementSourcePosStr(Proc)],Data^.Proc.ProcType)
- else
- begin
- // Delphi/FPC do not give a message when hiding a non virtual method
- // -> emit Hint with other message id
- if (Data^.Proc.Parent is TPasMembersType) then
- begin
- ProcScope:=Proc.CustomData as TPasProcedureScope;
- if (Proc.Visibility=visStrictPrivate)
- or ((Proc.Visibility=visPrivate)
- and (Proc.GetModule<>Data^.Proc.GetModule)) then
- // a private private is hidden by definition -> no hint
- else if (ProcScope.ImplProc<>nil) // not abstract, external
- and (not ProcHasImplElements(ProcScope.ImplProc)) then
- // hidden method has implementation, but no statements -> useless
- // -> do not give a hint for hiding this useless method
- // Note: if this happens in the same unit, the body was not yet parsed
- else if (Proc is TPasConstructor)
- and (Data^.Proc.ClassType=Proc.ClassType) then
- // do not give a hint for hiding a constructor
- else if Store then
- begin
- // method hides ancestor method with same signature
- LogMsg(20190316152656,mtHint,
- nMethodHidesNonVirtualMethodExactly,sMethodHidesNonVirtualMethodExactly,
- [GetElementSourcePosStr(Proc)],Data^.Proc.ProcType);
- end
- else
- begin
- //writeln('TPasResolver.OnFindProc Proc=',Proc.PathName,' Data^.Proc=',Data^.Proc.PathName,' ',Proc.Visibility);
- LogMsg(20171118214523,mtHint,
- nFunctionHidesIdentifier_NonVirtualMethod,sFunctionHidesIdentifier,
- [GetElementSourcePosStr(Proc)],Data^.Proc.ProcType);
- end;
- end;
- end;
- Abort:=true;
- end;
- end;
- end;
- if Store then
- begin
- Data^.Found:=Proc;
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- Abort:=true;
- end;
- end;
- procedure TPasResolver.OnFindProcDeclaration(El: TPasElement; ElScope,
- StartScope: TPasScope; FindProcData: Pointer; var Abort: boolean);
- var
- Data: PFindProcData absolute FindProcData;
- Proc: TPasProcedure;
- Store: Boolean;
- begin
- //writeln('TPasResolver.OnFindProcDeclaration START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc);
- if not (El is TPasProcedure) then
- begin
- // identifier is not a proc
- Data^.FoundNonProc:=El;
- Abort:=true;
- exit;
- end;
- if El=Data^.Proc then
- // found itself -> this is normal when searching for overloads
- exit;
- // identifier is a proc
- Proc:=TPasProcedure(El);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindProcDeclaration ',GetTreeDbg(El,2));
- {$ENDIF}
- Store:=CheckProcOverloadCompatibility(Data^.Proc,Proc);
- if Store then
- begin
- Data^.Found:=Proc;
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- Abort:=true;
- end;
- end;
- function TPasResolver.IsSameProcContext(ProcParentA, ProcParentB: TPasElement
- ): boolean;
- begin
- if ProcParentA=ProcParentB then exit(true);
- if (ProcParentA.ClassType=TInterfaceSection) then
- begin
- if (ProcParentB.ClassType=TImplementationSection)
- and (ProcParentB.Parent=ProcParentA.Parent) then
- exit(true);
- end
- else if (ProcParentB.ClassType=TInterfaceSection) then
- begin
- if (ProcParentA.ClassType=TImplementationSection)
- and (ProcParentA.Parent=ProcParentB.Parent) then
- exit(true);
- end;
- Result:=false;
- end;
- function TPasResolver.FindProcSameSignature(const ProcName: string;
- Proc: TPasProcedure; Scope: TPasIdentifierScope; OnlyLocal: boolean
- ): TPasProcedure;
- var
- FindData: TFindProcData;
- Abort: boolean;
- begin
- FindData:=Default(TFindProcData);
- FindData.Proc:=Proc;
- FindData.Args:=Proc.ProcType.Args;
- FindData.Kind:=fpkProcDeclaration;
- Abort:=false;
- //writeln('TPasResolver.FindProcSameSignature ',ProcName,' OnlyLocal=',OnlyLocal);
- if OnlyLocal then
- Scope.IterateLocalElements(ProcName,Scope,@OnFindProcDeclaration,@FindData,Abort)
- else
- Scope.IterateElements(ProcName,Scope,@OnFindProcDeclaration,@FindData,Abort);
- Result:=FindData.Found;
- end;
- procedure TPasResolver.SetCurrentParser(AValue: TPasParser);
- var
- Scanner: TPascalScanner;
- begin
- //writeln('TPasResolver.SetCurrentParser ',AValue<>nil);
- if AValue=CurrentParser then exit;
- Clear;
- inherited SetCurrentParser(AValue);
- if CurrentParser<>nil then
- begin
- CurrentParser.Options:=CurrentParser.Options+po_Resolver;
- if CurrentParser.Scanner<>nil then
- begin
- Scanner:=CurrentParser.Scanner;
- if (Scanner.OnWarnDirective=nil) then
- Scanner.OnWarnDirective:=@ScannerWarnDirective;
- Scanner.SetNonToken(tkself);
- end;
- end;
- end;
- procedure TPasResolver.ScannerWarnDirective(Sender: TObject;
- Identifier: string; State: TWarnMsgState; var Handled: boolean);
- var
- MsgNumbers: TIntegerDynArray;
- i: Integer;
- begin
- if not GetWarnIdentifierNumbers(Identifier,MsgNumbers) then exit;
- Handled:=true;
- for i:=0 to length(MsgNumbers)-1 do
- TPascalScanner(Sender).WarnMsgState[MsgNumbers[i]]:=State;
- end;
- procedure TPasResolver.CheckTopScope(ExpectedClass: TPasScopeClass;
- AllowDescendants: boolean);
- var
- Scope: TPasScope;
- begin
- Scope:=TopScope;
- if Scope=nil then
- RaiseInternalError(20160922163319,'Expected TopScope='+ExpectedClass.ClassName+' but found nil');
- if Scope.ClassType<>ExpectedClass then
- if (not AllowDescendants) or (not Scope.InheritsFrom(ExpectedClass)) then
- RaiseInternalError(20160922163323,'Expected TopScope='+ExpectedClass.ClassName+' but found '+Scope.ClassName);
- end;
- function TPasResolver.AddIdentifier(Scope: TPasIdentifierScope;
- const aName: String; El: TPasElement; const Kind: TPasIdentifierKind
- ): TPasIdentifier;
- function SkipGenericTypes(Identifier: TPasIdentifier;
- TypeParamCnt: integer): TPasIdentifier;
- var
- CurEl: TPasElement;
- begin
- while Identifier<>nil do
- begin
- CurEl:=Identifier.Element;
- if CurEl is TPasGenericType then
- begin
- if GetTypeParameterCount(TPasGenericType(CurEl))=TypeParamCnt then
- break;
- end
- else
- begin
- if TypeParamCnt=0 then
- break;
- end;
- Identifier:=Identifier.NextSameIdentifier;
- end;
- Result:=Identifier;
- end;
- var
- Group: TPasGroupScope;
- Identifier, OlderIdentifier: TPasIdentifier;
- OlderEl: TPasElement;
- C: TClass;
- i, TypeParamCnt: Integer;
- OtherScope: TPasIdentifierScope;
- ParentScope: TPasScope;
- IsGeneric, IsDelphi: Boolean;
- begin
- if aName='' then exit(nil);
- IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
- if Scope is TPasGroupScope then
- begin
- Group:=TPasGroupScope(Scope);
- Scope:=Group.Scopes[0];
- end
- else
- Group:=nil;
- if El is TPasGenericType then
- begin
- IsGeneric:=true;
- TypeParamCnt:=GetTypeParameterCount(TPasGenericType(El));
- end
- else
- begin
- IsGeneric:=false;
- TypeParamCnt:=0;
- end;
- if (El.Visibility=visPublished) then
- begin
- C:=El.ClassType;
- if (C=TPasProperty) or (C=TPasVariable) then
- // Note: VarModifiers are not yet set
- else if (C=TPasProcedure) or (C=TPasFunction) then
- // ok
- else
- RaiseMsg(20170403223024,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El);
- end;
- if (Kind=pikSimple) and (Group<>nil) and (El.ClassType<>TPasProperty)
- and not IsDelphi then
- begin
- // check duplicate in ancestors and helpers
- for i:=1 to Group.Count-1 do
- begin
- OtherScope:=Group.Scopes[i];
- OlderIdentifier:=OtherScope.FindLocalIdentifier(aName);
- if IsGeneric then
- OlderIdentifier:=SkipGenericTypes(OlderIdentifier,TypeParamCnt);
- while OlderIdentifier<>nil do
- begin
- OlderEl:=OlderIdentifier.Element;
- OlderIdentifier:=OlderIdentifier.NextSameIdentifier;
- if OlderEl is TPasVariable then
- begin
- if TPasVariable(OlderEl).Visibility=visStrictPrivate then
- continue; // OlderEl is hidden
- if (TPasVariable(OlderEl).Visibility=visPrivate)
- and (OlderEl.GetModule<>El.GetModule) then
- continue; // OlderEl is hidden
- end;
- RaiseMsg(20170221130001,nDuplicateIdentifier,sDuplicateIdentifier,
- [aName,GetElementSourcePosStr(OlderEl)],El);
- end;
- end;
- end;
- Identifier:=Scope.AddIdentifier(aName,El,Kind);
- // check duplicate in current scope
- OlderIdentifier:=Identifier.NextSameIdentifier;
- if IsGeneric and IsDelphi then
- OlderIdentifier:=SkipGenericTypes(OlderIdentifier,TypeParamCnt);
- if OlderIdentifier<>nil then
- begin
- OlderEl:=OlderIdentifier.Element;
- if (OlderEl.ClassType=TPasEnumValue)
- and (OlderEl.Parent.Parent<>Scope.Element) then
- begin
- // this enum was propagated from a sub type -> remove enum from this scope
- if OlderIdentifier.NextSameIdentifier<>nil then
- RaiseNotYetImplemented(20190807114726,El,GetElementSourcePosStr(OlderEl));
- Scope.RemoveLocalIdentifier(OlderEl);
- OlderIdentifier:=nil;
- OlderEl:=nil;
- end
- else if (El.Visibility=visPublished) and (El is TPasProcedure)
- and (OlderEl is TPasProcedure) then
- // published method bites method in same scope
- RaiseMsg(20190626175432,nDuplicatePublishedMethodXAtY,
- sDuplicatePublishedMethodXAtY,
- [aName,GetElementSourcePosStr(OlderEl)],El)
- else if (Identifier.Kind=pikSimple)
- or (OlderIdentifier.Kind=pikSimple) then
- // duplicate identifier
- RaiseMsg(20170216151530,nDuplicateIdentifier,sDuplicateIdentifier,
- [aName,GetElementSourcePosStr(OlderEl)],El);
- end;
- if (Scope=TopScope) and (Scope is TPasSectionScope) then
- begin
- ParentScope:=Scopes[ScopeCount-2];
- if ParentScope is TPasSectionScope then
- begin
- // check unit interface and implementation duplicates
- OlderIdentifier:=TPasSectionScope(ParentScope).FindLocalIdentifier(aName);
- repeat
- if IsGeneric then
- OlderIdentifier:=SkipGenericTypes(OlderIdentifier,TypeParamCnt);
- if OlderIdentifier=nil then break;
- OlderEl:=OlderIdentifier.Element;
- if (Identifier.Kind=pikNamespace)
- or (OlderIdentifier.Kind=pikNamespace) then
- else if (Identifier.Kind=pikSimple)
- or (OlderIdentifier.Kind=pikSimple) then
- RaiseMsg(20190818141630,nDuplicateIdentifier,sDuplicateIdentifier,
- [aName,GetElementSourcePosStr(OlderEl)],El);
- OlderIdentifier:=OlderIdentifier.NextSameIdentifier;
- until OlderIdentifier=nil;
- end;
- end;
- Result:=Identifier;
- end;
- procedure TPasResolver.FinishModule(CurModule: TPasModule);
- var
- CurModuleClass: TClass;
- i: Integer;
- ModScope: TPasModuleScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishModule START ',CurModule.Name);
- {$ENDIF}
- FStep:=prsFinishingModule;
- CurModuleClass:=CurModule.ClassType;
- ModScope:=CurModule.CustomData as TPasModuleScope;
- if bsRangeChecks in CurrentParser.Scanner.CurrentBoolSwitches then
- begin
- Include(ModScope.Flags,pmsfRangeErrorNeeded);
- FindRangeErrorConstructors(nil);
- end;
- if (CurModuleClass=TPasProgram) then
- begin
- FinishSection(TPasProgram(CurModule).ProgramSection);
- // resolve begin..end block
- ResolveImplBlock(CurModule.InitializationSection);
- end
- else if (CurModuleClass=TPasLibrary) then
- begin
- FinishSection(TPasLibrary(CurModule).LibrarySection);
- // resolve begin..end block
- ResolveImplBlock(CurModule.InitializationSection);
- ResolveImplBlock(CurModule.FinalizationSection);
- end
- else if (CurModuleClass=TPasModule) then
- begin
- // unit
- FinishSection(CurModule.InterfaceSection);
- if CurModule.ImplementationSection<>nil then
- FinishSection(CurModule.ImplementationSection);
- if CurModule.FinalizationSection<>nil then
- // finalization section finished -> resolve
- ResolveImplBlock(CurModule.FinalizationSection);
- if CurModule.InitializationSection<>nil then
- // initialization section finished -> resolve
- ResolveImplBlock(CurModule.InitializationSection);
- end
- else
- RaiseInternalError(20160922163327); // unknown module
- // check all methods have bodies
- // and all forward classes and pointers are resolved
- for i:=0 to FPendingForwardProcs.Count-1 do
- CheckPendingForwardProcs(TPasElement(FPendingForwardProcs[i]));
- FPendingForwardProcs.Clear;
- // close all sections
- while (TopScope<>nil) and (TopScope.ClassType=ScopeClass_Section) do
- PopScope;
- CheckTopScope(FScopeClass_Module);
- PopScope;
- FStep:=prsFinishedModule;
- if (CurrentParser<>nil) and (CurrentParser.Scanner<>nil) then
- begin
- CurrentParser.NextToken;
- if CurrentParser.Scanner.CurToken<>tkEOF then
- LogMsg(20180628131456,mtHint,nTextAfterFinalIgnored,sTextAfterFinalIgnored,
- [],nil);
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishModule END ',CurModule.Name);
- {$ENDIF}
- end;
- procedure TPasResolver.FinishUsesClause;
- var
- Section: TPasSection;
- i, j: Integer;
- PublicEl, UseModule: TPasElement;
- Scope: TPasSectionScope;
- UsesScope: TPasSectionScope;
- UseUnit: TPasUsesUnit;
- FirstName: String;
- p: SizeInt;
- OldIdentifier: TPasIdentifier;
- IntfHelpers: TPRHelperEntryArray;
- begin
- CheckTopScope(ScopeClass_Section);
- Scope:=TPasSectionScope(TopScope);
- Section:=TPasSection(Scope.Element);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishUsesClause Section=',Section.ClassName,' Section.UsesList.Count=',Section.UsesList.Count);
- {$ENDIF}
- if Scope.UsesFinished then
- RaiseInternalError(20180305145220);
- Scope.UsesFinished:=true;
- for i:=0 to Section.UsesList.Count-1 do
- begin
- UseUnit:=Section.UsesClause[i];
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishUsesClause ',GetObjName(UseUnit));
- {$ENDIF}
- UseModule:=UseUnit.Module;
- // check used unit
- PublicEl:=nil;
- if (UseModule.ClassType=TPasLibrary) then
- PublicEl:=TPasLibrary(UseModule).LibrarySection
- else if (UseModule.ClassType=TPasModule) then
- PublicEl:=TPasModule(UseModule).InterfaceSection
- else
- RaiseXExpectedButYFound(20170503004803,'unit',GetElementTypeName(UseModule),UseUnit);
- if PublicEl=nil then
- RaiseInternalError(20160922163352,'uses element has no interface section: '+GetObjName(UseModule));
- if PublicEl.CustomData=nil then
- RaiseInternalError(20160922163358,'uses element has no resolver data: '
- +UseUnit.Name+'->'+GetObjName(PublicEl));
- if not (PublicEl.CustomData is TPasSectionScope) then
- RaiseInternalError(20160922163403,'uses element has invalid resolver data: '
- +UseUnit.Name+'->'+GetObjName(PublicEl)+'->'+PublicEl.CustomData.ClassName);
- UsesScope:=TPasSectionScope(PublicEl.CustomData);
- // add full uses name
- AddIdentifier(Scope,UseUnit.Name,UseUnit,pikSimple);
- // add scope
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishUsesClause Add UsesScope=',GetObjName(UsesScope));
- {$ENDIF}
- Scope.UsesScopes.Add(UsesScope);
- // add helpers
- IntfHelpers:=UsesScope.Helpers;
- for j:=0 to length(IntfHelpers)-1 do
- AddActiveHelper(TPRHelperEntry(IntfHelpers[j]).Helper);
- EmitElementHints(Section,UseUnit);
- end;
- // Add first name of dotted unitname (top level subnamespace) as identifier
- for i:=Section.UsesList.Count-1 downto 0 do
- begin
- UseUnit:=Section.UsesClause[i];
- FirstName:=UseUnit.Name;
- p:=Pos('.',FirstName);
- if p<1 then continue;
- FirstName:=LeftStr(FirstName,p-1);
- OldIdentifier:=Scope.FindLocalIdentifier(FirstName);
- if (OldIdentifier=nil) then
- AddIdentifier(Scope,FirstName,UseUnit,pikNamespace);
- end;
- // Note: a sub identifier (e.g. a class member) hides all unitnames starting
- // with this identifier
- end;
- procedure TPasResolver.FinishSection(Section: TPasSection);
- // Note: can be called multiple times for a section
- var
- Scope: TPasSectionScope;
- begin
- Scope:=Section.CustomData as TPasSectionScope;
- if Scope.Finished then exit;
- Scope.Finished:=true;
- if Section is TInterfaceSection then
- FinishInterfaceSection(Section);
- end;
- procedure TPasResolver.FinishInterfaceSection(Section: TPasSection);
- begin
- {$IFDEF VerboseUnitQueue}
- writeln('TPasResolver.FinishInterfaceSection ',GetObjName(RootElement));
- {$ENDIF}
- {$IF defined(VerbosePasResolver) or defined(VerboseUnitQueue)}
- if not IsUnitIntfFinished(Section.GetModule) then
- RaiseInternalError(20171214004323,'TPasResolver.FinishInterfaceSection "'+RootElement.Name+'" "'+Section.GetModule.Name+'" IsUnitIntfFinished=false');
- {$ENDIF}
- inc(Hub.FinishedInterfaceCount);
- FFinishedInterfaceIndex:=Hub.FinishedInterfaceCount;
- NotifyPendingUsedInterfaces;
- if Section=nil then ;
- end;
- procedure TPasResolver.FinishTypeSection(El: TPasElement);
- procedure FinishDeclarations(El: TPasDeclarations);
- var
- i: Integer;
- Decl: TPasElement;
- begin
- for i:=0 to El.Declarations.Count-1 do
- begin
- Decl:=TPasElement(El.Declarations[i]);
- if Decl is TPasType then
- FinishTypeSectionEl(TPasType(Decl));
- end;
- end;
- procedure FinishMembersType(El: TPasMembersType);
- var
- i: Integer;
- Decl: TPasElement;
- begin
- for i:=0 to El.Members.Count-1 do
- begin
- Decl:=TPasElement(El.Members[i]);
- if Decl is TPasType then
- FinishTypeSectionEl(TPasType(Decl));
- end;
- end;
- begin
- // resolve pending forwards
- if El is TPasDeclarations then
- FinishDeclarations(TPasDeclarations(El))
- else if El is TPasMembersType then
- FinishMembersType(TPasMembersType(El))
- else
- RaiseNotYetImplemented(20181226105933,El);
- end;
- procedure TPasResolver.FinishTypeSectionEl(El: TPasType);
- function ReplaceDestType(Decl: TPasType; var DestType: TPasType;
- const DestName: string; MustExist: boolean; ErrorEl: TPasElement
- {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF}): boolean;
- // returns true if replaces
- var
- Abort: boolean;
- Data: TPRFindData;
- OldDestType: TPasType;
- begin
- Abort:=false;
- Data:=Default(TPRFindData);
- Data.ErrorPosEl:=ErrorEl;
- (TopScope as TPasIdentifierScope).IterateElements(DestName,
- TopScope,@OnFindFirst,@Data,Abort);
- //writeln('ReplaceDestType ',GetObjName(El),' DestType=',GetObjName(DestType),' DestType.Parent=',GetObjName(DestType.Parent),' RefCount=',DestType.RefCount);
- if Data.Found=nil then
- if MustExist then
- begin
- RaiseIdentifierNotFound(20170216151543,DestName,ErrorEl);
- end
- else
- exit(false);
- if Data.Found=DestType then exit;
- if Decl is TPasClassOfType then
- begin
- if (Data.Found.ClassType<>TPasClassType)
- or (TPasClassType(Data.Found).ObjKind<>okClass) then
- RaiseXExpectedButYFound(20170216151548,'class',GetElementTypeName(Data.Found),ErrorEl);
- end;
- // replace unresolved
- OldDestType:=DestType;
- DestType:=TPasType(Data.Found);
- DestType.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
- OldDestType.Release{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
- CheckUseAsType(DestType,20190123100649,El);
- // check cycles
- if Decl is TPasPointerType then
- CheckPointerCycle(TPasPointerType(Decl));
- Result:=true;
- end;
- var
- C: TClass;
- ClassOfEl: TPasClassOfType;
- TypeEl: TPasType;
- UnresolvedEl: TUnresolvedPendingRef;
- OldClassType: TPasClassType;
- PtrType: TPasPointerType;
- begin
- C:=El.ClassType;
- if C=TPasClassType then
- begin
- if TPasClassType(El).IsForward
- and not (TPasClassType(El).CustomData is TResolvedReference) then
- RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[El.Name],El);
- end
- else if (C=TPasClassOfType) then
- begin
- ClassOfEl:=TPasClassOfType(El);
- TypeEl:=ResolveAliasType(ClassOfEl.DestType);
- if (TypeEl.ClassType=TUnresolvedPendingRef) then
- begin
- // forward class-of -> resolve now
- UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"');
- {$ENDIF}
- ReplaceDestType(ClassOfEl,ClassOfEl.DestType,TypeEl.Name,true,UnresolvedEl
- {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
- end
- else if TypeEl.ClassType=TPasClassType then
- begin
- // class-of has found a type
- // another later in the same type section has priority -> check
- OldClassType:=TypeEl as TPasClassType;
- if OldClassType.Parent=ClassOfEl.Parent then
- exit; // class in same type section -> ok
- // class not in same type section -> check
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"');
- {$ENDIF}
- ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl
- {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
- end;
- end
- else if C=TPasPointerType then
- begin
- PtrType:=TPasPointerType(El);
- TypeEl:=ResolveAliasType(PtrType.DestType);
- if (TypeEl.ClassType=TUnresolvedPendingRef) then
- begin
- // forward pointer -> resolve now
- UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"');
- {$ENDIF}
- ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl
- {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
- end
- else
- begin
- // pointer-of has found a type
- // another later in the same type section has priority -> check
- if TypeEl.Parent=PtrType.Parent then
- exit; // class in same type section -> ok
- // dest not in same type section -> check
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishTypeSection improving "',PtrType.Name,'" = pointer of resolved "',TypeEl.Name,'"');
- {$ENDIF}
- ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,false,PtrType
- {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
- end;
- end;
- end;
- procedure TPasResolver.FinishTypeDef(El: TPasType);
- var
- C: TClass;
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FinishTypeDef El=',GetObjName(El));
- {$ENDIF}
- C:=El.ClassType;
- if C=TPasEnumType then
- FinishEnumType(TPasEnumType(El))
- else if C=TPasSetType then
- FinishSetType(TPasSetType(El))
- else if C=TPasRangeType then
- FinishRangeType(TPasRangeType(El))
- else if C=TPasRecordType then
- FinishRecordType(TPasRecordType(El))
- else if C=TPasClassType then
- FinishClassType(TPasClassType(El))
- else if C=TPasClassOfType then
- FinishClassOfType(TPasClassOfType(El))
- else if C=TPasPointerType then
- FinishPointerType(TPasPointerType(El))
- else if C=TPasArrayType then
- FinishArrayType(TPasArrayType(El))
- else if (C=TPasAliasType) or (C=TPasTypeAliasType) then
- FinishAliasType(TPasAliasType(El))
- else if (C=TPasPointerType) then
- EmitTypeHints(El,TPasPointerType(El).DestType)
- else if C=TPasGenericTemplateType then
- FinishGenericTemplateType(TPasGenericTemplateType(El))
- else if C=TPasSpecializeType then
- FinishSpecializeType(TPasSpecializeType(El));
- end;
- procedure TPasResolver.FinishEnumType(El: TPasEnumType);
- begin
- if TopScope.Element=El then
- PopScope;
- end;
- procedure TPasResolver.FinishSetType(El: TPasSetType);
- function GetEnumTypePosEl: TPasElement;
- begin
- Result:=El.EnumType;
- if Result.Parent<>El then
- Result:=El;
- end;
- var
- BaseTypeData: TResElDataBaseType;
- StartResolved, EndResolved: TPasResolverResult;
- RangeExpr: TBinaryExpr;
- C: TClass;
- EnumType: TPasType;
- begin
- EnumType:=ResolveAliasType(El.EnumType);
- C:=EnumType.ClassType;
- if C=TPasEnumType then
- begin
- FinishSubElementType(El,EnumType);
- exit;
- end
- else if C=TPasRangeType then
- begin
- RangeExpr:=TPasRangeType(EnumType).RangeExpr;
- if (RangeExpr.Parent=El) and (RangeExpr.CustomData=nil) then
- FinishConstRangeExpr(RangeExpr,StartResolved,EndResolved);
- FinishSubElementType(El,EnumType);
- exit;
- end
- else if C=TPasUnresolvedSymbolRef then
- begin
- if EnumType.CustomData is TResElDataBaseType then
- begin
- BaseTypeData:=TResElDataBaseType(EnumType.CustomData);
- if BaseTypeData.BaseType in (btAllChars+[btBoolean,btByte]) then
- exit;
- RaiseXExpectedButYFound(20170216151553,'char or boolean',
- GetElementTypeName(EnumType),GetEnumTypePosEl);
- end;
- end;
- RaiseXExpectedButYFound(20170216151557,'enum type',
- GetElementTypeName(EnumType),GetEnumTypePosEl);
- end;
- procedure TPasResolver.FinishSubElementType(Parent: TPasElement; El: TPasType);
- procedure InsertInFront(NewParent: TPasElement; List: TFPList
- {$IFDEF CheckPasTreeRefCount};const aId: string{$ENDIF});
- var
- i: Integer;
- p: TPasElement;
- begin
- p:=El.Parent;
- if NewParent=p.Parent then
- begin
- // e.g. a:array of longint; -> insert a$a in front of a
- i:=List.Count-1;
- while (i>=0) and (List[i]<>Pointer(p)) do
- dec(i);
- if i<0 then
- List.Add(El)
- else
- List.Insert(i,El);
- end
- else
- begin
- List.Add(El);
- end;
- El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF};
- El.Parent:=NewParent;
- end;
- var
- Decl: TPasDeclarations;
- EnumScope: TPasEnumTypeScope;
- p: TPasElement;
- MembersType: TPasMembersType;
- begin
- EmitTypeHints(Parent,El);
- if (El.Name<>'') or (AnonymousElTypePostfix='') then exit;
- if Parent.Name='' then
- RaiseMsg(20170415165455,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
- if El.Parent<>Parent then
- RaiseNotYetImplemented(20190215085011,Parent);
- // give anonymous sub type a name
- El.Name:=Parent.Name+AnonymousElTypePostfix;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishSubElementType parent="',GetObjName(Parent),'" named anonymous type "',GetObjName(El),'"');
- {$ENDIF}
- p:=Parent.Parent;
- repeat
- if p is TPasDeclarations then
- begin
- Decl:=TPasDeclarations(p);
- InsertInFront(Decl,Decl.Declarations{$IFDEF CheckPasTreeRefCount},'TPasDeclarations.Declarations'{$ENDIF});
- Decl.Types.Add(El);
- break;
- end
- else if p is TPasMembersType then
- begin
- MembersType:=TPasMembersType(p);
- InsertInFront(MembersType,MembersType.Members{$IFDEF CheckPasTreeRefCount},'TPasMembersType.Members'{$ENDIF});
- break;
- end
- else
- p:=p.Parent;
- if p=nil then
- RaiseMsg(20170416094735,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
- until false;
- if (El.ClassType=TPasEnumType) and (Parent.ClassType=TPasSetType) then
- begin
- // anonymous enumtype
- EnumScope:=TPasEnumTypeScope(El.CustomData);
- if EnumScope.CanonicalSet<>Parent then
- begin
- // When a TPasEnumType is created a CanonicalSet is created.
- // Release the autocreated CanonicalSet and use the parent.
- if EnumScope.CanonicalSet<>nil then
- EnumScope.CanonicalSet.Release{$IFDEF CheckPasTreeRefCount}('TPasEnumTypeScope.CanonicalSet'){$ENDIF};
- EnumScope.CanonicalSet:=TPasSetType(Parent);
- Parent.AddRef{$IFDEF CheckPasTreeRefCount}('TPasEnumTypeScope.CanonicalSet'){$ENDIF};
- end;
- end;
- end;
- procedure TPasResolver.FinishRangeType(El: TPasRangeType);
- var
- RangeExpr: TBinaryExpr;
- StartResolved, EndResolved: TPasResolverResult;
- begin
- RangeExpr:=El.RangeExpr;
- ResolveExpr(RangeExpr.left,rraRead);
- ResolveExpr(RangeExpr.right,rraRead);
- FinishConstRangeExpr(RangeExpr,StartResolved,EndResolved);
- end;
- procedure TPasResolver.FinishConstRangeExpr(RangeExpr: TBinaryExpr; out
- LeftResolved, RightResolved: TPasResolverResult);
- // for example Left..Right
- var
- RgValue: TResEvalValue;
- Left, Right: TPasExpr;
- begin
- Left:=RangeExpr.left;
- Right:=RangeExpr.right;
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.FinishConstRangeExpr Left=',GetObjName(Left),' Right=',GetObjName(Right));
- {$ENDIF}
- // check type compatibility
- ComputeElement(Left,LeftResolved,[rcConstant]);
- ComputeElement(Right,RightResolved,[rcConstant]);
- CheckSetLitElCompatible(Left,Right,LeftResolved,RightResolved);
- RgValue:=Eval(RangeExpr,[refConst]);
- ReleaseEvalValue(RgValue);
- end;
- procedure TPasResolver.FinishRecordType(El: TPasRecordType);
- var
- Scope: TPasRecordScope;
- begin
- if TopScope.Element<>El then
- RaiseNotYetImplemented(20190801232042,El);
- PopScope;
- Scope:=El.CustomData as TPasRecordScope;
- FinishGenericClassOrRecIntf(Scope);
- end;
- procedure TPasResolver.FinishClassType(El: TPasClassType);
- type
- TMethResolution = record
- InterfaceIndex: integer;
- ProcClassType: TPasProcedureClass;
- InterfaceName: string;
- ImplementName: string;
- ResolutionEl: TPasMethodResolution;
- Count: integer; // needed to check if method resolution is used
- end;
- var
- ClassScope: TPasClassScope;
- i, j, k: Integer;
- IntfType: TPasClassType;
- Resolutions: array of TMethResolution;
- Map: TPasClassIntfMap;
- o: TObject;
- Member, Parent: TPasElement;
- IntfProc: TPasProcedure;
- FindData: TFindProcData;
- Abort: boolean;
- MethRes: TPasMethodResolution;
- ResolvedEl: TPasResolverResult;
- ProcName, IntfProcName: String;
- Expr: TPasExpr;
- SectionScope: TPasSectionScope;
- begin
- Resolutions:=nil;
- ClassScope:=nil;
- if not El.IsForward then
- begin
- if TopScope.Element<>El then
- RaiseInternalError(20180322142534,GetObjName(El)+'<>'+GetObjName(TopScope.Element));
- ClassScope:=El.CustomData as TPasClassScope;
- if ClassScope=nil then
- RaiseNotYetImplemented(20190803204709,El);
- if El.ObjKind=okClass then
- begin
- if (El.Interfaces.Count>0) then
- begin
- if (ClassScope.Interfaces=nil) then
- RaiseInternalError(20180408162725,'');
- if (ClassScope.Interfaces.Count<>El.Interfaces.Count) then
- RaiseInternalError(20180408162746,'');
- end
- else if ClassScope.Interfaces<>nil then
- RaiseInternalError(20180408162803,'');
- // check explicit method resolutions, e.g. procedure intf.intfproc = implproc
- for i:=0 to El.Members.Count-1 do
- begin
- Member:=TPasElement(El.Members[i]);
- if not (Member is TPasMethodResolution) then continue;
- MethRes:=TPasMethodResolution(Member);
- // get interface
- ComputeElement(MethRes.InterfaceName,ResolvedEl,[rcNoImplicitProc]);
- if not (ResolvedEl.IdentEl is TPasType) then
- RaiseInternalError(20180323135729,GetResolverResultDbg(ResolvedEl));
- j:=El.Interfaces.IndexOf(ResolvedEl.IdentEl);
- if j<0 then
- RaiseInternalError(20180323135900,GetResolverResultDbg(ResolvedEl));
- // get class-interface-map, check delegations
- o:=TObject(ClassScope.Interfaces[j]);
- if o is TPasProperty then
- RaiseMsg(20180323140046,nCannotMixMethodResolutionAndDelegationAtX,
- sCannotMixMethodResolutionAndDelegationAtX,
- [GetElementSourcePosStr(TPasProperty(o))],MethRes.InterfaceName);
- if o=nil then
- o:=CreateClassIntfMap(El,j);
- Map:=TPasClassIntfMap(o);
- // get interface proc name
- Expr:=MethRes.InterfaceProc;
- if not (Expr is TPrimitiveExpr) then
- RaiseXExpectedButYFound(20180327162230,'method name',GetElementTypeName(Expr),Expr);
- if TPrimitiveExpr(Expr).Kind<>pekIdent then
- RaiseXExpectedButYFound(20180327162236,'method name',GetElementTypeName(Expr),Expr);
- IntfProcName:=TPrimitiveExpr(Expr).Value;
- // get implementation proc name
- Expr:=MethRes.ImplementationProc;
- if not (Expr is TPrimitiveExpr) then
- RaiseXExpectedButYFound(20180327152115,'method name',GetElementTypeName(Expr),Expr);
- if TPrimitiveExpr(Expr).Kind<>pekIdent then
- RaiseXExpectedButYFound(20180327152157,'method name',GetElementTypeName(Expr),Expr);
- ProcName:=TPrimitiveExpr(Expr).Value;
- for k:=0 to length(Resolutions)-1 do
- with Resolutions[k] do
- if (InterfaceIndex=j) and (ProcClassType=MethRes.ProcClass)
- and (InterfaceName=IntfProcName) then
- RaiseMsg(20180327164626,nDuplicateIdentifier,sDuplicateIdentifier,
- [GetElementTypeName(ProcClassType)+' '+Map.Intf.Name+'.'+InterfaceName,
- GetElementSourcePosStr(ResolutionEl)],MethRes.InterfaceProc);
- // add resolution
- k:=length(Resolutions);
- SetLength(Resolutions,k+1);
- with Resolutions[k] do
- begin
- InterfaceIndex:=j;
- ProcClassType:=MethRes.ProcClass;
- InterfaceName:=IntfProcName;
- ImplementName:=ProcName;
- ResolutionEl:=MethRes;
- Count:=0;
- end;
- end;
- // method resolution
- for i:=0 to El.Interfaces.Count-1 do
- begin
- o:=TObject(ClassScope.Interfaces[i]);
- //writeln('TPasResolver.FinishClassType class=',GetObjName(El),' i=',i,' Intf=',GetObjName(TObject(El.Interfaces[i])),' Map=',GetObjName(o));
- if o is TPasProperty then
- continue; // interface implemented via a property
- if o=nil then
- o:=CreateClassIntfMap(El,i);
- Map:=TPasClassIntfMap(o);
- while Map<>nil do
- begin
- IntfType:=Map.Intf;
- //writeln('TPasResolver.FinishClassType ',GetObjName(Map),' ',GetObjName(IntfType),' Count=',IntfType.Members.Count);
- for j:=0 to IntfType.Members.Count-1 do
- begin
- Member:=TPasElement(IntfType.Members[j]);
- if not (Member is TPasProcedure) then continue;
- IntfProc:=TPasProcedure(Member);
- ProcName:=IntfProc.Name;
- // check resolutions
- for k:=0 to length(Resolutions)-1 do
- with Resolutions[k] do
- begin
- if (InterfaceIndex=i) and (ProcClassType=IntfProc.ClassType)
- and SameText(InterfaceName,IntfProc.Name) then
- begin
- ProcName:=ImplementName;
- inc(Count);
- end;
- end;
- // search interface method in class
- FindData:=Default(TFindProcData);
- FindData.Proc:=IntfProc;
- FindData.Args:=IntfProc.ProcType.Args;
- FindData.Kind:=fpkProcDeclaration;
- Abort:=false;
- IterateElements(ProcName,@OnFindProcDeclaration,@FindData,Abort);
- if FindData.Found=nil then
- RaiseMsg(20180322143202,nNoMatchingImplForIntfMethodXFound,
- sNoMatchingImplForIntfMethodXFound,
- [GetProcTypeDescription(IntfProc.ProcType,[prptdUseName,prptdAddPaths,prptdResolveSimpleAlias])],El); // ToDo: jump to interface list
- // check calling conventions
- //writeln('TPasResolver.FinishClassType Intf=',GetObjPath(IntfProc),' Found=',GetObjPath(FindData.Found));
- CheckProcSignatureMatch(IntfProc,TPasProcedure(FindData.Found),true);
- Map.Procs[j]:=FindData.Found;
- end;
- Map:=Map.AncestorMap;
- end;
- end;
- // ToDo: hint if method resolution is not used
- end;
- if El.ObjKind in okAllHelpers then
- begin
- // activate helper
- AddActiveHelper(El);
- // cache helpers in interface, so other modules don't have to search
- Parent:=El.Parent;
- while Parent<>nil do
- begin
- if Parent.ClassType=TInterfaceSection then
- begin
- SectionScope:=Parent.CustomData as TPasSectionScope;
- AddHelper(El,SectionScope.Helpers);
- break;
- end;
- Parent:=Parent.Parent;
- end;
- end;
- end;
- if TopScope.Element=El then
- PopScope // pop TPasClassScope
- else
- ; // e.g. class forward
- if TopScope is TPasGenericParamsScope then
- PopGenericParamScope(El);
- if not El.IsForward then
- FinishGenericClassOrRecIntf(ClassScope);
- end;
- procedure TPasResolver.FinishClassOfType(El: TPasClassOfType);
- var
- TypeEl: TPasType;
- begin
- TypeEl:=ResolveAliasType(El.DestType);
- if TypeEl is TUnresolvedPendingRef then
- begin
- TypeEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- exit;
- end;
- if (TypeEl is TPasClassType) and (TPasClassType(TypeEl).ObjKind=okClass) then exit;
- RaiseMsg(20170216151602,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [El.DestType.Name,'class'],El);
- end;
- procedure TPasResolver.FinishPointerType(El: TPasPointerType);
- var
- TypeEl: TPasType;
- begin
- TypeEl:=ResolveAliasType(El.DestType);
- if TypeEl is TUnresolvedPendingRef then
- begin
- TypeEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- exit;
- end;
- if El.DestType.Parent=El then
- RaiseMsg(20180429094237,nNotYetImplemented,sNotYetImplemented,['pointer of anonymous type'], El.DestType);
- CheckUseAsType(El.DestType,20190123095118,El);
- CheckPointerCycle(El);
- end;
- procedure TPasResolver.FinishArrayType(El: TPasArrayType);
- var
- i: Integer;
- Expr: TPasExpr;
- RangeResolved: TPasResolverResult;
- TypeEl: TPasType;
- Parent: TPasArrayType;
- Scope: TPasArrayScope;
- begin
- // check cycles
- Parent:=El;
- repeat
- if Parent=El.ElType then
- RaiseMsg(20190807104630,nIllegalExpression,sIllegalExpression,[],El);
- if Parent.Parent is TPasArrayType then
- Parent:=TPasArrayType(Parent.Parent)
- else
- break;
- until false;
- for i:=0 to length(El.Ranges)-1 do
- begin
- Expr:=El.Ranges[i];
- ResolveExpr(Expr,rraRead);
- ComputeElement(Expr,RangeResolved,[rcConstant]);
- if (RangeResolved.IdentEl<>nil) and not (RangeResolved.IdentEl is TPasType) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishArrayType ',GetResolverResultDbg(RangeResolved));
- {$ENDIF}
- RaiseXExpectedButYFound(20170216151607,'range',GetElementTypeName(RangeResolved.IdentEl),Expr);
- end;
- if (RangeResolved.BaseType=btRange) then
- begin
- if (RangeResolved.SubType in btArrayRangeTypes) then
- // range, e.g. 1..2
- else if RangeResolved.SubType=btContext then
- begin
- TypeEl:=RangeResolved.LoTypeEl;
- if TypeEl is TPasRangeType then
- // custom range
- else if TypeEl is TPasEnumType then
- // anonymous enum range
- else
- RaiseXExpectedButYFound(20171009193629,'range',GetElementTypeName(RangeResolved.IdentEl),Expr);
- end
- else
- RaiseXExpectedButYFound(20171009193514,'range',GetElementTypeName(RangeResolved.IdentEl),Expr);
- end
- else if RangeResolved.BaseType in btArrayRangeTypes then
- // full range, e.g. array[char]
- else if (RangeResolved.BaseType=btContext) and (RangeResolved.LoTypeEl is TPasEnumType) then
- // e.g. array[enumtype]
- else if (RangeResolved.BaseType=btContext) and (RangeResolved.LoTypeEl is TPasGenericTemplateType) then
- // e.g. Tarr<T> = array[T] of ...
- else if RangeResolved.IdentEl<>nil then
- RaiseXExpectedButYFound(20170216151609,'range',GetElementTypeName(RangeResolved.IdentEl),Expr)
- else
- RaiseXExpectedButYFound(20190830215123,'range',GetResolverResultDescription(RangeResolved),Expr);
- end;
- if El.ElType=nil then
- begin
- // array of const
- if length(El.Ranges)>0 then
- RaiseNotYetImplemented(20190215102529,El);
- FindTVarRec(El);
- end
- else
- begin
- CheckUseAsType(El.ElType,20190123095401,El);
- FinishSubElementType(El,El.ElType);
- end;
- if El.CustomData is TPasArrayScope then
- begin
- Scope:=TPasArrayScope(El.CustomData);
- Scope.GenericStep:=psgsImplementationParsed;
- end;
- if TopScope.Element=El then
- PopScope;
- end;
- procedure TPasResolver.FinishAliasType(El: TPasAliasType);
- var
- aType: TPasType;
- begin
- aType:=ResolveAliasType(El);
- if (aType is TPasMembersType) and (aType.CustomData=nil) then
- exit;
- if (aType is TPasGenericType)
- and (GetTypeParameterCount(TPasGenericType(aType))>0) then
- RaiseMsg(20190818135830,nXExpectedButYFound,sXExpectedButYFound,
- ['type',GetTypeDescription(aType)],El);
- EmitTypeHints(El,TPasAliasType(El).DestType);
- end;
- procedure TPasResolver.FinishGenericTemplateType(El: TPasGenericTemplateType);
- var
- ConEl: TPasElement;
- procedure RaiseCannotBeTogether(const Id: TMaxPrecInt; const X,Y: string);
- begin
- RaiseMsg(Id,nConstraintXAndConstraintYCannotBeTogether,
- sConstraintXAndConstraintYCannotBeTogether,[X,Y],
- GetGenericConstraintErrorEl(ConEl,El));
- end;
- procedure RaiseXIsNotAValidConstraint(const Id: TMaxPrecInt; const X: string);
- begin
- RaiseMsg(Id,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[X],
- GetGenericConstraintErrorEl(ConEl,El));
- end;
- var
- i: Integer;
- IsClass, IsRecord, IsConstructor: Boolean;
- LastType: TPasType;
- MemberType: TPasMembersType;
- aClass: TPasClassType;
- ConToken: TToken;
- ResolvedEl: TPasResolverResult;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishGenericTemplateType ',GetObjName(El),' El.Parent=',GetObjName(El.Parent),' Constraints=',length(El.Constraints));
- {$ENDIF}
- IsClass:=false;
- IsRecord:=false;
- IsConstructor:=false;
- LastType:=nil;
- for i:=0 to length(El.Constraints)-1 do
- begin
- ConEl:=El.Constraints[i];
- ConToken:=GetGenericConstraintKeyword(ConEl);
- case ConToken of
- tkclass:
- begin
- if IsClass then
- RaiseMsg(20190720202412,nConstraintXSpecifiedMoreThanOnce,
- sConstraintXSpecifiedMoreThanOnce,['class'],ConEl);
- if IsRecord then
- RaiseCannotBeTogether(20190720202516,'record','class');
- if LastType<>nil then
- RaiseCannotBeTogether(20190720205708,LastType.Name,'class');
- IsClass:=true;
- end;
- tkrecord:
- begin
- if IsRecord then
- RaiseMsg(20190720203028,nConstraintXSpecifiedMoreThanOnce,
- sConstraintXSpecifiedMoreThanOnce,['record'],ConEl);
- if IsClass then
- RaiseCannotBeTogether(20190720203039,'class','record');
- if IsConstructor then
- RaiseCannotBeTogether(20190720203056,'constructor','record');
- if LastType<>nil then
- RaiseCannotBeTogether(20190720205938,LastType.Name,'record');
- IsRecord:=true;
- end;
- tkconstructor:
- begin
- if IsConstructor then
- RaiseMsg(20190720203123,nConstraintXSpecifiedMoreThanOnce,
- sConstraintXSpecifiedMoreThanOnce,['constructor'],ConEl);
- if IsRecord then
- RaiseCannotBeTogether(20190720203148,'record','constructor');
- if LastType<>nil then
- RaiseCannotBeTogether(20190720210005,LastType.Name,'constructor');
- IsConstructor:=true;
- end;
- else
- if not (ConEl is TPasType) then
- RaiseXIsNotAValidConstraint(20190912215619,GetElementTypeName(ConEl));
- // type identifier: class, record or interface
- ComputeElement(ConEl,ResolvedEl,[rcType]);
- if ResolvedEl.BaseType<>btContext then
- RaiseXIsNotAValidConstraint(20190914105144,GetElementTypeName(ConEl));
- if IsRecord then
- RaiseCannotBeTogether(20190720210130,'record',ResolvedEl.HiTypeEl.Name);
- if IsClass then
- RaiseCannotBeTogether(20190720210202,'class',ResolvedEl.HiTypeEl.Name);
- if IsConstructor then
- RaiseCannotBeTogether(20190720210244,'constructor',ResolvedEl.HiTypeEl.Name);
- if ResolvedEl.LoTypeEl is TPasGenericTemplateType then
- begin
- if ResolvedEl.LoTypeEl=El then
- RaiseMsg(20200820185313,nTypeCycleFound,sTypeCycleFound,[],
- GetGenericConstraintErrorEl(ConEl,El));
- // ok
- if length(El.Constraints)>1 then
- RaiseXIsNotAValidConstraint(20190831213645,ResolvedEl.HiTypeEl.Name);
- end
- else if ResolvedEl.LoTypeEl is TPasMembersType then
- begin
- MemberType:=TPasMembersType(ResolvedEl.LoTypeEl);
- if MemberType is TPasClassType then
- begin
- aClass:=TPasClassType(MemberType);
- case aClass.ObjKind of
- okClass:
- begin
- // there can be at most one classtype constraint
- if LastType<>nil then
- RaiseCannotBeTogether(20190720210351,LastType.Name,MemberType.Name);
- end;
- okInterface:
- begin
- if LastType<>nil then
- begin
- // there can be multiple interfacetype constraint
- if not (LastType is TPasClassType) then
- RaiseCannotBeTogether(20190720211236,LastType.Name,MemberType.Name);
- if TPasClassType(LastType).ObjKind<>okInterface then
- RaiseCannotBeTogether(20190720211304,LastType.Name,MemberType.Name);
- end;
- end;
- else
- RaiseXIsNotAValidConstraint(20190720210919,MemberType.Name);
- end;
- end
- else
- RaiseXIsNotAValidConstraint(20190720210809,MemberType.Name);
- end
- else
- RaiseXIsNotAValidConstraint(20190720204604,GetResolverResultDescription(ResolvedEl,true));
- LastType:=ResolvedEl.LoTypeEl;
- end; // end of case
- end; // end of for
- end;
- procedure TPasResolver.FinishSpecializeType(El: TPasSpecializeType);
- var
- Params, GenericTemplateList: TFPList;
- P: TPasElement;
- DestType: TPasType;
- i, ScopeDepth: Integer;
- GenType: TPasGenericType;
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FinishSpecializeType ');
- {$ENDIF}
- // resolve Params
- ScopeDepth:=StashSubExprScopes;
- Params:=El.Params;
- if Params.Count=0 then
- RaiseMsg(20190724114416,nMissingParameterX,sMissingParameterX,['type'],El);
- for i:=0 to Params.Count-1 do
- begin
- P:=TPasElement(Params[i]);
- if P is TPasExpr then
- ResolveExpr(TPasExpr(P),rraRead)
- else if P is TPasType then
- else
- RaiseMsg(20190728113336,nXExpectedButYFound,sXExpectedButYFound,['type identifier',GetObjName(P)+' parameter '+IntToStr(i+1)],El);
- end;
- RestoreStashedScopes(ScopeDepth);
- // check DestType
- DestType:=El.DestType;
- if DestType=nil then
- RaiseMsg(20190725184734,nIdentifierNotFound,sIdentifierNotFound,['specialize type'],El)
- else if not (DestType is TPasGenericType) then
- RaiseMsg(20190725193552,nXExpectedButYFound,sXExpectedButYFound,['generic type',DestType.Name],El);
- GenType:=TPasGenericType(DestType);
- // Note: there can be TBird, TBird<T> and TBird<T,U>
- GenericTemplateList:=GenType.GenericTemplateTypes;
- if GenericTemplateList=nil then
- RaiseMsg(20190725194222,nWrongNumberOfParametersForGenericX,sWrongNumberOfParametersForGenericX,
- ['type '+DestType.Name],El);
- if GenericTemplateList.Count<>Params.Count then
- RaiseMsg(20190801222656,nWrongNumberOfParametersForGenericX,sWrongNumberOfParametersForGenericX,
- ['type '+DestType.Name],El);
- GetSpecializedEl(El,GenType,Params);
- end;
- procedure TPasResolver.FinishResourcestring(El: TPasResString);
- var
- ResolvedEl: TPasResolverResult;
- begin
- ResolveExpr(El.Expr,rraRead);
- ComputeElement(El.Expr,ResolvedEl,[rcConstant]);
- if not (ResolvedEl.BaseType in btAllStringAndChars) then
- RaiseXExpectedButYFound(20171004135753,'string',GetTypeDescription(ResolvedEl),El.Expr);
- end;
- procedure TPasResolver.FinishProcedure(Proc: TPasProcedure);
- var
- i: Integer;
- Body: TProcedureBody;
- SubEl: TPasElement;
- SubProcScope, ProcScope, DeclProcScope: TPasProcedureScope;
- SpecializedItem: TPRSpecializedItem;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishProcedure START');
- {$ENDIF}
- CheckTopScope(FScopeClass_Proc);
- ProcScope:=TPasProcedureScope(TopScope);
- if ProcScope.Element<>Proc then
- RaiseInternalError(20170220163043);
- SpecializedItem:=ProcScope.SpecializedFromItem;
- if SpecializedItem<>nil then
- begin
- if SpecializedItem.Step<prssImplementationBuilding then
- RaiseNotYetImplemented(20190920184908,Proc);
- if SpecializedItem.Step>prssImplementationBuilding then
- RaiseNotYetImplemented(20190920185123,Proc);
- end;
- Body:=Proc.Body;
- if Body<>nil then
- begin
- StoreScannerFlagsInProc(ProcScope);
- if Body.Body is TPasImplAsmStatement then
- Proc.Modifiers:=Proc.Modifiers+[pmAssembler];
- ResolveImplBlock(Body.Body);
- // check if all nested forward procs are resolved
- for i:=0 to Body.Declarations.Count-1 do
- begin
- SubEl:=TPasElement(Body.Declarations[i]);
- if (SubEl is TPasProcedure) and TPasProcedure(SubEl).IsForward then
- begin
- SubProcScope:=TPasProcedure(SubEl).CustomData as TPasProcedureScope;
- if SubProcScope.ImplProc=nil then
- RaiseMsg(20170216151613,nForwardProcNotResolved,sForwardProcNotResolved,
- [GetElementTypeName(SubEl),SubEl.Name],SubEl);
- end;
- end;
- if ProcScope.GroupScope<>nil then
- begin
- ProcScope.GroupScope.Free;
- ProcScope.GroupScope:=nil;
- if ProcScope.NestedMembersScope<>nil then
- begin
- for i:=0 to ScopeCount-1 do
- if Scopes[i]=ProcScope.NestedMembersScope then
- begin
- DeleteScope(i);
- break;
- end;
- ProcScope.NestedMembersScope.Free;
- ProcScope.NestedMembersScope:=nil;
- end;
- end;
- ProcScope.GenericStep:=psgsImplementationParsed;
- if ProcScope.DeclarationProc<>nil then
- begin
- DeclProcScope:=ProcScope.DeclarationProc.CustomData as TPasProcedureScope;
- DeclProcScope.GenericStep:=psgsImplementationParsed;
- end;
- end;
- if ProcScope.GroupScope<>nil then
- RaiseNotYetImplemented(20190122142142,Proc);
- if ProcScope.NestedMembersScope<>nil then
- RaiseNotYetImplemented(20191014233200,Proc);
- if TopScope.Element<>Proc then
- RaiseInternalError(20190806094032);
- PopScope;
- if ProcScope.GenericStep=psgsImplementationParsed then
- begin
- if ProcScope.DeclarationProc<>nil then
- ProcScope:=TPasProcedureScope(ProcScope.DeclarationProc.CustomData);
- if ProcScope.SpecializedItems<>nil then
- FinishSpecializations(ProcScope);
- end;
- end;
- procedure TPasResolver.FinishProcedureType(El: TPasProcedureType);
- var
- ProcName: String;
- FindData: TFindProcData;
- DeclProc, Proc, ParentProc: TPasProcedure;
- Abort, HasDots, IsClassConDestructor: boolean;
- DeclProcScope, ProcScope: TPasProcedureScope;
- ParentScope: TPasIdentifierScope;
- pm: TProcedureModifier;
- ptm: TProcTypeModifier;
- ObjKind: TPasObjKind;
- ParentBody: TProcedureBody;
- HelperForType: TPasType;
- Args, TemplTypes: TFPList;
- Arg: TPasArgument;
- ProcTypeScope: TPasProcTypeScope;
- C: TClass;
- FuncType: TPasFunctionType;
- begin
- if TopScope.Element=El then
- begin
- ProcTypeScope:=El.CustomData as TPasProcTypeScope;
- ProcTypeScope.GenericStep:=psgsImplementationParsed;
- PopScope;
- end;
- if El.Parent is TPasProcedure then
- Proc:=TPasProcedure(El.Parent)
- else
- Proc:=nil;
- if (Proc<>nil) and (Proc.ProcType=El) then
- begin
- // finished header of a procedure declaration
- CheckTopScope(FScopeClass_Proc);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDbg(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent));
- {$ENDIF}
- ProcName:=Proc.Name;
- ProcScope:=Proc.CustomData as TPasProcedureScope;
- TemplTypes:=GetProcTemplateTypes(Proc);
- if (TemplTypes<>nil) then
- begin
- // Proc is parametrized
- if (Proc is TPasConstructor) or (Proc is TPasDestructor) then
- RaiseMsg(20190911104114,nTypeParamsNotAllowedOnX,sTypeParamsNotAllowedOnX,
- [Proc.ElementTypeName],Proc);
- if Proc.IsVirtual or Proc.IsDynamic or Proc.IsMessage or Proc.IsOverride then
- RaiseMsg(20190911112925,nXMethodsCannotHaveTypeParams,
- sXMethodsCannotHaveTypeParams,['virtual, dynamic or message'],El);
- if Proc.IsOverride then
- RaiseMsg(20191016174218,nXMethodsCannotHaveTypeParams,
- sXMethodsCannotHaveTypeParams,['override'],El);
- if not (Proc.Visibility in [visDefault,visPrivate,visStrictPrivate,visProtected,visStrictProtected,visPublic]) then
- RaiseMsg(20191016174327,nXMethodsCannotHaveTypeParams,
- sXMethodsCannotHaveTypeParams,[VisibilityNames[Proc.Visibility]],El);
- end;
- if El is TPasFunctionType then
- begin
- FuncType:=TPasFunctionType(El);
- if FuncType.ResultEl<>nil then
- CheckUseAsType(FuncType.ResultEl.ResultType,20190123095743,FuncType.ResultEl);
- end;
- if (proProcTypeWithoutIsNested in Options) and El.IsNested then
- RaiseInvalidProcTypeModifier(20170402120811,El,ptmIsNested,El);
- ParentBody:=GetParentProcBody(Proc.Parent);
- if (ParentBody<>nil) then
- begin
- // nested sub proc
- if TemplTypes<>nil then
- RaiseMsg(20190912173450,nTypeParamsNotAllowedOnX,sTypeParamsNotAllowedOnX,
- ['nested '+Proc.ElementTypeName],Proc);
- if not (proProcTypeWithoutIsNested in Options) then
- El.IsNested:=true;
- // inherit 'of Object'
- ParentProc:=ParentBody.Parent as TPasProcedure;
- if ParentProc.ProcType.IsOfObject then
- El.IsOfObject:=true;
- end;
- if El.IsReferenceTo then
- begin
- if El.IsNested then
- RaiseInvalidProcTypeModifier(20170419142818,El,ptmIsNested,El);
- if El.IsOfObject then
- RaiseInvalidProcTypeModifier(20170419142844,El,ptmOfObject,El);
- end;
- if Proc.IsExternal then
- begin
- for pm in Proc.Modifiers do
- if not (pm in [pmVirtual, pmDynamic, pmOverride,
- pmOverload, pmMessage, pmReintroduce,
- pmExternal, pmDispId,
- pmfar]) then
- RaiseMsg(20170216151616,nInvalidXModifierY,
- sInvalidXModifierY,[GetElementTypeName(Proc),'external, '+ModifierNames[pm]],Proc);
- for ptm in Proc.ProcType.Modifiers do
- if not (ptm in [ptmOfObject,ptmIsNested,ptmStatic,ptmVarargs,ptmReferenceTo,ptmAsync]) then
- RaiseMsg(20170411171224,nInvalidXModifierY,
- sInvalidXModifierY,[GetElementTypeName(Proc),'external, '+ProcTypeModifiers[ptm]],Proc);
- end;
- if El.IsAsync then
- begin
- // async procedure
- C:=Proc.ClassType;
- if (C<>TPasProcedure)
- and (C<>TPasFunction)
- and (C<>TPasClassProcedure)
- and (C<>TPasClassFunction)
- and (C<>TPasAnonymousProcedure)
- and (C<>TPasAnonymousFunction) then
- RaiseMsg(20200524105449,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'async'],Proc);
- end;
- IsClassConDestructor:=(Proc.ClassType=TPasClassConstructor)
- or (Proc.ClassType=TPasClassDestructor);
- if IsClassConDestructor then
- begin
- // class constructor/destructor
- if Proc.IsVirtual then
- RaiseMsg(20181231150237,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'virtual'],Proc);
- if Proc.IsOverride then
- RaiseMsg(20181231150305,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'override'],Proc);
- if Proc.IsDynamic then
- RaiseMsg(20181231150319,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'dynamic'],Proc);
- if Proc.IsStatic then
- RaiseMsg(20190216214651,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'static'],Proc);
- if El.Args.Count>0 then
- RaiseMsg(20181231150404,nXCannotHaveParameters,sXCannotHaveParameters,[GetElementTypeName(Proc)],Proc);
- end;
- HasDots:=GetFirstDotPos(ProcName)>0;
- if Proc.Parent is TPasClassType then
- begin
- // method declaration
- ObjKind:=TPasClassType(Proc.Parent).ObjKind;
- case ObjKind of
- okInterface,okDispInterface:
- begin
- if Proc.IsVirtual then
- RaiseMsg(20180321234324,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
- if Proc.IsOverride then
- RaiseMsg(20180321234551,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
- if TemplTypes<>nil then
- RaiseMsg(20190912153024,nXMethodsCannotHaveTypeParams,sXMethodsCannotHaveTypeParams,['interface'],Proc);
- end;
- okClassHelper,okRecordHelper,okTypeHelper:
- begin
- if Proc.IsAbstract then
- RaiseMsg(20190116215744,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'abstract'],Proc);
- {if msDelphi in CurrentParser.CurrentModeswitches then
- begin
- // Delphi allows virtual/override in class helpers
- // But using them crashes in Delphi 10.3
- // -> do not support them
- end
- }
- if Proc.IsVirtual then
- RaiseMsg(20190116215823,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
- if Proc.IsOverride then
- RaiseMsg(20190116215825,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
- HelperForType:=ResolveAliasType(TPasClassType(Proc.Parent).HelperForType);
- if (not Proc.IsStatic) and IsClassMethod(Proc) and not IsClassConDestructor then
- begin
- // non static class methods require a class
- if (not (HelperForType.ClassType=TPasClassType))
- or (TPasClassType(HelperForType).ObjKind<>okClass) then
- RaiseMsg(20190201153831,nClassMethodsMustBeStaticInX,sClassMethodsMustBeStaticInX,[ObjKindNames[ObjKind]],Proc);
- end;
- if Proc.ClassType=TPasDestructor then
- RaiseMsg(20190302151019,nXIsNotSupported,sXIsNotSupported,['destructor'],Proc);
- if (Proc.ClassType=TPasConstructor)
- and (HelperForType.ClassType=TPasClassType)
- and (TPasClassType(HelperForType).ObjKind<>okClass) then
- RaiseMsg(20190302151514,nXIsNotSupported,sXIsNotSupported,['constructor'],Proc);
- end;
- end;
- if Proc.IsAbstract then
- begin
- if not Proc.IsVirtual then
- RaiseMsg(20170216151623,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'abstract without virtual'],Proc);
- if Proc.IsOverride then
- RaiseMsg(20170216151625,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'abstract, override'],Proc);
- end;
- if Proc.IsVirtual and Proc.IsOverride then
- RaiseMsg(20170216151627,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'virtual, override'],Proc);
- if Proc.IsReintroduced and Proc.IsOverride then
- RaiseMsg(20171119111845,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'reintroduce, override'],Proc);
- if Proc.IsForward then
- RaiseMsg(20170216151629,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'forward'],Proc);
- if Proc.IsStatic then
- if (Proc.ClassType<>TPasClassProcedure) and (Proc.ClassType<>TPasClassFunction) then
- RaiseMsg(20170216151631,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'static'],Proc);
- end
- else if Proc.Parent is TPasRecordType then
- begin
- if (Proc.ClassType=TPasConstructor)
- and ((El.Args.Count=0)
- or (TPasArgument(El.Args[0]).ValueExpr<>nil)) then
- RaiseMsg(20181226231333,nParameterlessConstructorsNotAllowedInRecords,
- sParameterlessConstructorsNotAllowedInRecords,[],El);
- if Proc.IsReintroduced then
- RaiseMsg(20181218195735,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'reintroduce'],Proc);
- if Proc.IsVirtual then
- RaiseMsg(20181218195431,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'virtual'],Proc);
- if Proc.IsOverride then
- RaiseMsg(20181218195437,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'override'],Proc);
- if Proc.IsAbstract then
- RaiseMsg(20181218195552,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'abstract'],Proc);
- if Proc.IsForward then
- RaiseMsg(20181218195514,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'forward'],Proc);
- if IsClassMethod(Proc) and not IsClassConDestructor then
- begin
- // Note: class constructor/destructor must not be static
- if not Proc.IsStatic then
- RaiseMsg(20190106121503,nClassMethodsMustBeStaticInX,sClassMethodsMustBeStaticInX,['records'],Proc);
- end
- else if Proc.IsStatic then
- RaiseMsg(20190206150922,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),'static'],Proc);
- end
- else
- begin
- // intf proc, forward proc, proc body, method body, anonymous proc
- if Proc.IsAbstract then
- RaiseInvalidProcModifier(20170216151634,Proc,pmAbstract,Proc);
- if Proc.IsVirtual then
- RaiseInvalidProcModifier(20170216151635,Proc,pmVirtual,Proc);
- if Proc.IsOverride then
- RaiseInvalidProcModifier(20170216151637,Proc,pmOverride,Proc);
- if Proc.IsMessage then
- RaiseInvalidProcModifier(20170216151638,Proc,pmMessage,Proc);
- if Proc.IsStatic and not HasDots then
- RaiseInvalidProcTypeModifier(20170216151640,El,ptmStatic,El);
- if (not HasDots)
- and (Proc.GetProcTypeEnum in [
- ptClassOperator,
- ptConstructor, ptDestructor,
- ptClassProcedure, ptClassFunction,
- ptClassConstructor, ptClassDestructor
- ]) then
- RaiseXExpectedButYFound(20170419232724,'full method name','short name',El);
- end;
- ProcScope.GenericStep:=psgsInterfaceParsed;
- if HasDots then
- begin
- FinishMethodImplHeader(Proc);
- exit;
- end;
- // finish interface/implementation/nested procedure/method declaration
- if (ProcName='')
- and not (Proc.GetProcTypeEnum in [ptAnonymousProcedure,ptAnonymousFunction]) then
- RaiseNotYetImplemented(20160922163407,El);
- if (El is TPasFunctionType) and not (ppsfIsSpecialized in ProcScope.Flags) then
- EmitTypeHints(TPasFunctionType(El).ResultEl,TPasFunctionType(El).ResultEl.ResultType);
- if Proc.PublicName<>nil then
- ResolveExpr(Proc.PublicName,rraRead);
- if Proc.LibraryExpr<>nil then
- ResolveExpr(Proc.LibraryExpr,rraRead);
- if Proc.LibrarySymbolName<>nil then
- ResolveExpr(Proc.LibrarySymbolName,rraRead);
- if Proc.DispIDExpr<>nil then
- ResolveExpr(Proc.DispIDExpr,rraRead);
- if Proc.MessageExpr<>nil then
- begin
- // message modifier
- ResolveExpr(Proc.MessageExpr,rraRead);
- Args:=Proc.ProcType.Args;
- if Args.Count<>1 then
- RaiseMsg(20190303223701,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El);
- Arg:=TPasArgument(Args[0]);
- if not (Arg.Access in [argVar,argOut]) then
- RaiseMsg(20190303223834,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El);
- if (Proc.ClassType<>TPasProcedure)
- and (Proc.ClassType<>TPasFunction) then
- RaiseMsg(20190303224128,nXExpectedButYFound,sXExpectedButYFound,['procedure name(var Msg);message id;',GetElementTypeName(El)],El);
- end;
- if Proc.Parent is TPasMembersType then
- begin
- FinishMethodDeclHeader(Proc);
- exit;
- end;
- // finish interface/implementation/nested procedure
- if (ProcName<>'') and ProcNeedsBody(Proc) then
- begin
- if ppsfIsSpecialized in ProcScope.Flags then
- begin
- if ProcScope.DeclarationProc<>nil then
- ReplaceProcScopeImplArgsWithDeclArgs(ProcScope);
- end
- else
- begin
- // check if there is a forward declaration
- //writeln('TPasResolver.FinishProcedureType ',GetObjName(TopScope),' ',GetObjName(Scopes[ScopeCount-2]));
- ParentScope:=GetParentLocalScope as TPasIdentifierScope;
- //writeln('TPasResolver.FinishProcedureType FindForward2 ParentScope=',GetObjName(ParentScope),'=',GetObjName(ParentScope.Element),' Proc=',GetObjName(Proc),' at ',GetElementSourcePosStr(Proc));
- DeclProc:=FindProcSameSignature(ProcName,Proc,ParentScope,true);
- //writeln('TPasResolver.FinishProcedureType FindForward3 DeclProc=',GetObjName(DeclProc),' Proc.Parent=',GetObjName(Proc.Parent));
- //if DeclProc<>nil then writeln('TPasResolver.FinishProcedureType DeclProc at ',GetElementSourcePosStr(DeclProc));
- if (DeclProc=nil) and (Proc.Parent.ClassType=TImplementationSection) then
- DeclProc:=FindProcSameSignature(ProcName,Proc,
- (Proc.GetModule.InterfaceSection.CustomData) as TPasIdentifierScope,true);
- //writeln('TPasResolver.FinishProcedureType FindForward4 ',GetObjName(DeclProc),' at ',GetElementSourcePosStr(DeclProc));
- if (DeclProc<>nil) then
- begin
- if ProcNeedsImplProc(DeclProc) then
- begin
- // found forward declaration
- DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
- if DeclProcScope.ImplProc<>nil then
- RaiseMsg(20180318222430,nDuplicateIdentifier,sDuplicateIdentifier,
- [DeclProcScope.ImplProc.Name,GetElementSourcePosStr(DeclProcScope.ImplProc)],Proc);
- // connect
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishProcedureHeader forward found: Proc2=',GetTreeDbg(DeclProc),' ',GetElementSourcePosStr(DeclProc),' IsForward=',DeclProc.IsForward,' Parent=',GetObjName(DeclProc.Parent));
- {$ENDIF}
- CheckProcSignatureMatch(DeclProc,Proc,false);
- DeclProcScope.ImplProc:=Proc;
- if DeclProc.IsAssembler then
- Proc.Modifiers:=Proc.Modifiers+[pmAssembler];
- ProcScope.DeclarationProc:=DeclProc;
- // remove ImplProc from scope
- ParentScope.RemoveLocalIdentifier(Proc);
- // replace arguments with declaration arguments
- ReplaceProcScopeImplArgsWithDeclArgs(ProcScope);
- exit;
- end
- else
- RaiseMsg(20180318220543,nDuplicateIdentifier,sDuplicateIdentifier,
- [DeclProc.Name,GetElementSourcePosStr(DeclProc)],Proc);
- end;
- end;
- end
- else
- begin
- // forward declaration
- // ToDo: store the scanner flags *before* it has parsed the token after the proc
- StoreScannerFlagsInProc(ProcScope);
- end;
- if ProcName<>'' then
- begin
- // check for invalid overloads
- FindData:=Default(TFindProcData);
- FindData.Proc:=Proc;
- FindData.Args:=Proc.ProcType.Args;
- FindData.Kind:=fpkProc;
- Abort:=false;
- IterateElements(ProcName,@OnFindProc,@FindData,Abort);
- end;
- end
- else if El.Name<>'' then
- begin
- // finished proc type, e.g. type TProcedure = procedure;
- end
- else
- RaiseNotYetImplemented(20160922163411,El.Parent,'anonymous procedure type');
- end;
- procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure);
- procedure VisibilityLowered(Proc, OverloadProc: TPasProcedure);
- begin
- LogMsg(20170325004215,mtNote,nVirtualMethodXHasLowerVisibility,
- sVirtualMethodXHasLowerVisibility,[Proc.Name,
- VisibilityNames[Proc.Visibility],OverloadProc.Parent.Name,
- VisibilityNames[OverloadProc.Visibility]],Proc);
- Proc.Visibility:=OverloadProc.Visibility;
- end;
- {$IF defined(fpc) and (FPC_FULLVERSION<30101)}
- procedure Delete(var A: TArrayOfPasProcedure; Index, Count: integer); overload;
- var
- i: Integer;
- begin
- if Index<0 then
- RaiseInternalError(20171227121538);
- if Index+Count>length(A) then
- RaiseInternalError(20171227121156);
- for i:=Index+Count to length(A)-1 do
- A[i-Count]:=A[i];
- SetLength(A,length(A)-Count);
- end;
- procedure Insert(Item: TPasProcedure; var A: TArrayOfPasProcedure; Index: integer); overload;
- var
- i: Integer;
- begin
- if Index<0 then
- RaiseInternalError(20171227121544);
- if Index>length(A) then
- RaiseInternalError(20171227121558);
- SetLength(A,length(A)+1);
- for i:=length(A)-1 downto Index+1 do
- A[i]:=A[i-1];
- A[Index]:=Item;
- end;
- {$ENDIF}
- var
- Abort, IsClassConDestructor: boolean;
- ClassOrRecScope: TPasClassOrRecordScope;
- FindData: TFindProcData;
- OverloadProc: TPasProcedure;
- ProcScope: TPasProcedureScope;
- i: Integer;
- ParentScope: TPasScope;
- TemplTypes: TFPList;
- ClassRecType: TPasMembersType;
- begin
- if not (ptmStatic in Proc.ProcType.Modifiers) then
- Proc.ProcType.IsOfObject:=true;
- ProcScope:=TopScope as TPasProcedureScope;
- ParentScope:=Scopes[ScopeCount-2];
- // ToDo: store the scanner flags *before* it has parsed the token after the proc
- StoreScannerFlagsInProc(ProcScope);
- ClassRecType:=TPasMembersType(Proc.Parent);
- ClassOrRecScope:=ClassRecType.CustomData as TPasClassOrRecordScope;
- ProcScope.ClassRecScope:=ClassOrRecScope;
- TemplTypes:=GetProcTemplateTypes(Proc);
- FindData:=Default(TFindProcData);
- IsClassConDestructor:=(Proc.ClassType=TPasClassConstructor)
- or (Proc.ClassType=TPasClassDestructor);
- if IsClassConDestructor then
- begin
- if TemplTypes<>nil then
- RaiseNotYetImplemented(20190911105953,Proc);
- end
- else
- begin
- FindData.Proc:=Proc;
- FindData.Args:=Proc.ProcType.Args;
- FindData.Kind:=fpkMethod;
- Abort:=false;
- ParentScope.IterateElements(Proc.Name,ClassOrRecScope,
- @OnFindProc,@FindData,Abort);
- end;
- if FindData.Found=nil then
- begin
- // no overload
- if Proc.IsOverride then
- RaiseMsg(20170216151702,nNoMethodInAncestorToOverride,
- sNoMethodInAncestorToOverride,[GetProcTypeDescription(Proc.ProcType)],Proc.ProcType);
- end
- else
- begin
- // overload found
- OverloadProc:=FindData.Found;
- // Note: 'inherited;' needs the OverriddenProc, even without 'override' modifier
- ProcScope.OverriddenProc:=OverloadProc;
- if Proc.IsOverride then
- begin
- if (not OverloadProc.IsVirtual) and (not OverloadProc.IsOverride) then
- // the OverloadProc fits the signature, but is not virtual
- RaiseMsg(20170216151708,nNoMethodInAncestorToOverride,
- sNoMethodInAncestorToOverride,[GetProcTypeDescription(Proc.ProcType)],Proc.ProcType);
- // override a virtual method
- CheckProcSignatureMatch(OverloadProc,Proc,true);
- // check visibility
- if Proc.Visibility<>OverloadProc.Visibility then
- case Proc.Visibility of
- visPrivate,visStrictPrivate:
- if not (OverloadProc.Visibility in [visPrivate,visStrictPrivate]) then
- VisibilityLowered(Proc,OverloadProc);
- visProtected,visStrictProtected:
- if not (OverloadProc.Visibility in [visPrivate,visProtected,visStrictPrivate,visStrictProtected]) then
- VisibilityLowered(Proc,OverloadProc);
- visPublic:
- if not (OverloadProc.Visibility in [visPrivate..visPublic,visStrictPrivate,visStrictProtected]) then
- VisibilityLowered(Proc,OverloadProc);
- visPublished: ;
- else
- RaiseNotYetImplemented(20170325003315,Proc,'visibility');
- end;
- // check name case
- if proFixCaseOfOverrides in Options then
- Proc.Name:=OverloadProc.Name;
- // remove abstract
- if OverloadProc.IsAbstract and (ClassOrRecScope is TPasClassScope) then
- for i:=length(TPasClassScope(ClassOrRecScope).AbstractProcs)-1 downto 0 do
- if TPasClassScope(ClassOrRecScope).AbstractProcs[i]=OverloadProc then
- Delete(TPasClassScope(ClassOrRecScope).AbstractProcs,i,1);
- end;
- end;
- // add abstract
- if Proc.IsAbstract and (ClassOrRecScope is TPasClassScope) then
- Insert(Proc,TPasClassScope(ClassOrRecScope).AbstractProcs,
- length(TPasClassScope(ClassOrRecScope).AbstractProcs));
- CreateProcSelfArg(Proc);
- end;
- procedure TPasResolver.FinishMethodImplHeader(ImplProc: TPasProcedure);
- var
- ProcName: String;
- ImplProcScope, DeclProcScope: TPasProcedureScope;
- DeclProc: TPasProcedure;
- ClassOrRecScope: TPasClassOrRecordScope;
- SelfArg: TPasArgument;
- LastNamePart: TProcedureNamePart;
- begin
- if ImplProc.IsExternal then
- RaiseMsg(20170216151715,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(ImplProc),'external'],ImplProc);
- if ImplProc.IsExported then
- RaiseMsg(20170216151717,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(ImplProc),'export'],ImplProc);
- ProcName:=ImplProc.Name;
- ImplProcScope:=ImplProc.CustomData as TPasProcedureScope;
- ClassOrRecScope:=ImplProcScope.ClassRecScope;
- if ClassOrRecScope=nil then
- RaiseInternalError(20161013172346);
- if ImplProcScope.GroupScope=nil then
- RaiseInternalError(20190120135017);
- if ImplProc.NameParts<>nil then
- begin
- LastNamePart:=TProcedureNamePart(ImplProc.NameParts[ImplProc.NameParts.Count-1]);
- ProcName:=LastNamePart.Name;
- end
- else
- begin
- // remove path from ProcName
- ProcName:=LastDottedIdentifier(ProcName);
- end;
- DeclProc:=nil;
- DeclProcScope:=nil;
- if ImplProcScope.DeclarationProc=nil then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishMethodImplHeader searching declaration "',ImplProc.Name,'" ...');
- {$ENDIF}
- // search ImplProc in class
- if not IsValidIdent(ProcName) then
- RaiseNotYetImplemented(20160922163421,ImplProc.ProcType);
- // search proc in class/record
- if ImplProc.ClassType=TPasClassConstructor then
- DeclProc:=ClassOrRecScope.ClassConstructor
- else if ImplProc.ClassType=TPasClassDestructor then
- DeclProc:=ClassOrRecScope.ClassDestructor
- else
- DeclProc:=FindProcSameSignature(ProcName,ImplProc,ClassOrRecScope,false);
- if DeclProc=nil then
- RaiseIdentifierNotFound(20170216151720,GetProcName(ImplProc),ImplProc.ProcType);
- DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
- ImplProc.ProcType.IsOfObject:=DeclProc.ProcType.IsOfObject;
- // connect method declaration and body
- if DeclProcScope.ImplProc<>nil then
- RaiseMsg(20180212094546,nDuplicateIdentifier,sDuplicateIdentifier,
- [DeclProcScope.ImplProc.Name,GetElementSourcePosStr(DeclProcScope.ImplProc)],
- ImplProc);
- if DeclProc.IsAbstract then
- RaiseMsg(20170216151722,nAbstractMethodsMustNotHaveImplementation,sAbstractMethodsMustNotHaveImplementation,[],ImplProc);
- if DeclProc.IsExternal then
- RaiseXExpectedButYFound(20170216151725,'method','external method',ImplProc);
- CheckProcSignatureMatch(DeclProc,ImplProc,false);
- if DeclProc.IsAssembler then
- ImplProc.Modifiers:=ImplProc.Modifiers+[pmAssembler];
- ImplProcScope.DeclarationProc:=DeclProc;
- DeclProcScope.ImplProc:=ImplProc;
- // replace arguments in scope with declaration arguments
- ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope);
- end
- else if ppsfIsSpecialized in ImplProcScope.Flags then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishMethodImplHeader specialized "',ImplProc.Name,'" ...');
- {$ENDIF}
- DeclProc:=ImplProcScope.DeclarationProc;
- DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
- if DeclProcScope.ImplProc<>ImplProc then
- RaiseNotYetImplemented(20190804182220,ImplProc);
- // replace arguments in scope with declaration arguments
- ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope);
- end
- else
- RaiseNotYetImplemented(20190804181222,ImplProc);
- SelfArg:=DeclProcScope.SelfArg;
- if SelfArg<>nil then
- begin
- // add 'Self'
- ImplProcScope.SelfArg:=SelfArg;
- SelfArg.AddRef{$IFDEF CheckPasTreeRefCount}('TPasProcedureScope.SelfArg'){$ENDIF};
- {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
- AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishMethodImplHeader END "',ImplProc.Name,'" ...');
- {$ENDIF}
- end;
- procedure TPasResolver.FinishExceptOnExpr;
- var
- El: TPasImplExceptOn;
- ResolvedType: TPasResolverResult;
- TypeEl: TPasType;
- begin
- CheckTopScope(TPasExceptOnScope);
- El:=TPasImplExceptOn(FTopScope.Element);
- TypeEl:=El.TypeEl;
- ComputeElement(TypeEl,ResolvedType,[rcType]);
- CheckIsClass(TypeEl,ResolvedType);
- end;
- procedure TPasResolver.FinishExceptOnStatement;
- begin
- //writeln('TPasResolver.FinishExceptOnStatement START');
- CheckTopScope(TPasExceptOnScope);
- ResolveImplElement(TPasImplExceptOn(FTopScope.Element).Body);
- PopScope;
- end;
- procedure TPasResolver.FinishWithDo(El: TPasImplWithDo);
- begin
- PopWithScope(El);
- end;
- procedure TPasResolver.FinishForLoopHeader(Loop: TPasImplForLoop);
- var
- VarResolved, StartResolved, EndResolved,
- OrigStartResolved: TPasResolverResult;
- EnumeratorFound, HasInValues: Boolean;
- InRange, VarRange: TResEvalValue;
- InRangeInt, VarRangeInt: TResEvalRangeInt;
- bt: TResolverBaseType;
- TypeEl, ElType: TPasType;
- C: TClass;
- begin
- CreateScope(Loop,TPasForLoopScope);
- // loop var
- ResolveExpr(Loop.VariableName,rraReadAndAssign);
- ComputeElement(Loop.VariableName,VarResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
- if not ResolvedElCanBeVarParam(VarResolved,Loop.VariableName) then
- RaiseVarExpected(20170216151955,Loop.VariableName,VarResolved.IdentEl);
- // resolve start expression
- ResolveExpr(Loop.StartExpr,rraRead);
- ComputeElement(Loop.StartExpr,StartResolved,[rcSetReferenceFlags]);
- case Loop.LoopType of
- ltNormal,ltDown:
- begin
- // start value
- if CheckAssignResCompatibility(VarResolved,StartResolved,Loop.StartExpr,true)=cIncompatible then
- RaiseIncompatibleTypeRes(20170216151958,nIncompatibleTypesGotExpected,
- [],StartResolved,VarResolved,Loop.StartExpr);
- CheckAssignExprRange(VarResolved,Loop.StartExpr);
- // end value
- ResolveExpr(Loop.EndExpr,rraRead);
- ComputeElement(Loop.EndExpr,EndResolved,[rcSetReferenceFlags]);
- if CheckAssignResCompatibility(VarResolved,EndResolved,Loop.EndExpr,false)=cIncompatible then
- RaiseIncompatibleTypeRes(20170216152001,nIncompatibleTypesGotExpected,
- [],EndResolved,VarResolved,Loop.EndExpr);
- CheckAssignExprRange(VarResolved,Loop.EndExpr);
- end;
- ltIn:
- begin
- // check range
- EnumeratorFound:=CheckForIn(Loop,VarResolved,StartResolved);
- if (not EnumeratorFound)
- and not (StartResolved.IdentEl is TPasType)
- and (rrfReadable in StartResolved.Flags) then
- begin
- EnumeratorFound:=CheckForInClassOrRec(Loop,VarResolved,StartResolved);
- end;
- if not EnumeratorFound then
- begin
- VarRange:=nil;
- InRange:=nil;
- try
- OrigStartResolved:=StartResolved;
- if StartResolved.IdentEl is TPasType then
- begin
- // e.g. for e in TEnum do
- TypeEl:=StartResolved.LoTypeEl;
- if TypeEl is TPasArrayType then
- begin
- if length(TPasArrayType(TypeEl).Ranges)=1 then
- InRange:=Eval(TPasArrayType(TypeEl).Ranges[0],[refConst]);
- end;
- if InRange=nil then
- InRange:=EvalTypeRange(TypeEl,[]);
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if InRange<>nil then
- writeln('TPasResolver.ResolveImplForLoop in type: InRange=',InRange.AsDebugString)
- else
- writeln('TPasResolver.ResolveImplForLoop in type: InRange=nil');
- {AllowWriteln-}
- {$ENDIF}
- end
- else if rrfReadable in StartResolved.Flags then
- begin
- // value (variable or expression)
- bt:=StartResolved.BaseType;
- if bt in [btSet,btArrayOrSet] then
- begin
- if (StartResolved.IdentEl=nil) and (StartResolved.ExprEl<>nil) then
- InRange:=Eval(StartResolved.ExprEl,[]);
- if InRange=nil then
- InRange:=EvalTypeRange(StartResolved.LoTypeEl,[]);
- end
- else if bt=btContext then
- begin
- TypeEl:=StartResolved.LoTypeEl;
- C:=TypeEl.ClassType;
- if C=TPasArrayType then
- begin
- ElType:=GetArrayElType(TPasArrayType(TypeEl));
- ComputeElement(ElType,StartResolved,[rcType]);
- StartResolved.Flags:=OrigStartResolved.Flags*[rrfReadable,rrfWritable];
- if CheckAssignResCompatibility(VarResolved,StartResolved,Loop.StartExpr,true)=cIncompatible then
- RaiseIncompatibleTypeRes(20171112210138,nIncompatibleTypesGotExpected,
- [],StartResolved,VarResolved,Loop.StartExpr);
- EnumeratorFound:=true;
- end;
- end
- else
- begin
- bt:=GetActualBaseType(bt);
- case bt of
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiString:
- InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff);
- {$endif}
- btUnicodeString:
- InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ffff);
- end;
- end;
- end;
- if (not EnumeratorFound) and (InRange<>nil) then
- begin
- // for v in <constant> do
- // -> check if same type
- VarRange:=EvalTypeRange(VarResolved.LoTypeEl,[]);
- if VarRange=nil then
- RaiseXExpectedButYFound(20171109191528,'range',
- GetResolverResultDescription(VarResolved),Loop.VariableName);
- //writeln('TPasResolver.ResolveImplForLoop ForIn VarRange=',VarRange.AsDebugString);
- //writeln('TPasResolver.ResolveImplForLoop ForIn InRange=',InRange.AsDebugString,' ElType=',GetResolverResultDbg(StartResolved));
- case InRange.Kind of
- revkRangeInt,revkSetOfInt:
- begin
- InRangeInt:=TResEvalRangeInt(InRange);
- case VarRange.Kind of
- revkRangeInt:
- begin
- VarRangeInt:=TResEvalRangeInt(VarRange);
- HasInValues:=(InRange.Kind<>revkSetOfInt) or (length(TResEvalSet(InRange).Ranges)>0);
- case InRangeInt.ElKind of
- revskEnum:
- if (VarRangeInt.ElKind<>revskEnum)
- or not IsSameType(InRangeInt.ElType,VarRangeInt.ElType,prraAlias) then
- RaiseXExpectedButYFound(20171109200752,GetTypeDescription(InRangeInt.ElType),
- GetResolverResultDescription(VarResolved,true),loop.VariableName);
- revskInt:
- if VarRangeInt.ElKind<>revskInt then
- RaiseXExpectedButYFound(20171109200752,'integer',
- GetResolverResultDescription(VarResolved,true),loop.VariableName);
- revskChar:
- if VarRangeInt.ElKind<>revskChar then
- RaiseXExpectedButYFound(20171109200753,'char',
- GetResolverResultDescription(VarResolved,true),loop.VariableName);
- revskBool:
- if VarRangeInt.ElKind<>revskBool then
- RaiseXExpectedButYFound(20171109200754,'boolean',
- GetResolverResultDescription(VarResolved,true),loop.VariableName);
- else
- if HasInValues then
- RaiseNotYetImplemented(20171109200954,Loop.StartExpr);
- end;
- if HasInValues then
- begin
- if (VarRangeInt.RangeStart>InRangeInt.RangeStart) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRangeInt.AsDebugString,' ',InRangeInt.AsDebugString);
- {$ENDIF}
- fExprEvaluator.EmitRangeCheckConst(20171109201428,
- InRangeInt.ElementAsString(InRangeInt.RangeStart),
- VarRangeInt.ElementAsString(VarRangeInt.RangeStart),
- VarRangeInt.ElementAsString(VarRangeInt.RangeEnd),Loop.VariableName,mtError);
- end;
- if (VarRangeInt.RangeEnd<InRangeInt.RangeEnd) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRangeInt.AsDebugString,' ',InRangeInt.AsDebugString);
- {$ENDIF}
- fExprEvaluator.EmitRangeCheckConst(20171109201429,
- InRangeInt.ElementAsString(InRangeInt.RangeEnd),
- VarRangeInt.ElementAsString(VarRangeInt.RangeStart),
- VarRangeInt.ElementAsString(VarRangeInt.RangeEnd),Loop.VariableName,mtError);
- end;
- end;
- EnumeratorFound:=true;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplForLoop ForIn VarRange=',VarRange.AsDebugString);
- {$ENDIF}
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplForLoop ForIn InRange=',InRange.AsDebugString);
- {$ENDIF}
- end;
- end;
- if not EnumeratorFound then
- begin
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- writeln('TPasResolver.ResolveImplForLoop StartResolved=',GetResolverResultDbg(StartResolved));
- if VarRange<>nil then
- writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRange.AsDebugString);
- {AllowWriteln-}
- {$ENDIF}
- RaiseMsg(20171108223818,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
- [GetBaseDescription(OrigStartResolved)],Loop.StartExpr);
- end;
- finally
- ReleaseEvalValue(VarRange);
- ReleaseEvalValue(InRange);
- end;
- end;
- end;
- else
- RaiseNotYetImplemented(20171108221334,Loop);
- end;
- end;
- procedure TPasResolver.FinishDeclaration(El: TPasElement);
- var
- C: TClass;
- begin
- C:=El.ClassType;
- if (C=TPasVariable) or (C=TPasConst) then
- FinishVariable(TPasVariable(El))
- else if C=TPasProperty then
- FinishProperty(TPasProperty(El))
- else if C=TPasArgument then
- FinishArgument(TPasArgument(El))
- else if C=TPasMethodResolution then
- FinishMethodResolution(TPasMethodResolution(El))
- else if C=TPasAttributes then
- FinishAttributes(TPasAttributes(El))
- else if C=TPasExportSymbol then
- FinishExportSymbol(TPasExportSymbol(El))
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishDeclaration ',GetObjName(El));
- {$ENDIF}
- RaiseNotYetImplemented(20180127121557,El);
- end;
- end;
- procedure TPasResolver.FinishVariable(El: TPasVariable);
- var
- ResolvedAbs: TPasResolverResult;
- C: TClass;
- Value: TResEvalValue;
- begin
- if (El.Visibility=visPublished) then
- begin
- if [vmClass,vmStatic,vmCVar]*El.VarModifiers<>[] then
- RaiseMsg(20170403223837,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El);
- end;
- if El.Expr<>nil then
- ResolveExpr(El.Expr,rraRead);
- if El.VarType<>nil then
- begin
- if (El.Parent is TPasRecordType) and (El.VarType=El.Parent) then
- RaiseMsg(20181218173631,nTypeXIsNotYetCompletelyDefined,
- sTypeXIsNotYetCompletelyDefined,[El.VarType.Name],El);
- CheckUseAsType(El.VarType,20190123095916,El);
- if El.Expr<>nil then
- CheckAssignCompatibility(El,El.Expr,true);
- if El.VarType.Parent=El then
- FinishSubElementType(El,El.VarType);
- end
- else if El.Expr<>nil then
- begin
- // no VarType, has Expr, e.g. const a = Expr
- Value:=Eval(El.Expr,[refConstExt]); // e.g. const Tau = 2*PI
- ReleaseEvalValue(Value);
- end;
- if El.AbsoluteExpr<>nil then
- begin
- if El.ClassType=TPasConst then
- RaiseMsg(20180201225530,nXModifierMismatchY,sXModifierMismatchY,
- ['absolute','const'],El.AbsoluteExpr);
- if El.VarType=nil then
- RaiseMsg(20171225235125,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
- if vmExternal in El.VarModifiers then
- RaiseMsg(20171226104221,nXModifierMismatchY,sXModifierMismatchY,
- ['absolute','external'],El.AbsoluteExpr);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishVariable El=',GetObjName(El),' Absolute="',GetObjName(El.AbsoluteExpr),'"');
- {$ENDIF}
- ResolveExpr(El.AbsoluteExpr,rraRead);
- ComputeElement(El.AbsoluteExpr,ResolvedAbs,[rcNoImplicitProc]);
- if (not (rrfReadable in ResolvedAbs.Flags))
- or (ResolvedAbs.IdentEl=nil) then
- RaiseVarExpected(20171225234734,El.AbsoluteExpr,ResolvedAbs.IdentEl);
- C:=ResolvedAbs.IdentEl.ClassType;
- if (C=TPasVariable)
- or (C=TPasArgument)
- or ((C=TPasConst) and (TPasConst(ResolvedAbs.IdentEl).VarType<>nil)) then
- else
- RaiseMsg(20171225235203,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
- if not (rrfReadable in ResolvedAbs.Flags) then
- RaiseVarExpected(20171225235249,El.AbsoluteExpr,ResolvedAbs.IdentEl);
- // check for cycles
- if ResolvedAbs.IdentEl=El then
- RaiseMsg(20171226000703,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
- end;
- if El.VarType<>nil then
- EmitTypeHints(El,El.VarType);
- end;
- procedure TPasResolver.FinishProperty(PropEl: TPasProperty);
- var
- PropType: TPasType;
- ClassOrRecScope: TPasClassOrRecordScope;
- ClassScope: TPasClassScope;
- AncestorProp: TPasProperty;
- IndexExpr: TPasExpr;
- procedure GetPropType;
- var
- AncEl: TPasElement;
- GroupScope: TPasGroupScope;
- begin
- if PropType<>nil then exit;
- AncEl:=nil;
- if (ClassScope<>nil) and (ClassScope.AncestorScope<>nil) then
- begin
- CheckTopScope(TPasGroupScope);
- GroupScope:=TPasGroupScope(TopScope);
- AncEl:=GroupScope.FindAncestorElement(PropEl.Name);
- end;
- if AncEl is TPasProperty then
- begin
- // override or redeclaration property
- AncestorProp:=TPasProperty(AncEl);
- TPasPropertyScope(PropEl.CustomData).AncestorProp:=AncestorProp;
- if proFixCaseOfOverrides in Options then
- PropEl.Name:=AncestorProp.Name;
- end
- else
- AncestorProp:=nil;
- if PropEl.VarType<>nil then
- begin
- // new property or redeclaration
- PropType:=PropEl.VarType;
- CheckUseAsType(PropEl.VarType,20190123100011,PropEl);
- end
- else
- begin
- // property override
- if AncestorProp=nil then
- RaiseMsg(20170216151741,nNoPropertyFoundToOverride,sNoPropertyFoundToOverride,[],PropEl);
- // check property versus class property
- if PropEl.ClassType<>AncestorProp.ClassType then
- RaiseXExpectedButYFound(20170216151744,GetElementTypeName(AncestorProp),GetElementTypeName(PropEl),PropEl);
- // get inherited type
- PropType:=GetPasPropertyType(AncestorProp);
- // update DefaultProperty
- if ClassScope=nil then
- RaiseNotYetImplemented(20181231130642,PropEl);
- if ClassScope.DefaultProperty=AncestorProp then
- ClassScope.DefaultProperty:=PropEl;
- end;
- end;
- function CheckClassAccessorStatic(ProcIsStatic: boolean): boolean;
- begin
- if ClassScope=nil then
- // record: class getter/setter must be static
- Result:=ProcIsStatic=true
- else if proClassPropertyNonStatic in Options then
- Result:=true // both allowed
- else
- Result:=ProcIsStatic=true;
- end;
- procedure CheckIndexArg(ArgNo: integer; const IndexResolved: TPasResolverResult;
- ProcArg: TPasArgument; ErrorEl: TPasElement);
- var
- ProcArgResolved: TPasResolverResult;
- begin
- // check access: const, ...
- if not (ProcArg.Access in [argDefault,argConst]) then
- RaiseMsg(20170924202437,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),AccessDescriptions[ProcArg.Access],
- AccessDescriptions[argConst]],ErrorEl);
- // check argument type
- if ProcArg.ArgType=nil then
- RaiseMsg(20170924202531,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),'untyped',GetTypeDescription(IndexResolved)],ErrorEl)
- else
- begin
- if CheckParamCompatibility(IndexExpr,ProcArg,ArgNo,true)=cIncompatible then
- begin
- ComputeElement(ProcArg.ArgType,ProcArgResolved,[rcType]);
- RaiseIncompatibleTypeRes(20170924203829,nIncompatibleTypeArgNo,
- [IntToStr(ArgNo)],ProcArgResolved,IndexResolved,ErrorEl);
- end;
- end;
- end;
- procedure CheckArgs(Proc: TPasProcedure; const IndexVal: TResEvalValue;
- const IndexResolved: TPasResolverResult; ErrorEl: TPasElement);
- var
- ArgNo: Integer;
- PropArg, ProcArg: TPasArgument;
- PropArgResolved, ProcArgResolved: TPasResolverResult;
- NeedCheckingAccess: Boolean;
- begin
- ArgNo:=0;
- while ArgNo<PropEl.Args.Count do
- begin
- if ArgNo>=Proc.ProcType.Args.Count then
- RaiseMsg(20170216151805,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[Proc.Name],ErrorEl);
- PropArg:=TPasArgument(PropEl.Args[ArgNo]);
- ProcArg:=TPasArgument(Proc.ProcType.Args[ArgNo]);
- inc(ArgNo);
- // check access: var, const, ...
- NeedCheckingAccess:=false;
- if PropArg.Access<>ProcArg.Access then
- begin
- if (PropArg.Access in [argDefault, argConst])
- and (ProcArg.Access in [argDefault, argConst]) then
- begin
- // passing an arg as default to const or const to default
- if (PropArg.ArgType<>nil)
- and (ProcArg.ArgType<>nil) then
- NeedCheckingAccess:=true;
- end;
- if not NeedCheckingAccess then
- RaiseMsg(20170216151808,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),AccessDescriptions[ProcArg.Access],
- AccessDescriptions[PropArg.Access]],ErrorEl);
- end;
- // check argument type
- if PropArg.ArgType=nil then
- begin
- if ProcArg.ArgType<>nil then
- RaiseMsg(20170216151811,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),GetElementTypeName(ProcArg.ArgType),'untyped'],ErrorEl);
- end
- else if ProcArg.ArgType=nil then
- RaiseMsg(20170216151813,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),'untyped',GetElementTypeName(PropArg.ArgType)],ErrorEl)
- else
- begin
- ComputeElement(PropArg,PropArgResolved,[rcNoImplicitProc]);
- ComputeElement(ProcArg,ProcArgResolved,[rcNoImplicitProc]);
- if (PropArgResolved.BaseType<>ProcArgResolved.BaseType) then
- RaiseMsg(20170216151816,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),BaseTypeNames[ProcArgResolved.BaseType],BaseTypeNames[PropArgResolved.BaseType]],ErrorEl);
- if PropArgResolved.LoTypeEl=nil then
- RaiseInternalError(20161010125255);
- if ProcArgResolved.LoTypeEl=nil then
- RaiseInternalError(20161010125304);
- if not IsSameType(PropArgResolved.HiTypeEl,ProcArgResolved.HiTypeEl,prraSimple) then
- RaiseIncompatibleType(20170216151819,nIncompatibleTypeArgNo,
- [IntToStr(ArgNo)],ProcArgResolved.HiTypeEl,PropArgResolved.HiTypeEl,ErrorEl);
- end;
- if NeedCheckingAccess then
- begin
- // passing an arg as default to const or const to default
- // e.g.
- // function GetItems(const i: integer): byte;
- // property Items[i: integer]: byte read GetItems;
- // => allowed for simple types
- if not (PropArgResolved.BaseType in (btAllBooleans+btAllInteger+btAllStringAndChars+btAllFloats)) then
- RaiseMsg(20181007181647,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),AccessDescriptions[ProcArg.Access],
- AccessDescriptions[PropArg.Access]],ErrorEl);
- end;
- end;
- if IndexVal<>nil then
- begin
- if ArgNo>=Proc.ProcType.Args.Count then
- RaiseMsg(20170924202334,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[Proc.Name],ErrorEl);
- ProcArg:=TPasArgument(Proc.ProcType.Args[ArgNo]);
- CheckIndexArg(ArgNo,IndexResolved,ProcArg,ErrorEl);
- end;
- end;
- procedure CheckImplements;
- var
- i, j: Integer;
- Expr: TPasExpr;
- ResolvedEl: TPasResolverResult;
- aClass, PropClassType: TPasClassType;
- IntfType, OrigIntfType, PropTypeRes: TPasType;
- o: TObject;
- begin
- if not (PropEl.Parent is TPasClassType) then
- RaiseInternalError(20180323172125,GetElementDbgPath(PropEl));
- aClass:=TPasClassType(PropEl.Parent);
- if PropEl.Args.Count>0 then
- RaiseMsg(20180323170952,nImplementsDoesNotSupportArrayProperty,
- sImplementsDoesNotSupportArrayProperty,[],PropEl.Implements[0]);
- if IndexExpr<>nil then
- RaiseMsg(20180323171354,nImplementsDoesNotSupportIndex,
- sImplementsDoesNotSupportIndex,[],PropEl.Implements[0]);
- if GetPasPropertyGetter(PropEl)=nil then
- RaiseMsg(20180323221322,nImplPropMustHaveReadSpec,
- sImplPropMustHaveReadSpec,[],PropEl.Implements[0]);
- for i:=0 to length(PropEl.Implements)-1 do
- begin
- // resolve expression
- Expr:=PropEl.Implements[i];
- ResolveExpr(Expr,rraRead);
- // check expr is an interface type
- ComputeElement(Expr,ResolvedEl,[rcType,rcNoImplicitProc]);
- if not (ResolvedEl.IdentEl is TPasType) then
- if ResolvedEl.IdentEl=nil then
- RaiseXExpectedButYFound(20180323171911,'interface',
- GetElementTypeName(ResolvedEl.LoTypeEl),Expr)
- else
- RaiseXExpectedButYFound(20180323224846,'interface',
- GetElementTypeName(ResolvedEl.IdentEl),Expr);
- OrigIntfType:=TPasType(ResolvedEl.IdentEl);
- IntfType:=ResolveAliasType(OrigIntfType);
- if (not (IntfType is TPasClassType))
- or (TPasClassType(IntfType).ObjKind<>okInterface) then
- RaiseXExpectedButYFound(20180323172904,'interface',
- GetElementTypeName(OrigIntfType),Expr);
- // check it is one of the current implemented interfaces (not of ancestors)
- j:=IndexOfImplementedInterface(aClass,IntfType);
- if j<0 then
- RaiseMsg(20180323172420,nImplementsUsedOnUnimplIntf,sImplementsUsedOnUnimplIntf,
- [OrigIntfType.Name],Expr);
- // check property type fits
- PropTypeRes:=ResolveAliasType(PropType);
- if not (PropTypeRes is TPasClassType) then
- RaiseMsg(20180323222334,nDoesNotImplementInterface,sDoesNotImplementInterface,
- [GetElementTypeName(PropType),GetElementTypeName(OrigIntfType)],Expr);
- PropClassType:=TPasClassType(PropTypeRes);
- case PropClassType.ObjKind of
- okClass:
- // e.g. property Obj: ClassType read Getter implements IntfType
- // check ClassType or ancestors implements IntfType
- if GetClassImplementsIntf(PropClassType,TPasClassType(IntfType))=nil then
- RaiseMsg(20180323223324,nDoesNotImplementInterface,sDoesNotImplementInterface,
- [GetElementTypeName(PropType),GetElementTypeName(OrigIntfType)],Expr);
- okInterface:
- // e.g. property IntfVar: IntfType read Getter implements IntfType2
- // check that IntfType is IntfType2
- if CheckClassIsClass(PropType,IntfType)=cIncompatible then
- RaiseIncompatibleType(20180323173746,nIncompatibleTypesGotExpected,
- [],OrigIntfType,PropType,Expr);
- else
- RaiseMsg(20180323222821,nDoesNotImplementInterface,sDoesNotImplementInterface,
- [GetElementTypeName(PropType),GetElementTypeName(OrigIntfType)],Expr);
- end;
- // map
- o:=TObject(ClassScope.Interfaces[j]);
- if o is TPasProperty then
- RaiseMsg(20180323174240,nDuplicateImplementsForIntf,sDuplicateImplementsForIntf,
- [OrigIntfType.Name,GetElementSourcePosStr(TPasProperty(o))],Expr)
- else if o is TPasClassIntfMap then
- begin
- // properties are checked before method resolutions
- RaiseInternalError(20180323175919,GetElementDbgPath(PropEl));
- end
- else if o<>nil then
- RaiseInternalError(20180323174342,GetObjName(o))
- else
- ClassScope.Interfaces[j]:=PropEl;
- end;
- end;
- procedure CheckStoredAccessor(Expr: TPasExpr; const IndexVal: TResEvalValue;
- const IndexResolved: TPasResolverResult);
- var
- ResolvedEl: TPasResolverResult;
- Value: TResEvalValue;
- Proc: TPasProcedure;
- ResultType, TypeEl: TPasType;
- aVar: TPasVariable;
- IdentEl: TPasElement;
- ExpArgCnt: Integer;
- ProcArg: TPasArgument;
- begin
- ResolveExpr(Expr,rraRead);
- ComputeElement(Expr,ResolvedEl,[rcNoImplicitProc]);
- IdentEl:=ResolvedEl.IdentEl;
- if IdentEl is TPasProcedure then
- begin
- // function
- Proc:=TPasProcedure(IdentEl);
- // check if member
- if not (Expr is TPrimitiveExpr) then
- RaiseXExpectedButYFound(20170923202002,'member function','foreign '+GetElementTypeName(Proc),Expr);
- if Proc.ClassType<>TPasFunction then
- RaiseXExpectedButYFound(20170216151925,'function',GetElementTypeName(Proc),Expr);
- // check function result type
- ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
- if not IsBaseType(ResultType,btBoolean,true) then
- RaiseXExpectedButYFound(20170923200836,'function: boolean',
- 'function:'+GetTypeDescription(ResultType),PropEl.StoredAccessor);
- if Proc.IsAsync then
- RaiseInvalidProcTypeModifier(20200524104719,Proc.ProcType,ptmAsync,Expr);
- // check arg count
- ExpArgCnt:=0;
- if IndexVal<>nil then
- inc(ExpArgCnt);
- if Proc.ProcType.Args.Count<>ExpArgCnt then
- RaiseMsg(20170923200840,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
- [Proc.Name],Expr);
- if IndexVal<>nil then
- begin
- // check arg type
- ProcArg:=TPasArgument(Proc.ProcType.Args[0]);
- CheckIndexArg(1,IndexResolved,ProcArg,Expr);
- end;
- exit;
- end;
- if (IdentEl<>nil)
- and ((IdentEl.ClassType=TPasVariable)
- or ((IdentEl.ClassType=TPasConst) and not TPasConst(IdentEl).IsConst)) then
- begin
- // field
- aVar:=TPasVariable(IdentEl);
- // check if member
- if not (Expr is TPrimitiveExpr) then
- RaiseXExpectedButYFound(20170923202003,'member variable','foreign '+GetElementTypeName(aVar),Expr);
- // check type boolean
- TypeEl:=aVar.VarType;
- TypeEl:=ResolveAliasType(TypeEl);
- if not IsBaseType(TypeEl,btBoolean,true) then
- RaiseIncompatibleType(20170409214300,nIncompatibleTypesGotExpected,
- [],TypeEl,BaseTypes[btBoolean],Expr);
- // check class var
- if (vmClass in PropEl.VarModifiers)<>(vmClass in aVar.VarModifiers) then
- if vmClass in PropEl.VarModifiers then
- RaiseXExpectedButYFound(20170409214351,'class var','var',Expr)
- else
- RaiseXExpectedButYFound(20170409214359,'var','class var',Expr);
- exit;
- end;
- if (ResolvedEl.BaseType=btBoolean) and (ResolvedEl.ExprEl<>nil) then
- begin
- // try evaluating const boolean
- Value:=Eval(Expr,[refConst]);
- if Value<>nil then
- try
- if Value.Kind<>revkBool then
- RaiseXExpectedButYFound(20170923200256,'boolean',GetResolverResultDescription(ResolvedEl),Expr);
- exit;
- finally
- ReleaseEvalValue(Value);
- end;
- end;
- RaiseXExpectedButYFound(20170923194234,'identifier',GetResolverResultDescription(ResolvedEl),Expr);
- end;
- var
- ResultType, aType: TPasType;
- MembersType: TPasMembersType;
- AccEl: TPasElement;
- Proc: TPasProcedure;
- Arg: TPasArgument;
- PropArgCount, NeedArgCnt: Integer;
- PropTypeResolved, DefaultResolved, IndexResolved,
- AncIndexResolved: TPasResolverResult;
- m: TVariableModifier;
- IndexVal: TResEvalValue;
- AncIndexExpr, ErrorEl: TPasExpr;
- CurClass: TPasClassType;
- begin
- CheckTopScope(TPasPropertyScope);
- PopScope;
- if PropEl.Visibility=visPublished then
- for m in PropEl.VarModifiers do
- if not (m in [vmExternal]) then
- RaiseMsg(20170403224112,nInvalidXModifierY,sInvalidXModifierY,
- ['published property','"'+VariableModifierNames[m]+'"'],PropEl);
- PropType:=nil;
- MembersType:=PropEl.Parent as TPasMembersType;
- ClassOrRecScope:=NoNil(MembersType.CustomData) as TPasClassOrRecordScope;
- ClassScope:=nil;
- CurClass:=nil;
- if ClassOrRecScope is TPasClassScope then
- begin
- ClassScope:=TPasClassScope(ClassOrRecScope);
- CurClass:=TPasClassType(MembersType);
- end;
- AncestorProp:=nil;
- GetPropType;
- IndexVal:=nil;
- try
- if PropEl.IndexExpr<>nil then
- begin
- // index specifier
- // -> check if simple value
- IndexExpr:=PropEl.IndexExpr;
- ResolveExpr(IndexExpr,rraRead);
- end
- else
- IndexExpr:=GetPasPropertyIndex(PropEl);
- if IndexExpr<>nil then
- begin
- ComputeElement(IndexExpr,IndexResolved,[rcConstant]);
- IndexVal:=Eval(IndexExpr,[refConst]);
- case IndexVal.Kind of
- revkBool,
- revkInt, revkUInt,
- revkFloat,
- revkCurrency,
- {$ifdef FPC_HAS_CPSTRING}
- revkString,
- {$endif}
- revkUnicodeString,
- revkEnum: ; // ok
- else
- RaiseXExpectedButYFound(20170924202837,'ordinal',GetTypeDescription(IndexResolved),PropEl.IndexExpr);
- end;
- if (PropEl.IndexExpr<>nil) and (PropEl.VarType=nil) then
- begin
- // check if index is compatible to ancestor index specifier
- AncIndexExpr:=GetPasPropertyIndex(AncestorProp);
- if AncIndexExpr=nil then
- begin
- // ancestor had no index specifier
- if PropEl.ReadAccessor=nil then
- begin
- AccEl:=GetPasPropertyGetter(AncestorProp);
- if AccEl is TPasProcedure then
- RaiseMsg(20171002144103,nAddingIndexSpecifierRequiresNewX,
- sAddingIndexSpecifierRequiresNewX,['read'],IndexExpr);
- end;
- if PropEl.WriteAccessor=nil then
- begin
- AccEl:=GetPasPropertySetter(AncestorProp);
- if AccEl is TPasProcedure then
- RaiseMsg(20171002144419,nAddingIndexSpecifierRequiresNewX,
- sAddingIndexSpecifierRequiresNewX,['write'],IndexExpr);
- end;
- if PropEl.StoredAccessor=nil then
- begin
- AccEl:=GetPasPropertyStoredExpr(AncestorProp);
- if AccEl<>nil then
- begin
- ComputeElement(AccEl,AncIndexResolved,[rcNoImplicitProc]);
- if AncIndexResolved.IdentEl is TPasProcedure then
- RaiseMsg(20171002144644,nAddingIndexSpecifierRequiresNewX,
- sAddingIndexSpecifierRequiresNewX,['stored'],IndexExpr);
- end;
- end;
- end
- else
- // ancestor had already an index specifier -> check same type
- CheckEqualElCompatibility(PropEl.IndexExpr,AncIndexExpr,PropEl.IndexExpr,true);
- end;
- end;
- if PropEl.ReadAccessor<>nil then
- begin
- // check compatibility
- ErrorEl:=PropEl.ReadAccessor;
- AccEl:=ResolveAccessor(PropEl.ReadAccessor);
- if (AccEl.ClassType=TPasVariable) or (AccEl.ClassType=TPasConst) then
- begin
- if (PropEl.Args.Count>0) then
- RaiseXExpectedButYFound(20170216151823,'function',GetElementTypeName(AccEl),ErrorEl);
- if not IsSameType(TPasVariable(AccEl).VarType,PropType,prraAlias) then
- RaiseIncompatibleType(20170216151826,nIncompatibleTypesGotExpected,
- [],PropType,TPasVariable(AccEl).VarType,ErrorEl);
- if (vmClass in PropEl.VarModifiers)<>(vmClass in TPasVariable(AccEl).VarModifiers) then
- if vmClass in PropEl.VarModifiers then
- RaiseXExpectedButYFound(20170216151828,'class var','var',ErrorEl)
- else
- RaiseXExpectedButYFound(20170216151831,'var','class var',ErrorEl);
- end
- else if AccEl is TPasProcedure then
- begin
- // check function
- Proc:=TPasProcedure(AccEl);
- if (vmClass in PropEl.VarModifiers) then
- begin
- if Proc.ClassType<>TPasClassFunction then
- RaiseXExpectedButYFound(20170216151834,'class function',GetElementTypeName(Proc),ErrorEl);
- if not CheckClassAccessorStatic(Proc.IsStatic) then
- if Proc.IsStatic then
- RaiseMsg(20170216151837,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],ErrorEl)
- else
- RaiseMsg(20170216151839,nClassPropertyAccessorMustBeStatic,sClassPropertyAccessorMustBeStatic,[],ErrorEl);
- end
- else
- begin
- if Proc.ClassType<>TPasFunction then
- RaiseXExpectedButYFound(20170216151842,'function',GetElementTypeName(Proc),ErrorEl);
- end;
- // check function result type
- ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
- if not IsSameType(ResultType,PropType,prraAlias) then
- RaiseXExpectedButYFound(20170216151844,'function result '+GetTypeDescription(PropType,true),
- GetTypeDescription(ResultType,true),ErrorEl);
- if Proc.IsAsync then
- RaiseMsg(20200526101546,nInvalidXModifierY,sInvalidXModifierY,['property getter',
- ProcTypeModifiers[ptmAsync]],ErrorEl);
- // check args
- CheckArgs(Proc,IndexVal,IndexResolved,PropEl.ReadAccessor);
- NeedArgCnt:=PropEl.Args.Count;
- if IndexVal<>nil then
- inc(NeedArgCnt);
- if Proc.ProcType.Args.Count<>NeedArgCnt then
- RaiseMsg(20170216151847,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
- [Proc.Name],ErrorEl);
- end
- else
- RaiseXExpectedButYFound(20170216151850,'variable',GetElementTypeName(AccEl),ErrorEl);
- end;
- if PropEl.WriteAccessor<>nil then
- begin
- // check compatibility
- ErrorEl:=PropEl.WriteAccessor;
- AccEl:=ResolveAccessor(PropEl.WriteAccessor);
- if (AccEl.ClassType=TPasVariable)
- or ((AccEl.ClassType=TPasConst) and (not TPasConst(AccEl).IsConst)) then
- begin
- if (PropEl.Args.Count>0) then
- RaiseXExpectedButYFound(20170216151852,'procedure',GetElementTypeName(AccEl),ErrorEl);
- if not IsSameType(TPasVariable(AccEl).VarType,PropType,prraAlias) then
- RaiseIncompatibleType(20170216151855,nIncompatibleTypesGotExpected,
- [],PropType,TPasVariable(AccEl).VarType,ErrorEl);
- if (vmClass in PropEl.VarModifiers)<>(vmClass in TPasVariable(AccEl).VarModifiers) then
- if vmClass in PropEl.VarModifiers then
- RaiseXExpectedButYFound(20170216151858,'class var','var',ErrorEl)
- else
- RaiseXExpectedButYFound(20170216151900,'var','class var',ErrorEl);
- end
- else if AccEl is TPasProcedure then
- begin
- // check procedure
- Proc:=TPasProcedure(AccEl);
- if (vmClass in PropEl.VarModifiers) then
- begin
- if Proc.ClassType<>TPasClassProcedure then
- RaiseXExpectedButYFound(20170216151903,'class procedure',GetElementTypeName(Proc),ErrorEl);
- if not CheckClassAccessorStatic(Proc.IsStatic) then
- if Proc.IsStatic then
- RaiseMsg(20170216151905,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],ErrorEl)
- else
- RaiseMsg(20170216151906,nClassPropertyAccessorMustBeStatic,sClassPropertyAccessorMustBeStatic,[],ErrorEl);
- end
- else
- begin
- if Proc.ClassType<>TPasProcedure then
- RaiseXExpectedButYFound(20170216151910,'procedure',GetElementTypeName(Proc),ErrorEl);
- end;
- if Proc.IsAsync then
- RaiseMsg(20200526101635,nInvalidXModifierY,sInvalidXModifierY,['property setter',
- ProcTypeModifiers[ptmAsync]],ErrorEl);
- // check args
- CheckArgs(Proc,IndexVal,IndexResolved,PropEl.WriteAccessor);
- // check write arg
- PropArgCount:=PropEl.Args.Count;
- if IndexVal<>nil then
- inc(PropArgCount);
- if Proc.ProcType.Args.Count<>PropArgCount+1 then
- RaiseMsg(20170216151913,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
- [Proc.Name],ErrorEl);
- Arg:=TPasArgument(Proc.ProcType.Args[PropArgCount]);
- if not (Arg.Access in [argDefault,argConst]) then
- RaiseMsg(20170216151917,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(PropArgCount+1),AccessDescriptions[Arg.Access],
- AccessDescriptions[argConst]],ErrorEl);
- if not IsSameType(Arg.ArgType,PropType,prraAlias) then
- RaiseIncompatibleType(20170216151919,nIncompatibleTypeArgNo,
- [IntToStr(PropArgCount+1)],Arg.ArgType,PropType,ErrorEl);
- end
- else
- RaiseXExpectedButYFound(20170216151921,'variable',GetElementTypeName(AccEl),ErrorEl);
- end
- else if (PropEl.ReadAccessor=nil) and (PropEl.VarType<>nil) then
- RaiseMsg(20180519173551,nPropertyMustHaveReadOrWrite,sPropertyMustHaveReadOrWrite,[],PropEl);
- if length(PropEl.Implements)>0 then
- CheckImplements;
- if PropEl.StoredAccessor<>nil then
- begin
- // check compatibility
- CheckStoredAccessor(PropEl.StoredAccessor,IndexVal,IndexResolved);
- end;
- if PropEl.DefaultExpr<>nil then
- begin
- // check compatibility with type
- ResolveExpr(PropEl.DefaultExpr,rraRead);
- ComputeElement(PropEl.DefaultExpr,DefaultResolved,[rcConstant]);
- ComputeElement(PropType,PropTypeResolved,[rcType]);
- PropTypeResolved.IdentEl:=PropEl;
- PropTypeResolved.Flags:=[rrfReadable];
- CheckEqualResCompatibility(PropTypeResolved,DefaultResolved,PropEl.DefaultExpr,true);
- end;
- if PropEl.IsDefault then
- begin
- if (CurClass<>nil) and (CurClass.HelperForType<>nil) then
- begin
- aType:=ResolveAliasType(CurClass.HelperForType);
- if not (aType is TPasMembersType) then
- RaiseMsg(20190117125004,nDefaultPropertyNotAllowedInHelperForX,
- sDefaultPropertyNotAllowedInHelperForX,
- [GetTypeDescription(CurClass.HelperForType)],PropEl);
- end;
- // set default array property
- if (ClassOrRecScope.DefaultProperty<>nil)
- and (ClassOrRecScope.DefaultProperty.Parent=PropEl.Parent) then
- RaiseMsg(20170216151938,nOnlyOneDefaultPropertyIsAllowed,sOnlyOneDefaultPropertyIsAllowed,[],PropEl);
- ClassOrRecScope.DefaultProperty:=PropEl;
- end;
- EmitTypeHints(PropEl,PropEl.VarType);
- finally
- ReleaseEvalValue(IndexVal);
- end;
- end;
- procedure TPasResolver.FinishArgument(El: TPasArgument);
- procedure CheckHasGenTemplRef(Arg: TPasArgument);
- procedure Check(Parent: TPasElement; Cur: TPasType; TemplTypes: TFPList);
- var
- C: TClass;
- Arr: TPasArrayType;
- begin
- if Cur=nil then exit;
- C:=Cur.ClassType;
- if C=TPasGenericTemplateType then
- begin
- if TemplTypes.IndexOf(Cur)>=0 then
- RaiseMsg(20191007213121,nParamOfThisTypeCannotHaveDefVal,sParamOfThisTypeCannotHaveDefVal,[],El);
- end
- else if Cur.Parent<>Parent then
- exit
- else if C=TPasArrayType then
- begin
- Arr:=TPasArrayType(Cur);
- Check(Arr,Arr.ElType,TemplTypes);
- end;
- end;
- var
- Proc: TPasProcedure;
- TemplTypes: TFPList;
- begin
- if Arg.ArgType=nil then exit;
- if not (Arg.Parent is TPasProcedureType) then exit;
- if not (Arg.Parent.Parent is TPasProcedure) then exit;
- Proc:=TPasProcedure(Arg.Parent.Parent);
- TemplTypes:=GetProcTemplateTypes(Proc);
- if TemplTypes=nil then exit;
- Check(Arg,Arg.ArgType,TemplTypes);
- end;
- var
- IsDelphi: Boolean;
- begin
- if not (El.Access in [argDefault,argConst,argVar,argOut,argConstRef]) then
- RaiseMsg(20191018235644,nNotYetImplemented,sNotYetImplemented,[AccessDescriptions[El.Access]],El);
- if El.ArgType<>nil then
- CheckUseAsType(El.ArgType,20190123100049,El);
- if El.ValueExpr<>nil then
- begin
- ResolveExpr(El.ValueExpr,rraRead);
- if El.ArgType<>nil then
- begin
- CheckAssignCompatibility(El,El.ValueExpr,true);
- IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
- if IsDelphi then
- CheckHasGenTemplRef(El);
- end;
- end;
- EmitTypeHints(El,El.ArgType);
- end;
- procedure TPasResolver.FinishAncestors(aClass: TPasClassType);
- // called when the ancestor and interface list of a class has been parsed,
- // before parsing the class elements
- var
- DirectAncestor: TPasType; // e.g. TPasAliasType or TPasClassType
- AncestorClassEl: TPasClassType;
- function IsDefaultAncestor(c: TPasClassType; const DefAncestorName: string): boolean;
- begin
- Result:=SameText(c.Name,DefAncestorName)
- and (c.Parent is TPasSection);
- end;
- procedure FindDefaultAncestor(const DefAncestorName, Expected: string);
- var
- CurEl: TPasElement;
- begin
- AncestorClassEl:=nil;
- if SameText(aClass.Name,DefAncestorName) then
- begin
- if IsDefaultAncestor(aClass,DefAncestorName) then exit;
- RaiseXExpectedButYFound(20190106132328,'top level '+DefAncestorName,'nested '+aClass.Name,aClass);
- end;
- CurEl:=FindElementWithoutParams(DefAncestorName,aClass,false,true);
- if not (CurEl is TPasType) then
- RaiseXExpectedButYFound(20180321150128,Expected,GetElementTypeName(CurEl),aClass);
- DirectAncestor:=TPasType(CurEl);
- CurEl:=ResolveAliasType(DirectAncestor);
- if not (CurEl is TPasClassType) then
- RaiseXExpectedButYFound(20170216151941,Expected,GetElementTypeName(DirectAncestor),aClass);
- AncestorClassEl:=TPasClassType(CurEl);
- end;
- var
- ClassScope, AncestorClassScope: TPasClassScope;
- AncestorType, El: TPasType;
- i: Integer;
- aModifier, DefAncestorName: String;
- IsSealed, IsDelphi: Boolean;
- CanonicalSelf: TPasClassOfType;
- Decl: TPasElement;
- j, TypeParamCnt: integer;
- IntfType, IntfTypeRes, HelperForType, AncestorHelperFor: TPasType;
- ResIntfList, Members: TFPList;
- GroupScope: TPasGroupScope;
- C: TClass;
- begin
- IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
- if aClass.IsForward then
- begin
- PopGenericParamScope(aClass);
- // check for duplicate forwards
- C:=aClass.Parent.ClassType;
- if C.InheritsFrom(TPasDeclarations) then
- Members:=TPasDeclarations(aClass.Parent).Declarations
- else if (C=TPasClassType) or (C=TPasRecordType) then
- Members:=TPasMembersType(aClass.Parent).Members
- else
- RaiseNotYetImplemented(20180430141934,aClass,GetObjName(aClass.Parent));
- TypeParamCnt:=GetTypeParameterCount(aClass);
- for i:=0 to Members.Count-1 do
- begin
- Decl:=TPasElement(Members[i]);
- if (CompareText(Decl.Name,aClass.Name)<>0)
- or (Decl=aClass) then continue;
- if (Decl is TPasGenericType)
- and (GetTypeParameterCount(TPasGenericType(Decl))<>TypeParamCnt) then
- continue;
- RaiseMsg(20180212144132,nDuplicateIdentifier,sDuplicateIdentifier,
- [Decl.Name,GetElementSourcePosStr(Decl)],aClass);
- end;
- if TypeParamCnt>0 then
- begin
- // A generic forward needs TPasClassScope to store the specialized types.
- // Will later be transferred to the actual class.
- CreateScope(aClass,ScopeClass_Class);
- end;
- exit;
- end;
- // not forward, actual declaration ...
- case aClass.ObjKind of
- okClass:
- begin
- AncestorType:=ResolveAliasType(aClass.AncestorType);
- if (AncestorType is TPasClassType)
- and (TPasClassType(AncestorType).ObjKind=okInterface)
- and not isDelphi then
- begin
- // e.g. type c = class(intf)
- // ObjFPC allows to omit TObject as default ancestor, Delphi does not
- aClass.Interfaces.Insert(0,aClass.AncestorType);
- aClass.AncestorType:=nil;
- end;
- end;
- okInterface:
- begin
- if aClass.IsExternal then
- RaiseMsg(20180321115831,nIllegalQualifier,sIllegalQualifier,['external'],aClass);
- if not (aClass.InterfaceType in [citCom,citCorba]) then
- RaiseMsg(20180321143613,nIllegalQualifier,sIllegalQualifier,
- [CurrentParser.Scanner.CurrentValueSwitch[vsInterfaces]],aClass);
- end;
- okClassHelper,okRecordHelper,okTypeHelper:
- begin
- if aClass.IsExternal then
- RaiseMsg(20190116192722,nIllegalQualifier,sIllegalQualifier,['external'],aClass);
- HelperForType:=ResolveAliasType(aClass.HelperForType);
- if HelperForType=nil then
- RaiseNotYetImplemented(20191016125557,aClass);
- if (aClass=HelperForType) or (aClass.HasParent(HelperForType)) then
- RaiseMsg(20190118190935,nTypeXIsNotYetCompletelyDefined,
- sTypeXIsNotYetCompletelyDefined,[HelperForType.Name],aClass);
- case aClass.ObjKind of
- okClassHelper:
- begin
- if not (HelperForType is TPasClassType) then
- RaiseXExpectedButYFound(20190116194751,'class type',GetTypeDescription(aClass.HelperForType),aClass);
- if TPasClassType(HelperForType).ObjKind<>okClass then
- RaiseXExpectedButYFound(20190116194855,'class type',GetTypeDescription(aClass.HelperForType),aClass);
- if TPasClassType(HelperForType).IsForward then
- RaiseMsg(20190116194931,nTypeXIsNotYetCompletelyDefined,
- sTypeXIsNotYetCompletelyDefined,[HelperForType.Name],aClass);
- end;
- okRecordHelper:
- if isDelphi then
- begin
- if (HelperForType.ClassType=TPasRecordType)
- or (HelperForType.ClassType=TPasArrayType)
- or (HelperForType.ClassType=TPasSetType)
- or (HelperForType.ClassType=TPasEnumType)
- or (HelperForType.ClassType=TPasRangeType)
- then
- // ok
- else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
- and (HelperForType.CustomData is TResElDataBaseType)) then
- else
- RaiseMsg(20190116200304,nTypeXCannotBeExtendedByARecordHelper,
- sTypeXCannotBeExtendedByARecordHelper,[GetTypeDescription(HelperForType)],aClass);
- end
- else
- begin
- // mode objfpc
- if (HelperForType.ClassType=TPasRecordType) then
- else
- RaiseMsg(20190116200519,nTypeXCannotBeExtendedByARecordHelper,
- sTypeXCannotBeExtendedByARecordHelper,[GetTypeDescription(HelperForType)],aClass);
- end;
- okTypeHelper:
- begin
- if (HelperForType.ClassType=TPasRecordType)
- or (HelperForType.ClassType=TPasArrayType)
- or (HelperForType.ClassType=TPasSetType)
- or (HelperForType.ClassType=TPasEnumType)
- or (HelperForType.ClassType=TPasRangeType)
- then
- // ok
- else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
- and (HelperForType.CustomData is TResElDataBaseType)) then
- else if (HelperForType.ClassType=TPasClassType)
- and (TPasClassType(HelperForType).ObjKind in [okClass,okInterface]) then
- begin
- if TPasClassType(HelperForType).IsForward then
- RaiseMsg(20190116200940,nTypeXIsNotYetCompletelyDefined,
- sTypeXIsNotYetCompletelyDefined,[HelperForType.Name],aClass);
- end
- else
- RaiseMsg(20190116200304,nTypeXCannotBeExtendedByATypeHelper,
- sTypeXCannotBeExtendedByATypeHelper,[GetTypeDescription(HelperForType)],aClass);
- end;
- end;
- end
- else
- RaiseNotYetImplemented(20161010174638,aClass,'Kind='+ObjKindNames[aClass.ObjKind]);
- end;
- IsSealed:=false;
- for i:=0 to aClass.Modifiers.Count-1 do
- begin
- aModifier:=lowercase(aClass.Modifiers[i]);
- case aModifier of
- 'sealed': IsSealed:=true;
- 'abstract': ;
- else
- RaiseMsg(20170320190619,nIllegalQualifier,sIllegalQualifier,[aClass.Modifiers[i]],aClass);
- end;
- end;
- AncestorClassEl:=nil;
- DirectAncestor:=aClass.AncestorType;
- AncestorType:=ResolveAliasType(DirectAncestor);
- if AncestorType=nil then
- begin
- if DirectAncestor<>nil then
- RaiseInternalError(20180321151851,GetObjName(DirectAncestor));
- // use default ancestor
- DefAncestorName:='';
- case aClass.ObjKind of
- okClass:
- begin
- DefAncestorName:='TObject';
- if aClass.IsExternal or IsDefaultAncestor(aClass,DefAncestorName) then
- begin
- // ok, no ancestor
- AncestorClassEl:=nil;
- end
- else
- begin
- // search default ancestor TObject
- FindDefaultAncestor(DefAncestorName,'class type');
- if TPasClassType(AncestorClassEl).ObjKind<>okClass then
- RaiseXExpectedButYFound(20180321145626,'class type',GetElementTypeName(AncestorClassEl),aClass);
- end;
- end;
- okInterface:
- begin
- if aClass.InterfaceType=citCom then
- begin
- if isDelphi then
- DefAncestorName:='IInterface'
- else
- DefAncestorName:='IUnknown';
- if IsDefaultAncestor(aClass,DefAncestorName) then
- AncestorClassEl:=nil
- else
- begin
- // search default ancestor interface
- FindDefaultAncestor(DefAncestorName,'interface type');
- if TPasClassType(AncestorClassEl).ObjKind<>okInterface then
- RaiseXExpectedButYFound(20180321145725,'interface type',
- GetElementTypeName(AncestorClassEl),aClass);
- end;
- end;
- end;
- okClassHelper,okRecordHelper,okTypeHelper: ; // no root ancestor
- end;
- end
- else if AncestorType.ClassType<>TPasClassType then
- RaiseXExpectedButYFound(20170216151944,'class type',GetTypeDescription(AncestorType),aClass)
- else if aClass=AncestorType then
- RaiseMsg(20170525125854,nAncestorCycleDetected,sAncestorCycleDetected,[],aClass)
- else
- begin
- AncestorClassEl:=TPasClassType(AncestorType);
- if AncestorClassEl.ObjKind<>aClass.ObjKind then
- RaiseXExpectedButYFound(20180321152107,GetElementTypeName(aClass)+' type',
- GetElementTypeName(AncestorClassEl)+' type',aClass);
- if aClass.ObjKind in okAllHelpers then
- begin
- HelperForType:=ResolveAliasType(aClass.HelperForType);
- AncestorHelperFor:=ResolveAliasType(AncestorClassEl.HelperForType);
- if IsSameType(HelperForType,AncestorHelperFor,prraNone) then
- // helper for same type as ancestor helper -> ok
- else if (HelperForType is TPasClassType)
- and (AncestorHelperFor is TPasClassType)
- and (CheckClassIsClass(HelperForType,AncestorHelperFor)<>cIncompatible) then
- // helper for descendant class of ancestor helper for -> ok
- else
- RaiseMsg(20190116203931,nDerivedXMustExtendASubClassY,sDerivedXMustExtendASubClassY,
- [GetElementTypeName(aClass),AncestorClassEl.HelperForType.Name],aClass);
- end;
- EmitTypeHints(aClass,AncestorClassEl);
- end;
- AncestorClassScope:=nil;
- if AncestorClassEl=nil then
- begin
- // root class e.g. TObject, IUnknown, helper
- end
- else
- begin
- // inherited class
- if AncestorClassEl.IsForward then
- RaiseMsg(20170216151947,nCantUseForwardDeclarationAsAncestor,
- sCantUseForwardDeclarationAsAncestor,[AncestorClassEl.Name],aClass);
- if aClass.IsExternal and not AncestorClassEl.IsExternal then
- RaiseMsg(20170321144035,nAncestorIsNotExternal,sAncestorIsNotExternal,
- [AncestorClassEl.Name],aClass);
- AncestorClassScope:=AncestorClassEl.CustomData as TPasClassScope;
- if pcsfSealed in AncestorClassScope.Flags then
- RaiseMsg(20170320191735,nCannotCreateADescendantOfTheSealedXY,
- sCannotCreateADescendantOfTheSealedXY,
- [GetElementTypeName(AncestorClassEl),AncestorClassEl.Name],aClass);
- // check for cycle
- El:=AncestorClassEl;
- repeat
- if El=aClass then
- RaiseMsg(20170216151949,nAncestorCycleDetected,sAncestorCycleDetected,[],aClass);
- if (El.ClassType=TPasAliasType)
- or (El.ClassType=TPasTypeAliasType)
- or (El.ClassType=TPasSpecializeType)
- then
- El:=TPasAliasType(El).DestType
- else if El.ClassType=TPasClassType then
- El:=TPasClassType(El).AncestorType
- else
- RaiseNotYetImplemented(20190825195203,aClass,GetObjName(El));
- until El=nil;
- end;
- if TopScope is TPasGenericParamsScope then
- PopGenericParamScope(aClass);
- // start scope for members
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FinishAncestors ',GetObjName(aClass.CustomData));
- {$ENDIF}
- if aClass.CustomData=nil then
- ClassScope:=TPasClassScope(CreateScope(aClass,ScopeClass_Class))
- else
- begin
- // has already the scope, e.g. scope moved from a generic forward
- ClassScope:=aClass.CustomData as TPasClassScope;
- if pcsfAncestorResolved in ClassScope.Flags then
- RaiseNotYetImplemented(20190803203715,aClass);
- end;
- Include(ClassScope.Flags,pcsfAncestorResolved);
- if IsSealed then
- Include(ClassScope.Flags,pcsfSealed);
- AddGenericTemplateIdentifiers(aClass.GenericTemplateTypes,ClassScope);
- ClassScope.DirectAncestor:=DirectAncestor;
- if AncestorClassEl<>nil then
- begin
- ClassScope.AncestorScope:=AncestorClassScope;
- ClassScope.DefaultProperty:=AncestorClassScope.DefaultProperty;
- if pcsfPublished in AncestorClassScope.Flags then
- Include(ClassScope.Flags,pcsfPublished);
- ClassScope.AbstractProcs:=copy(AncestorClassScope.AbstractProcs);
- end;
- if bsTypeInfo in CurrentParser.Scanner.CurrentBoolSwitches then
- Include(ClassScope.Flags,pcsfPublished);
- if aClass.ObjKind in ([okClass]+okAllHelpers) then
- begin
- // create canonical class-of for the "Self" in non static class functions
- CanonicalSelf:=TPasClassOfType.Create('Self',aClass);
- ClassScope.CanonicalClassOf:=CanonicalSelf;
- {$IFDEF CheckPasTreeRefCount}CanonicalSelf.RefIds.Add('TPasClassScope.CanonicalClassOf');{$ENDIF}
- CanonicalSelf.DestType:=aClass;
- aClass.AddRef{$IFDEF CheckPasTreeRefCount}('TPasAliasType.DestType'){$ENDIF};
- CanonicalSelf.Visibility:=visStrictPrivate;
- CanonicalSelf.SourceFilename:=aClass.SourceFilename;
- CanonicalSelf.SourceLinenumber:=aClass.SourceLinenumber;
- end;
- // push scope (must be done after setting aClass.AncestorScope)
- GroupScope:=PushGroupScope(aClass);
- GroupScope.VisibilityContext:=aClass;
- // check interfaces
- if aClass.Interfaces.Count>0 then
- begin
- if not (aClass.ObjKind in [okClass]) then
- RaiseXExpectedButYFound(20180322001341,'one ancestor',
- IntToStr(1+aClass.Interfaces.Count),aClass);
- if aClass.IsExternal then
- RaiseMsg(20180324183641,nIllegalQualifier,sIllegalQualifier,['external'],aClass);
- ResIntfList:=TFPList.Create;
- try
- for i:=0 to aClass.Interfaces.Count-1 do
- begin
- IntfType:=TPasType(aClass.Interfaces[i]);
- IntfTypeRes:=ResolveAliasType(IntfType);
- if IntfTypeRes=nil then
- RaiseMsg(20180322140044,nCantUseForwardDeclarationAsAncestor,
- sCantUseForwardDeclarationAsAncestor,[IntfType.Name],aClass);
- if not (IntfTypeRes is TPasClassType) then
- RaiseXExpectedButYFound(20180322001051,'interface type',
- GetElementTypeName(IntfTypeRes)+' type',aClass);
- if TPasClassType(IntfTypeRes).ObjKind<>okInterface then
- RaiseXExpectedButYFound(20180322001143,'interface type',
- GetElementTypeName(IntfTypeRes)+' type',aClass);
- j:=ResIntfList.IndexOf(IntfTypeRes);
- if j>=0 then
- RaiseMsg(20180322001505,nDuplicateIdentifier,sDuplicateIdentifier,
- [IntfType.Name,IntToStr(j+1)],aClass); // todo: jump to interface list
- ResIntfList.Add(IntfTypeRes);
- end;
- finally
- ResIntfList.Free;
- end;
- // create interfaces maps
- ClassScope.Interfaces:=TFPList.Create;
- ClassScope.Interfaces.Count:=aClass.Interfaces.Count;
- end;
- end;
- procedure TPasResolver.FinishMethodResolution(El: TPasMethodResolution);
- var
- ResolvedEl: TPasResolverResult;
- aClass, IntfType: TPasClassType;
- i: Integer;
- IntfProc: TPasProcedure;
- Expr: TPasExpr;
- ProcName: String;
- IntfScope: TPasClassScope;
- Identifier: TPasIdentifier;
- begin
- // procedure InterfaceName.InterfaceProc = ...
- // check InterfaceName
- ResolveExpr(El.InterfaceName,rraRead);
- ComputeElement(El.InterfaceName,ResolvedEl,[rcType,rcNoImplicitProc]);
- if not (ResolvedEl.IdentEl is TPasType) then
- RaiseXExpectedButYFound(20180323132601,'interface type',
- GetResolverResultDescription(ResolvedEl),El.InterfaceName);
- aClass:=El.Parent as TPasClassType;
- i:=IndexOfImplementedInterface(aClass,TPasType(ResolvedEl.IdentEl));
- if i<0 then
- RaiseXExpectedButYFound(20180323133055,'interface type',
- GetResolverResultDescription(ResolvedEl),El.InterfaceName);
- IntfType:=TPasClassType(ResolveAliasType(TPasClassType(aClass.Interfaces[i])));
- // check InterfaceProc
- Expr:=El.InterfaceProc;
- if not (Expr is TPrimitiveExpr) then
- RaiseXExpectedButYFound(20180327152808,'method name',GetElementTypeName(Expr),Expr);
- if TPrimitiveExpr(Expr).Kind<>pekIdent then
- RaiseXExpectedButYFound(20180327152841,'method name',GetElementTypeName(Expr),Expr);
- ProcName:=TPrimitiveExpr(Expr).Value;
- IntfScope:=IntfType.CustomData as TPasClassScope;
- IntfProc:=nil;
- while IntfScope<>nil do
- begin
- Identifier:=IntfScope.FindLocalIdentifier(ProcName);
- while Identifier<>nil do
- begin
- if not (Identifier.Element is TPasProcedure) then
- RaiseXExpectedButYFound(20180327153110,'interface method',GetElementTypeName(Identifier.Element),Expr);
- IntfProc:=TPasProcedure(Identifier.Element);
- if IntfProc.ClassType=El.ProcClass then
- break;
- Identifier:=Identifier.NextSameIdentifier;
- end;
- IntfScope:=IntfScope.AncestorScope;
- end;
- if IntfProc=nil then
- RaiseIdentifierNotFound(20180327153044,ProcName,Expr);
- CreateReference(IntfProc,Expr,rraRead);
- if IntfProc.ClassType<>El.ProcClass then
- RaiseXExpectedButYFound(20180323144107,GetElementTypeName(El.ProcClass),GetElementTypeName(IntfProc),El.InterfaceProc);
- // Note: do not create map here. CheckImplements in FinishProperty must be called before.
- // El.ImplementationProc is resolved in FinishClassType
- end;
- procedure TPasResolver.FinishAttributes(El: TPasAttributes);
- var
- i, j: Integer;
- NameExpr, Expr: TPasExpr;
- Bin: TBinaryExpr;
- LeftResolved, ParamResolved: TPasResolverResult;
- aModule: TPasModule;
- LTypeEl: TPasType;
- AttrName: String;
- Data: TPRFindData;
- CurEl, DeclEl: TPasElement;
- ClassEl: TPasClassType;
- aConstructor: TPasConstructor;
- Args: TFPList;
- AttrRef, ParamRef: TResolvedReference;
- DotScope: TPasDotBaseScope;
- Params: TPasExprArray;
- begin
- for i:=0 to length(El.Calls)-1 do
- begin
- NameExpr:=El.Calls[i];
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FinishAttributes El.Calls[',i,']=',GetObjName(NameExpr));
- {$ENDIF}
- if NameExpr is TParamsExpr then
- NameExpr:=TParamsExpr(NameExpr).Value;
- DotScope:=nil;
- if NameExpr is TBinaryExpr then
- begin
- Bin:=TBinaryExpr(NameExpr);
- ResolveExpr(Bin.left,rraRead);
- ComputeElement(Bin.Left,LeftResolved,[rcType,rcSetReferenceFlags]);
- if LeftResolved.BaseType=btModule then
- begin
- // e.g. unitname.identifier
- // => search in interface and if this is our module in the implementation
- aModule:=NoNil(LeftResolved.IdentEl) as TPasModule;
- DotScope:=PushModuleDotScope(aModule);
- end
- else if (LeftResolved.BaseType=btContext)
- and (LeftResolved.IdentEl is TPasType)
- and (LeftResolved.LoTypeEl is TPasMembersType) then
- begin
- // classtype.identifier or recordtype.identifier
- LTypeEl:=LeftResolved.LoTypeEl;
- if LTypeEl.ClassType=TPasClassType then
- begin
- DotScope:=PushClassDotScope(TPasClassType(LTypeEl));
- DotScope.OnlyTypeMembers:=true;
- end
- else if LTypeEl.ClassType=TPasRecordType then
- begin
- DotScope:=PushRecordDotScope(TPasRecordType(LTypeEl));
- DotScope.OnlyTypeMembers:=true;
- end
- else
- RaiseNotYetImplemented(20190221124930,Bin);
- end
- else
- RaiseMsg(20190221102049,nXExpectedButYFound,sXExpectedButYFound,
- ['module or type',GetResolverResultDescription(LeftResolved,true)],NameExpr);
- NameExpr:=Bin.right;
- end;
- // find attribute class
- if not IsNameExpr(NameExpr) then
- RaiseMsg(20190221125204,nXExpectedButYFound,sXExpectedButYFound,
- ['identifier',GetElementTypeName(Bin)],NameExpr);
- AttrName:=TPrimitiveExpr(NameExpr).Value;
- CurEl:=nil;
- if not SameText(RightStr(AttrName,length('Attribute')),'Attribute') then
- begin
- // first search AttrName+'Attribute'
- CurEl:=FindFirstEl(AttrName+'Attribute',Data,NameExpr);
- end;
- // then search the name
- if CurEl=nil then
- CurEl:=FindFirstEl(AttrName,Data,NameExpr);
- if DotScope<>nil then
- PopScope;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishAttributes Found Attr "'+AttrName+'"=',GetObjName(CurEl),' TopScope=',GetObjName(TopScope));
- {$ENDIF}
- // check if found element is a TCustomAttribute
- if CurEl=nil then
- begin
- LogMsg(20190221144613,mtWarning,nUnknownCustomAttributeX,sUnknownCustomAttributeX,
- [AttrName],NameExpr);
- continue;
- end;
- if not IsCustomAttribute(CurEl) then
- RaiseMsg(20190221130400,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [GetElementTypeName(CurEl),'TCustomAttribute'],NameExpr);
- ClassEl:=TPasClassType(CurEl);
- AttrRef:=CreateReference(ClassEl,NameExpr,rraRead);
- if ClassEl.IsAbstract then
- // Delphi silently skips attributes using abstract classes/methods
- LogMsg(20190223194424,mtWarning,nAttributeIgnoredBecauseAbstractX,
- sAttributeIgnoredBecauseAbstractX,['class'],NameExpr);
- // search constructor "Create" using the params
- DotScope:=PushClassDotScope(ClassEl);
- DotScope.OnlyTypeMembers:=true;
- Expr:=El.Calls[i];
- if Expr is TParamsExpr then
- begin
- // attribute with params
- if Expr.Kind<>pekFuncParams then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishAttributes ',ExprKindNames[Expr.Kind]);
- {$ENDIF}
- RaiseMsg(20190223195605,nXExpectedButYFound,sXExpectedButYFound,
- ['(','['],Expr);
- end;
- // first resolve params
- ResolveParamsExprParams(TParamsExpr(Expr));
- // then resolve call 'Create'
- ResolveFuncParamsExprName(Expr,nil,TParamsExpr(Expr),rraRead,'Create');
- // then check that each parameter is a constant expression
- Params:=TParamsExpr(Expr).Params;
- for j:=0 to length(Params)-1 do
- ComputeElement(Params[j],ParamResolved,[rcConstant]);
- // check if call is constructor
- ParamRef:=Expr.CustomData as TResolvedReference;
- DeclEl:=ParamRef.Declaration;
- if DeclEl.ClassType<>TPasConstructor then
- RaiseXExpectedButYFound(20190221150212,'constructor Create',GetElementTypeName(DeclEl),NameExpr);
- aConstructor:=TPasConstructor(DeclEl);
- end
- else
- begin
- // attribute without params
- // -> resolve call 'Create'
- DeclEl:=FindElementWithoutParams('Create',Data,NameExpr,false,true);
- if DeclEl=nil then
- RaiseIdentifierNotFound(20190221144516,'Create',NameExpr);
- // check call is constructor
- if DeclEl.ClassType<>TPasConstructor then
- RaiseXExpectedButYFound(20190221145003,'constructor Create',
- GetElementTypeName(DeclEl),NameExpr);
- aConstructor:=TPasConstructor(DeclEl);
- // check constructor without needed args
- Args:=aConstructor.ProcType.Args;
- if (Args.Count>0) and (TPasArgument(Args[0]).ValueExpr=nil) then
- RaiseMsg(20190221145407,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[aConstructor.Name],Expr);
- end;
- if aConstructor.IsAbstract then
- LogMsg(20190223193645,mtWarning,nAttributeIgnoredBecauseAbstractX,
- sAttributeIgnoredBecauseAbstractX,['mrthod'],NameExpr);
- // store reference to constructor in NameExpr
- if AttrRef.Context<>nil then
- RaiseNotYetImplemented(20190221164717,NameExpr,GetObjName(AttrRef.Context));
- AttrRef.Context:=TResolvedRefCtxAttrProc.Create;
- TResolvedRefCtxAttrProc(AttrRef.Context).Proc:=aConstructor;
- PopScope;
- end;
- end;
- procedure TPasResolver.FinishExportSymbol(El: TPasExportSymbol);
- procedure CheckConstExpr(Expr: TPasExpr; Kinds: TREVKinds; const Expected: string);
- var
- Value: TResEvalValue;
- ResolvedEl: TPasResolverResult;
- begin
- if Expr=nil then exit;
- ResolveExpr(Expr,rraRead);
- Value:=Eval(Expr,[refConst]);
- if (Value<>nil) and (Value.Kind in Kinds) then
- begin
- ReleaseEvalValue(Value);
- exit;
- end;
- ReleaseEvalValue(Value);
- ComputeElement(Expr,ResolvedEl,[rcConstant]);
- RaiseXExpectedButYFound(20210101194628,Expected,GetTypeDescription(ResolvedEl),Expr);
- end;
- var
- Expr: TPasExpr;
- DeclEl: TPasElement;
- FindData: TPRFindData;
- Ref: TResolvedReference;
- ResolvedEl: TPasResolverResult;
- Section: TPasSection;
- Scope: TPasIdentifierScope;
- ScopeIdent: TPasIdentifier;
- begin
- Expr:=El.NameExpr;
- if Expr<>nil then
- begin
- ResolveExpr(Expr,rraRead);
- ComputeElement(Expr,ResolvedEl,[rcConstant]);
- DeclEl:=ResolvedEl.IdentEl;
- if DeclEl=nil then
- RaiseMsg(20210103012907,nXExpectedButYFound,sXExpectedButYFound,['symbol',GetTypeDescription(ResolvedEl)],Expr);
- if not (DeclEl.Parent is TPasSection) then
- RaiseMsg(20210103012908,nXExpectedButYFound,sXExpectedButYFound,['global symbol',GetElementTypeName(DeclEl)],Expr);
- end
- else
- begin
- FindFirstEl(El.Name,FindData,El);
- DeclEl:=FindData.Found;
- if DeclEl=nil then
- RaiseMsg(20210103002747,nIdentifierNotFound,sIdentifierNotFound,[El.Name],El);
- if not (DeclEl.Parent is TPasSection) then
- RaiseMsg(20210103003244,nXExpectedButYFound,sXExpectedButYFound,['global symbol',GetObjPath(DeclEl)],El);
- Ref:=CreateReference(DeclEl,El,rraRead,@FindData);
- CheckFoundElement(FindData,Ref);
- end;
- if DeclEl is TPasProcedure then
- begin
- Section:=DeclEl.Parent as TPasSection;
- Scope:=Section.CustomData as TPasIdentifierScope;
- ScopeIdent:=Scope.FindLocalIdentifier(DeclEl.Name);
- if (ScopeIdent=nil) then
- RaiseNotYetImplemented(20210106103001,El,GetObjPath(DeclEl));
- if ScopeIdent.NextSameIdentifier<>nil then
- RaiseMsg(20210106103320,nCantDetermineWhichOverloadedFunctionToCall,
- sCantDetermineWhichOverloadedFunctionToCall,[],El);
- end;
- // check index and name
- CheckConstExpr(El.ExportIndex,[revkInt,revkUInt],'integer');
- CheckConstExpr(El.ExportName,revkAllStrings,'string');
- end;
- procedure TPasResolver.FinishProcParamAccess(ProcType: TPasProcedureType;
- Params: TParamsExpr);
- var
- ParamAccess: TResolvedRefAccess;
- i: Integer;
- ArrParams: TPasExprArray;
- begin
- ArrParams:=Params.Params;
- for i:=0 to length(ArrParams)-1 do
- begin
- ParamAccess:=rraRead;
- if i<ProcType.Args.Count then
- case TPasArgument(ProcType.Args[i]).Access of
- argVar: ParamAccess:=rraVarParam;
- argOut: ParamAccess:=rraOutParam;
- end;
- AccessExpr(ArrParams[i],ParamAccess);
- end;
- CheckCallProcCompatibility(ProcType,Params,false,true);
- end;
- procedure TPasResolver.FinishPropertyParamAccess(Params: TParamsExpr;
- Prop: TPasProperty);
- var
- i: Integer;
- ParamAccess: TResolvedRefAccess;
- begin
- for i:=0 to length(Params.Params)-1 do
- begin
- ParamAccess:=rraRead;
- if i<Prop.Args.Count then
- case TPasArgument(Prop.Args[i]).Access of
- argVar: ParamAccess:=rraVarParam;
- argOut: ParamAccess:=rraOutParam;
- end;
- FinishCallArgAccess(Params.Params[i],ParamAccess);
- end;
- end;
- procedure TPasResolver.FinishCallArgAccess(Expr: TPasExpr;
- Access: TResolvedRefAccess);
- var
- ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags;
- begin
- AccessExpr(Expr,Access);
- Flags:=[rcSetReferenceFlags];
- if Access<>rraRead then
- Include(Flags,rcNoImplicitProc);
- ComputeElement(Expr,ResolvedEl,Flags);
- end;
- procedure TPasResolver.FinishInitialFinalization(El: TPasImplBlock);
- begin
- if El=nil then ;
- CheckTopScope(ScopeClass_InitialFinalization);
- PopScope;
- end;
- procedure TPasResolver.EmitTypeHints(PosEl: TPasElement; aType: TPasType);
- begin
- while aType<>nil do
- begin
- if EmitElementHints(PosEl,aType) then
- exit; // give only hints for the nearest
- if aType.InheritsFrom(TPasAliasType) then
- aType:=TPasAliasType(aType).DestType
- else if aType.ClassType=TPasPointerType then
- aType:=TPasPointerType(aType).DestType
- else if (aType.ClassType=TPasClassType) and TPasClassType(aType).IsForward
- and (aType.CustomData is TResolvedReference) then
- aType:=TPasType(TResolvedReference(aType.CustomData).Declaration)
- else
- exit;
- end;
- end;
- function TPasResolver.EmitElementHints(PosEl, El: TPasElement): boolean;
- begin
- if IsElementSkipped(El) then
- RaiseNotYetImplemented(20170927160030,PosEl,GetObjName(El));
- if El.Hints=[] then exit(false);
- Result:=true;
- if hDeprecated in El.Hints then
- begin
- if El.HintMessage<>'' then
- LogMsg(20170422160807,mtWarning,nSymbolXIsDeprecatedY,sSymbolXIsDeprecatedY,
- [El.Name,El.HintMessage],PosEl)
- else
- LogMsg(20170419190434,mtWarning,nSymbolXIsDeprecated,sSymbolXIsDeprecated,
- [El.Name],PosEl);
- end;
- if hLibrary in El.Hints then
- LogMsg(20170419190426,mtWarning,nSymbolXBelongsToALibrary,sSymbolXBelongsToALibrary,
- [El.Name],PosEl);
- if hPlatform in El.Hints then
- LogMsg(20170419185916,mtWarning,nSymbolXIsNotPortable,sSymbolXIsNotPortable,
- [El.Name],PosEl);
- if hExperimental in El.Hints then
- LogMsg(20170419190111,mtWarning,nSymbolXIsExperimental,sSymbolXIsExperimental,
- [El.Name],PosEl);
- if hUnimplemented in El.Hints then
- LogMsg(20170419190317,mtWarning,nSymbolXIsNotImplemented,sSymbolXIsNotImplemented,
- [El.Name],PosEl);
- end;
- procedure TPasResolver.StoreScannerFlagsInProc(ProcScope: TPasProcedureScope);
- var
- ModScope: TPasModuleScope;
- begin
- if ppsfIsSpecialized in ProcScope.Flags then exit;
- ProcScope.BoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
- if bsRangeChecks in ProcScope.BoolSwitches then
- begin
- ModScope:=RootElement.CustomData as TPasModuleScope;
- Include(ModScope.Flags,pmsfRangeErrorNeeded);
- end;
- end;
- procedure TPasResolver.ReplaceProcScopeImplArgsWithDeclArgs(
- ImplProcScope: TPasProcedureScope);
- var
- DeclProc, ImplProc: TPasProcedure;
- DeclArgs, ImplArgs, ImplTemplates, DeclTemplates: TFPList;
- i, j: Integer;
- DeclArg, ImplArg: TPasArgument;
- Identifier: TPasIdentifier;
- ImplNameParts: TProcedureNameParts;
- ImplNamePart: TProcedureNamePart;
- ImplTemplType, DeclTemplType: TPasGenericTemplateType;
- FuncType: TPasFunctionType;
- begin
- ImplProc:=ImplProcScope.Element as TPasProcedure;
- DeclProc:=ImplProcScope.DeclarationProc;
- // redirect impl generic template types with declaration types
- ImplNameParts:=ImplProc.NameParts;
- if ImplNameParts<>nil then
- begin
- // For example: "procedure TA<T>.Fly<U>;"
- // The generic type templates (e.g. "T") are in the class
- // -> remove generic type templates from proc scope
- for i:=0 to ImplNameParts.Count-2 do
- begin
- ImplNamePart:=TProcedureNamePart(ImplNameParts[i]);
- ImplTemplates:=ImplNamePart.Templates;
- if ImplTemplates=nil then continue;
- for j:=0 to ImplTemplates.Count-1 do
- begin
- ImplTemplType:=TPasGenericTemplateType(ImplTemplates[j]);
- ImplProcScope.RemoveLocalIdentifier(ImplTemplType);
- end;
- end;
- // redirect implproc parameters to declproc parameters
- ImplTemplates:=GetProcTemplateTypes(ImplProc);
- DeclTemplates:=GetProcTemplateTypes(DeclProc);
- if ImplTemplates<>nil then
- begin
- if (DeclTemplates=nil) or (ImplTemplates.Count<>DeclTemplates.Count) then
- RaiseNotYetImplemented(20190912153602,ImplProc); // inconsistency
- for i:=0 to ImplTemplates.Count-1 do
- begin
- DeclTemplType:=TPasGenericTemplateType(DeclTemplates[i]);
- ImplTemplType:=TPasGenericTemplateType(ImplTemplates[i]);
- Identifier:=ImplProcScope.FindLocalIdentifier(ImplTemplType.Name);
- if Identifier.Element<>ImplTemplType then
- RaiseInternalError(20190912154009,GetObjName(DeclTemplType)+' '+GetObjName(ImplTemplType));
- Identifier.Element:=DeclTemplType;
- Identifier.Identifier:=DeclTemplType.Name;
- end;
- end
- else if DeclTemplates<>nil then
- // declproc is parametrized, implproc is not
- RaiseNotYetImplemented(20190912153439,ImplProc); // inconsistency
- end;
- // redirect impl arguments to declaration args
- ImplArgs:=ImplProc.ProcType.Args;
- DeclArgs:=DeclProc.ProcType.Args;
- for i:=0 to DeclArgs.Count-1 do
- begin
- DeclArg:=TPasArgument(DeclArgs[i]);
- if i<ImplArgs.Count then
- begin
- ImplArg:=TPasArgument(ImplArgs[i]);
- Identifier:=ImplProcScope.FindLocalIdentifier(DeclArg.Name);
- //writeln('TPasResolver.ReplaceProcScopeImplArgsWithDeclArgs i=',i,' replacing ',GetObjName(ImplArg),' with ',GetObjName(DeclArg));
- if Identifier.Element<>ImplArg then
- RaiseInternalError(20170203161659,GetObjName(DeclArg)+' '+GetObjName(ImplArg));
- Identifier.Element:=DeclArg;
- Identifier.Identifier:=DeclArg.Name;
- end
- else
- begin
- // e.g. when Delphi mode omits ImplProc signature
- AddIdentifier(ImplProcScope,DeclArg.Name,DeclArg,pikSimple);
- end;
- end;
- if DeclProc.ProcType is TPasFunctionType then
- begin
- // redirect implementation 'Result' to declaration FuncType.ResultEl
- FuncType:=TPasFunctionType(DeclProc.ProcType);
- if FuncType.ResultEl<>nil then
- begin
- Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar);
- if Identifier=nil then
- begin
- // e.g. when Delphi mode omits ImplProc signature
- AddIdentifier(ImplProcScope,ResolverResultVar,FuncType.ResultEl,pikSimple);
- end
- else if Identifier.Element is TPasResultElement then
- Identifier.Element:=FuncType.ResultEl;
- end;
- end;
- end;
- function TPasResolver.CreateClassIntfMap(El: TPasClassType; Index: integer
- ): TPasClassIntfMap;
- var
- IntfType: TPasClassType;
- Map: TPasClassIntfMap;
- ClassScope: TPasClassScope;
- begin
- ClassScope:=El.CustomData as TPasClassScope;
- if ClassScope.Interfaces[Index]<>nil then
- RaiseInternalError(20180322141916,GetElementDbgPath(El)+' '+IntToStr(Index)+' '+GetObjName(TObject(ClassScope.Interfaces[Index])));
- IntfType:=TPasClassType(ResolveAliasType(TPasType(El.Interfaces[Index])));
- Map:=nil;
- while IntfType<>nil do
- begin
- if Map=nil then
- begin
- Map:=TPasClassIntfMap.Create;
- Map.Element:=El;
- Result:=Map;
- ClassScope.Interfaces[Index]:=Map;
- end
- else
- begin
- Map.AncestorMap:=TPasClassIntfMap.Create;
- Map:=Map.AncestorMap;
- Map.Element:=El;
- end;
- Map.Intf:=IntfType;
- Map.Procs:=TFPList.Create;
- Map.Procs.Count:=IntfType.Members.Count;
- IntfType:=GetPasClassAncestor(IntfType,true) as TPasClassType;
- end;
- end;
- procedure TPasResolver.CheckConditionExpr(El: TPasExpr;
- const ResolvedEl: TPasResolverResult);
- begin
- if ResolvedEl.BaseType=btBoolean then exit;
- if IsGenericTemplType(ResolvedEl) then exit;
- RaiseXExpectedButYFound(20170216152135,
- BaseTypeNames[btBoolean],BaseTypeNames[ResolvedEl.BaseType],El);
- end;
- procedure TPasResolver.CheckProcSignatureMatch(DeclProc,
- ImplProc: TPasProcedure; IsOverride: boolean);
- var
- i: Integer;
- DeclArgs, ImplArgs, ImplTemplates, DeclTemplates: TFPList;
- DeclName, ImplName: String;
- ImplResult, DeclResult: TPasType;
- ImplTemplType, DeclTemplType: TPasGenericTemplateType;
- NewImplPTMods, DeclPTMods, ImplPTMods: TProcTypeModifiers;
- ptm: TProcTypeModifier;
- NewImplProcMods: TProcedureModifiers;
- pm: TProcedureModifier;
- begin
- if ImplProc.ClassType<>DeclProc.ClassType then
- RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc);
- DeclArgs:=DeclProc.ProcType.Args;
- ImplArgs:=ImplProc.ProcType.Args;
- if DeclArgs.Count<>ImplArgs.Count then
- RaiseNotYetImplemented(20190912110642,ImplProc);
- DeclPTMods:=DeclProc.ProcType.Modifiers;
- ImplPTMods:=ImplProc.ProcType.Modifiers;
- DeclTemplates:=GetProcTemplateTypes(DeclProc);
- ImplTemplates:=GetProcTemplateTypes(ImplProc);
- if DeclTemplates<>nil then
- begin
- // DeclProc has templates
- if IsOverride then
- RaiseNotYetImplemented(20190912113857,ImplProc); // inconsistency
- if ImplTemplates=nil then
- RaiseMsg(20190912144529,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetProcName(ImplProc),GetElementSourcePosStr(DeclProc)],ImplProc);
- // declaration proc has template type aka is parametrized
- // -> check template types
- if ImplTemplates.Count<>DeclTemplates.Count then
- RaiseMsg(20190912145320,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetProcName(ImplProc),GetElementSourcePosStr(TPasElement(DeclTemplates[0]))],ImplProc);
- for i:=0 to DeclTemplates.Count-1 do
- begin
- DeclTemplType:=TPasGenericTemplateType(DeclTemplates[i]);
- ImplTemplType:=TPasGenericTemplateType(ImplTemplates[i]);
- if not SameText(DeclTemplType.Name,ImplTemplType.Name) then
- RaiseMsg(20190912150311,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetProcName(ImplProc),GetElementSourcePosStr(TPasElement(DeclTemplType))],ImplTemplType);
- if length(ImplTemplType.Constraints)>0 then
- RaiseMsg(20190912150739,nImplMustNotRepeatConstraints,sImplMustNotRepeatConstraints,[],ImplTemplType);
- end;
- end
- else if ImplTemplates<>nil then
- begin
- // ImplProc has templates, DeclProc does not
- RaiseMsg(20190912113857,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetProcName(ImplProc),GetElementSourcePosStr(DeclProc)],ImplProc);
- end;
- if not IsOverride then
- begin
- // check argument names
- for i:=0 to DeclArgs.Count-1 do
- begin
- DeclName:=TPasArgument(DeclArgs[i]).Name;
- ImplName:=TPasArgument(ImplArgs[i]).Name;
- if CompareText(DeclName,ImplName)<>0 then
- RaiseMsg(20170216151738,nFunctionHeaderMismatchForwardVarName,
- sFunctionHeaderMismatchForwardVarName,[DeclProc.Name,DeclName,ImplName],ImplProc);
- end;
- end;
- if ImplProc.ProcType is TPasFunctionType then
- begin
- // check result type
- ImplResult:=TPasFunctionType(ImplProc.ProcType).ResultEl.ResultType;
- DeclResult:=TPasFunctionType(DeclProc.ProcType).ResultEl.ResultType;
- if CheckElTypeCompatibility(ImplResult,DeclResult,prraSimple)>cGenericExact then
- RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound,
- [],DeclResult,ImplResult,ImplProc);
- end;
- // calling convention
- if ImplProc.CallingConvention<>DeclProc.CallingConvention then
- RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
- // modifiers
- if IsOverride then
- begin
- // override/class-intf-impl: calling conventions must match
- NewImplPTMods:=ImplPTMods><DeclPTMods;
- for ptm in NewImplPTMods do
- RaiseMsg(20201227213020,nXModifierMismatchY,sXModifierMismatchY,
- ['procedure type',ProcTypeModifiers[ptm]],ImplProc.ProcType);
- end
- else
- begin
- // implementation proc must not add modifiers, except "assembler"
- NewImplProcMods:=ImplProc.Modifiers-DeclProc.Modifiers-[pmAssembler];
- if NewImplProcMods<>[] then
- for pm in NewImplProcMods do
- RaiseMsg(20200518182445,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere,
- [ModifierNames[pm]],ImplProc.ProcType);
- // implementation proc must not add modifiers
- NewImplPTMods:=ImplPTMods-DeclPTMods;
- if NewImplPTMods<>[] then
- for ptm in NewImplPTMods do
- RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere,
- [ProcTypeModifiers[ptm]],ImplProc.ProcType);
- end;
- end;
- procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock);
- var
- i: Integer;
- begin
- if Block=nil then exit;
- for i:=0 to Block.Elements.Count-1 do
- ResolveImplElement(TPasImplElement(Block.Elements[i]));
- end;
- procedure TPasResolver.ResolveImplElement(El: TPasImplElement);
- var
- C: TClass;
- begin
- //writeln('TPasResolver.ResolveImplElement ',GetObjName(El));
- if El=nil then exit;
- C:=El.ClassType;
- if C=TPasImplBeginBlock then
- ResolveImplBlock(TPasImplBeginBlock(El))
- else if C=TPasImplAssign then
- ResolveImplAssign(TPasImplAssign(El))
- else if C=TPasImplSimple then
- ResolveImplSimple(TPasImplSimple(El))
- else if C=TPasImplBlock then
- ResolveImplBlock(TPasImplBlock(El))
- else if C=TPasImplRepeatUntil then
- begin
- ResolveImplBlock(TPasImplBlock(El));
- ResolveStatementConditionExpr(TPasImplRepeatUntil(El).ConditionExpr);
- end
- else if C=TPasImplIfElse then
- begin
- ResolveStatementConditionExpr(TPasImplIfElse(El).ConditionExpr);
- ResolveImplElement(TPasImplIfElse(El).IfBranch);
- ResolveImplElement(TPasImplIfElse(El).ElseBranch);
- end
- else if C=TPasImplWhileDo then
- begin
- ResolveStatementConditionExpr(TPasImplWhileDo(El).ConditionExpr);
- ResolveImplElement(TPasImplWhileDo(El).Body);
- end
- else if C=TPasImplCaseOf then
- ResolveImplCaseOf(TPasImplCaseOf(El))
- else if C=TPasImplLabelMark then
- ResolveImplLabelMark(TPasImplLabelMark(El))
- else if C=TPasImplForLoop then
- // the header was already resolved
- ResolveImplElement(TPasImplForLoop(El).Body)
- else if C=TPasImplTry then
- begin
- ResolveImplBlock(TPasImplTry(El));
- ResolveImplBlock(TPasImplTry(El).FinallyExcept);
- ResolveImplBlock(TPasImplTry(El).ElseBranch);
- end
- else if C=TPasImplExceptOn then
- // handled in FinishExceptOnStatement
- else if C=TPasImplRaise then
- ResolveImplRaise(TPasImplRaise(El))
- else if C=TPasImplCommand then
- begin
- if TPasImplCommand(El).Command<>'' then
- RaiseNotYetImplemented(20160922163442,El,'TPasResolver.ResolveImplElement');
- end
- else if C=TPasImplAsmStatement then
- ResolveImplAsm(TPasImplAsmStatement(El))
- else if C=TPasImplWithDo then
- ResolveImplWithDo(TPasImplWithDo(El))
- else
- RaiseNotYetImplemented(20160922163445,El,'TPasResolver.ResolveImplElement');
- end;
- procedure TPasResolver.ResolveImplCaseOf(CaseOf: TPasImplCaseOf);
- type
- TRangeItem = record
- RangeStart, RangeEnd: TMaxPrecInt;
- Expr: TPasExpr;
- aString: UnicodeString;
- // Note: for case-of-string:
- // single values are stored in aString and RangeStart=1, RangeEnd=0
- // ranges are stored as aString='', RangeStart, RangeEnd
- end;
- PRangeItem = ^TRangeItem;
- function CreateValues(const ResolvedEl: TPasResolverResult;
- var ValueSet: TResEvalSet): boolean;
- var
- CaseExprType: TPasType;
- bt: TResolverBaseType;
- ElTypeResolved: TPasResolverResult;
- begin
- Result:=false;
- bt:=ResolvedEl.BaseType;
- if bt in btAllStrings then
- exit(true)
- else if bt=btRange then
- bt:=ResolvedEl.SubType;
- if bt in btAllInteger then
- begin
- ValueSet:=TResEvalSet.CreateEmpty(revskInt);
- Result:=true;
- end
- else if bt in btAllBooleans then
- begin
- ValueSet:=TResEvalSet.CreateEmpty(revskBool);
- Result:=true;
- end
- else if bt in btAllChars then
- begin
- ValueSet:=TResEvalSet.CreateEmpty(revskChar);
- Result:=true;
- end
- else if bt=btContext then
- begin
- CaseExprType:=ResolvedEl.LoTypeEl;
- if CaseExprType.ClassType=TPasEnumType then
- begin
- ValueSet:=TResEvalSet.CreateEmpty(revskEnum,CaseExprType);
- Result:=true;
- end
- else if CaseExprType.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(CaseExprType).RangeExpr.left,ElTypeResolved,[rcConstant]);
- Result:=CreateValues(ElTypeResolved,ValueSet);
- end;
- end;
- end;
- function AddRangeItem(Values: TFPList; const RangeStart, RangeEnd: TMaxPrecInt;
- Expr: TPasExpr): PRangeItem;
- begin
- New(Result);
- Result^.RangeStart:=RangeStart;
- Result^.RangeEnd:=RangeEnd;
- Result^.Expr:=Expr;
- Values.Add(Result);
- end;
- function AddValue(Value: TResEvalValue; Values: TFPList; ValueSet: TResEvalSet;
- Expr: TPasExpr): boolean;
- function AddString(const s: UnicodeString): boolean;
- var
- Dupl: TPasExpr;
- i, o: Integer;
- Item: PRangeItem;
- begin
- if length(s)=1 then
- o:=ord(s[1])
- else
- o:=-1;
- for i:=0 to Values.Count-1 do
- begin
- Item:=PRangeItem(Values[i]);
- if (Item^.aString=s)
- or ((o>=Item^.RangeStart) and (o<=Item^.RangeEnd)) then
- begin
- Dupl:=PRangeItem(Values[i])^.Expr;
- RaiseMsg(20180424220139,nDuplicateCaseValueXatY,sDuplicateCaseValueXatY,
- ['string',GetElementSourcePosStr(Dupl)],Expr);
- end;
- end;
- Item:=AddRangeItem(Values,1,0,Expr);
- Item^.aString:=s;
- Result:=true;
- end;
- function AddStringRange(CharStart, CharEnd: TMaxPrecInt): boolean;
- var
- i, o: Integer;
- s: UnicodeString;
- Item: PRangeItem;
- Dupl: TPasExpr;
- begin
- if CharEnd>$ffff then
- RaiseNotYetImplemented(20180501221359,Expr,Value.AsDebugString);
- for i:=0 to Values.Count-1 do
- begin
- Item:=PRangeItem(Values[i]);
- s:=Item^.aString;
- if length(s)=1 then
- o:=ord(s[1])
- else
- o:=-1;
- if ((o>=CharStart) and (o<=CharEnd))
- or ((Item^.RangeStart<=CharEnd) and (Item^.RangeEnd>=CharStart)) then
- begin
- Dupl:=PRangeItem(Values[i])^.Expr;
- RaiseMsg(20180501223914,nDuplicateCaseValueXatY,sDuplicateCaseValueXatY,
- ['string',GetElementSourcePosStr(Dupl)],Expr);
- end;
- end;
- AddRangeItem(Values,CharStart,CharEnd,Expr);
- Result:=true;
- end;
- var
- RangeStart, RangeEnd: TMaxPrecInt;
- i: Integer;
- Item: PRangeItem;
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.ResolveImplCaseOf.AddValue Value={',Value.AsDebugString,'} Values.Count=',Values.Count);
- {$ENDIF}
- Result:=true;
- case Value.Kind of
- revkBool:
- begin
- RangeStart:=ord(TResEvalBool(Value).B);
- RangeEnd:=RangeStart;
- end;
- revkInt:
- begin
- RangeStart:=TResEvalInt(Value).Int;
- RangeEnd:=RangeStart;
- end;
- revkUInt:
- begin
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- if TResEvalUInt(Value).UInt>HighIntAsUInt then
- ExprEvaluator.EmitRangeCheckConst(20180424212414,Value.AsString,
- '0',IntToStr(High(TMaxPrecInt)),Expr,mtError);
- RangeStart:=TResEvalUInt(Value).UInt;
- RangeEnd:=RangeStart;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- if ValueSet=nil then
- exit(AddString(ExprEvaluator.GetUnicodeStr(TResEvalString(Value).S,Expr)))
- else
- begin
- RangeStart:=fExprEvaluator.StringToOrd(Value,nil);
- if RangeStart>$ffff then
- exit(false);
- RangeEnd:=RangeStart;
- end;
- {$endif}
- revkUnicodeString:
- if ValueSet=nil then
- exit(AddString(TResEvalUTF16(Value).S))
- else
- begin
- if length(TResEvalUTF16(Value).S)<>1 then
- exit(false);
- RangeStart:=ord(TResEvalUTF16(Value).S[1]);
- RangeEnd:=RangeStart;
- end;
- revkEnum:
- begin
- RangeStart:=TResEvalEnum(Value).Index;
- RangeEnd:=RangeStart;
- end;
- revkRangeInt:
- if ValueSet=nil then
- exit(AddStringRange(TResEvalRangeInt(Value).RangeStart,TResEvalRangeInt(Value).RangeEnd))
- else
- begin
- RangeStart:=TResEvalRangeInt(Value).RangeStart;
- RangeEnd:=TResEvalRangeInt(Value).RangeEnd;
- end;
- revkRangeUInt:
- begin
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- if TResEvalRangeUInt(Value).RangeEnd>HighIntAsUInt then
- ExprEvaluator.EmitRangeCheckConst(20180424212648,Value.AsString,
- '0',IntToStr(High(TMaxPrecInt)),Expr,mtError);
- RangeStart:=TResEvalRangeUInt(Value).RangeStart;
- RangeEnd:=TResEvalRangeUInt(Value).RangeEnd;
- end;
- else
- Result:=false;
- end;
- if ValueSet=nil then
- RaiseNotYetImplemented(20180424215728,Expr,Value.AsDebugString);
- i:=ValueSet.Intersects(RangeStart,RangeEnd);
- if i<0 then
- begin
- ValueSet.Add(RangeStart,RangeEnd);
- AddRangeItem(Values,RangeStart,RangeEnd,Expr);
- exit(true);
- end;
- // duplicate value -> show where
- for i:=0 to Values.Count-1 do
- begin
- Item:=PRangeItem(Values[i]);
- if (Item^.RangeStart>RangeEnd) or (Item^.RangeEnd<RangeStart) then continue;
- RaiseMsg(20180424214305,nDuplicateCaseValueXatY,sDuplicateCaseValueXatY,
- [Value.AsString,GetElementSourcePosStr(Item^.Expr)],Expr);
- end;
- Result:=false;
- end;
- var
- i, j: Integer;
- El: TPasElement;
- Stat: TPasImplCaseStatement;
- CaseExprResolved, OfExprResolved: TPasResolverResult;
- OfExpr: TPasExpr;
- ok: Boolean;
- Values: TFPList; // list of PRangeItem
- ValueSet: TResEvalSet;
- Value: TResEvalValue;
- Item: PRangeItem;
- begin
- ResolveExpr(CaseOf.CaseExpr,rraRead);
- ComputeElement(CaseOf.CaseExpr,CaseExprResolved,[rcSetReferenceFlags]);
- ok:=false;
- Values:=TFPList.Create;
- ValueSet:=nil;
- Value:=nil;
- try
- if (rrfReadable in CaseExprResolved.Flags) then
- ok:=CreateValues(CaseExprResolved,ValueSet);
- if not ok then
- begin
- if not IsGenericTemplType(CaseExprResolved) then
- RaiseXExpectedButYFound(20170216151952,'ordinal expression',
- GetTypeDescription(CaseExprResolved.LoTypeEl),CaseOf.CaseExpr);
- end;
- for i:=0 to CaseOf.Elements.Count-1 do
- begin
- El:=TPasElement(CaseOf.Elements[i]);
- if El.ClassType=TPasImplCaseStatement then
- begin
- Stat:=TPasImplCaseStatement(El);
- for j:=0 to Stat.Expressions.Count-1 do
- begin
- //writeln('TPasResolver.ResolveImplCaseOf Stat.Expr[',j,']=',GetObjName(El));
- OfExpr:=TPasExpr(Stat.Expressions[j]);
- ResolveExpr(OfExpr,rraRead);
- ComputeElement(OfExpr,OfExprResolved,[rcConstant,rcSetReferenceFlags]);
- if OfExprResolved.BaseType=btRange then
- ConvertRangeToElement(OfExprResolved);
- if not ok then
- continue;
- CheckEqualResCompatibility(CaseExprResolved,OfExprResolved,OfExpr,true);
- Value:=Eval(OfExpr,[refConstExt]);
- if Value<>nil then
- begin
- if Value.Kind=revkExternal then
- begin
- // external const
- end
- else if not AddValue(Value,Values,ValueSet,OfExpr) then
- RaiseIncompatibleTypeRes(20180424210815,nIncompatibleTypesGotExpected,
- [],OfExprResolved,CaseExprResolved,OfExpr);
- ReleaseEvalValue(Value);
- end
- else
- RaiseMsg(20180518102047,nConstantExpressionExpected,sConstantExpressionExpected,[],OfExpr);
- end;
- ResolveImplElement(Stat.Body);
- end
- else if El.ClassType=TPasImplCaseElse then
- ResolveImplBlock(TPasImplCaseElse(El))
- else
- RaiseNotYetImplemented(20160922163448,El);
- end;
- // Note: CaseOf.ElseBranch was already resolved via Elements
- finally
- ReleaseEvalValue(Value);
- ValueSet.Free;
- for i:=0 to Values.Count-1 do
- begin
- Item:=PRangeItem(Values[i]);
- Dispose(Item);
- end;
- Values.Free;
- end;
- end;
- procedure TPasResolver.ResolveImplLabelMark(Mark: TPasImplLabelMark);
- begin
- RaiseNotYetImplemented(20161014141636,Mark);
- end;
- procedure TPasResolver.ResolveImplWithDo(El: TPasImplWithDo);
- // Note: the expressions were already resolved during parsing
- // and the scopes were already stored in a TPasWithScope.
- // -> simply push them onto the scope stack
- var
- i: Integer;
- WithScope: TPasWithScope;
- ExprScope: TPasWithExprScope;
- begin
- if not (El.CustomData is TPasWithScope) then
- RaiseInternalError(20181210175349);
- WithScope:=TPasWithScope(El.CustomData);
- PushScope(WithScope);
- for i:=0 to WithScope.ExpressionScopes.Count-1 do
- begin
- ExprScope:=TPasWithExprScope(WithScope.ExpressionScopes[i]);
- PushScope(ExprScope);
- end;
- ResolveImplElement(El.Body);
- PopWithScope(El);
- end;
- procedure TPasResolver.ResolveImplAsm(El: TPasImplAsmStatement);
- begin
- if El=nil then ;
- end;
- procedure TPasResolver.ResolveImplAssign(El: TPasImplAssign);
- var
- LeftResolved, RightResolved: TPasResolverResult;
- Flags: TPasResolverComputeFlags;
- Access: TResolvedRefAccess;
- Value: TResEvalValue;
- begin
- if El.Kind=akDefault then
- Access:=rraAssign
- else
- Access:=rraReadAndAssign;
- ResolveExpr(El.left,Access);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplAssign Kind=',El.Kind,' left=',GetObjName(El.left),' right=',GetObjName(el.right));
- {$ENDIF}
- // check LHS can be assigned
- ComputeElement(El.left,LeftResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
- CheckCanBeLHS(LeftResolved,true,GetRightMostExpr(El.left));
- // compute RHS
- ResolveExpr(El.right,rraRead);
- Flags:=[rcSetReferenceFlags];
- if IsProcedureType(LeftResolved,true) then
- begin
- if (msDelphi in CurrentParser.CurrentModeswitches) then
- Include(Flags,rcNoImplicitProc) // a proc type can use param less procs
- else
- Include(Flags,rcNoImplicitProcType); // a proc type can use a param less proc type
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplAssign Left=',GetResolverResultDbg(LeftResolved),' Flags=',dbgs(Flags));
- {$ENDIF}
- ComputeElement(El.right,RightResolved,Flags);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplAssign Right=',GetResolverResultDbg(RightResolved));
- {$ENDIF}
- case El.Kind of
- akDefault:
- begin
- CheckAssignResCompatibility(LeftResolved,RightResolved,El.right,true);
- CheckAssignExprRange(LeftResolved,El.right);
- if (LeftResolved.BaseType=btContext) and (LeftResolved.LoTypeEl.ClassType=TPasArrayType) then
- MarkArrayExprRecursive(El.right,TPasArrayType(LeftResolved.LoTypeEl));
- end;
- akAdd, akMinus,akMul,akDivision:
- begin
- if (LeftResolved.BaseType in btAllInteger) and (El.Kind in [akAdd,akMinus,akMul]) then
- begin
- if (not (rrfReadable in RightResolved.Flags))
- or not (RightResolved.BaseType in btAllInteger) then
- RaiseMsg(20170216152009,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [BaseTypes[RightResolved.BaseType],BaseTypes[LeftResolved.BaseType]],El.right);
- end
- else if (LeftResolved.BaseType in btAllStrings) and (El.Kind=akAdd) then
- begin
- if (not (rrfReadable in RightResolved.Flags))
- or not (RightResolved.BaseType in btAllStringAndChars) then
- RaiseMsg(20170216152012,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [BaseTypes[RightResolved.BaseType],BaseTypes[LeftResolved.BaseType]],El.right);
- end
- else if (LeftResolved.BaseType in btAllFloats)
- and (El.Kind in [akAdd,akMinus,akMul,akDivision]) then
- begin
- if (not (rrfReadable in RightResolved.Flags))
- or not (RightResolved.BaseType in (btAllInteger+btAllFloats)) then
- RaiseMsg(20170216152107,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [BaseTypes[RightResolved.BaseType],BaseTypes[LeftResolved.BaseType]],El.right);
- end
- else if (LeftResolved.BaseType=btSet) and (El.Kind in [akAdd,akMinus,akMul]) then
- begin
- if (not (rrfReadable in RightResolved.Flags))
- or not (RightResolved.BaseType in [btSet,btArrayOrSet]) then
- RaiseMsg(20170216152110,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [BaseTypeNames[RightResolved.BaseType],'set of '+BaseTypeNames[LeftResolved.SubType]],El.right);
- if (LeftResolved.SubType=RightResolved.SubType)
- or ((LeftResolved.SubType in btAllInteger) and (RightResolved.SubType in btAllInteger))
- or ((LeftResolved.SubType in btAllBooleans) and (RightResolved.SubType in btAllBooleans))
- then
- else
- RaiseMsg(20170216152117,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['set of '+BaseTypeNames[RightResolved.SubType],'set of '+BaseTypeNames[LeftResolved.SubType]],El.right);
- end
- else if LeftResolved.BaseType=btContext then
- begin
- if (LeftResolved.LoTypeEl.ClassType=TPasArrayType) and (El.Kind=akAdd)
- and (rrfReadable in RightResolved.Flags)
- and IsDynArray(LeftResolved.LoTypeEl) then
- begin
- // DynArr+=...
- CheckAssignCompatibilityArrayType(LeftResolved,RightResolved,El,true);
- exit;
- end
- else
- RaiseIncompatibleTypeRes(20180615235749,nOperatorIsNotOverloadedAOpB,[AssignKindNames[El.Kind]],LeftResolved,RightResolved,El);
- end
- else
- RaiseIncompatibleTypeRes(20180208115707,nOperatorIsNotOverloadedAOpB,[AssignKindNames[El.Kind]],LeftResolved,RightResolved,El);
- // store const expression result
- Value:=Eval(El.right,[]);
- ReleaseEvalValue(Value);
- end;
- else
- RaiseNotYetImplemented(20160927143649,El,'AssignKind '+AssignKindNames[El.Kind]);
- end;
- end;
- procedure TPasResolver.ResolveImplSimple(El: TPasImplSimple);
- var
- ExprResolved: TPasResolverResult;
- Expr: TPasExpr;
- begin
- Expr:=El.expr;
- ResolveExpr(Expr,rraRead);
- ComputeElement(Expr,ExprResolved,[rcSetReferenceFlags]);
- if (rrfCanBeStatement in ExprResolved.Flags) then
- exit;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplSimple El=',GetObjName(El),' El.Expr=',GetObjName(El.Expr),' ExprResolved=',GetResolverResultDbg(ExprResolved));
- {$ENDIF}
- RaiseMsg(20170216152127,nIllegalExpression,sIllegalExpression,[],El);
- end;
- procedure TPasResolver.ResolveImplRaise(El: TPasImplRaise);
- var
- ResolvedEl: TPasResolverResult;
- begin
- if El.ExceptObject<>nil then
- begin
- ResolveExpr(El.ExceptObject,rraRead);
- ComputeElement(El.ExceptObject,ResolvedEl,[rcSetReferenceFlags]);
- CheckIsClass(El.ExceptObject,ResolvedEl);
- if ResolvedEl.IdentEl<>nil then
- begin
- if (ResolvedEl.IdentEl is TPasVariable)
- or (ResolvedEl.IdentEl is TPasArgument)
- or (ResolvedEl.IdentEl is TPasResultElement) then
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplRaise ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- RaiseXExpectedButYFound(20170216152133,
- 'variable',GetElementTypeName(ResolvedEl.IdentEl),El.ExceptObject);
- end;
- end
- else if ResolvedEl.ExprEl<>nil then
- else
- RaiseXExpectedButYFound(201702303145230,
- 'variable',GetResolverResultDbg(ResolvedEl),El.ExceptObject);
- if not (rrfReadable in ResolvedEl.Flags) then
- RaiseMsg(20170303145037,nNotReadable,sNotReadable,[],El.ExceptObject);
- end;
- if El.ExceptAddr<>nil then
- ResolveExpr(El.ExceptAddr,rraRead);
- end;
- procedure TPasResolver.ResolveExpr(El: TPasExpr; Access: TResolvedRefAccess);
- var
- Primitive: TPrimitiveExpr;
- ElClass: TClass;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveExpr ',GetObjName(El),' ',Access);
- {$ENDIF}
- if El=nil then
- RaiseNotYetImplemented(20160922163453,El);
- ElClass:=El.ClassType;
- if ElClass=TPrimitiveExpr then
- begin
- Primitive:=TPrimitiveExpr(El);
- case Primitive.Kind of
- pekIdent: ResolveNameExpr(El,Primitive.Value,Access);
- pekNumber: ;
- pekString: ;
- pekNil,pekBoolConst: ;
- else
- RaiseNotYetImplemented(20160922163451,El);
- end;
- end
- else if ElClass=TUnaryExpr then
- ResolveExpr(TUnaryExpr(El).Operand,Access)
- else if ElClass=TBinaryExpr then
- ResolveBinaryExpr(TBinaryExpr(El),Access)
- else if ElClass=TParamsExpr then
- ResolveParamsExpr(TParamsExpr(El),Access)
- else if ElClass=TBoolConstExpr then
- else if ElClass=TNilExpr then
- else if ElClass=TInheritedExpr then
- ResolveInherited(TInheritedExpr(El),Access)
- else if ElClass=TArrayValues then
- begin
- if Access<>rraRead then
- RaiseMsg(20170303205743,nVariableIdentifierExpected,sVariableIdentifierExpected,
- [],El);
- ResolveArrayValues(TArrayValues(El));
- end
- else if ElClass=TRecordValues then
- begin
- if Access<>rraRead then
- RaiseMsg(20180429103024,nVariableIdentifierExpected,sVariableIdentifierExpected,
- [],El);
- ResolveRecordValues(TRecordValues(El));
- end
- else if ElClass=TProcedureExpr then
- // resolved by FinishScope(stProcedure)
- else if ElClass=TInlineSpecializeExpr then
- ResolveInlineSpecializeExpr(TInlineSpecializeExpr(El),Access)
- else
- RaiseNotYetImplemented(20170222184329,El);
- if El.format1<>nil then
- ResolveExpr(El.format1,rraRead);
- if El.format2<>nil then
- ResolveExpr(El.format2,rraRead);
- end;
- procedure TPasResolver.ResolveStatementConditionExpr(El: TPasExpr);
- var
- ResolvedCond: TPasResolverResult;
- begin
- ResolveExpr(El,rraRead);
- ComputeElement(El,ResolvedCond,[rcSetReferenceFlags]);
- CheckConditionExpr(El,ResolvedCond);
- end;
- procedure TPasResolver.ResolveNameExpr(El: TPasExpr; const aName: string;
- Access: TResolvedRefAccess);
- var
- FindData: TPRFindData;
- DeclEl: TPasElement;
- Proc, ImplProc: TPasProcedure;
- Ref: TResolvedReference;
- BuiltInProc: TResElDataBuiltInProc;
- p: SizeInt;
- DottedName: String;
- Bin: TBinaryExpr;
- ProcScope: TPasProcedureScope;
- ParentParams: TPRParentParams;
- TypeCnt: Integer;
- InlParams, TemplTypes: TFPList;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveNameExpr El=',GetObjName(El),' Name="',aName,'" ',Access);
- {$ENDIF}
- GetParamsOfNameExpr(El,ParentParams);
- if ParentParams.InlineSpec<>nil then
- InlParams:=ParentParams.InlineSpec.Params
- else
- InlParams:=nil;
- //writeln('TPasResolver.ResolveNameExpr Inline=',GetObjName(ParentParams.InlineSpec),' Params=',GetObjName(ParentParams.Params),' ',GetObjPath(El));
- if ParentParams.Params<>nil then
- begin
- case ParentParams.Params.Kind of
- pekFuncParams:
- ResolveFuncParamsExprName(El,InlParams,ParentParams.Params,Access);
- pekArrayParams:
- ResolveArrayParamsExprName(El,ParentParams.Params,Access);
- else
- RaiseNotYetImplemented(20190912190428,El,GetObjPath(ParentParams.Params));
- end;
- exit;
- end;
- if ParentParams.InlineSpec<>nil then
- begin
- TypeCnt:=InlParams.Count;
- DeclEl:=FindGenericEl(aName,TypeCnt,FindData,El);
- if DeclEl<>nil then
- begin
- // GenType<params> -> create specialize type/proc
- DeclEl:=GetSpecializedEl(ParentParams.InlineSpec,DeclEl,InlParams);
- end
- else
- RaiseXExpectedButYFound(20190916160829,'generic type',GetElementTypeName(DeclEl),El);
- end
- else
- DeclEl:=FindElementWithoutParams(aName,FindData,El,false,false);
- if DeclEl.ClassType=TPasUsesUnit then
- begin
- // the first name of a unit matches -> find unit with longest match
- FindLongestUnitName(DeclEl,El);
- FindData.Found:=DeclEl;
- end;
- Ref:=CreateReference(DeclEl,El,Access,@FindData);
- CheckFoundElement(FindData,Ref);
- if DeclEl is TPasProcedure then
- begin
- // identifier is a proc and args brackets are missing
- Proc:=TPasProcedure(DeclEl);
- if ParentParams.InlineSpec=nil then
- begin
- TemplTypes:=GetProcTemplateTypes(Proc);
- if (TemplTypes<>nil) then
- begin
- // implicit function specialization without bracket
- {$IFDEF VerbosePasResolver}
- DeclEl:=El;
- while DeclEl.Parent is TPasExpr do
- DeclEl:=DeclEl.Parent;
- {AllowWriteln}
- writeln('TPasResolver.ResolveNameExpr ',WritePasElTree(TPasExpr(DeclEl),' '));
- {AllowWriteln-}
- {$ENDIF}
- RaiseMsg(20191007222004,nCouldNotInferTypeArgXForMethodY,
- sCouldNotInferTypeArgXForMethodY,[TPasGenericTemplateType(TemplTypes[0]).Name,Proc.Name],El);
- end;
- end;
- if El.Parent.ClassType=TPasProperty then
- // a property accessor does not need args -> ok
- // Note: the detailed tests are in FinishProperty
- else
- begin
- // examples: funca or @proca or a.funca or @a.funca ...
- if (Access=rraAssign) and (Proc.ProcType is TPasFunctionType)
- and (El.ClassType=TPrimitiveExpr)
- and (El.Parent.ClassType=TPasImplAssign)
- and (TPasImplAssign(El.Parent).left=El) then
- begin
- // e.g. funcname:=
- ProcScope:=Proc.CustomData as TPasProcedureScope;
- ImplProc:=ProcScope.ImplProc;
- if ImplProc=nil then
- ImplProc:=Proc;
- if El.HasParent(ImplProc) then
- begin
- // "FuncA:=" within FuncA -> redirect to ResultEl
- Ref.Declaration:=TPasFunctionType(Proc.ProcType).ResultEl;
- exit;
- end;
- end;
- if ProcNeedsParams(Proc.ProcType) and not ExprIsAddrTarget(El) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveNameExpr ',GetObjPath(El));
- {$ENDIF}
- RaiseMsg(20170216152138,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[Proc.Name],El);
- end;
- end;
- end
- else if DeclEl.ClassType=TPasUnresolvedSymbolRef then
- begin
- if DeclEl.CustomData is TResElDataBuiltInProc then
- begin
- BuiltInProc:=TResElDataBuiltInProc(DeclEl.CustomData);
- BuiltInProc.GetCallCompatibility(BuiltInProc,El,true);
- end;
- end
- else if (DeclEl.ClassType=TPasUsesUnit) or (DeclEl is TPasModule) then
- begin
- // unit reference
- // dotted unit name needs a ref for each expression identifier
- // Note: El is the first TPrimitiveExpr of the dotted unit name reference
- DottedName:=DeclEl.Name;
- repeat
- p:=Pos('.',DottedName);
- if p<1 then break;
- Delete(DottedName,1,p);
- El:=GetNextDottedExpr(El);
- if El=nil then
- RaiseInternalError(20170503002012);
- CreateReference(DeclEl,El,Access);
- if (El.Parent is TBinaryExpr) and (TBinaryExpr(El.Parent).right=El) then
- begin
- Bin:=TBinaryExpr(El.Parent);
- while Bin.OpCode=eopSubIdent do
- begin
- CreateReference(DeclEl,Bin,Access);
- if not (Bin.Parent is TBinaryExpr) then break;
- if (TBinaryExpr(Bin.Parent).right<>Bin) then break;
- Bin:=TBinaryExpr(Bin.Parent);
- end;
- end;
- until false;
- end;
- end;
- procedure TPasResolver.ResolveInherited(El: TInheritedExpr;
- Access: TResolvedRefAccess);
- var
- SelfScope: TPasProcedureScope;
- AncestorScope: TPasClassScope;
- ClassRecScope: TPasClassOrRecordScope;
- DeclProc, AncestorProc: TPasProcedure;
- aClass: TPasClassType;
- HelperForType: TPasType;
- InhScope: TPasInheritedScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveInherited El.Parent=',GetTreeDbg(El.Parent));
- {$ENDIF}
- if (El.Parent.ClassType=TBinaryExpr)
- and (TBinaryExpr(El.Parent).OpCode=eopNone) then
- begin
- // e.g. 'inherited Proc;'
- ResolveInheritedName(TBinaryExpr(El.Parent),Access);
- exit;
- end;
- // 'inherited;' without expression
- SelfScope:=GetCurrentSelfScope(El);
- if SelfScope=nil then
- RaiseMsg(20170216152141,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
- DeclProc:=SelfScope.DeclarationProc;
- if DeclProc=nil then
- RaiseNotYetImplemented(20190121172251,El);
- ClassRecScope:=SelfScope.ClassRecScope;
- if not (ClassRecScope is TPasClassScope) then
- begin
- // inherited in record method
- RaiseMsg(20181218194022,nTheUseOfXisNotAllowedInARecord,sTheUseOfXisNotAllowedInARecord,
- ['inherited'],El);
- end;
- AncestorProc:=nil;
- // inherited in class/interface/helper method
- aClass:=ClassRecScope.Element as TPasClassType;
- HelperForType:=ResolveAliasType(aClass.HelperForType);
- //writeln('TPasResolver.ResolveInherited aClass=',GetObjName(aClass),' HelperForType=',GetObjName(HelperForType));
- if HelperForType is TPasMembersType then
- begin
- // inherited; inside helper -> skip helper ancestors and search in HelperForType
- if msDelphi in CurrentParser.CurrentModeswitches then
- begin
- // Delphi skips ancestors and HelperForType
- if not (HelperForType is TPasClassType) then
- // 'inherited;' without ancestor class is silently ignored
- exit;
- AncestorScope:=TPasClassScope(HelperForType.CustomData).AncestorScope;
- if AncestorScope=nil then
- // 'inherited;' without ancestor class is silently ignored
- exit;
- InhScope:=PushInheritedScope(TPasMembersType(AncestorScope.Element),true,nil);
- end
- else
- begin
- // ObjFPC searches first in HelperForType and its ancestors, then in
- // own ancestors
- AncestorScope:=TPasClassScope(aClass.CustomData).AncestorScope;
- InhScope:=PushInheritedScope(TPasMembersType(HelperForType),false,
- AncestorScope);
- end;
- end
- else
- begin
- // inherited; inside class/interface method
- // -> search in ancestor and its helper(s)
- AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope;
- if AncestorScope=nil then
- // 'inherited;' without ancestor class is silently ignored
- exit;
- InhScope:=PushInheritedScope(TPasMembersType(AncestorScope.Element),true,nil);
- end;
- AncestorProc:=FindProcSameSignature(DeclProc.Name,DeclProc,InhScope,false);
- PopScope;
- if AncestorProc=nil then
- // 'inherited;' without ancestor DeclProc is silently ignored
- exit;
- if not (AncestorProc.Parent is TPasMembersType) then
- RaiseNotYetImplemented(20190121181234,El); // inconsistency
- CreateReference(AncestorProc,El,Access);
- if AncestorProc.IsAbstract then
- RaiseMsg(20170216152144,nAbstractMethodsCannotBeCalledDirectly,
- sAbstractMethodsCannotBeCalledDirectly,[],El);
- end;
- procedure TPasResolver.ResolveInheritedName(El: TBinaryExpr;
- Access: TResolvedRefAccess);
- // El.OpCode=eopNone
- // El.left is TInheritedExpr
- // El.right is the identifier and/or paramexpr
- var
- SelfScope: TPasProcedureScope;
- ClassRecScope: TPasClassOrRecordScope;
- AncestorClass, aClass: TPasClassType;
- HelperForType: TPasType;
- OnlyTypeMembers: Boolean;
- Proc: TPasProcedure;
- AncestorScope: TPasClassScope;
- InhScope: TPasInheritedScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El),' Access=',Access);
- {$ENDIF}
- SelfScope:=GetCurrentSelfScope(El);
- if SelfScope=nil then
- RaiseMsg(20170216152148,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
- ClassRecScope:=SelfScope.ClassRecScope;
- if not (ClassRecScope is TPasClassScope) then
- // inherited in a method of a record
- RaiseMsg(20181218194436,nTheUseOfXisNotAllowedInARecord,sTheUseOfXisNotAllowedInARecord,
- ['inherited'],El);
- Proc:=TPasProcedure(SelfScope.Element);
- OnlyTypeMembers:=IsClassMethod(Proc);
- // inherited in a method of a class/interface/helper
- aClass:=TPasClassType(ClassRecScope.Element);
- AncestorScope:=TPasClassScope(ClassRecScope).AncestorScope;
- if aClass.ObjKind in okAllHelpers then
- begin
- HelperForType:=ResolveAliasType(aClass.HelperForType);
- if HelperForType is TPasMembersType then
- begin
- // record helper(ancestor) for aRecord
- // or class helper(ancestor) for aClass
- // -> search in helperfortype, then in ancestors
- InhScope:=PushInheritedScope(TPasMembersType(HelperForType),false,
- AncestorScope);
- InhScope.OnlyTypeMembers:=OnlyTypeMembers;
- ResolveExpr(El.right,Access);
- PopScope;
- exit;
- end
- else
- begin
- // type helper(ancestortype) for simpletype -> search in ancestortype
- end;
- end
- else
- begin
- // class or interface -> search in ancestor and its helpers
- end;
- // search in ancestor and its helpers
- if AncestorScope=nil then
- RaiseMsg(20170216152151,nInheritedNeedsAncestor,sInheritedNeedsAncestor,[],El.left);
- // search call in ancestor
- AncestorClass:=TPasClassType(AncestorScope.Element);
- InhScope:=PushInheritedScope(AncestorClass,true,nil);
- InhScope.OnlyTypeMembers:=OnlyTypeMembers;
- ResolveExpr(El.right,Access);
- PopScope;
- end;
- procedure TPasResolver.ResolveBinaryExpr(El: TBinaryExpr;
- Access: TResolvedRefAccess);
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.ResolveBinaryExpr left=',GetObjName(El.left),' right=',GetObjName(El.right),' opcode=',OpcodeStrings[El.OpCode]);
- {$ENDIF}
- case El.OpCode of
- eopNone:
- case El.Kind of
- pekRange:
- begin
- ResolveExpr(El.left,rraRead);
- if El.right=nil then exit;
- ResolveExpr(El.right,rraRead);
- end;
- else
- if El.left.ClassType=TInheritedExpr then
- begin
- ResolveExpr(El.left,Access);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveBinaryExpr El.Kind=',ExprKindNames[El.Kind],' El.Left=',GetObjName(El.left),' El.Right=',GetObjName(El.right),' parent=',GetObjName(El.Parent));
- {$ENDIF}
- RaiseNotYetImplemented(20160922163456,El);
- end;
- end;
- eopAdd,
- eopSubtract,
- eopMultiply,
- eopDivide,
- eopDiv,
- eopMod,
- eopPower,
- eopShr,
- eopShl,
- eopNot,
- eopAnd,
- eopOr,
- eopXor,
- eopEqual,
- eopNotEqual,
- eopLessThan,
- eopGreaterThan,
- eopLessthanEqual,
- eopGreaterThanEqual,
- eopIn,
- eopIs,
- eopAs,
- eopSymmetricaldifference:
- begin
- ResolveExpr(El.left,rraRead);
- if El.right=nil then exit;
- ResolveExpr(El.right,rraRead);
- end;
- eopSubIdent:
- begin
- ResolveExpr(El.left,rraRead);
- if El.right=nil then exit;
- ResolveSubIdent(El,Access);
- end;
- else
- RaiseNotYetImplemented(20160922163459,El,OpcodeStrings[El.OpCode]);
- end;
- end;
- procedure TPasResolver.ResolveSubIdent(El: TBinaryExpr;
- Access: TResolvedRefAccess);
- procedure ResolveRight; inline;
- begin
- ResolveExpr(El.right,Access);
- PopScope;
- end;
- function SearchInTypeHelpers(HiType: TPasType; IdentEl: TPasElement): boolean;
- var
- DotScope: TPasDotBaseScope;
- begin
- if HiType=nil then exit(false);
- DotScope:=PushHelperDotScope(HiType);
- if DotScope=nil then exit(false);
- if IdentEl is TPasType then
- // e.g. TFlag.HelperProc
- DotScope.OnlyTypeMembers:=true;
- ResolveRight;
- Result:=true;
- end;
- var
- aModule: TPasModule;
- ClassEl: TPasClassType;
- ClassScope: TPasDotClassScope;
- LeftResolved: TPasResolverResult;
- Left: TPasExpr;
- RecordEl: TPasRecordType;
- RecordScope: TPasDotClassOrRecordScope;
- LLoTypeEl, LHiTypeEl: TPasType;
- DotScope: TPasDotBaseScope;
- SetType: TPasSetType;
- begin
- if El.CustomData is TResolvedReference then
- exit; // for example, when a.b has a dotted unit name
- Left:=El.left;
- //writeln('TPasResolver.ResolveSubIdent Left=',GetObjName(Left));
- ComputeElement(Left,LeftResolved,[rcSetReferenceFlags]);
- if LeftResolved.BaseType=btModule then
- begin
- // e.g. unitname.identifier
- // => search in interface and if this is our module in the implementation
- aModule:=NoNil(LeftResolved.IdentEl) as TPasModule;
- PushModuleDotScope(aModule);
- ResolveRight;
- exit;
- end
- else if LeftResolved.LoTypeEl=nil then
- begin
- // illegal qualifier, see below
- end
- else
- begin
- LHiTypeEl:=LeftResolved.HiTypeEl;
- LLoTypeEl:=LeftResolved.LoTypeEl;
- if (LLoTypeEl.ClassType=TPasPointerType)
- and ElHasModeSwitch(El,msAutoDeref)
- and (rrfReadable in LeftResolved.Flags)
- then
- begin
- // a.b -> a^.b
- LHiTypeEl:=TPasPointerType(LLoTypeEl).DestType;
- LLoTypeEl:=ResolveAliasType(LHiTypeEl);
- Include(LeftResolved.Flags,rrfWritable);
- end;
- //writeln('TPasResolver.ResolveSubIdent ',GetObjPath(El),' ',GetObjPath(LLoTypeEl));
- if LLoTypeEl.ClassType=TPasClassType then
- begin
- ClassEl:=TPasClassType(LLoTypeEl);
- if ClassEl.HelperForType<>nil then
- RaiseHelpersCannotBeUsedAsType(20190123093438,El);
- ClassScope:=PushClassDotScope(ClassEl);
- if LeftResolved.IdentEl is TPasType then
- // e.g. TFPMemoryImage.FindHandlerFromExtension()
- ClassScope.OnlyTypeMembers:=true
- else
- // e.g. Image.Width
- ClassScope.OnlyTypeMembers:=false;
- ResolveRight;
- exit;
- end
- else if LLoTypeEl.ClassType=TPasClassOfType then
- begin
- // e.g. ImageClass.FindHandlerFromExtension()
- ClassEl:=ResolveAliasType(TPasClassOfType(LLoTypeEl).DestType) as TPasClassType;
- ClassScope:=PushClassDotScope(ClassEl);
- ClassScope.OnlyTypeMembers:=true;
- ClassScope.IsClassOf:=true;
- ResolveRight;
- exit;
- end
- else if LLoTypeEl.ClassType=TPasRecordType then
- begin
- RecordEl:=TPasRecordType(LLoTypeEl);
- RecordScope:=PushRecordDotScope(RecordEl);
- RecordScope.ConstParent:=not (rrfWritable in LeftResolved.Flags);
- if LeftResolved.IdentEl is TPasType then
- // e.g. TPoint.PointInCircle
- RecordScope.OnlyTypeMembers:=true
- else
- begin
- // e.g. aPoint.X
- AccessExpr(El.left,Access);
- RecordScope.OnlyTypeMembers:=false;
- end;
- ResolveRight;
- exit;
- end
- else if LLoTypeEl.ClassType=TPasEnumType then
- begin
- if (LeftResolved.IdentEl is TPasType)
- and (ResolveAliasType(TPasType(LeftResolved.IdentEl)).ClassType=TPasEnumType) then
- begin
- // e.g. TShiftState.ssAlt
- DotScope:=PushEnumDotScope(LHiTypeEl,TPasEnumType(LLoTypeEl));
- DotScope.OnlyTypeMembers:=true;
- ResolveRight;
- exit;
- end;
- end
- else if LLoTypeEl.ClassType=TPasGenericTemplateType then
- begin
- DotScope:=PushTemplateDotScope(TPasGenericTemplateType(LLoTypeEl),El);
- if DotScope<>nil then
- begin
- if LeftResolved.IdentEl is TPasType then
- // e.g. T.Member
- DotScope.OnlyTypeMembers:=true
- else
- // e.g. VarOfTypeT.Member
- DotScope.OnlyTypeMembers:=false;
- ResolveRight;
- exit;
- end;
- end;
- // default: search for type helpers
- if (LeftResolved.BaseType in btAllIntrinsicTypes)
- or (LeftResolved.BaseType=btContext)
- or (LeftResolved.BaseType=btCustom) then
- begin
- if SearchInTypeHelpers(LeftResolved.HiTypeEl,LeftResolved.IdentEl) then exit;
- end
- else if LeftResolved.BaseType=btSet then
- begin
- SetType:=GetSetType(LeftResolved);
- if SearchInTypeHelpers(SetType,LeftResolved.IdentEl) then exit;
- end;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveSubIdent left=',GetObjName(Left),' right=',GetObjName(El.right),' leftresolved=',GetResolverResultDbg(LeftResolved));
- {$ENDIF}
- RaiseMsg(20170216152157,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['.',GetResolverResultDescription(LeftResolved)],El);
- end;
- procedure TPasResolver.ResolveParamsExpr(Params: TParamsExpr;
- Access: TResolvedRefAccess);
- begin
- if (Params.Kind=pekSet) and not (Access in [rraRead,rraParamToUnknownProc]) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveParamsExpr SET literal Access=',Access);
- {$ENDIF}
- RaiseMsg(20170303211052,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Params);
- end;
- // first resolve params
- ResolveParamsExprParams(Params);
- // then resolve the call, typecast, array, set
- if (Params.Kind=pekFuncParams) then
- ResolveFuncParamsExpr(Params,Access)
- else if (Params.Kind=pekArrayParams) then
- ResolveArrayParamsExpr(Params,Access)
- else if (Params.Kind=pekSet) then
- ResolveSetParamsExpr(Params)
- else
- RaiseNotYetImplemented(20160922163501,Params);
- end;
- procedure TPasResolver.ResolveParamsExprParams(Params: TParamsExpr);
- var
- ScopeDepth, i: integer;
- ParamAccess: TResolvedRefAccess;
- Pars: TPasExprArray;
- begin
- ScopeDepth:=StashSubExprScopes;
- if Params.Kind in [pekFuncParams,pekArrayParams] then
- ParamAccess:=rraParamToUnknownProc
- else
- ParamAccess:=rraRead;
- Pars:=Params.Params;
- for i:=0 to length(Pars)-1 do
- ResolveExpr(Pars[i],ParamAccess);
- RestoreStashedScopes(ScopeDepth);
- end;
- procedure TPasResolver.ResolveFuncParamsExpr(Params: TParamsExpr;
- Access: TResolvedRefAccess);
- var
- Value: TPasExpr;
- SubParams: TParamsExpr;
- ResolvedEl: TPasResolverResult;
- begin
- Value:=Params.Value;
- if Value is TBinaryExpr then
- begin
- // Note: a.b() is the same as (a.b)()
- // Note: a.b().c is stored as
- // TBinaryExpr eopSubIdent
- // / \
- // left = TParamsExpr right = TPrimitiveExpr 'c'
- // Value = TBinaryExpr
- // / \
- // left = TPrimitiveExpr 'a' right = TPrimitiveExpr 'b'
- if (Value is TBinaryExpr) and (TBinaryExpr(Value).OpCode=eopSubIdent) then
- Value:=TBinaryExpr(Value).right;
- if IsNameExpr(Value) then
- begin
- ResolveBinaryExpr(TBinaryExpr(Params.Value),Access);
- if not (Value.CustomData is TResolvedReference) then
- RaiseNotYetImplemented(20190115140557,Params);
- // already resolved
- exit;
- end
- else if Value.ClassType=TInlineSpecializeExpr then
- begin
- ResolveBinaryExpr(TBinaryExpr(Params.Value),Access);
- // already resolved
- exit;
- end;
- // ToDo: (a+b)()
- //ResolveBinaryExpr(TBinaryExpr(Params.Value),rraRead);
- RaiseNotYetImplemented(20190115140809,Params);
- end
- else if IsNameExpr(Value) then
- ResolveFuncParamsExprName(Value,nil,Params,Access)
- else if Value.ClassType=TInlineSpecializeExpr then
- begin
- // e.g. Name<>()
- ResolveInlineSpecializeExpr(TInlineSpecializeExpr(Value),Access);
- end
- else if Value.ClassType=TParamsExpr then
- begin
- SubParams:=TParamsExpr(Value);
- if (SubParams.Kind in [pekArrayParams,pekFuncParams]) then
- begin
- // e.g. Name()() or Name[]()
- ResolveParamsExpr(SubParams,rraRead);
- ComputeElement(SubParams,ResolvedEl,[rcNoImplicitProc,rcSetReferenceFlags]);
- if IsProcedureType(ResolvedEl,true) then
- begin
- CreateReference(TPasProcedureType(ResolvedEl.LoTypeEl),Value,Access);
- FinishProcParamAccess(TPasProcedureType(ResolvedEl.LoTypeEl),Params);
- exit;
- end
- end;
- RaiseMsg(20170216152202,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['(',SubParams.ElementTypeName],Params);
- end
- else
- RaiseNotYetImplemented(20161014085118,Params.Value);
- end;
- procedure TPasResolver.ResolveFuncParamsExprName(NameExpr: TPasExpr;
- TemplParams: TFPList; Params: TParamsExpr; Access: TResolvedRefAccess;
- CallName: string);
- procedure RaiseMultiFit;
- var
- FindCallData: TFindCallElData;
- Msg: String;
- i: Integer;
- El: TPasElement;
- Abort: boolean;
- begin
- FindCallData:=Default(TFindCallElData);
- FindCallData.Params:=Params;
- FindCallData.List:=TFPList.Create;
- try
- Abort:=false;
- IterateElements(CallName,@OnFindCallElements,@FindCallData,Abort);
- Msg:='';
- for i:=0 to FindCallData.List.Count-1 do
- begin
- El:=TPasElement(FindCallData.List[i]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExpr Overload Candidate: ',GetElementSourcePosStr(El),' ',GetTreeDbg(El));
- {$ENDIF}
- // emit a hint for each candidate
- if El is TPasProcedure then
- LogMsg(20170417180320,mtHint,nFoundCallCandidateX,sFoundCallCandidateX,
- [GetProcTypeDescription(TPasProcedure(El).ProcType,
- [prptdUseName,prptdAddPaths,prptdResolveSimpleAlias])],El);
- Msg:=Msg+', '+GetElementSourcePosStr(El);
- end;
- finally
- FindCallData.List.Free;
- end;
- RaiseMsg(20170216152200,nCantDetermineWhichOverloadedFunctionToCall,
- sCantDetermineWhichOverloadedFunctionToCall+Msg,[CallName],NameExpr);
- end;
- procedure FinishUntypedParams(ParamAccess: TResolvedRefAccess);
- var
- i: Integer;
- begin
- if ParamAccess=rraParamToUnknownProc then exit;
- for i:=0 to length(Params.Params)-1 do
- FinishCallArgAccess(Params.Params[i],ParamAccess);
- end;
- procedure CheckTemplParams(GenTemplates, TemplParams: TFPList);
- var
- i: Integer;
- Param, PosEl: TPasElement;
- ResolvedEl: TPasResolverResult;
- begin
- for i:=0 to TemplParams.Count-1 do
- begin
- Param:=TPasElement(TemplParams[i]);
- ComputeElement(Param,ResolvedEl,[rcType]);
- if Param is TPasExpr then
- PosEl:=Param
- else
- PosEl:=Params;
- if CheckTemplateFitsParamRes(TPasGenericTemplateType(GenTemplates[i]),
- ResolvedEl,prtcoAssignToTempl,PosEl)=cIncompatible then
- // should have raise error
- RaiseNotYetImplemented(20190919095604,PosEl,GetResolverResultDbg(ResolvedEl));
- end;
- end;
- procedure CheckIncompatibleProc(const CallName: string;
- FoundProcType: TPasProcedureType; TemplParamsCnt: integer);
- var
- FoundTemplCnt: Integer;
- aName: String;
- begin
- CheckCallProcCompatibility(FoundProcType,Params,true);
- if FoundProcType.GenericTemplateTypes<>nil then
- FoundTemplCnt:=FoundProcType.GenericTemplateTypes.Count
- else
- FoundTemplCnt:=0;
- if TemplParamsCnt<>FoundTemplCnt then
- begin
- if FoundProcType.Parent is TPasProcedure then
- aName:=FoundProcType.Parent.Name
- else
- aName:=FoundProcType.Name;
- if aName='' then
- aName:=GetObjPath(FoundProcType);
- RaiseMsg(20201101205447,nXExpectedButYFound,sXExpectedButYFound,
- [aName,CallName+GetGenericParamCommas(TemplParamsCnt)],Params);
- end;
- end;
- var
- FindCallData: TFindCallElData;
- Abort: boolean;
- FoundEl: TPasElement;
- Ref: TResolvedReference;
- FindData: TPRFindData;
- BuiltInProc: TResElDataBuiltInProc;
- ResolvedEl: TPasResolverResult;
- TypeEl: TPasType;
- C: TClass;
- TemplParamsCnt: Integer;
- GenTemplates, InferenceParams: TFPList;
- begin
- // e.g. Name() -> find compatible
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.ResolveFuncParamsExprName NameExpr=',GetObjName(NameExpr),' TemplParams=',TemplParams<>nil,' CallName="',CallName,'"');
- {$ENDIF}
- if CallName<>'' then
- else if NameExpr.ClassType=TPrimitiveExpr then
- CallName:=TPrimitiveExpr(NameExpr).Value
- else
- RaiseNotYetImplemented(20190115143539,NameExpr);
- FindCallData:=Default(TFindCallElData);
- FindCallData.Params:=Params;
- if TemplParams<>nil then
- begin
- TemplParamsCnt:=TemplParams.Count;
- FindCallData.TemplCnt:=TemplParamsCnt;
- end
- else
- TemplParamsCnt:=0;
- Abort:=false;
- IterateElements(CallName,@OnFindCallElements,@FindCallData,Abort);
- FoundEl:=FindCallData.Found;
- if FoundEl=nil then
- RaiseIdentifierNotFound(20170216152544,CallName,NameExpr);
- if FindCallData.Distance=cIncompatible then
- begin
- // FoundEl one element, but it was incompatible => raise error
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExpr found one element, but it was incompatible => check again to raise error. Found=',GetObjName(FindCallData.Found));
- WriteScopes;
- {$ENDIF}
- if FoundEl is TPasProcedure then
- CheckIncompatibleProc(CallName,TPasProcedure(FoundEl).ProcType,TemplParamsCnt)
- else if FoundEl is TPasProcedureType then
- CheckTypeCast(TPasProcedureType(FoundEl),Params,true)
- else if FoundEl.ClassType=TPasUnresolvedSymbolRef then
- begin
- if FoundEl.CustomData is TResElDataBuiltInProc then
- begin
- BuiltInProc:=TResElDataBuiltInProc(FoundEl.CustomData);
- BuiltInProc.GetCallCompatibility(BuiltInProc,Params,true);
- RaiseNotYetImplemented(20200525124749,FoundEl,'missing exception, Found=['+BuiltInProc.Signature+']');
- end
- else if FoundEl.CustomData is TResElDataBaseType then
- CheckTypeCast(TPasUnresolvedSymbolRef(FoundEl),Params,true)
- else
- RaiseNotYetImplemented(20161006132825,FoundEl);
- end
- else if FoundEl is TPasType then
- // Note: check TPasType after TPasUnresolvedSymbolRef
- CheckTypeCast(TPasType(FoundEl),Params,true)
- else if FoundEl is TPasVariable then
- begin
- TypeEl:=ResolveAliasType(TPasVariable(FoundEl).VarType);
- if TypeEl is TPasProcedureType then
- CheckIncompatibleProc(CallName,TPasProcedureType(TypeEl),TemplParamsCnt)
- else
- RaiseMsg(20170405003522,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['(',TypeEl.ElementTypeName],Params);
- end
- else if FoundEl is TPasArgument then
- begin
- TypeEl:=ResolveAliasType(TPasArgument(FoundEl).ArgType);
- if TypeEl is TPasProcedureType then
- CheckIncompatibleProc(CallName,TPasProcedureType(TypeEl),TemplParamsCnt)
- else
- RaiseMsg(20180228145412,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['(',TypeEl.ElementTypeName],Params);
- end
- else
- RaiseNotYetImplemented(20161003134755,FoundEl);
- // missing raise exception
- RaiseNotYetImplemented(20180621002400,Params,'missing exception, Found='+GetObjName(FoundEl));
- end;
- if FindCallData.Count>1 then
- begin
- // multiple overloads fit
- if (FoundEl is TPasProcedure)
- and (IndexOfGenericParam(Params.Params)>=0) then
- // generic params -> ignore ambiguity
- else
- // => search again and list the candidates
- RaiseMultiFit;
- end;
- // check template params
- if FoundEl is TPasProcedure then
- GenTemplates:=GetProcTemplateTypes(TPasProcedure(FoundEl))
- else if FoundEl is TPasGenericType then
- GenTemplates:=TPasGenericType(FoundEl).GenericTemplateTypes
- else
- GenTemplates:=nil;
- if TemplParamsCnt>0 then
- begin
- // check template types
- if GenTemplates=nil then
- RaiseMsg(20190919100922,nTypeParamsNotAllowedOnX,sTypeParamsNotAllowedOnX,
- [FoundEl.Name],NameExpr);
- if TemplParamsCnt<>GenTemplates.Count then
- RaiseMsg(20190919101051,nWrongNumberOfParametersForGenericX,sWrongNumberOfParametersForGenericX,
- [GetElementTypeName(FoundEl)+' '+FoundEl.Name],NameExpr);
- CheckTemplParams(GenTemplates,TemplParams);
- FoundEl:=GetSpecializedEl(NameExpr,FoundEl,TemplParams);
- if FoundEl is TPasProcedure then
- begin
- // check if params fit the explicit specialized function, e.g. Run<Word>()
- CheckCallProcCompatibility(TPasProcedure(FoundEl).ProcType,Params,true);
- end;
- end
- else if (GenTemplates<>nil) and (GenTemplates.Count>0) then
- begin
- if (FoundEl is TPasProcedure)
- and (msImplicitFunctionSpec in CurrentParser.CurrentModeswitches) then
- begin
- // GenericProc() -> create template types by inference
- InferenceParams:=CreateInferenceTypesForCall(Params,TPasProcedure(FoundEl));
- try
- CheckTemplParams(GenTemplates,InferenceParams);
- FoundEl:=GetSpecializedEl(NameExpr,FoundEl,InferenceParams);
- // check if params fit the implicit specialized function, e.g. Run()
- CheckCallProcCompatibility(TPasProcedure(FoundEl).ProcType,Params,true);
- finally
- ReleaseElementList(InferenceParams{$IFDEF CheckPasTreeRefCount},RefIdInferenceParamsExpr{$ENDIF});
- FreeAndNil(InferenceParams);
- end;
- end
- else
- // GenericType() -> missing type params
- RaiseMsg(20190919120728,nWrongNumberOfParametersForGenericX,sWrongNumberOfParametersForGenericX,
- [GetElementTypeName(FoundEl)+' '+FoundEl.Name],NameExpr);
- end;
- if FoundEl is TPasType then
- begin
- // typecast
- TypeEl:=ResolveAliasType(TPasType(FoundEl));
- C:=TypeEl.ClassType;
- if C=TPasUnresolvedSymbolRef then
- begin
- // typecast to built-in type
- if TypeEl.CustomData is TResElDataBaseType then
- CheckTypeCast(TypeEl,Params,true); // emit warnings
- end
- else
- begin
- // typecast to user type
- CheckTypeCast(TypeEl,Params,true); // emit warnings, and errors for specializations
- end;
- end;
- // FoundEl compatible element -> create reference
- Ref:=CreateReference(FoundEl,NameExpr,rraRead);
- if FindCallData.StartScope.ClassType=ScopeClass_WithExpr then
- Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope);
- FindData:=Default(TPRFindData);
- FindData.ErrorPosEl:=NameExpr;
- FindData.StartScope:=FindCallData.StartScope;
- FindData.ElScope:=FindCallData.ElScope;
- FindData.Found:=FoundEl;
- CheckFoundElement(FindData,Ref);
- // set param expression Access flags
- if FoundEl is TPasProcedure then
- begin
- // now it is known which overloaded proc to call
- if not (Access in [rraRead,rraParamToUnknownProc]) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExprName Params=',GetObjName(Params),' NameExpr=',GetObjName(NameExpr),' Access=',Access);
- {$ENDIF}
- RaiseMsg(20170306104440,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Params);
- end;
- FinishProcParamAccess(TPasProcedure(FoundEl).ProcType,Params);
- end
- else if FoundEl is TPasType then
- begin
- TypeEl:=ResolveAliasType(TPasType(FoundEl));
- C:=TypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasRecordType)
- or (C=TPasEnumType)
- or (C=TPasSetType)
- or (C=TPasPointerType)
- or (C=TPasArrayType)
- or (C=TPasRangeType)
- or (C=TPasGenericTemplateType) then
- begin
- // type cast
- FinishUntypedParams(Access);
- end
- else if (C=TPasProcedureType)
- or (C=TPasFunctionType) then
- begin
- // type cast to proc type
- AccessExpr(Params.Params[0],Access);
- end
- else if C=TPasUnresolvedSymbolRef then
- begin
- if TypeEl.CustomData is TResElDataBuiltInProc then
- begin
- // call built-in proc
- BuiltInProc:=TResElDataBuiltInProc(TypeEl.CustomData);
- if Assigned(BuiltInProc.FinishParamsExpression) then
- BuiltInProc.FinishParamsExpression(BuiltInProc,Params)
- else
- FinishUntypedParams(rraRead);
- end
- else if TypeEl.CustomData is TResElDataBaseType then
- begin
- // type cast to base type
- FinishUntypedParams(Access);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExpr FoundEl=',GetObjName(FoundEl),' CustomData=',GetObjName(FoundEl.CustomData));
- {$ENDIF}
- RaiseNotYetImplemented(20170325145720,Params);
- end;
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExpr FoundEl=',GetObjName(FoundEl),' CustomData=',GetObjName(FoundEl.CustomData));
- {$ENDIF}
- RaiseMsg(20170306121908,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['(',TypeEl.ElementTypeName],Params);
- end;
- end
- else
- begin
- // FoundEl is not a type, maybe a var
- ComputeElement(FoundEl,ResolvedEl,[rcNoImplicitProc,rcSetReferenceFlags]);
- TypeEl:=ResolvedEl.LoTypeEl;
- if TypeEl is TPasProcedureType then
- begin
- if not (Access in [rraRead,rraParamToUnknownProc]) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExprName Params=',GetObjName(Params),' NameExpr=',GetObjName(NameExpr),' Access=',Access);
- {$ENDIF}
- RaiseMsg(20190215195439,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Params);
- end;
- FinishProcParamAccess(TPasProcedureType(TypeEl),Params);
- exit;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExpr FoundEl=',GetObjName(FoundEl),' CustomData=',GetObjName(FoundEl.CustomData),' Resolvedel=',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- RaiseMsg(20170306104301,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['(',TypeEl.ElementTypeName],Params);
- end;
- end;
- procedure TPasResolver.ResolveArrayParamsExpr(Params: TParamsExpr;
- Access: TResolvedRefAccess);
- var
- ResolvedEl: TPasResolverResult;
- Value: TPasExpr;
- SubParams: TParamsExpr;
- begin
- Value:=Params.Value;
- if Value=nil then
- RaiseInternalError(20180423093120,GetObjName(Params));
- if IsNameExpr(Value) then
- begin
- // e.g. Name[]
- ResolveArrayParamsExprName(Value,Params,Access);
- exit;
- end
- else if Value.ClassType=TParamsExpr then
- begin
- SubParams:=TParamsExpr(Value);
- // e.g. Name()[] or Name[][] or [][]
- ResolveExpr(SubParams,rraRead);
- ComputeElement(SubParams,ResolvedEl,[rcNoImplicitProc,rcSetReferenceFlags]);
- if Value.CustomData=nil then
- CreateReference(ResolvedEl.LoTypeEl,Value,Access);
- ResolvedEl.IdentEl:=nil;
- end
- else if Value.InheritsFrom(TUnaryExpr) then
- begin
- ResolveExpr(TUnaryExpr(Value).Operand,Access);
- ComputeElement(Value,ResolvedEl,[rcSetReferenceFlags]);
- end
- else if Value is TBinaryExpr then
- begin
- // Note: a.b[] is the same as (a.b)[]
- // Note: a.b[].c is stored as
- // TBinaryExpr eopSubIdent
- // / \
- // left = TParamsExpr right = TPrimitiveExpr 'c'
- // Value = TBinaryExpr
- // / \
- // left = TPrimitiveExpr 'a' right = TPrimitiveExpr 'b'
- while (Value is TBinaryExpr) and (TBinaryExpr(Value).OpCode=eopSubIdent) do
- Value:=TBinaryExpr(Value).right;
- if IsNameExpr(Value) then
- begin
- ResolveBinaryExpr(TBinaryExpr(Params.Value),Access);
- if not (Value.CustomData is TResolvedReference) then
- RaiseNotYetImplemented(20190115144534,Params);
- // already resolved via ResolveNameExpr, which calls ResolveArrayParamsExprName
- exit;
- end
- else
- begin
- // For example (a+b)[] or (a as b)[]
- Value:=Params.Value;
- ResolveBinaryExpr(TBinaryExpr(Value),rraRead);
- ComputeElement(Value,ResolvedEl,[rcSetReferenceFlags]);
- end;
- end
- else
- RaiseNotYetImplemented(20160927212610,Value);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveArrayParamsExpr Value=',GetObjName(Value),' ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- ResolveArrayParamsArgs(Params,ResolvedEl,Access);
- end;
- procedure TPasResolver.ResolveArrayParamsExprName(NameExpr: TPasExpr;
- Params: TParamsExpr; Access: TResolvedRefAccess);
- // e.g. a.NameExpr[]
- var
- ArrayName: String;
- FindData: TPRFindData;
- Ref: TResolvedReference;
- DeclEl: TPasElement;
- Proc, ImplProc: TPasProcedure;
- ProcScope: TPasProcedureScope;
- ResolvedEl: TPasResolverResult;
- begin
- if (NameExpr.ClassType=TPrimitiveExpr)
- and (TPrimitiveExpr(NameExpr).Kind=pekIdent) then
- // e.g. Name[]
- ArrayName:=TPrimitiveExpr(NameExpr).Value
- else if NameExpr.ClassType=TInlineSpecializeExpr then
- RaiseMsg(20190912190518,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['[','inline specialize'],Params)
- else
- RaiseNotYetImplemented(20190131154557,NameExpr);
- DeclEl:=FindElementWithoutParams(ArrayName,FindData,NameExpr,true,true);
- Ref:=CreateReference(DeclEl,NameExpr,Access,@FindData);
- CheckFoundElement(FindData,Ref);
- if DeclEl is TPasProcedure then
- begin
- Proc:=TPasProcedure(DeclEl);
- if (Access=rraAssign)
- and (Proc.ProcType is TPasFunctionType)
- and (Params.Parent.ClassType=TPasImplAssign)
- and (TPasImplAssign(Params.Parent).left=Params) then
- begin
- // e.g. funcname[]:=
- ProcScope:=Proc.CustomData as TPasProcedureScope;
- ImplProc:=ProcScope.ImplProc;
- if ImplProc=nil then
- ImplProc:=Proc;
- if Params.HasParent(ImplProc) then
- begin
- // "FuncA[]:=" within FuncA -> redirect to ResultEl
- Ref.Declaration:=TPasFunctionType(Proc.ProcType).ResultEl;
- end;
- end;
- end;
- ComputeElement(NameExpr,ResolvedEl,[rcSetReferenceFlags]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveArrayParamsExprName NameExp=',GetObjName(NameExpr),' ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- ResolveArrayParamsArgs(Params,ResolvedEl,Access);
- end;
- procedure TPasResolver.ResolveArrayParamsArgs(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess);
- procedure ReadAccessParamValue;
- var
- Left: TPasExpr;
- Ref: TResolvedReference;
- begin
- if Access=rraAssign then
- begin
- // ArrayStringPointer[]:=
- // -> writing the element needs reading the value
- Left:=Params.Value;
- if (Left is TBinaryExpr) and (TBinaryExpr(Left).OpCode=eopSubIdent) then
- Left:=TBinaryExpr(Left).right;
- if Left.CustomData is TResolvedReference then
- begin
- Ref:=TResolvedReference(Left.CustomData);
- if Ref.Access=rraAssign then
- Ref.Access:=rraReadAndAssign;
- end;
- end;
- end;
- function CheckStringOrPointerIndex(IsStringIndex: boolean): boolean;
- var
- ArgExp: TPasExpr;
- ResolvedArg: TPasResolverResult;
- begin
- ReadAccessParamValue;
- if not IsStringIndex then
- begin
- // pointer
- if not ElHasBoolSwitch(Params,bsPointerMath) then
- exit(false);
- end;
- Result:=true;
- if not (rrfReadable in ResolvedValue.Flags) then
- RaiseXExpectedButYFound(20170216152548,'index',GetElementTypeName(ResolvedValue.LoTypeEl),Params);
- // check single argument
- if length(Params.Params)<1 then
- RaiseMsg(20170216152204,nMissingParameterX,
- sMissingParameterX,[BoolToStr(IsStringIndex,'character index','index')],Params)
- else if length(Params.Params)>1 then
- RaiseMsg(20170216152551,nIllegalQualifier,sIllegalQualifier,[','],Params.Params[1]);
- // check argument is integer
- ArgExp:=Params.Params[0];
- ComputeElement(ArgExp,ResolvedArg,[rcSetReferenceFlags]);
- if not (ResolvedArg.BaseType in btAllInteger) then
- RaiseMsg(20170216152209,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [BaseTypeNames[ResolvedArg.BaseType],'integer'],ArgExp);
- if not (rrfReadable in ResolvedArg.Flags) then
- RaiseMsg(20170216152211,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['type','value'],ArgExp);
- AccessExpr(ArgExp,rraRead);
- end;
- var
- PropEl: TPasProperty;
- i: Integer;
- TypeEl: TPasType;
- C: TClass;
- begin
- if ResolvedValue.BaseType in btAllStrings then
- begin
- // string -> check that ResolvedValue is not merely a type, but has a value
- if CheckStringOrPointerIndex(true) then
- exit;
- end
- else if (ResolvedValue.IdentEl is TPasProperty)
- and (GetPasPropertyArgs(TPasProperty(ResolvedValue.IdentEl)).Count>0) then
- begin
- PropEl:=TPasProperty(ResolvedValue.IdentEl);
- CheckCallPropertyCompatibility(PropEl,Params,true);
- FinishPropertyParamAccess(Params,PropEl);
- exit;
- end
- else if ResolvedValue.BaseType=btPointer then
- begin
- if CheckStringOrPointerIndex(false) then
- exit;
- end
- else if ResolvedValue.BaseType=btContext then
- begin
- TypeEl:=ResolvedValue.LoTypeEl;
- C:=TypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasRecordType)
- or (C=TPasClassOfType) then
- begin
- if ResolveBracketOperatorClassOrRec(Params,ResolvedValue,Access) then
- exit;
- end
- else if C=TPasArrayType then
- begin
- if ResolvedValue.IdentEl is TPasType then
- RaiseMsg(20170216152215,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['[',ResolvedValue.IdentEl.ElementTypeName],Params);
- ReadAccessParamValue;
- CheckCallArrayCompatibility(TPasArrayType(TypeEl),Params,true,true);
- for i:=0 to length(Params.Params)-1 do
- AccessExpr(Params.Params[i],rraRead);
- exit;
- end
- else if C=TPasPointerType then
- begin
- if CheckStringOrPointerIndex(false) then exit;
- end;
- end;
- RaiseMsg(20170216152217,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['[',GetResolverResultDescription(ResolvedValue,true)],Params);
- end;
- function TPasResolver.ResolveBracketOperatorClassOrRec(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess): boolean;
- var
- PropEl: TPasProperty;
- Value: TPasExpr;
- Group: TPasGroupScope;
- i: Integer;
- Scope: TPasIdentifierScope;
- HiType, LoType: TPasType;
- IsClassOf: Boolean;
- begin
- HiType:=ResolvedValue.HiTypeEl;
- LoType:=ResolvedValue.LoTypeEl;
- IsClassOf:=LoType.ClassType=TPasClassOfType;
- if IsClassOf then
- begin
- HiType:=TPasClassOfType(LoType).DestType;
- LoType:=ResolveAliasType(LoType);
- end;
- Group:=CreateGroupScope(HiType);
- PropEl:=nil;
- for i:=0 to Group.Count-1 do
- begin
- Scope:=Group.Scopes[i];
- if Scope is TPasClassOrRecordScope then
- begin
- PropEl:=TPasClassOrRecordScope(Scope).DefaultProperty;
- if PropEl<>nil then break;
- end;
- end;
- Group.Free;
- if PropEl=nil then exit(false);
- // class/record/interface has default property
- if (IsClassOf or (ResolvedValue.IdentEl is TPasType)) and (not PropEl.IsClass) then
- RaiseMsg(20170216152213,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['[',GetResolverResultDescription(ResolvedValue,true)],Params);
- Value:=Params.Value;
- if Value.CustomData is TResolvedReference then
- SetResolvedRefAccess(Value,TResolvedReference(Value.CustomData),rraRead);
- CreateReference(PropEl,Params,Access);
- CheckCallPropertyCompatibility(PropEl,Params,true);
- FinishPropertyParamAccess(Params,PropEl);
- Result:=true;
- end;
- procedure TPasResolver.ResolveSetParamsExpr(Params: TParamsExpr);
- // e.g. resolving '[1,2..3]'
- var
- i: Integer;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveSetParamsExpr ',GetTreeDbg(Params));
- {$ENDIF}
- if Params.Value<>nil then
- RaiseNotYetImplemented(20160930135910,Params);
- for i:=0 to length(Params.Params)-1 do
- begin
- Param:=Params.Params[i];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProcType,rcSetReferenceFlags]);
- end;
- end;
- procedure TPasResolver.ResolveArrayValues(El: TArrayValues);
- var
- i: Integer;
- begin
- for i:=0 to length(El.Values)-1 do
- ResolveExpr(El.Values[i],rraRead);
- end;
- procedure TPasResolver.ResolveRecordValues(El: TRecordValues);
- function GetMember(RecType: TPasRecordType; const aName: string): TPasElement;
- var
- i: Integer;
- begin
- for i:=0 to RecType.Members.Count-1 do
- begin
- Result:=TPasElement(RecType.Members[i]);
- if SameText(Result.Name,aName) then
- exit;
- end;
- if RecType.VariantEl is TPasVariable then
- begin
- Result:=TPasVariable(RecType.VariantEl);
- if SameText(Result.Name,aName) then
- exit;
- end;
- if RecType.Variants<>nil then
- for i:=0 to RecType.Variants.Count-1 do
- begin
- Result:=GetMember(TPasVariant(RecType.Variants[i]).Members,aName);
- if Result<>nil then
- exit;
- end;
- Result:=nil;
- end;
- var
- i, j: Integer;
- Member: TPasElement;
- RecType: TPasRecordType;
- Field: PRecordValuesItem;
- s: String;
- ResolvedEl: TPasResolverResult;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveRecordValues ',El.Fields[0].Name,' ',GetObjName(El.Parent),' ',GetObjName(El.Parent.Parent));
- {$ENDIF}
- ComputeElement(El,ResolvedEl,[]);
- if (ResolvedEl.BaseType<>btContext)
- or (ResolvedEl.LoTypeEl.ClassType<>TPasRecordType) then
- begin
- RaiseIncompatibleTypeDesc(20180429104135,nIncompatibleTypesGotExpected,
- [],'record value',GetTypeDescription(ResolvedEl),El);
- end;
- RecType:=TPasRecordType(ResolvedEl.LoTypeEl);
- //writeln('TPasResolver.ResolveRecordValues ',GetObjName(El.Parent),' ',GetObjName(RecType));
- for i:=0 to length(El.Fields)-1 do
- begin
- Field:[email protected][i];
- // check member exists
- Member:=GetMember(RecType,Field^.Name);
- if Member=nil then
- RaiseIdentifierNotFound(20180429104703,Field^.Name,Field^.NameExp);
- if Member.ClassType<>TPasVariable then
- RaiseMsg(20180429121933,nIdentifierXIsNotAnInstanceField,sIdentifierXIsNotAnInstanceField,
- [],Field^.ValueExp);
- if TPasVariable(Member).VarModifiers*[vmClass,vmStatic]<>[] then
- RaiseMsg(20190105221450,nIdentifierXIsNotAnInstanceField,sIdentifierXIsNotAnInstanceField,
- ['record assignment'],Field^.ValueExp);
- CreateReference(Member,Field^.NameExp,rraAssign);
- // check duplicates
- for j:=0 to i-1 do
- if SameText(Field^.Name,El.Fields[j].Name) then
- RaiseMsg(20180429104942,nDuplicateIdentifier,sDuplicateIdentifier,
- [Field^.Name,GetElementSourcePosStr(El.Fields[j].NameExp)],Field^.NameExp);
- // resolve expression
- ResolveExpr(El.Fields[i].ValueExp,rraRead);
- // check compatible
- CheckAssignCompatibility(Member,Field^.ValueExp);
- end;
- // hint for missing fields
- s:='';
- for i:=0 to RecType.Members.Count-1 do
- begin
- Member:=TPasElement(RecType.Members[i]);
- if Member.ClassType<>TPasVariable then continue;
- if TPasVariable(Member).VarModifiers*[vmClass,vmStatic]<>[] then
- continue;
- j:=length(El.Fields)-1;
- while (j>=0) and not SameText(Member.Name,El.Fields[j].Name) do
- dec(j);
- //writeln('TPasResolver.ResolveRecordValues ',GetObjName(Member),' ',j);
- if j<0 then
- begin
- if s<>'' then s:=s+', ';
- if length(s)>30 then
- begin
- s:=s+'...';
- break;
- end;
- s:=s+Member.Name;
- end;
- end;
- // ToDo: hint for missing variants
- if s<>'' then
- LogMsg(20180429121127,mtHint,nMissingFieldsX,sMissingFieldsX,[s],El);
- end;
- procedure TPasResolver.ResolveInlineSpecializeExpr(El: TInlineSpecializeExpr;
- Access: TResolvedRefAccess);
- begin
- // params are TPasTypes and already resolved
- if El.Params.Count=0 then
- RaiseMsg(20190916155014,nMissingParameterX,sMissingParameterX,['type'],El);
- // resolve name
- // Note: ResolveNameExpr considers the params
- ResolveExpr(El.NameExpr,Access);
- end;
- function TPasResolver.ResolveAccessor(Expr: TPasExpr): TPasElement;
- function SubResolvePrimitive(Prim: TPrimitiveExpr): TPasElement;
- var
- FindData: TPRFindData;
- Ref: TResolvedReference;
- Scope: TPasScope;
- Abort: boolean;
- begin
- if Prim.Kind<>pekIdent then
- RaiseXExpectedButYFound(20170216151746,'class',Prim.Value,Prim);
- // search in class and ancestors, not in unit interface
- Scope:=TopScope;
- FindData:=Default(TPRFindData);
- FindData.ErrorPosEl:=Expr;
- Abort:=false;
- Scope.IterateElements(Prim.Value,Scope,@OnFindFirst,@FindData,Abort);
- Result:=FindData.Found;
- if Result=nil then
- RaiseIdentifierNotFound(20170216151749,Prim.Value,Prim);
- Ref:=CreateReference(Result,Prim,rraRead);
- CheckFoundElementVisibility(FindData,Ref);
- end;
- var
- Prim: TPrimitiveExpr;
- DeclEl: TPasElement;
- begin
- if Expr.ClassType=TBinaryExpr then
- begin
- DeclEl:=nil;
- if (TBinaryExpr(Expr).left is TPrimitiveExpr) then
- begin
- Prim:=TPrimitiveExpr(TBinaryExpr(Expr).left);
- DeclEl:=SubResolvePrimitive(Prim);
- if not (DeclEl is TPasMembersType) then
- RaiseXExpectedButYFound(20170216151752,'class',GetElementTypeName(DeclEl),Prim);
- end
- else
- RaiseMsg(20170216151754,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TBinaryExpr(Expr).OpCode]],Expr);
- if TBinaryExpr(Expr).OpCode<>eopSubIdent then
- RaiseMsg(20170216151757,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TBinaryExpr(Expr).OpCode]],Expr);
- if DeclEl.ClassType=TPasClassType then
- PushClassDotScope(TPasClassType(DeclEl))
- else if DeclEl.ClassType=TPasRecordType then
- PushRecordDotScope(TPasRecordType(DeclEl))
- else
- RaiseMsg(20190123145559,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TBinaryExpr(Expr).OpCode]],Expr);
- Expr:=TBinaryExpr(Expr).right;
- Result:=ResolveAccessor(Expr);
- PopScope;
- end
- else if Expr.ClassType=TPrimitiveExpr then
- begin
- Prim:=TPrimitiveExpr(Expr);
- Result:=SubResolvePrimitive(Prim);
- end
- else
- RaiseNotYetImplemented(20160922163436,Expr);
- end;
- procedure TPasResolver.SetResolvedRefAccess(Expr: TPasExpr;
- Ref: TResolvedReference; Access: TResolvedRefAccess);
- begin
- if (Ref.Access=Access) then exit;
- if Access in [rraNone,rraParamToUnknownProc] then
- exit;
- if Expr=nil then ;
- case Ref.Access of
- rraNone,rraParamToUnknownProc:
- Ref.Access:=Access;
- rraRead:
- if Access in [rraAssign,rraReadAndAssign,rraVarParam,rraOutParam] then
- Ref.Access:=rraReadAndAssign
- else
- exit;
- rraAssign,rraOutParam:
- if Access in [rraRead,rraReadAndAssign,rraVarParam] then
- Ref.Access:=rraReadAndAssign
- else
- exit;
- rraReadAndAssign: exit;
- rraVarParam: exit;
- else
- RaiseInternalError(20170403163727);
- end;
- end;
- procedure TPasResolver.AccessExpr(Expr: TPasExpr;
- Access: TResolvedRefAccess);
- // called after a call target was found, called for each element
- // to change the rraParamToUnknownProc value to Access
- var
- Ref: TResolvedReference;
- Bin: TBinaryExpr;
- Params: TParamsExpr;
- ValueResolved: TPasResolverResult;
- C: TClass;
- begin
- if (Expr.CustomData is TResolvedReference) then
- begin
- Ref:=TResolvedReference(Expr.CustomData);
- SetResolvedRefAccess(Expr,Ref,Access);
- end;
- C:=Expr.ClassType;
- if C=TBinaryExpr then
- begin
- Bin:=TBinaryExpr(Expr);
- if Bin.OpCode in [eopSubIdent,eopNone] then
- AccessExpr(Bin.right,Access);
- end
- else if C=TParamsExpr then
- begin
- Params:=TParamsExpr(Expr);
- case Params.Kind of
- pekFuncParams:
- if IsTypeCast(Params) then
- FinishCallArgAccess(Params.Params[0],Access)
- else
- AccessExpr(Params.Value,Access);
- pekArrayParams:
- begin
- ComputeElement(Params.Value,ValueResolved,[]);
- if IsDynArray(ValueResolved.LoTypeEl,false)
- or (ValueResolved.BaseType=btPointer) then
- // when accessing an element of a dynamic array the array is read
- AccessExpr(Params.Value,rraRead)
- else
- AccessExpr(Params.Value,Access);
- // Note: an element of an open or static array or a string is connected to the variable
- end;
- pekSet:
- if Access<>rraRead then
- RaiseMsg(20170306112306,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr);
- else
- RaiseNotYetImplemented(20170403173831,Params);
- end;
- end
- else if (C=TPrimitiveExpr) and (TPrimitiveExpr(Expr).Kind=pekIdent) then
- // ok
- else if (Access in [rraRead,rraParamToUnknownProc])
- and ((C=TPrimitiveExpr)
- or (C=TNilExpr)
- or (C=TBoolConstExpr)
- or (C=TInheritedExpr)
- or (C=TProcedureExpr))
- or (C=TInlineSpecializeExpr) then
- // ok
- else if C=TUnaryExpr then
- AccessExpr(TUnaryExpr(Expr).Operand,Access)
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AccessExpr Expr=',GetObjName(Expr),' Access=',Access,' Declaration="',Expr.GetDeclaration(false),'"');
- {$ENDIF}
- RaiseNotYetImplemented(20170306102158,Expr);
- end;
- end;
- function TPasResolver.MarkArrayExpr(Expr: TParamsExpr; ArrayType: TPasArrayType
- ): boolean;
- var
- Ref: TResolvedReference;
- begin
- if Expr.CustomData=nil then
- begin
- // mark set expression as array
- CreateReference(ArrayType,Expr,rraRead);
- Result:=true;
- end
- else if Expr.CustomData is TResolvedReference then
- begin
- // already set
- Result:=false;
- // check consistency
- Ref:=TResolvedReference(Expr.CustomData);
- if not (Ref.Declaration is TPasArrayType) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.MarkArrayExpr Expr=',GetObjName(Expr),' Ref.Declaration=',GetObjName(Ref.Declaration),' ',Ref.Declaration.ParentPath);
- {$ENDIF}
- RaiseNotYetImplemented(20180618102230,Expr,GetObjName(Ref.Declaration));
- end;
- end
- else
- // already set with something else
- RaiseNotYetImplemented(20180618102408,Expr,GetObjName(Expr.CustomData));
- end;
- procedure TPasResolver.MarkArrayExprRecursive(Expr: TPasExpr;
- ArrType: TPasArrayType);
- procedure Traverse(CurExpr: TPasExpr; ArrayType: TPasArrayType; RgIndex: integer);
- var
- Params: TPasExprArray;
- i: Integer;
- ResolvedElType: TPasResolverResult;
- ParamsExpr: TParamsExpr;
- BuiltInProc: TResElDataBuiltInProc;
- Ref: TResolvedReference;
- begin
- if IsArrayOperatorAdd(CurExpr) then
- begin
- Traverse(TBinaryExpr(CurExpr).left,ArrayType,RgIndex);
- Traverse(TBinaryExpr(CurExpr).right,ArrayType,RgIndex);
- end
- else if CurExpr.ClassType=TParamsExpr then
- begin
- ParamsExpr:=TParamsExpr(CurExpr);
- Params:=ParamsExpr.Params;
- if CurExpr.Kind=pekSet then
- begin
- MarkArrayExpr(ParamsExpr,ArrayType);
- // traverse into nested expressions, e.g. [ A, B ]
- if length(Params)=0 then exit;
- inc(RgIndex);
- if RgIndex>length(ArrayType.Ranges) then
- begin
- if ArrayType.ElType=nil then
- exit; // elements are not arrays
- ComputeElement(ArrayType.ElType,ResolvedElType,[rcType]);
- if (ResolvedElType.BaseType=btContext)
- and (ResolvedElType.LoTypeEl is TPasArrayType) then
- begin
- ArrayType:=TPasArrayType(ResolvedElType.LoTypeEl);
- RgIndex:=0;
- end
- else
- exit; // elements are not arrays
- end;
- for i:=0 to length(Params)-1 do
- Traverse(Params[i],ArrayType,RgIndex);
- end
- else if CurExpr.Kind=pekFuncParams then
- begin
- if TParamsExpr(CurExpr).Value.CustomData is TResolvedReference then
- begin
- Ref:=TResolvedReference(TParamsExpr(CurExpr).Value.CustomData);
- if (Ref.Declaration is TPasUnresolvedSymbolRef)
- and (Ref.Declaration.CustomData is TResElDataBuiltInProc) then
- begin
- BuiltInProc:=TResElDataBuiltInProc(Ref.Declaration.CustomData);
- if BuiltInProc.BuiltIn=bfConcatArray then
- begin
- // concat(array1,array2,...)
- for i:=0 to length(Params)-1 do
- Traverse(Params[i],ArrayType,RgIndex);
- end
- else if BuiltInProc.BuiltIn=bfCopyArray then
- // copy(array,...)
- Traverse(Params[0],ArrayType,RgIndex);
- end;
- end;
- end;
- end;
- end;
- begin
- Traverse(Expr,ArrType,0);
- end;
- procedure TPasResolver.CheckPointerCycle(El: TPasPointerType);
- var
- C: TClass;
- CurEl, Dest: TPasType;
- begin
- CurEl:=El;
- while CurEl<>nil do
- begin
- C:=CurEl.ClassType;
- if C=TPasPointerType then
- Dest:=TPasPointerType(CurEl).DestType
- else if C.InheritsFrom(TPasAliasType) then
- Dest:=TPasAliasType(CurEl).DestType
- else
- exit;
- if Dest=El then
- RaiseMsg(20180422165758,nTypeCycleFound,sTypeCycleFound,[],El);
- CurEl:=Dest;
- end;
- end;
- procedure TPasResolver.CheckGenericTemplateTypes(El: TPasGenericType);
- var
- GenTemplates: TFPList;
- i: Integer;
- TemplType: TPasGenericTemplateType;
- begin
- GenTemplates:=El.GenericTemplateTypes;
- if (GenTemplates=nil) or (GenTemplates.Count=0) then
- RaiseNotYetImplemented(20190726184902,El,'empty generic template list');
- // template names must differ from generic type name
- for i:=0 to GenTemplates.Count-1 do
- begin
- TemplType:=TPasGenericTemplateType(GenTemplates[i]);
- if SameText(TemplType.Name,El.Name) then
- RaiseMsg(20190801101444,nDuplicateIdentifier,sDuplicateIdentifier,[
- TemplType.Name,GetElementSourcePosStr(El)],TemplType);
- end;
- end;
- procedure TPasResolver.ComputeUnaryNot(El: TUnaryExpr;
- var ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags);
- begin
- RaiseMsg(20180208121532,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
- [OpcodeStrings[El.OpCode],GetResolverResultDescription(ResolvedEl)],El);
- if Flags=[] then ;
- end;
- procedure TPasResolver.AddModule(El: TPasModule);
- var
- C: TClass;
- ModScope: TPasModuleScope;
- begin
- if Hub=nil then
- RaiseNotYetImplemented(20200815182122,El);
- if TopScope<>DefaultScope then
- RaiseInvalidScopeForElement(20160922163504,El);
- ModScope:=TPasModuleScope(PushScope(El,FScopeClass_Module));
- ModScope.VisibilityContext:=El;
- ModScope.FirstName:=FirstDottedIdentifier(El.Name);
- C:=El.ClassType;
- if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
- FDefaultNameSpace:=ChompDottedIdentifier(El.Name)
- else
- FDefaultNameSpace:='';
- ModScope.BoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
- end;
- procedure TPasResolver.AddSection(El: TPasSection);
- // TInterfaceSection, TImplementationSection, TProgramSection, TLibrarySection
- // Note: implementation scope is within the interface scope
- var
- Scope: TPasSectionScope;
- begin
- if TopScope is TPasSectionScope then
- FinishSection(TPasSectionScope(TopScope).Element as TPasSection);
- if TopScope is TPasModuleScope then
- TPasModuleScope(TopScope).BoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
- {$IFDEF VerbosePasResolver}
- if FPendingForwardProcs.IndexOf(El)=0 then
- RaiseNotYetImplemented(20190804114718,El);
- {$ENDIF}
- FPendingForwardProcs.Add(El); // check forward declarations at the end
- Scope:=TPasSectionScope(PushScope(El,ScopeClass_Section));
- Scope.BoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
- Scope.ModeSwitches:=CurrentParser.Scanner.CurrentModeSwitches;
- end;
- procedure TPasResolver.AddInitialFinalizationSection(El: TPasImplBlock);
- begin
- PushScope(El,ScopeClass_InitialFinalization);
- end;
- procedure TPasResolver.AddType(El: TPasType);
- begin
- if (El.Name='') then exit; // sub type
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddType El=',GetObjName(El),' El.Parent=',GetObjName(El.Parent));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160922163506,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- end;
- procedure TPasResolver.AddArrayType(El: TPasArrayType; TypeParams: TFPList);
- var
- Scope: TPasArrayScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddArrayType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
- {$ENDIF}
- if TypeParams<>nil then
- begin
- El.SetGenericTemplates(TypeParams);
- TypeParams:=El.GenericTemplateTypes;
- CheckGenericTemplateTypes(El);
- end;
- PopGenericParamScope(El);
- if El.Name<>'' then begin
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20190812215622,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- if TypeParams<>nil then
- begin
- Scope:=TPasArrayScope(PushScope(El,ScopeClass_Array));
- AddGenericTemplateIdentifiers(TypeParams,Scope);
- end;
- end else if TypeParams<>nil then
- RaiseNotYetImplemented(20190812215851,El); // anonymous generic array type
- end;
- procedure TPasResolver.AddRecordType(El: TPasRecordType; TypeParams: TFPList);
- var
- Scope: TPasRecordScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
- {$ENDIF}
- if TypeParams<>nil then
- begin
- El.SetGenericTemplates(TypeParams);
- TypeParams:=El.GenericTemplateTypes;
- CheckGenericTemplateTypes(El);
- end;
- PopGenericParamScope(El);
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160922163508,El);
- if El.Name<>'' then begin
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- {$IFDEF VerbosePasResolver}
- if FPendingForwardProcs.IndexOf(El)=0 then
- RaiseNotYetImplemented(20190804114737,El);
- {$ENDIF}
- FPendingForwardProcs.Add(El); // check forward declarations at the end
- end;
- if El.Parent.ClassType<>TPasVariant then
- begin
- Scope:=TPasRecordScope(PushScope(El,ScopeClass_Record));
- Scope.VisibilityContext:=El;
- if TypeParams<>nil then
- begin
- // generic array
- if El.Name='' then
- RaiseNotYetImplemented(20190812220821,El);
- AddGenericTemplateIdentifiers(TypeParams,Scope);
- end;
- end;
- end;
- procedure TPasResolver.AddClassType(El: TPasClassType; TypeParams: TFPList);
- // Note: IsForward is not yet set!
- var
- Duplicate: TPasIdentifier;
- ForwardDecl: TPasClassType;
- CurScope, LocalScope: TPasIdentifierScope;
- GenTemplCnt, i, j: Integer;
- ClassScope: TPasClassScope;
- ForwGenTempl, ActGenTempl: TPasGenericTemplateType;
- ForwConstraints, ActConstraints: TPasElementArray;
- DuplEl, ForwConstraint, ActConstraint: TPasElement;
- ForwToken, ActToken: TToken;
- ForwConstraintResolved, ActConstraintResolved: TPasResolverResult;
- begin
- // Beware: El.ObjKind is not yet set!
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.AddClassType ',GetObjName(El),' Parent=',GetObjName(El.Parent),' ',GetElementSourcePosStr(El));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160922163510,El);
- if TypeParams=nil then
- begin
- GenTemplCnt:=0;
- if TopScope is TPasGenericParamsScope then
- RaiseNotYetImplemented(20190831205006,El,GetObjName(TopScope));
- CurScope:=TPasIdentifierScope(TopScope);
- end
- else
- begin
- if not (TopScope is TPasGenericParamsScope) then
- RaiseInvalidScopeForElement(20190831205038,El,GetObjName(TopScope));
- CurScope:=TPasIdentifierScope(Scopes[ScopeCount-2]);
- GenTemplCnt:=TypeParams.Count;
- El.SetGenericTemplates(TypeParams);
- TypeParams:=El.GenericTemplateTypes;
- CheckGenericTemplateTypes(El);
- end;
- if CurScope is TPasGroupScope then
- LocalScope:=TPasGroupScope(CurScope).Scopes[0]
- else
- LocalScope:=CurScope;
- Duplicate:=LocalScope.FindLocalIdentifier(El.Name);
- while Duplicate<>nil do
- begin
- DuplEl:=Duplicate.Element;
- if (DuplEl is TPasGenericType)
- and (GetTypeParameterCount(TPasGenericType(DuplEl))=GenTemplCnt) then
- break;
- Duplicate:=Duplicate.NextSameIdentifier;
- end;
- //if Duplicate<>nil then
- //writeln(' Duplicate=',GetObjName(Duplicate.Element),' ',ord(Duplicate.Kind));
- if (Duplicate<>nil)
- and (Duplicate.Element is TPasClassType)
- and TPasClassType(Duplicate.Element).IsForward
- and (Duplicate.Element.Parent=El.Parent)
- then
- begin
- // forward declaration found
- ForwardDecl:=TPasClassType(Duplicate.Element);
- {$IFDEF VerbosePasResolver}
- writeln(' Resolving Forward=',GetObjName(ForwardDecl),' ',GetElementSourcePosStr(ForwardDecl));
- {$ENDIF}
- if GenTemplCnt>0 then
- begin
- // check generic constraints match exactly
- for i:=0 to GenTemplCnt-1 do
- begin
- ForwGenTempl:=TPasGenericTemplateType(ForwardDecl.GenericTemplateTypes[i]);
- ActGenTempl:=TPasGenericTemplateType(TypeParams[i]);
- if not SameText(ForwGenTempl.Name,ActGenTempl.Name) then
- RaiseMsg(20190814114811,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetTypeDescription(ActGenTempl),GetElementSourcePosStr(ForwGenTempl)],ActGenTempl);
- ForwConstraints:=ForwGenTempl.Constraints;
- ActConstraints:=ActGenTempl.Constraints;
- if length(ForwConstraints)<>length(ActConstraints) then
- RaiseMsg(20190814121031,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetTypeDescription(ActGenTempl),GetElementSourcePosStr(ForwGenTempl)],ActGenTempl);
- for j:=0 to length(ForwConstraints)-1 do
- begin
- ForwConstraint:=ForwConstraints[j];
- ActConstraint:=ActConstraints[j];
- ForwToken:=GetGenericConstraintKeyword(ForwConstraint);
- ActToken:=GetGenericConstraintKeyword(ActConstraint);
- if ForwToken<>ActToken then
- RaiseMsg(20190814121139,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetTypeDescription(ActGenTempl),GetElementSourcePosStr(ForwConstraint)],
- GetGenericConstraintErrorEl(ActConstraint,ActGenTempl));
- if ForwToken=tkEOF then
- begin
- ComputeElement(ForwConstraint,ForwConstraintResolved,[rcType]);
- ComputeElement(ActConstraint,ActConstraintResolved,[rcType]);
- if CheckElTypeCompatibility(ForwConstraintResolved.LoTypeEl,
- ActConstraintResolved.LoTypeEl,prraNone)<>cExact then
- RaiseMsg(20190814121509,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
- [GetTypeDescription(ActGenTempl),
- GetElementSourcePosStr(GetGenericConstraintErrorEl(ForwConstraint,ForwGenTempl))],
- GetGenericConstraintErrorEl(ActConstraint,ActGenTempl));
- end;
- end;
- end;
- end;
- if ForwardDecl.CustomData<>nil then
- begin
- // move the classscope to the real declaration
- ClassScope:=ForwardDecl.CustomData as TPasClassScope;
- if El.CustomData<>nil then
- RaiseInternalError(20190803202959,'real class has already customdata');
- ForwardDecl.CustomData:=nil;
- El.CustomData:=ClassScope;
- ClassScope.Element:=El;
- end;
- // create a ref from the forward to the real declaration
- CreateReference(El,ForwardDecl,rraRead);
- // change the cache item
- Duplicate.Element:=El;
- end
- else
- AddIdentifier(CurScope,El.Name,El,pikSimple);
- if TypeParams<>nil then
- begin
- // Parsing the ancestor+interface list requires the type params.
- // AddGenericTemplateIdentifiers not needed, already in TPasGenericParamsScope
- end;
- {$IFDEF VerbosePasResolver}
- if FPendingForwardProcs.IndexOf(El)>=0 then
- RaiseNotYetImplemented(20190804114746,El);
- {$ENDIF}
- FPendingForwardProcs.Add(El); // check forward declarations at the end
- end;
- procedure TPasResolver.AddVariable(El: TPasVariable);
- begin
- if (El.Name='') then exit; // anonymous var
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddVariable ',GetObjName(El));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160929205730,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- end;
- procedure TPasResolver.AddResourceString(El: TPasResString);
- var
- C: TClass;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddResourceString ',GetObjName(El));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20171004092114,El);
- C:=El.Parent.ClassType;
- if not C.InheritsFrom(TPasSection) then
- RaiseNotYetImplemented(20171004092518,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- end;
- procedure TPasResolver.AddExportSymbol(El: TPasExportSymbol);
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddExportSymbol ',GetObjName(El));
- {$ENDIF}
- // Note: export symbol is not added to scope
- if El=nil then ;
- end;
- procedure TPasResolver.AddEnumType(El: TPasEnumType);
- var
- CanonicalSet: TPasSetType;
- EnumScope: TPasEnumTypeScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddEnumType ',GetObjName(El));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160929205732,El);
- if El.Name<>'' then
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple)
- else
- begin
- // anonymous enumtype
- end;
- EnumScope:=TPasEnumTypeScope(PushScope(El,TPasEnumTypeScope));
- // add canonical set
- if El.Parent is TPasSetType then
- begin
- // set of anonymous enumtype, e.g. "set of ()"
- CanonicalSet:=TPasSetType(El.Parent);
- CanonicalSet.AddRef{$IFDEF CheckPasTreeRefCount}('TPasEnumTypeScope.CanonicalSet'){$ENDIF};
- end
- else
- begin
- CanonicalSet:=TPasSetType.Create('',El);
- {$IFDEF CheckPasTreeRefCount}CanonicalSet.RefIds.Add('TPasEnumTypeScope.CanonicalSet'){$ENDIF};
- CanonicalSet.EnumType:=El;
- El.AddRef{$IFDEF CheckPasTreeRefCount}('TPasSetType.EnumType'){$ENDIF};
- end;
- EnumScope.CanonicalSet:=CanonicalSet;
- end;
- procedure TPasResolver.AddEnumValue(El: TPasEnumValue);
- var
- i: Integer;
- Scope: TPasScope;
- Old: TPasIdentifier;
- ClassOrRec: TPasMembersType;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddEnumValue ',GetObjName(El));
- {$ENDIF}
- if not (TopScope is TPasEnumTypeScope) then
- RaiseInvalidScopeForElement(20160929205736,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- // propagate enum to parent scopes
- // TEnum = (red, green); -> dot not propagate
- // TFlags = set of (red,blue); -> propagate
- if (bsScopedEnums in CurrentParser.Scanner.CurrentBoolSwitches)
- and not (El.Parent.Parent is TPasSetType) then
- exit;
- for i:=ScopeCount-2 downto 0 do
- begin
- Scope:=Scopes[i];
- if Scope is TPasGroupScope then
- Scope:=TPasGroupScope(Scope).Scopes[0];
- if Scope is TPasClassOrRecordScope then
- begin
- // class or record: add if not duplicate
- Old:=TPasIdentifierScope(Scope).FindIdentifier(El.Name);
- if Old=nil then
- TPasIdentifierScope(Scope).AddIdentifier(El.Name,El,pikSimple);
- ClassOrRec:=Scope.Element as TPasMembersType;
- if GetTypeParameterCount(ClassOrRec)>0 then
- break; // enums in generics do not propagate
- end
- else if (Scope is TPasProcedureScope) or (Scope is TPasSectionScope) then
- begin
- // procedure or section: check for duplicate and add
- Old:=TPasIdentifierScope(Scope).FindLocalIdentifier(El.Name);
- if Old<>nil then
- RaiseMsg(20170216152224,nDuplicateIdentifier,sDuplicateIdentifier,
- [El.Name,GetElementSourcePosStr(Old.Element)],El);
- TPasIdentifierScope(Scope).AddIdentifier(El.Name,El,pikSimple);
- break;
- end
- else
- break;
- end;
- end;
- procedure TPasResolver.AddProperty(El: TPasProperty);
- begin
- if (El.Name='') then
- RaiseNotYetImplemented(20160922163518,El);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProperty ',GetObjName(El));
- {$ENDIF}
- if not (GetLocalScope is TPasClassOrRecordScope) then
- RaiseInvalidScopeForElement(20160922163520,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- PushScope(El,TPasPropertyScope);
- end;
- procedure TPasResolver.AddProcedureType(El: TPasProcedureType;
- TypeParams: TFPList);
- var
- Scope: TPasProcTypeScope;
- begin
- if El.Name<>'' then begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProcedureType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
- {$ENDIF}
- if El.Parent is TPasProcedure then
- RaiseNotYetImplemented(20190911102852,El,GetObjPath(El.Parent));
- if TypeParams<>nil then
- begin
- El.SetGenericTemplates(TypeParams);
- TypeParams:=El.GenericTemplateTypes;
- CheckGenericTemplateTypes(El);
- end;
- PopGenericParamScope(El);
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20190813193703,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- if TypeParams<>nil then
- begin
- Scope:=TPasProcTypeScope(PushScope(El,ScopeClass_ProcType));
- AddGenericTemplateIdentifiers(TypeParams,Scope);
- end;
- end else if TypeParams<>nil then
- RaiseNotYetImplemented(20190813193745,El);
- end;
- procedure TPasResolver.AddProcedure(El: TPasProcedure; TypeParams: TFPList);
- procedure AddClassConDestructor(ClassOrRecordScope: TPasClassOrRecordScope;
- var Field: TPasProcedure);
- begin
- if Field<>nil then
- RaiseMsg(20181231144353,nMultipleXinTypeYNameZCAandB,
- sMultipleXinTypeYNameZCAandB,[GetElementTypeName(El),
- GetElementTypeName(ClassOrRecordScope.Element),
- ClassOrRecordScope.Element.Name,Field.Name,El.Name],El);
- Field:=El;
- end;
- function FindBestMembersType(const ClassOrRecName: string;
- TypeParamCnt: integer; Scope: TPasIdentifierScope;
- var Best: TPasMembersType; ErrorPos: TPasElement): integer;
- // returns number of candidates
- var
- Identifier: TPasIdentifier;
- CurEl: TPasElement;
- begin
- Result:=0;
- Identifier:=Scope.FindLocalIdentifier(ClassOrRecName);
- while Identifier<>nil do
- begin
- CurEl:=Identifier.Element;
- if not (CurEl is TPasMembersType) then
- RaiseXExpectedButYFound(20170216152557,
- 'class',CurEl.Name+':'+GetElementTypeName(CurEl),ErrorPos);
- inc(Result);
- if Best=nil then
- Best:=TPasMembersType(CurEl);
- if GetTypeParameterCount(TPasGenericType(CurEl))=TypeParamCnt then
- begin
- // fits
- Best:=TPasMembersType(CurEl);
- exit;
- end;
- Identifier:=Identifier.NextSameIdentifier;
- end;
- end;
- function FindMembersType(Scope: TPasIdentifierScope;
- const ClassOrRecName: string; TypeParamCnt: integer; IsDelphi: boolean;
- ErrorPos: TPasElement): TPasMembersType;
- var
- Found: integer;
- begin
- Result:=nil;
- if Scope<>nil then
- Found:=FindBestMembersType(ClassOrRecName,TypeParamCnt,Scope,Result,ErrorPos)
- else if TopScope is TPasIdentifierScope then
- begin
- Found:=FindBestMembersType(ClassOrRecName,TypeParamCnt,
- TPasIdentifierScope(TopScope),Result,ErrorPos);
- if (Result=nil) or (TypeParamCnt<>GetTypeParameterCount(Result)) then
- begin
- if (TopScope is TPasSectionScope)
- and (ScopeCount>1) and (Scopes[ScopeCount-2] is TPasSectionScope) then
- // search in unit interface too
- Found:=Found+FindBestMembersType(ClassOrRecName,TypeParamCnt,
- TPasIdentifierScope(Scopes[ScopeCount-2]),Result,ErrorPos);
- end;
- end;
- if Result=nil then
- RaiseMsg(20190818112356,nClassXNotFoundInThisModule,sClassXNotFoundInThisModule,
- [ClassOrRecName+GetGenericParamCommas(TypeParamCnt)],ErrorPos);
- if TypeParamCnt=GetTypeParameterCount(Result) then
- exit; // fits perfectly
- if (not IsDelphi) and (TypeParamCnt=0) and (Found=1) then
- exit; // in objfpc type params can be omitted if there is only one type
- // found one or more, but type param count do not fit
- RaiseMsg(20190818112856,nXExpectedButYFound,sXExpectedButYFound,
- [Result.Name+GetGenericParamCommas(GetTypeParameterCount(Result)),
- ClassOrRecName+GetGenericParamCommas(TypeParamCnt)],ErrorPos);
- end;
- procedure CheckTemplateNames;
- var
- i, j: Integer;
- NamePart: TProcedureNamePart;
- TemplTypes: TFPList;
- TemplType: TPasGenericTemplateType;
- begin
- for i:=0 to TypeParams.Count-1 do
- begin
- NamePart:=TProcedureNamePart(TypeParams[i]);
- TemplTypes:=NamePart.Templates;
- if TemplTypes=nil then continue;
- for j:=0 to TemplTypes.Count-1 do
- begin
- TemplType:=TPasGenericTemplateType(TemplTypes[j]);
- if SameText(TemplType.Name,El.Name) then
- RaiseMsg(20190912174817,nDuplicateIdentifier,sDuplicateIdentifier,
- [],TemplType);
- end;
- end;
- end;
- var
- ProcName, aClassName: String;
- p: SizeInt;
- ClassOrRecType: TPasMembersType;
- ProcScope: TPasProcedureScope;
- HasDot, IsClassConDestructor, IsDelphi: Boolean;
- ClassOrRecScope: TPasClassOrRecordScope;
- C: TClass;
- CurScope: TPasScope;
- LocalScope: TPasScope;
- Level, TypeParamCount, i: Integer;
- NamePart: TProcedureNamePart;
- TemplType, FoundTemplType: TPasGenericTemplateType;
- NestedMembersScope: TPasGroupScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProcedure ',GetObjName(El));
- {$ENDIF}
- if TypeParams<>nil then
- begin
- // move type param elements to El
- El.SetNameParts(TypeParams);
- TypeParams:=El.NameParts;
- if TopScope is TPasGenericParamsScope then
- PopScope;
- CheckTemplateNames;
- end;
- CurScope:=TopScope;
- if CurScope.ClassType=TPasGroupScope then
- LocalScope:=TPasGroupScope(CurScope).Scopes[0]
- else
- LocalScope:=CurScope;
- ProcName:=El.Name;
- if El.Name<>'' then
- begin
- // named proc
- if not (LocalScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160922163522,El);
- end
- else
- begin
- // anonymous proc
- if TypeParams<>nil then
- RaiseNotYetImplemented(20190818101856,El);
- C:=LocalScope.ClassType;
- if (C=ScopeClass_InitialFinalization)
- or C.InheritsFrom(TPasProcedureScope)
- or (C=TPasWithScope)
- or (C=ScopeClass_WithExpr)
- or (C=TPasExceptOnScope)
- or (C=TPasForLoopScope) then
- // ok
- else
- RaiseInvalidScopeForElement(20181210173134,El);
- end;
- // Note: El.ProcType is nil ! It is parsed later.
- HasDot:=GetFirstDotPos(ProcName)>1;
- if (TypeParams<>nil) then
- if HasDot<>(TypeParams.Count>1) then
- RaiseNotYetImplemented(20190818093923,El);
- IsClassConDestructor:=(El.ClassType=TPasClassConstructor)
- or (El.ClassType=TPasClassDestructor);
- ClassOrRecType:=nil;
- if El.CustomData is TPasProcedureScope then
- begin
- // adding a specialized implementation proc
- ProcScope:=TPasProcedureScope(El.CustomData);
- if ProcScope.DeclarationProc<>nil then
- TypeParams:=ProcScope.DeclarationProc.NameParts;
- ClassOrRecScope:=ProcScope.ClassRecScope;
- if ClassOrRecScope<>nil then
- begin
- ClassOrRecType:=TPasMembersType(ClassOrRecScope.Element);
- if GetTypeParameterCount(ClassOrRecType)>0 then
- RaiseNotYetImplemented(20190804175518,El);
- if ProcScope.GroupScope<>nil then
- RaiseNotYetImplemented(20190804175451,El);
- if (not HasDot) and IsClassConDestructor then
- begin
- if El.ClassType=TPasClassConstructor then
- AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassConstructor))
- else
- AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassDestructor));
- end;
- end;
- PushScope(ProcScope);
- end
- else
- begin
- IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
- if (not HasDot) and IsClassConDestructor then
- begin
- if ProcName='' then
- RaiseNotYetImplemented(20181231145302,El);
- if not (LocalScope is TPasClassOrRecordScope) then
- RaiseInvalidScopeForElement(20181231143831,El);
- ClassOrRecScope:=TPasClassOrRecordScope(LocalScope);
- if El.ClassType=TPasClassConstructor then
- AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassConstructor))
- else
- AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassDestructor));
- if TypeParams<>nil then
- RaiseMsg(20190818094753,nTypeParamsNotAllowedOnX,sTypeParamsNotAllowedOnX,
- [El.ElementTypeName],El);
- end;
- if (not HasDot) and (ProcName<>'')
- and not IsClassConDestructor // the name of a class con/destructor is irrelevant and cannot be referenced
- then
- begin
- // add proc name to scope
- AddIdentifier(TPasIdentifierScope(CurScope),ProcName,El,pikProc);
- end;
- ProcScope:=TPasProcedureScope(CreateScope(El,FScopeClass_Proc));
- ProcScope.ModeSwitches:=CurrentParser.CurrentModeswitches;
- if HasDot then
- begin
- // method implementation -> search class
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProcedure searching class of "',ProcName,'" ...');
- {$ENDIF}
- ClassOrRecType:=nil;
- Level:=0;
- repeat
- inc(Level);
- p:=GetFirstDotPos(ProcName);
- if p<1 then
- begin
- if ClassOrRecType=nil then
- RaiseInternalError(20161013170829);
- break;
- end;
- aClassName:=FirstDottedIdentifier(ProcName);
- Delete(ProcName,1,p);
- TypeParamCount:=0;
- if TypeParams<>nil then
- begin
- // e.g. aclassname<T>.
- if Level>TypeParams.Count then
- RaiseNotYetImplemented(20190818122217,El);
- NamePart:=TProcedureNamePart(TypeParams[Level-1]);
- if NamePart.Name<>aClassName then
- RaiseNotYetImplemented(20190818102541,El,IntToStr(Level)+': '+NamePart.Name+'<>'+aClassName);
- if NamePart.Templates<>nil then
- begin
- TypeParamCount:=NamePart.Templates.Count;
- for i:=0 to TypeParamCount-1 do
- begin
- TemplType:=TPasGenericTemplateType(NamePart.Templates[i]);
- if length(TemplType.Constraints)>0 then
- RaiseMsg(20190818102850,nIllegalQualifierAfter,sIllegalQualifierAfter,
- [':',TemplType.name],TemplType);
- end;
- end;
- end
- else
- NamePart:=nil;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProcedure searching class "',aClassName,GetGenericParamCommas(TypeParamCount),'" ProcName="',ProcName,'" ...');
- {$ENDIF}
- if not IsValidIdent(aClassName) then
- RaiseNotYetImplemented(20161013170844,El);
- if ClassOrRecType<>nil then
- begin
- ClassOrRecScope:=TPasClassOrRecordScope(ClassOrRecType.CustomData);
- ClassOrRecType:=FindMembersType(ClassOrRecScope,aClassName,
- TypeParamCount,IsDelphi,El);
- end
- else
- ClassOrRecType:=FindMembersType(nil,aClassName,
- TypeParamCount,IsDelphi,El);
- if ClassOrRecType is TPasClassType then
- begin
- if not (TPasClassType(ClassOrRecType).ObjKind in
- ([okClass]+okAllHelpers)) then
- begin
- aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName)-1);
- RaiseXExpectedButYFound(20180321161722,'class',
- aClassname+GetGenericParamCommas(GetTypeParameterCount(ClassOrRecType))+':'+GetElementTypeName(ClassOrRecType),El);
- end
- end;
- if ClassOrRecType.GetModule<>El.GetModule then
- RaiseNotYetImplemented(20190818120051,El);
- if NamePart<>nil then
- begin
- // check that all type param names match
- for i:=0 to TypeParamCount-1 do
- begin
- TemplType:=TPasGenericTemplateType(NamePart.Templates[i]);
- FoundTemplType:=TPasGenericTemplateType(ClassOrRecType.GenericTemplateTypes[i]);
- if not SameText(TemplType.Name,FoundTemplType.Name) then
- RaiseMsg(20190822014652,nXExpectedButYFound,
- sXExpectedButYFound,[FoundTemplType.Name,TemplType.Name],TemplType);
- end;
- end;
- until false;
- if not IsValidIdent(ProcName) then
- RaiseNotYetImplemented(20161013170956,El);
- ProcScope.VisibilityContext:=ClassOrRecType;
- ProcScope.ClassRecScope:=NoNil(ClassOrRecType.CustomData) as TPasClassOrRecordScope;
- if TypeParams<>nil then
- begin
- if Level<>TypeParams.Count then
- RaiseNotYetImplemented(20190818122315,El);
- NamePart:=TProcedureNamePart(TypeParams[Level-1]);
- if NamePart.Name<>ProcName then
- RaiseNotYetImplemented(20190818122551,El,IntToStr(Level)+': '+NamePart.Name+'<>'+ProcName);
- end;
- end
- else
- begin
- // HasDot=false
- end;
- PushScope(ProcScope);
- end;// end source proc, not specialized
- if HasDot then
- begin
- // create GroupScope
- if TopScope<>ProcScope then
- RaiseNotYetImplemented(20191014235935,El,GetObjName(TopScope));
- ProcScope.GroupScope:=CreateGroupScope(ClassOrRecType);
- if ClassOrRecType.Parent is TPasMembersType then
- begin
- // nested class
- ClassOrRecType:=TPasMembersType(ClassOrRecType.Parent);
- NestedMembersScope:=CreateGroupScope(ClassOrRecType);
- ProcScope.NestedMembersScope:=NestedMembersScope;
- NestedMembersScope.OnlyTypeMembers:=true;
- // Delphi searches the parent class scopes *after* the section scopes
- // and before the module scope - sigh
- // -> Move scope between module scope and section scope
- i:=0;
- while (i<ScopeCount) and not (FScopes[i] is TPasModuleScope) do
- inc(i);
- InsertScope(NestedMembersScope,i+1);
- while ClassOrRecType.Parent is TPasMembersType do
- begin
- ClassOrRecType:=TPasMembersType(ClassOrRecType.Parent);
- GroupScope_AddTypeAndAncestors(NestedMembersScope,ClassOrRecType);
- end;
- end;
- end;
- // add generic params to scope
- if TypeParams<>nil then
- begin
- NamePart:=TProcedureNamePart(TypeParams[TypeParams.Count-1]);
- if NamePart<>nil then
- AddGenericTemplateIdentifiers(NamePart.Templates,ProcScope);
- end;
- end;
- procedure TPasResolver.AddArgument(El: TPasArgument);
- var
- ProcType: TPasProcedureType;
- i: Integer;
- Arg: TPasArgument;
- CurScope: TPasScope;
- begin
- if (El.Name='') then
- RaiseInternalError(20160922163526,GetObjName(El));
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddArgument ',GetObjName(El));
- {$ENDIF}
- CurScope:=TopScope;
- if (CurScope=nil) then
- RaiseInvalidScopeForElement(20160922163529,El);
- if El.Parent.ClassType=TPasProperty then
- begin
- if CurScope.ClassType<>TPasPropertyScope then
- RaiseInvalidScopeForElement(20161014124530,El);
- AddIdentifier(TPasIdentifierScope(CurScope),El.Name,El,pikSimple);
- end
- else if El.Parent is TPasProcedureType then
- begin
- ProcType:=TPasProcedureType(El.Parent);
- if ProcType.Parent is TPasProcedure then
- begin
- if CurScope.ClassType<>FScopeClass_Proc then
- RaiseInvalidScopeForElement(20160922163529,El,GetObjName(TopScope));
- AddIdentifier(TPasIdentifierScope(CurScope),El.Name,El,pikSimple);
- end
- else
- begin
- for i:=0 to ProcType.Args.Count-1 do
- begin
- Arg:=TPasArgument(ProcType.Args[i]);
- if (Arg<>El) and (CompareText(TPasArgument(ProcType.Args[i]).Name,El.Name)=0) then
- RaiseMsg(20170216152225,nDuplicateIdentifier,sDuplicateIdentifier,[Arg.Name,GetElementSourcePosStr(Arg)],El);
- end;
- end;
- end
- else
- RaiseNotYetImplemented(20161014124937,El);
- end;
- procedure TPasResolver.AddFunctionResult(El: TPasResultElement);
- var
- CurScope: TPasScope;
- begin
- CurScope:=TopScope;
- if CurScope.ClassType<>FScopeClass_Proc then exit;
- if El.Parent is TPasProcedureType then
- begin
- if not (El.Parent.Parent is TPasProcedure) then
- exit;
- end
- else if not (El.Parent is TPasProcedure) then
- exit;
- AddIdentifier(TPasProcedureScope(CurScope),ResolverResultVar,El,pikSimple);
- end;
- procedure TPasResolver.AddGenericTemplateType(El: TPasGenericTemplateType);
- var
- ParamScope: TPasGenericParamsScope;
- OldIdentifier: TPasIdentifier;
- begin
- if TopScope is TPasGenericParamsScope then
- begin
- ParamScope:=TPasGenericParamsScope(TopScope);
- if ParamScope.Element.Parent<>El.Parent then
- RaiseNotYetImplemented(20190831203132,El,GetObjName(ParamScope.Element));
- end
- else
- begin
- if El.CustomData<>nil then
- RaiseNotYetImplemented(20190831202627,El,GetObjName(El.CustomData));
- ParamScope:=TPasGenericParamsScope.Create;
- AddResolveData(El,ParamScope,lkModule);
- PushScope(ParamScope);
- end;
- OldIdentifier:=ParamScope.FindIdentifier(El.Name);
- if OldIdentifier<>nil then
- RaiseMsg(20190831202920,nDuplicateIdentifier,sDuplicateIdentifier,
- [OldIdentifier.Identifier,GetElementSourcePosStr(OldIdentifier.Element)],El);
- ParamScope.AddIdentifier(El.Name,El,pikSimple);
- end;
- procedure TPasResolver.AddExceptOn(El: TPasImplExceptOn);
- begin
- PushScope(El,TPasExceptOnScope);
- end;
- procedure TPasResolver.AddWithDo(El: TPasImplWithDo);
- begin
- if TPasWithScope.FreeOnPop then
- RaiseInternalError(20181210162344);
- PushScope(El,TPasWithScope);
- end;
- procedure TPasResolver.AddProcedureBody(El: TProcedureBody);
- begin
- if El=nil then ;
- CheckTopScope(FScopeClass_Proc);
- end;
- procedure TPasResolver.WriteScopes;
- {AllowWriteln}
- var
- i: Integer;
- Scope: TPasScope;
- begin
- writeln('TPasResolver.WriteScopes ScopeCount=',ScopeCount);
- for i:=ScopeCount-1 downto 0 do
- begin
- Scope:=Scopes[i];
- writeln(' ',i,'/',ScopeCount,' ',GetObjName(Scope));
- Scope.WriteIdentifiers(' ');
- end;
- {AllowWriteln-}
- end;
- procedure TPasResolver.ComputeBinaryExpr(Bin: TBinaryExpr; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- var
- LeftResolved, RightResolved: TPasResolverResult;
- begin
- if (Bin.OpCode=eopSubIdent)
- or ((Bin.OpCode=eopNone) and (Bin.left is TInheritedExpr)) then
- begin
- // Note: bin.left was already resolved via ResolveSubIdent
- ComputeElement(Bin.right,ResolvedEl,Flags,StartEl);
- exit;
- end;
- if Bin.OpCode in [eopEqual,eopNotEqual] then
- begin
- if CheckEqualElCompatibility(Bin.left,Bin.right,nil,true,
- rcSetReferenceFlags in Flags)=cIncompatible then
- RaiseInternalError(20161007215912);
- SetResolverValueExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],FBaseTypes[btBoolean],
- Bin,[rrfReadable]);
- exit;
- end;
- ComputeElement(Bin.left,LeftResolved,Flags-[rcNoImplicitProc],StartEl);
- ComputeElement(Bin.right,RightResolved,Flags-[rcNoImplicitProc],StartEl);
- // ToDo: check operator overloading
- ComputeBinaryExprRes(Bin,ResolvedEl,Flags,LeftResolved,RightResolved);
- end;
- procedure TPasResolver.ComputeBinaryExprRes(Bin: TBinaryExpr; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- var LeftResolved, RightResolved: TPasResolverResult);
- procedure SetBaseType(BaseType: TResolverBaseType);
- begin
- SetResolverValueExpr(ResolvedEl,BaseType,FBaseTypes[BaseType],FBaseTypes[BaseType],
- Bin,[rrfReadable]);
- end;
- procedure SetLeftValueExpr(Flags: TPasResolverResultFlags);
- begin
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,
- LeftResolved.LoTypeEl,LeftResolved.HiTypeEl,Bin,Flags);
- end;
- procedure SetRightValueExpr(Flags: TPasResolverResultFlags);
- begin
- SetResolverValueExpr(ResolvedEl,RightResolved.BaseType,
- RightResolved.LoTypeEl,RightResolved.HiTypeEl,Bin,Flags);
- end;
- var
- ElTypeResolved: TPasResolverResult;
- LeftTypeEl, RightTypeEl: TPasType;
- begin
- if LeftResolved.BaseType=btRange then
- ConvertRangeToElement(LeftResolved);
- if RightResolved.BaseType=btRange then
- ConvertRangeToElement(RightResolved);
- //writeln('TPasResolver.ComputeBinaryExpr ',OpcodeStrings[Bin.OpCode],' Left=',GetResolverResultDbg(LeftResolved),' Right=',GetResolverResultDbg(RightResolved));
- if IsGenericTemplType(LeftResolved) or IsGenericTemplType(RightResolved) then
- begin
- // cannot yet be decided
- case Bin.OpCode of
- eopEqual, eopNotEqual,
- eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual,
- eopIn,eopIs:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- eopAs:
- begin
- SetRightValueExpr([rrfReadable]);
- exit;
- end;
- end;
- ResolvedEl:=LeftResolved;
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable];
- exit;
- end;
- if LeftResolved.BaseType in btAllInteger then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- if (RightResolved.BaseType in (btAllInteger+btAllFloats)) then
- case Bin.OpCode of
- eopNone:
- if (Bin.Kind=pekRange) then
- begin
- if not (RightResolved.BaseType in btAllInteger) then
- RaiseXExpectedButYFound(20170216152600,'integer',BaseTypeNames[RightResolved.BaseType],Bin.right);
- // use left type for result
- SetLeftValueExpr([rrfReadable]);
- if Bin.Parent is TPasRangeType then
- begin
- ResolvedEl.LoTypeEl:=TPasRangeType(Bin.Parent);
- ResolvedEl.HiTypeEl:=ResolvedEl.LoTypeEl;
- end;
- exit;
- end;
- eopAdd, eopSubtract,
- eopMultiply, eopDiv, eopMod,
- eopPower,
- eopShl, eopShr,
- eopAnd, eopOr, eopXor:
- begin
- if RightResolved.BaseType in btAllFloats then
- // use right type for result
- SetRightValueExpr([rrfReadable])
- else
- // use left type for result
- SetLeftValueExpr([rrfReadable]);
- exit;
- end;
- eopLessThan,
- eopGreaterThan,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- eopDivide:
- begin
- SetBaseType(BaseTypeExtended);
- exit;
- end;
- end
- else if (RightResolved.BaseType in [btSet,btArrayOrSet]) then
- begin
- if (Bin.OpCode=eopIn) and (RightResolved.SubType in btAllInteger) then
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end
- else if RightResolved.BaseType=btPointer then
- begin
- if (Bin.OpCode in [eopAdd,eopSubtract])
- and ElHasBoolSwitch(Bin,bsPointerMath) then
- begin
- // integer+CanonicalPointer
- SetResolverValueExpr(ResolvedEl,btPointer,
- RightResolved.LoTypeEl,RightResolved.HiTypeEl,Bin,[rrfReadable]);
- exit;
- end;
- end
- else if RightResolved.BaseType=btContext then
- begin
- RightTypeEl:=RightResolved.LoTypeEl;
- if RightTypeEl.ClassType=TPasPointerType then
- begin
- if (Bin.OpCode in [eopAdd,eopSubtract])
- and ElHasBoolSwitch(Bin,bsPointerMath) then
- begin
- // integer+TypedPointer
- RightTypeEl:=TPasPointerType(RightTypeEl).DestType;
- SetResolverValueExpr(ResolvedEl,btPointer,
- ResolveAliasType(RightTypeEl),RightTypeEl,Bin,[rrfReadable]);
- exit;
- end;
- end;
- end;
- end;
- end
- else if LeftResolved.BaseType in btAllBooleans then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (RightResolved.BaseType in btAllBooleans)
- and (rrfReadable in RightResolved.Flags) then
- case Bin.OpCode of
- eopNone:
- if Bin.Kind=pekRange then
- begin
- SetResolverValueExpr(ResolvedEl,btRange,
- FBaseTypes[LeftResolved.BaseType],FBaseTypes[LeftResolved.BaseType],
- Bin,[rrfReadable]);
- ResolvedEl.SubType:=LeftResolved.BaseType;
- exit;
- end;
- eopAnd, eopOr, eopXor:
- begin
- // use left type for result
- SetLeftValueExpr([rrfReadable]);
- exit;
- end;
- end;
- end
- else if LeftResolved.BaseType in btAllStringAndChars then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- if (RightResolved.BaseType in btAllStringAndChars) then
- case Bin.OpCode of
- eopNone:
- if (Bin.Kind=pekRange) and (LeftResolved.BaseType in btAllChars) then
- begin
- if not (RightResolved.BaseType in btAllChars) then
- RaiseXExpectedButYFound(20170216152603,'char',BaseTypeNames[RightResolved.BaseType],Bin.right);
- SetResolverValueExpr(ResolvedEl,btRange,
- FBaseTypes[LeftResolved.BaseType],FBaseTypes[LeftResolved.BaseType],
- Bin,[rrfReadable]);
- ResolvedEl.SubType:=LeftResolved.BaseType;
- exit;
- end;
- eopAdd:
- if RightResolved.BaseType in btAllStringAndChars then
- if ComputeAddStringRes(LeftResolved,RightResolved,Bin,ResolvedEl) then
- exit;
- eopLessThan,
- eopGreaterThan,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end
- else if (RightResolved.BaseType in [btSet,btArrayOrSet])
- and (RightResolved.SubType in btAllChars)
- and (LeftResolved.BaseType in btAllChars) then
- begin
- case Bin.OpCode of
- eopIn:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end;
- end
- end
- end
- else if LeftResolved.BaseType in btAllFloats then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (RightResolved.BaseType in (btAllInteger+btAllFloats))
- and (rrfReadable in RightResolved.Flags) then
- case Bin.OpCode of
- eopAdd, eopSubtract,
- eopMultiply, eopDivide, eopMod,
- eopPower:
- begin
- if (RightResolved.BaseType=btCurrency)
- or ((RightResolved.BaseType in btAllFloats)
- and (RightResolved.BaseType>LeftResolved.BaseType)) then
- // use right side as result
- SetRightValueExpr([rrfReadable])
- else
- // use left side as result
- SetLeftValueExpr([rrfReadable]);
- exit;
- end;
- eopLessThan,
- eopGreaterThan,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end;
- end
- else if LeftResolved.BaseType=btPointer then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- if (RightResolved.BaseType in btAllInteger) then
- case Bin.OpCode of
- eopAdd,eopSubtract:
- if ElHasBoolSwitch(Bin,bsPointerMath) then
- begin
- // pointer+integer -> pointer
- SetResolverValueExpr(ResolvedEl,btPointer,
- LeftResolved.LoTypeEl,LeftResolved.HiTypeEl,Bin,[rrfReadable]);
- exit;
- end;
- end
- else if RightResolved.BaseType=btPointer then
- case Bin.OpCode of
- eopLessThan,
- eopGreaterThan,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end;
- end;
- end
- else if LeftResolved.BaseType=btContext then
- begin
- LeftTypeEl:=LeftResolved.LoTypeEl;
- case Bin.OpCode of
- eopNone:
- if Bin.Kind=pekRange then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- CheckSetLitElCompatible(Bin.left,Bin.right,LeftResolved,RightResolved);
- ResolvedEl:=LeftResolved;
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.SubType:=ResolvedEl.BaseType;
- ResolvedEl.BaseType:=btRange;
- ResolvedEl.ExprEl:=Bin;
- exit;
- end;
- end;
- eopIn:
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- if LeftResolved.BaseType in btArrayRangeTypes then
- begin
- if not (RightResolved.BaseType in [btSet,btArrayOrSet]) then
- RaiseXExpectedButYFound(20170216152607,'set of '+BaseTypeNames[LeftResolved.BaseType],GetElementTypeName(LeftResolved.LoTypeEl),Bin.right);
- if LeftResolved.BaseType in btAllBooleans then
- begin
- if not (RightResolved.SubType in btAllBooleans) then
- RaiseXExpectedButYFound(20170216152610,'set of '+BaseTypeNames[LeftResolved.BaseType],'set of '+BaseTypeNames[RightResolved.SubType],Bin.right);
- end
- else if LeftResolved.BaseType in btAllChars then
- begin
- if not (RightResolved.SubType in btAllChars) then
- RaiseXExpectedButYFound(20170216152609,'set of '+BaseTypeNames[LeftResolved.BaseType],'set of '+BaseTypeNames[RightResolved.SubType],Bin.right);
- end
- else if not (RightResolved.SubType in btAllInteger) then
- RaiseXExpectedButYFound(20170216152612,'set of '+BaseTypeNames[LeftResolved.BaseType],'set of '+BaseTypeNames[RightResolved.SubType],Bin.right);
- SetBaseType(btBoolean);
- exit;
- end
- else if (LeftResolved.BaseType=btContext)
- and (LeftTypeEl.ClassType=TPasEnumType) then
- begin
- if not (RightResolved.BaseType in [btSet,btArrayOrSet]) then
- RaiseXExpectedButYFound(20170216152615,'set of '+LeftResolved.LoTypeEl.Name,GetElementTypeName(LeftResolved.LoTypeEl),Bin.right);
- RightTypeEl:=RightResolved.LoTypeEl;
- if LeftTypeEl=RightTypeEl then
- // enum in setofenum
- else if RightResolved.LoTypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(RightTypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]);
- if LeftTypeEl<>ElTypeResolved.LoTypeEl then
- RaiseXExpectedButYFound(20171109215833,'set of '+LeftResolved.LoTypeEl.Name,'set of '+RightResolved.LoTypeEl.Name,Bin.right);
- end
- else
- RaiseXExpectedButYFound(20170216152618,'set of '+LeftResolved.LoTypeEl.Name,'set of '+RightResolved.LoTypeEl.Name,Bin.right);
- SetBaseType(btBoolean);
- exit;
- end
- else
- RaiseMsg(20170216152228,nInOperatorExpectsSetElementButGot,
- sInOperatorExpectsSetElementButGot,[GetElementTypeName(LeftResolved.LoTypeEl)],Bin);
- end;
- eopIs:
- begin
- RightTypeEl:=RightResolved.LoTypeEl;
- if (LeftTypeEl is TPasClassType) then
- begin
- if not (rrfReadable in LeftResolved.Flags) then
- RaiseIncompatibleTypeRes(20180204124637,nOperatorIsNotOverloadedAOpB,
- [OpcodeStrings[Bin.OpCode]],LeftResolved,RightResolved,Bin);
- if (LeftResolved.IdentEl is TPasType) then
- RaiseIncompatibleTypeRes(20180204124638,nOperatorIsNotOverloadedAOpB,
- [OpcodeStrings[Bin.OpCode]],LeftResolved,RightResolved,Bin);
- // left side is a class instance
- if (RightResolved.IdentEl is TPasType)
- and (RightTypeEl is TPasClassType) then
- begin
- if TPasClassType(LeftTypeEl).ObjKind=TPasClassType(RightTypeEl).ObjKind then
- begin
- if CheckSrcIsADstType(RightResolved,LeftResolved)<>cIncompatible then
- begin
- // e.g. if obj is TFPMemoryImage then ;
- // Note: at compile time the check is reversed: right must inherit from left
- SetBaseType(btBoolean);
- exit;
- end
- else if CheckSrcIsADstType(LeftResolved,RightResolved)<>cIncompatible then
- begin
- // e.g. if Image is TObject then ;
- // This is useful after some unchecked typecast -> allow
- SetBaseType(btBoolean);
- exit;
- end;
- end
- else if TPasClassType(RightTypeEl).ObjKind=okInterface then
- begin
- if (TPasClassType(LeftTypeEl).ObjKind=okClass)
- and (not TPasClassType(LeftTypeEl).IsExternal) then
- begin
- // e.g. if classintvar is intftype then ;
- SetBaseType(btBoolean);
- exit;
- end;
- end
- else if TPasClassType(LeftTypeEl).ObjKind=okInterface then
- begin
- if (TPasClassType(RightTypeEl).ObjKind=okClass)
- and (not TPasClassType(RightTypeEl).IsExternal) then
- begin
- // e.g. if intfvar is classtype then ;
- SetBaseType(btBoolean);
- exit;
- end;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeBinaryExprRes LeftClass=',GetClassAncestorsDbg(TPasClassType(LeftResolved.LoTypeEl)));
- writeln('TPasResolver.ComputeBinaryExprRes RightClass=',GetClassAncestorsDbg(TPasClassType(RightResolved.IdentEl)));
- {$ENDIF}
- end
- else if (RightTypeEl is TPasClassOfType)
- and (rrfReadable in RightResolved.Flags) then
- begin
- // e.g. if Image is ImageClass then ;
- if (CheckClassesAreRelated(LeftResolved.LoTypeEl,
- TPasClassOfType(RightTypeEl).DestType)<>cIncompatible) then
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end
- else
- RaiseXExpectedButYFound(20170216152625,'class type',GetElementTypeName(RightResolved.LoTypeEl),Bin.right);
- end
- else if (proClassOfIs in Options) and (LeftTypeEl is TPasClassOfType)
- and (rrfReadable in LeftResolved.Flags) then
- begin
- if (LeftResolved.IdentEl=nil) or (LeftResolved.IdentEl is TPasType) then
- RaiseIncompatibleTypeRes(20180204124657,nOperatorIsNotOverloadedAOpB,
- [OpcodeStrings[Bin.OpCode]],LeftResolved,RightResolved,Bin);
- // left side is class-of variable
- LeftTypeEl:=ResolveAliasType(TPasClassOfType(LeftTypeEl).DestType);
- if (RightResolved.IdentEl is TPasType)
- and (ResolveAliasType(TPasType(RightResolved.IdentEl)) is TPasClassType) then
- begin
- // e.g. if ImageClass is TFPMemoryImage then ;
- // Note: at compile time the check is reversed: right must inherit from left
- if CheckClassIsClass(RightResolved.LoTypeEl,LeftTypeEl)<>cIncompatible then
- begin
- SetBaseType(btBoolean);
- exit;
- end
- end
- else if (RightTypeEl is TPasClassOfType) then
- begin
- // e.g. if ImageClassA is ImageClassB then ;
- // or if ImageClassA is TFPImageClass then ;
- RightTypeEl:=ResolveAliasType(TPasClassOfType(RightTypeEl).DestType);
- if (CheckClassesAreRelated(LeftTypeEl,RightTypeEl)<>cIncompatible) then
- begin
- SetBaseType(btBoolean);
- exit;
- end
- end
- else
- RaiseXExpectedButYFound(20170322105252,'class type',GetElementTypeName(RightResolved.LoTypeEl),Bin.right);
- end
- else if LeftResolved.LoTypeEl=nil then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeBinaryExprRes is-operator: left=',GetResolverResultDbg(LeftResolved),' right=',GetResolverResultDbg(RightResolved));
- {$ENDIF}
- RaiseMsg(20170216152232,nLeftSideOfIsOperatorExpectsAClassButGot,sLeftSideOfIsOperatorExpectsAClassButGot,
- [BaseTypeNames[LeftResolved.BaseType]],Bin.left);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeBinaryExprRes is-operator: left=',GetResolverResultDbg(LeftResolved),' right=',GetResolverResultDbg(RightResolved));
- {$ENDIF}
- RaiseMsg(20170216152234,nLeftSideOfIsOperatorExpectsAClassButGot,sLeftSideOfIsOperatorExpectsAClassButGot,
- [GetElementTypeName(LeftResolved.LoTypeEl)],Bin.left);
- end;
- end;
- eopAs:
- begin
- if (LeftTypeEl.ClassType=TPasClassType) then
- begin
- if (LeftResolved.IdentEl is TPasType)
- or (not (rrfReadable in LeftResolved.Flags)) then
- RaiseIncompatibleTypeRes(20180204124711,nOperatorIsNotOverloadedAOpB,
- [OpcodeStrings[Bin.OpCode]],LeftResolved,RightResolved,Bin);
- if RightResolved.IdentEl=nil then
- RaiseXExpectedButYFound(20170216152630,'class',GetElementTypeName(RightResolved.LoTypeEl),Bin.right);
- if not (RightResolved.IdentEl is TPasType) then
- RaiseXExpectedButYFound(20170216152632,'class',RightResolved.IdentEl.Name,Bin.right);
- if not (RightResolved.BaseType=btContext) then
- RaiseXExpectedButYFound(20180426195816,'class',RightResolved.IdentEl.Name,Bin.right);
- RightTypeEl:=RightResolved.LoTypeEl;
- if RightTypeEl is TPasClassType then
- begin
- if TPasClassType(LeftTypeEl).ObjKind=TPasClassType(RightTypeEl).ObjKind then
- begin
- // e.g. classinst as classtype
- if (CheckSrcIsADstType(RightResolved,LeftResolved)<>cIncompatible) then
- begin
- SetRightValueExpr([rrfReadable]);
- exit;
- end;
- end
- else if TPasClassType(LeftTypeEl).ObjKind=okInterface then
- begin
- if (TPasClassType(RightTypeEl).ObjKind=okClass)
- and (not TPasClassType(RightTypeEl).IsExternal) then
- begin
- // e.g. intfvar as classtype
- SetRightValueExpr([rrfReadable]);
- exit;
- end;
- end
- else if TPasClassType(RightTypeEl).ObjKind=okInterface then
- begin
- if (TPasClassType(LeftTypeEl).ObjKind=okClass)
- and (not TPasClassType(LeftTypeEl).IsExternal) then
- begin
- // e.g. classinst as intftype
- SetRightValueExpr([rrfReadable]);
- exit;
- end;
- end;
- end;
- RaiseIncompatibleTypeRes(20180324190713,nTypesAreNotRelatedXY,[],LeftResolved,RightResolved,Bin);
- end
- else if LeftTypeEl.ClassType=TPasGenericTemplateType then
- begin
- // genericvar as ...
- if (LeftResolved.IdentEl is TPasType)
- or (not (rrfReadable in LeftResolved.Flags)) then
- RaiseIncompatibleTypeRes(20190908191127,nOperatorIsNotOverloadedAOpB,
- [OpcodeStrings[Bin.OpCode]],LeftResolved,RightResolved,Bin);
- if RightResolved.IdentEl=nil then
- RaiseXExpectedButYFound(20190908191202,'class',GetElementTypeName(RightResolved.LoTypeEl),Bin.right);
- if not (RightResolved.IdentEl is TPasType) then
- RaiseXExpectedButYFound(20190908191204,'class',RightResolved.IdentEl.Name,Bin.right);
- if not (RightResolved.BaseType=btContext) then
- RaiseXExpectedButYFound(20190908191206,'class',RightResolved.IdentEl.Name,Bin.right);
- RightTypeEl:=RightResolved.LoTypeEl;
- if RightTypeEl is TPasClassType then
- begin
- // e.g. genericvar as classtype
- SetRightValueExpr([rrfReadable]);
- exit;
- end;
- RaiseIncompatibleTypeRes(20190908192345,nTypesAreNotRelatedXY,[],LeftResolved,RightResolved,Bin);
- end;
- end;
- eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual:
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- RightTypeEl:=RightResolved.LoTypeEl;
- if (LeftTypeEl.ClassType=TPasEnumType) and (LeftTypeEl=RightTypeEl) then
- begin
- SetBaseType(btBoolean);
- exit;
- end
- else if (LeftTypeEl.ClassType=TPasPointerType)
- and (RightResolved.BaseType in btAllInteger) then
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end;
- eopSubIdent:
- begin
- ResolvedEl:=RightResolved;
- exit;
- end;
- eopAdd,eopSubtract:
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- if (LeftTypeEl.ClassType=TPasArrayType) then
- begin
- if IsDynArray(LeftTypeEl)
- and (Bin.OpCode=eopAdd)
- and ElHasModeSwitch(Bin,msArrayOperators)
- and ((RightResolved.BaseType in [btArrayOrSet,btArrayLit])
- or IsDynArray(RightResolved.LoTypeEl)) then
- begin
- // dynarr+[...]
- CheckAssignCompatibilityArrayType(LeftResolved,RightResolved,Bin,true);
- SetLeftValueExpr([rrfReadable]);
- exit;
- end;
- end
- else if LeftTypeEl.ClassType=TPasPointerType then
- begin
- if (RightResolved.BaseType in btAllInteger)
- and ElHasBoolSwitch(Bin,bsPointerMath) then
- begin
- // TypedPointer+Integer
- SetLeftValueExpr([rrfReadable]);
- exit;
- end;
- end;
- end;
- end;
- end
- else if LeftResolved.BaseType in [btSet,btArrayOrSet] then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags) then
- begin
- if (RightResolved.BaseType in [btSet,btArrayOrSet]) then
- case Bin.OpCode of
- eopAdd,
- eopSubtract,
- eopMultiply,
- eopSymmetricaldifference,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- if RightResolved.LoTypeEl=nil then
- begin
- // right is empty set/array
- if Bin.OpCode in [eopLessthanEqual,eopGreaterThanEqual] then
- SetBaseType(btBoolean)
- else
- begin
- ResolvedEl:=LeftResolved;
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.ExprEl:=Bin;
- end;
- exit;
- end
- else if LeftResolved.LoTypeEl=nil then
- begin
- // left is empty set/array
- if Bin.OpCode in [eopLessthanEqual,eopGreaterThanEqual] then
- SetBaseType(btBoolean)
- else
- begin
- ResolvedEl:=RightResolved;
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.ExprEl:=Bin;
- end;
- exit;
- end
- else if (LeftResolved.SubType=RightResolved.SubType)
- or ((LeftResolved.SubType in btAllBooleans)
- and (RightResolved.SubType in btAllBooleans))
- or ((LeftResolved.SubType in btAllInteger)
- and (RightResolved.SubType in btAllInteger)) then
- begin
- // compatible set
- if Bin.OpCode in [eopLessthanEqual,eopGreaterThanEqual] then
- SetBaseType(btBoolean)
- else
- begin
- ResolvedEl:=LeftResolved;
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.ExprEl:=Bin;
- end;
- exit;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeBinaryExprRes + - * >< Sets LeftSubType='+BaseTypeNames[LeftResolved.SubType]
- +' RightSubType='+BaseTypeNames[RightResolved.SubType]);
- {$ENDIF}
- end;
- end
- else if RightResolved.BaseType=btContext then
- begin
- RightTypeEl:=RightResolved.LoTypeEl;
- if RightTypeEl.ClassType=TPasArrayType then
- begin
- if IsDynArray(RightTypeEl) then
- begin
- // [...]+dynarr
- CheckAssignCompatibilityArrayType(RightResolved,LeftResolved,Bin,true);
- SetRightValueExpr([rrfReadable]);
- exit;
- end;
- end;
- end;
- end;
- end
- else if LeftResolved.BaseType=btArrayLit then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (rrfReadable in RightResolved.Flags)
- and (Bin.OpCode=eopAdd)
- and ElHasModeSwitch(Bin,msArrayOperators) then
- begin
- if RightResolved.BaseType=btArrayLit then
- begin
- if LeftResolved.LoTypeEl<>nil then
- ResolvedEl:=LeftResolved
- else
- ResolvedEl:=RightResolved;
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.ExprEl:=Bin;
- exit;
- end
- else if (RightResolved.BaseType=btContext)
- and (RightResolved.LoTypeEl.ClassType=TPasArrayType) then
- begin
- ResolvedEl:=RightResolved;
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.ExprEl:=Bin;
- exit;
- end;
- end;
- end
- else if LeftResolved.BaseType=btModule then
- begin
- if Bin.OpCode=eopSubIdent then
- begin
- ResolvedEl:=RightResolved;
- exit;
- end;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeBinaryExprRes OpCode=',OpcodeStrings[Bin.OpCode],' Kind=',Bin.Kind,' Left=',GetResolverResultDbg(LeftResolved),' Right=',GetResolverResultDbg(RightResolved));
- {$ENDIF}
- RaiseIncompatibleTypeRes(20180204114631,nOperatorIsNotOverloadedAOpB,
- [OpcodeStrings[Bin.OpCode]],LeftResolved,RightResolved,Bin);
- if Flags=[] then ;
- end;
- function TPasResolver.ComputeAddStringRes(const LeftResolved,
- RightResolved: TPasResolverResult; ExprEl: TPasExpr; out
- ResolvedEl: TPasResolverResult): boolean;
- procedure SetBaseType(BaseType: TResolverBaseType);
- begin
- SetResolverValueExpr(ResolvedEl,BaseType,FBaseTypes[BaseType],FBaseTypes[BaseType],
- ExprEl,[rrfReadable]);
- end;
- procedure SetLeftValueExpr(Flags: TPasResolverResultFlags);
- begin
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,
- LeftResolved.LoTypeEl,LeftResolved.HiTypeEl,ExprEl,Flags);
- end;
- procedure SetRightValueExpr(Flags: TPasResolverResultFlags);
- begin
- SetResolverValueExpr(ResolvedEl,RightResolved.BaseType,
- RightResolved.LoTypeEl,RightResolved.HiTypeEl,ExprEl,Flags);
- end;
- begin
- Result:=true;
- case LeftResolved.BaseType of
- btChar:
- begin
- case RightResolved.BaseType of
- btChar: SetBaseType(btString);
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar:
- if BaseTypeChar=btAnsiChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- {$endif}
- btWideChar:
- if BaseTypeChar=btWideChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- else
- // use right type for result
- SetRightValueExpr([rrfReadable]);
- end;
- exit;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar:
- begin
- case RightResolved.BaseType of
- btChar:
- if BaseTypeChar=btAnsiChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- btAnsiChar:
- if BaseTypeChar=btAnsiChar then
- SetBaseType(btString)
- else
- SetBaseType(btAnsiString);
- btWideChar:
- if BaseTypeChar=btWideChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- else
- // use right type for result
- SetRightValueExpr([rrfReadable]);
- end;
- exit;
- end;
- {$endif}
- btWideChar:
- begin
- case RightResolved.BaseType of
- btChar,{$ifdef FPC_HAS_CPSTRING}btAnsiChar,{$endif}btWideChar:
- if BaseTypeChar=btWideChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- else
- // use right type for result
- SetRightValueExpr([rrfReadable]);
- end;
- exit;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- btShortString:
- begin
- case RightResolved.BaseType of
- btChar,btAnsiChar,btShortString,btWideChar:
- // use left type for result
- SetLeftValueExpr([rrfReadable]);
- else
- // shortstring + string => string
- SetRightValueExpr([rrfReadable]);
- end;
- exit;
- end;
- {$endif}
- btString,{$ifdef FPC_HAS_CPSTRING}btAnsiString,{$endif}btUnicodeString:
- begin
- // string + x => string
- SetLeftValueExpr([rrfReadable]);
- exit;
- end;
- end;
- Result:=false;
- end;
- procedure TPasResolver.ComputeArgumentAndExpr(Arg: TPasArgument; out
- ArgResolved: TPasResolverResult; Expr: TPasExpr; out
- ExprResolved: TPasResolverResult; SetReferenceFlags: boolean);
- begin
- ComputeElement(Arg,ArgResolved,[]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeArgumentAndExpr Arg=',GetTreeDbg(Arg,2),' ArgResolved=',GetResolverResultDbg(ArgResolved));
- {$ENDIF}
- if (ArgResolved.LoTypeEl=nil) and (Arg.ArgType<>nil) then
- RaiseInternalError(20160922163628,'TypeEl=nil for '+GetTreeDbg(Arg));
- ComputeArgumentExpr(ArgResolved,Arg.Access,Expr,ExprResolved,SetReferenceFlags);
- end;
- procedure TPasResolver.ComputeArgumentExpr(
- const ArgResolved: TPasResolverResult; Access: TArgumentAccess;
- Expr: TPasExpr; out ExprResolved: TPasResolverResult;
- SetReferenceFlags: boolean);
- var
- NeedVar: Boolean;
- RHSFlags: TPasResolverComputeFlags;
- begin
- RHSFlags:=[];
- NeedVar:=Access in [argVar, argOut];
- if NeedVar then
- Include(RHSFlags,rcNoImplicitProc)
- else if IsProcedureType(ArgResolved,true)
- or (ArgResolved.BaseType=btPointer)
- or ((ArgResolved.LoTypeEl=nil) and (ArgResolved.IdentEl is TPasArgument)) then
- Include(RHSFlags,rcNoImplicitProcType);
- if SetReferenceFlags then
- Include(RHSFlags,rcSetReferenceFlags);
- ComputeElement(Expr,ExprResolved,RHSFlags);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeArgumentExpr Expr=',GetTreeDbg(Expr,2),' ExprResolved=',GetResolverResultDbg(ExprResolved),' RHSFlags=',dbgs(RHSFlags));
- {$ENDIF}
- end;
- procedure TPasResolver.ComputeArrayParams(Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeIndexProperty(Prop: TPasProperty);
- begin
- if [rcConstant,rcType]*Flags<>[] then
- RaiseConstantExprExp(20170216152635,Params);
- ComputeElement(GetPasPropertyType(Prop),ResolvedEl,[rcType],StartEl);
- ResolvedEl.IdentEl:=Prop;
- ResolvedEl.Flags:=[];
- if GetPasPropertyGetter(Prop)<>nil then
- Include(ResolvedEl.Flags,rrfReadable);
- if GetPasPropertySetter(Prop)<>nil then
- Include(ResolvedEl.Flags,rrfWritable);
- end;
- procedure ComputeArrayPointer(TypeEl: TPasType);
- begin
- if TypeEl=nil then
- RaiseInternalError(20180423092254);
- ComputeElement(TypeEl,ResolvedEl,[rcType],Params);
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.ExprEl:=Params;
- ResolvedEl.Flags:=ResolvedEl.Flags+[rrfReadable,rrfWritable];
- end;
- var
- TypeEl, ElType: TPasType;
- ArrayEl: TPasArrayType;
- ArgNo: Integer;
- OrigResolved: TPasResolverResult;
- ClassOrRecordScope: TPasClassOrRecordScope;
- Ref: TResolvedReference;
- begin
- ComputeElement(Params.Value,ResolvedEl,
- Flags-[rcNoImplicitProc,rcNoImplicitProcType],StartEl);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeArrayParams ResolvedEl=',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- if ResolvedEl.BaseType in btAllStrings then
- begin
- // stringvar[] => char
- case GetActualBaseType(ResolvedEl.BaseType) of
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiString,btRawByteString,btShortString:
- if BaseTypeChar=btAnsiChar then
- ResolvedEl.BaseType:=btChar
- else
- ResolvedEl.BaseType:=btAnsiChar;
- {$endif}
- btWideString,btUnicodeString:
- if BaseTypeChar=btWideChar then
- ResolvedEl.BaseType:=btChar
- else
- ResolvedEl.BaseType:=btWideChar;
- else
- RaiseNotYetImplemented(20170417202354,Params);
- end;
- // keep ResolvedEl.IdentEl the string var
- ResolvedEl.LoTypeEl:=FBaseTypes[ResolvedEl.BaseType];
- ResolvedEl.HiTypeEl:=ResolvedEl.LoTypeEl;
- ResolvedEl.ExprEl:=Params;
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable,rrfCanBeStatement]+[rrfAssignable];
- end
- else if ResolvedEl.BaseType=btPointer then
- // (@something)[]
- ComputeArrayPointer(ResolvedEl.LoTypeEl)
- else if (ResolvedEl.IdentEl is TPasProperty)
- and (GetPasPropertyArgs(TPasProperty(ResolvedEl.IdentEl)).Count>0) then
- // property with args
- ComputeIndexProperty(TPasProperty(ResolvedEl.IdentEl))
- else if ResolvedEl.BaseType=btContext then
- begin
- TypeEl:=ResolvedEl.LoTypeEl;
- if (TypeEl.ClassType=TPasClassType)
- or (TypeEl.ClassType=TPasRecordType)
- or (TypeEl.ClassType=TPasClassOfType) then
- begin
- if not (Params.CustomData is TResolvedReference) then
- RaiseNotYetImplemented(20190125143203,Params,GetObjName(Params.CustomData));
- Ref:=TResolvedReference(Params.CustomData);
- if Ref.Declaration is TPasProperty then
- ComputeIndexProperty(TPasProperty(Ref.Declaration))
- else if TypeEl is TPasMembersType then
- begin
- ClassOrRecordScope:=NoNil(TypeEl.CustomData) as TPasClassOrRecordScope;
- ComputeArrayParams_Class(Params,ResolvedEl,ClassOrRecordScope,Flags,StartEl);
- end
- else
- RaiseNotYetImplemented(20161010174916,Params);
- end
- else if TypeEl.ClassType=TPasArrayType then
- begin
- if not (rrfReadable in ResolvedEl.Flags) then
- RaiseMsg(20170517001140,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['[',TypeEl.ElementTypeName],Params);
- ArrayEl:=TPasArrayType(TypeEl);
- ArgNo:=0;
- repeat
- if length(ArrayEl.Ranges)=0 then
- begin
- inc(ArgNo); // dynamic/open array has one dimension
- if IsDynArray(ArrayEl) then
- Include(ResolvedEl.Flags,rrfWritable); // dynamic array elements are writable
- end
- else
- inc(ArgNo,length(ArrayEl.Ranges)); // static array has several dimensions
- if ArgNo>length(Params.Params) then
- RaiseInternalError(20161010185535);
- if ArgNo=length(Params.Params) then
- break;
- // continue in sub array
- ArrayEl:=NoNil(ResolveAliasType(ArrayEl.ElType)) as TPasArrayType;
- until false;
- OrigResolved:=ResolvedEl;
- ElType:=GetArrayElType(ArrayEl);
- ComputeElement(ElType,ResolvedEl,Flags,StartEl);
- // identifier and value is the array itself
- ResolvedEl.IdentEl:=OrigResolved.IdentEl;
- ResolvedEl.ExprEl:=OrigResolved.ExprEl;
- ResolvedEl.Flags:=OrigResolved.Flags*[rrfReadable,rrfWritable];
- if IsDynArray(ArrayEl) then
- // dyn array elements are writable independent of the array
- Include(ResolvedEl.Flags,rrfWritable);
- end
- else if TypeEl.ClassType=TPasPointerType then
- ComputeArrayPointer(TPasPointerType(TypeEl).DestType)
- else
- RaiseNotYetImplemented(20161010151727,Params,GetResolverResultDbg(ResolvedEl));
- end
- else
- RaiseNotYetImplemented(20160928174212,Params,GetResolverResultDbg(ResolvedEl));
- end;
- procedure TPasResolver.ComputeArrayParams_Class(Params: TParamsExpr;
- var ResolvedEl: TPasResolverResult; ClassOrRecScope: TPasClassOrRecordScope;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement);
- begin
- RaiseNotYetImplemented(20190125142240,Params);
- if Params=nil then ;
- if ClassOrRecScope=nil then ;
- if Flags=[] then ;
- if StartEl=nil then ;
- SetResolverIdentifier(ResolvedEl,btNone,nil,nil,nil,[]);
- end;
- procedure TPasResolver.ComputeFuncParams(Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- var
- DeclEl: TPasElement;
- BuiltInProc: TResElDataBuiltInProc;
- Proc: TPasProcedure;
- ParamResolved: TPasResolverResult;
- Ref: TResolvedReference;
- DeclType: TPasType;
- Param0: TPasExpr;
- begin
- Ref:=GetParamsValueRef(Params);
- if Ref=nil then
- RaiseNotYetImplemented(20160928174124,Params);
- DeclEl:=Ref.Declaration;
- if DeclEl.ClassType=TPasUnresolvedSymbolRef then
- begin
- if DeclEl.CustomData.ClassType=TResElDataBuiltInProc then
- begin
- BuiltInProc:=TResElDataBuiltInProc(DeclEl.CustomData);
- if Assigned(BuiltInProc.GetCallResult) then
- // built-in function
- BuiltInProc.GetCallResult(BuiltInProc,Params,ResolvedEl)
- else
- // built-in procedure
- SetResolverIdentifier(ResolvedEl,btProc,BuiltInProc.Proc,
- BuiltInProc.Proc,BuiltInProc.Proc,[]);
- if bipfCanBeStatement in BuiltInProc.Flags then
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else if DeclEl.CustomData is TResElDataBaseType then
- begin
- // type cast to base type
- DeclType:=TPasUnresolvedSymbolRef(DeclEl);
- if length(Params.Params)<>1 then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeFuncParams DeclEl=',GetObjName(DeclEl));
- {$ENDIF}
- RaiseMsg(20180503105409,nWrongNumberOfParametersForTypeCast,
- sWrongNumberOfParametersForTypeCast,[DeclType.Name],Params);
- end;
- Param0:=Params.Params[0];
- ComputeElement(Param0,ParamResolved,[]);
- ComputeTypeCast(DeclType,DeclType,Param0,ParamResolved,ResolvedEl,Flags);
- end
- else
- RaiseNotYetImplemented(20161006133040,Params,GetResolverResultDbg(ResolvedEl));
- end
- else
- begin
- // normal identifier (not built-in)
- ComputeElement(DeclEl,ResolvedEl,Flags+[rcNoImplicitProc],StartEl);
- if ResolvedEl.BaseType=btProc then
- begin
- if not (ResolvedEl.IdentEl is TPasProcedure) then
- RaiseNotYetImplemented(20160928180201,Params,GetResolverResultDbg(ResolvedEl));
- Proc:=TPasProcedure(ResolvedEl.IdentEl);
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152637,Params);
- if Proc.ProcType is TPasFunctionType then
- // function call => return result
- ComputeResultElement(TPasFunctionType(Proc.ProcType).ResultEl,ResolvedEl,
- Flags+[rcCall],StartEl)
- else if (Proc.ClassType=TPasConstructor) then
- begin
- // constructor -> return value of type class
- ResolvedEl:=GetReference_ConstructorType(Ref,Params.Value);
- end
- else
- // procedure call, result is neither readable nor writable
- SetResolverIdentifier(ResolvedEl,btProc,Proc,Proc.ProcType,Proc.ProcType,[]);
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else if ResolvedEl.LoTypeEl is TPasProcedureType then
- begin
- if Params.Value is TParamsExpr then
- begin
- // e.g. Name()() or Name[]()
- Include(ResolvedEl.Flags,rrfReadable);
- end;
- if rrfReadable in ResolvedEl.Flags then
- begin
- // call procvar
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152639,Params);
- if ResolvedEl.LoTypeEl is TPasFunctionType then
- // function call => return result
- ComputeResultElement(TPasFunctionType(ResolvedEl.LoTypeEl).ResultEl,
- ResolvedEl,Flags+[rcCall],StartEl)
- else
- // procedure call, result is neither readable nor writable
- SetResolverTypeExpr(ResolvedEl,btProc,
- ResolvedEl.LoTypeEl,ResolvedEl.HiTypeEl,[]);
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else
- begin
- // typecast to proctype
- if length(Params.Params)<>1 then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeFuncParams DeclEl=',GetObjName(DeclEl),' ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- RaiseMsg(20170416185211,nWrongNumberOfParametersForTypeCast,
- sWrongNumberOfParametersForTypeCast,[ResolvedEl.LoTypeEl.Name],Params);
- end;
- Param0:=Params.Params[0];
- ComputeElement(Param0,ParamResolved,[]);
- ComputeTypeCast(ResolvedEl.LoTypeEl,ResolvedEl.HiTypeEl,Param0,
- ParamResolved,ResolvedEl,Flags);
- end;
- end
- else if (DeclEl is TPasType) then
- begin
- // type cast
- Param0:=Params.Params[0];
- ComputeElement(Param0,ParamResolved,Flags);
- ComputeTypeCast(ResolvedEl.LoTypeEl,ResolvedEl.HiTypeEl,Param0,
- ParamResolved,ResolvedEl,Flags);
- end
- else
- RaiseNotYetImplemented(20160928180048,Params,GetResolverResultDbg(ResolvedEl));
- end;
- end;
- procedure TPasResolver.ComputeTypeCast(ToLoType, ToHiType: TPasType;
- Param: TPasExpr; const ParamResolved: TPasResolverResult; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags);
- function ParamIsVar: boolean;
- var
- IdentEl: TPasElement;
- begin
- IdentEl:=ParamResolved.IdentEl;
- if IdentEl=nil then exit(false);
- if [rcConstant,rcType]*Flags<>[] then
- Result:=(IdentEl.ClassType=TPasConst) and (TPasConst(IdentEl).IsConst)
- else
- Result:=(IdentEl is TPasVariable)
- or (IdentEl.ClassType=TPasArgument)
- or (IdentEl.ClassType=TPasResultElement);
- end;
- var
- WriteFlags: TPasResolverResultFlags;
- KeepWriteFlags: Boolean;
- bt: TResolverBaseType;
- Expr: TPasExpr;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeFuncParams START ToLoType=',GetObjName(ToLoType),' ',BoolToStr(ToLoType<>ToHiType,'ToHiType='+GetObjName(ToHiType),''),' ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- if ToLoType.CustomData is TResElDataBaseType then
- begin
- // type cast to base type (or alias of base type)
- bt:=GetActualBaseType(TResElDataBaseType(ToLoType.CustomData).BaseType);
- SetResolverValueExpr(ResolvedEl,
- TResElDataBaseType(ToLoType.CustomData).BaseType,
- ToLoType,ToHiType,
- Param,[rrfReadable]);
- ResolvedEl.IdentEl:=ParamResolved.IdentEl;
- WriteFlags:=ParamResolved.Flags*[rrfWritable,rrfAssignable];
- if (WriteFlags<>[]) and ParamIsVar then
- begin
- KeepWriteFlags:=false;
- // Param is writable -> check if typecast keeps this
- if (bt=btPointer) then
- begin
- // typecast to pointer
- if (ParamResolved.BaseType=btPointer)
- or (ParamResolved.BaseType in [btString,btUnicodeString,btWideString])
- or (ParamResolved.LoTypeEl=nil) // untyped
- or (ParamResolved.LoTypeEl.ClassType=TPasClassType)
- or IsDynArray(ParamResolved.LoTypeEl)
- then
- // e.g. pointer(ObjVar)
- KeepWriteFlags:=true;
- end
- else if IsSameType(ToLoType,ParamResolved.LoTypeEl,prraNone) then
- // e.g. Byte(TAliasByte)
- KeepWriteFlags:=true;
- if KeepWriteFlags then
- ResolvedEl.Flags:=ResolvedEl.Flags+WriteFlags;
- end;
- end
- else if ToLoType is TPasProcedureType then
- begin
- // typecast to proctype
- if ParamIsVar then
- WriteFlags:=ParamResolved.Flags*[rrfWritable,rrfAssignable]
- else
- WriteFlags:=[];
- SetResolverValueExpr(ResolvedEl,btContext,
- ToLoType,ToHiType,
- Param,[rrfReadable]+WriteFlags);
- ResolvedEl.IdentEl:=ParamResolved.IdentEl;
- end
- else
- begin
- // typecast to custom type, e.g. to classtype, recordtype, arraytype, range, set
- if (Param.Parent is TParamsExpr) then
- Expr:=TParamsExpr(Param.Parent)
- else
- Expr:=Param;
- ComputeElement(ToHiType,ResolvedEl,Flags,Expr);
- ResolvedEl.ExprEl:=Expr;
- ResolvedEl.IdentEl:=ParamResolved.IdentEl;
- ResolvedEl.Flags:=[rrfReadable];
- WriteFlags:=ParamResolved.Flags*[rrfWritable,rrfAssignable];
- if (WriteFlags<>[]) and ParamIsVar then
- begin
- KeepWriteFlags:=false;
- if (rrfReadable in ResolvedEl.Flags) then
- begin
- // typecast a value
- if ParamResolved.BaseType=btPointer then
- begin
- if (ToLoType.ClassType=TPasClassType)
- or IsDynArray(ParamResolved.LoTypeEl) then
- // aClassType(aPointer)
- KeepWriteFlags:=true;
- end
- else if ParamResolved.LoTypeEl=nil then
- // e.g. TAliasType(untyped)
- KeepWriteFlags:=true
- else if ToLoType=ParamResolved.LoTypeEl then
- // e.g. TAliasType(ActualType)
- KeepWriteFlags:=true
- else if (ToLoType.ClassType=TPasClassType)
- and (ParamResolved.LoTypeEl.ClassType=TPasClassType) then
- begin
- // e.g. aClassType(ObjVar)
- if (TPasClassType(ToLoType).ObjKind<>TPasClassType(ParamResolved.LoTypeEl).ObjKind) then
- // e.g. IntfType(ObjVar)
- else
- KeepWriteFlags:=true;
- end
- else if (ToLoType.ClassType=TPasRecordType)
- and (ParamResolved.LoTypeEl.ClassType=TPasRecordType) then
- // typecast record
- KeepWriteFlags:=true
- else if (ToLoType.ClassType=TPasArrayType)
- and (ParamResolved.LoTypeEl.ClassType=TPasArrayType)
- and IsDynArray(ToLoType)
- and IsDynArray(ParamResolved.LoTypeEl) then
- // typecast dyn array to dyn array
- KeepWriteFlags:=true;
- end
- else
- begin
- // typecast a type to a value, e.g. Pointer(TObject)
- end;
- if KeepWriteFlags then
- ResolvedEl.Flags:=ResolvedEl.Flags+WriteFlags;
- end;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeFuncParams END ToLoType=',GetObjName(ToLoType),' ',BoolToStr(ToLoType<>ToHiType,'ToHiType='+GetObjName(ToHiType),''),' ',GetResolverResultDbg(ParamResolved),' Result=',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- end;
- procedure TPasResolver.ComputeSetParams(Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- // [param,param,...]
- var
- ParamResolved, FirstResolved: TPasResolverResult;
- i: Integer;
- Param: TPasExpr;
- IsRange, IsArray: Boolean;
- ArrayType: TPasArrayType;
- begin
- ArrayType:=IsArrayExpr(Params);
- IsArray:=ArrayType<>nil;
- if length(Params.Params)=0 then
- begin
- SetResolverValueExpr(ResolvedEl,btArrayOrSet,nil,nil,Params,[rrfReadable]);
- if IsArray then
- ResolvedEl.BaseType:=btArrayLit;
- exit;
- end;
- FirstResolved:=Default(TPasResolverResult);
- Flags:=Flags-[rcNoImplicitProc]+[rcNoImplicitProcType];
- for i:=0 to length(Params.Params)-1 do
- begin
- Param:=Params.Params[i];
- ComputeElement(Params.Params[0],ParamResolved,Flags,StartEl);
- IsRange:=ParamResolved.BaseType=btRange;
- if IsRange then
- begin
- if IsArray then
- RaiseXExpectedButYFound(20180615111713,'array value','range expression',Param);
- ConvertRangeToElement(ParamResolved);
- end;
- if FirstResolved.BaseType=btNone then
- begin
- // first value -> check if type usable in a set/array
- FirstResolved:=ParamResolved;
- if IsRange then
- CheckIsOrdinal(FirstResolved,Param,true);
- if rrfReadable in FirstResolved.Flags then
- begin
- // has a value
- if (not IsArray) and (not IsRange)
- and (not CheckIsOrdinal(FirstResolved,Param,false)) then
- begin
- // can't be a set
- IsArray:=true;
- end;
- end
- else
- begin
- IsArray:=true;
- if (FirstResolved.BaseType=btContext) then
- begin
- if FirstResolved.IdentEl is TPasClassType then
- // array of classtypes
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeSetParams ',GetResolverResultDbg(FirstResolved));
- {$ENDIF}
- RaiseXExpectedButYFound(20170420002328,'array value','type',Param);
- end;
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeSetParams ',GetResolverResultDbg(FirstResolved));
- {$ENDIF}
- RaiseXExpectedButYFound(20170420002332,'array value','type',Param);
- end;
- end;
- end
- else
- begin
- // next value
- CombineArrayLitElTypes(Params.Params[0],Param,FirstResolved,ParamResolved);
- end;
- end;
- FirstResolved.IdentEl:=nil;
- FirstResolved.ExprEl:=Params;
- FirstResolved.SubType:=FirstResolved.BaseType;
- if IsArray then
- FirstResolved.BaseType:=btArrayLit
- else
- FirstResolved.BaseType:=btArrayOrSet;
- FirstResolved.Flags:=[rrfReadable];
- ResolvedEl:=FirstResolved;
- end;
- procedure TPasResolver.ComputeDereference(El: TUnaryExpr;
- var ResolvedEl: TPasResolverResult);
- procedure Deref(TypeEl: TPasType);
- var
- Expr: TPasExpr;
- begin
- Expr:=ResolvedEl.ExprEl;
- if Expr=nil then
- Expr:=El;
- ComputeElement(TypeEl,ResolvedEl,[rcNoImplicitProc],El);
- ResolvedEl.IdentEl:=nil;
- ResolvedEl.ExprEl:=Expr;
- ResolvedEl.Flags:=ResolvedEl.Flags+[rrfReadable,rrfWritable];
- end;
- var
- TypeEl: TPasType;
- begin
- if ResolvedEl.BaseType=btPointer then
- begin
- Deref(ResolvedEl.LoTypeEl);
- exit;
- end
- else if ResolvedEl.BaseType=btContext then
- begin
- TypeEl:=ResolvedEl.LoTypeEl;
- if TypeEl.ClassType=TPasPointerType then
- begin
- Deref(TPasPointerType(TypeEl).DestType);
- exit;
- end;
- end;
- RaiseMsg(20180422191139,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
- [OpcodeStrings[eopDeref],GetResolverResultDescription(ResolvedEl)],El);
- end;
- procedure TPasResolver.ComputeArrayValuesExpectedType(El: TArrayValues; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- // (expr, expr, ...)
- var
- Parent: TPasElement;
- HiTypeEl, LoTypeEl: TPasType;
- Field: PRecordValuesItem;
- Ref: TResolvedReference;
- Member: TPasVariable;
- i: Integer;
- ArrType: TPasArrayType;
- begin
- Parent:=El.Parent;
- if Parent is TPasVariable then
- begin
- HiTypeEl:=TPasVariable(Parent).VarType;
- if HiTypeEl=nil then
- RaiseMsg(20180429171628,nSyntaxErrorExpectedButFound,sSyntaxErrorExpectedButFound,
- ['const','array values'],El);
- LoTypeEl:=ResolveAliasType(HiTypeEl);
- if LoTypeEl.ClassType=TPasArrayType then
- // ok
- else
- RaiseIncompatibleTypeDesc(20180429171714,nIncompatibleTypesGotExpected,
- [],'array value',GetTypeDescription(HiTypeEl),El);
- SetResolverValueExpr(ResolvedEl,btContext,LoTypeEl,HiTypeEl,
- El,[rrfReadable]);
- end
- else if Parent.ClassType=TRecordValues then
- begin
- // record field array
- // get field
- i:=length(TRecordValues(Parent).Fields)-1;
- while (i>=0) and (TRecordValues(Parent).Fields[i].ValueExp<>El) do
- dec(i);
- if i<0 then
- RaiseInternalError(20180429181150);
- Field:=@TRecordValues(Parent).Fields[i];
- // get member
- Ref:=Field^.NameExp.CustomData as TResolvedReference;
- Member:=Ref.Declaration as TPasVariable;
- if Member=nil then
- RaiseInternalError(20180429181210);
- ComputeElement(Member,ResolvedEl,[],StartEl);
- ResolvedEl.Flags:=[rrfReadable];
- end
- else if Parent.ClassType=TArrayValues then
- begin
- // array of array
- ComputeArrayValuesExpectedType(TArrayValues(Parent),ResolvedEl,Flags,StartEl);
- if (ResolvedEl.BaseType=btContext)
- and (ResolvedEl.LoTypeEl.ClassType=TPasArrayType) then
- begin
- ArrType:=TPasArrayType(ResolvedEl.LoTypeEl);
- if length(ArrType.Ranges)>1 then
- RaiseNotYetImplemented(20180429180930,El);
- HiTypeEl:=ArrType.ElType;
- LoTypeEl:=ResolveAliasType(HiTypeEl);
- if LoTypeEl.ClassType<>TPasArrayType then
- RaiseIncompatibleTypeDesc(20180429180938,nIncompatibleTypesGotExpected,
- [],'array values',GetTypeDescription(HiTypeEl),El);
- SetResolverValueExpr(ResolvedEl,btContext,LoTypeEl,HiTypeEl,
- El,[rrfReadable]);
- end
- else
- RaiseIncompatibleTypeDesc(20180429173143,nIncompatibleTypesGotExpected,
- [],'array values',GetTypeDescription(ResolvedEl),El);
- end
- else
- SetResolverValueExpr(ResolvedEl,btArrayLit,nil,nil,TArrayValues(El),[rrfReadable]);
- end;
- procedure TPasResolver.ComputeRecordValues(El: TRecordValues; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- // (name:expr; name:expr; ...)
- var
- Parent, Member: TPasElement;
- LoTypeEl, HiTypeEl: TPasType;
- i: Integer;
- Field: PRecordValuesItem;
- Ref: TResolvedReference;
- ArrType: TPasArrayType;
- begin
- Parent:=El.Parent;
- if Parent is TPasVariable then
- begin
- HiTypeEl:=TPasVariable(Parent).VarType;
- if HiTypeEl=nil then
- RaiseMsg(20180429105451,nSyntaxErrorExpectedButFound,sSyntaxErrorExpectedButFound,
- ['const','record values'],El);
- LoTypeEl:=ResolveAliasType(HiTypeEl);
- if LoTypeEl.ClassType<>TPasRecordType then
- RaiseIncompatibleTypeDesc(20180429104135,nIncompatibleTypesGotExpected,
- [],'record value',GetTypeDescription(HiTypeEl),El);
- SetResolverValueExpr(ResolvedEl,btContext,LoTypeEl,HiTypeEl,
- El,[rrfReadable]);
- end
- else if Parent.ClassType=TRecordValues then
- begin
- // nested record
- // get field
- i:=length(TRecordValues(Parent).Fields)-1;
- while (i>=0) and (TRecordValues(Parent).Fields[i].ValueExp<>El) do
- dec(i);
- if i<0 then
- RaiseInternalError(20180429130244);
- Field:=@TRecordValues(Parent).Fields[i];
- // get member
- Ref:=Field^.NameExp.CustomData as TResolvedReference;
- Member:=Ref.Declaration as TPasVariable;
- if Member=nil then
- RaiseInternalError(20180429130548);
- ComputeElement(Member,ResolvedEl,[],StartEl);
- ResolvedEl.Flags:=[rrfReadable];
- end
- else if Parent.ClassType=TArrayValues then
- begin
- // array of record
- ComputeArrayValuesExpectedType(TArrayValues(Parent),ResolvedEl,Flags,StartEl);
- if (ResolvedEl.BaseType=btContext)
- and (ResolvedEl.LoTypeEl.ClassType=TPasArrayType) then
- begin
- ArrType:=TPasArrayType(ResolvedEl.LoTypeEl);
- if length(ArrType.Ranges)>1 then
- RaiseNotYetImplemented(20180429180450,El);
- HiTypeEl:=ArrType.ElType;
- LoTypeEl:=ResolveAliasType(HiTypeEl);
- if LoTypeEl.ClassType<>TPasRecordType then
- RaiseIncompatibleTypeDesc(20180429180642,nIncompatibleTypesGotExpected,
- [],'record values',GetTypeDescription(HiTypeEl),El);
- SetResolverValueExpr(ResolvedEl,btContext,LoTypeEl,HiTypeEl,
- El,[rrfReadable]);
- end
- else
- RaiseIncompatibleTypeDesc(20180429173143,nIncompatibleTypesGotExpected,
- [],'array values',GetTypeDescription(ResolvedEl),El);
- end
- else
- RaiseMsg(20180429110227,nSyntaxErrorExpectedButFound,sSyntaxErrorExpectedButFound,
- ['const','(name:'],El);
- end;
- procedure TPasResolver.CheckIsClass(El: TPasElement;
- const ResolvedEl: TPasResolverResult);
- var
- TypeEl: TPasType;
- begin
- if (ResolvedEl.BaseType<>btContext) then
- RaiseXExpectedButYFound(20170216152245,'class',BaseTypeNames[ResolvedEl.BaseType],El);
- TypeEl:=ResolvedEl.LoTypeEl;
- if (TypeEl.ClassType<>TPasClassType)
- or (TPasClassType(TypeEl).ObjKind<>okClass) then
- RaiseXExpectedButYFound(20170216152246,'class',GetElementTypeName(ResolvedEl.LoTypeEl),El);
- end;
- function TPasResolver.CheckTypeCastClassInstanceToClass(const FromClassRes,
- ToClassRes: TPasResolverResult; ErrorEl: TPasElement): integer;
- // called when type casting a class instance into an unrelated class
- begin
- if FromClassRes.BaseType=btNone then ;
- if ToClassRes.BaseType=btNone then ;
- if ErrorEl=nil then ;
- Result:=cIncompatible;
- end;
- procedure TPasResolver.CheckSetLitElCompatible(Left, Right: TPasExpr;
- const LHS, RHS: TPasResolverResult);
- var
- LBT, RBT: TResolverBaseType;
- begin
- // check both are values
- if not (rrfReadable in LHS.Flags) then
- begin
- if LHS.LoTypeEl<>nil then
- RaiseXExpectedButYFound(20170216152645,'ordinal',GetElementTypeName(LHS.LoTypeEl),Left)
- else
- RaiseXExpectedButYFound(20170216152648,'ordinal',BaseTypeNames[LHS.BaseType],Left);
- end;
- if not (rrfReadable in RHS.Flags) then
- begin
- if RHS.LoTypeEl<>nil then
- RaiseXExpectedButYFound(20170216152651,'ordinal',GetElementTypeName(RHS.LoTypeEl),Right)
- else
- RaiseXExpectedButYFound(20170216152653,'ordinal',BaseTypeNames[RHS.BaseType],Right);
- end;
- // check both have the same ordinal type
- LBT:=GetActualBaseType(LHS.BaseType);
- RBT:=GetActualBaseType(RHS.BaseType);
- if LBT in btAllBooleans then
- begin
- if RBT in btAllBooleans then
- exit;
- RaiseXExpectedButYFound(20170216152656,'boolean',BaseTypeNames[RHS.BaseType],Right);
- end
- else if LBT in btAllInteger then
- begin
- if RBT in btAllInteger then
- exit;
- RaiseXExpectedButYFound(20170216152658,'integer',BaseTypeNames[RHS.BaseType],Right);
- end
- else if LBT in btAllChars then
- begin
- if RBT in btAllChars then
- exit;
- RaiseXExpectedButYFound(20170216152702,'char',BaseTypeNames[RHS.BaseType],Right);
- end
- else if LBT=btContext then
- begin
- if LHS.LoTypeEl.ClassType=TPasEnumType then
- begin
- if LHS.LoTypeEl=RHS.LoTypeEl then
- exit;
- if RHS.LoTypeEl.ClassType<>TPasEnumType then
- RaiseXExpectedButYFound(20170216152707,LHS.LoTypeEl.Parent.Name,GetElementTypeName(RHS.LoTypeEl),Right);
- if LHS.LoTypeEl.Parent<>RHS.LoTypeEl.Parent then
- RaiseXExpectedButYFound(20170216152710,LHS.LoTypeEl.Parent.Name,RHS.LoTypeEl.Parent.Name,Right);
- end
- else
- RaiseXExpectedButYFound(20170216152712,'ordinal',BaseTypeNames[LHS.BaseType],Left);
- end
- else
- RaiseXExpectedButYFound(20170216152714,'ordinal',BaseTypeNames[LHS.BaseType],Left);
- end;
- function TPasResolver.CheckIsOrdinal(
- const ResolvedEl: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnError: boolean): boolean;
- begin
- Result:=false;
- if ResolvedEl.BaseType in btAllRanges then
- else if (ResolvedEl.BaseType=btContext) then
- begin
- if ResolvedEl.LoTypeEl.ClassType=TPasEnumType then
- else if RaiseOnError then
- RaiseXExpectedButYFound(20170216152718,'ordinal value',GetElementTypeName(ResolvedEl.LoTypeEl),ErrorEl)
- else
- exit;
- end
- else if RaiseOnError then
- RaiseXExpectedButYFound(20170216152720,'ordinal value',BaseTypeNames[ResolvedEl.BaseType],ErrorEl)
- else
- exit;
- Result:=true;
- end;
- procedure TPasResolver.CombineArrayLitElTypes(Left, Right: TPasExpr;
- var LHS: TPasResolverResult; const RHS: TPasResolverResult);
- // LHS defines the array element type
- // check if RHS
- var
- LBT, RBT: TResolverBaseType;
- C: TClass;
- begin
- if (LHS.LoTypeEl=RHS.LoTypeEl) and (LHS.BaseType=RHS.BaseType) then
- exit; // exact same type
- LBT:=GetActualBaseType(LHS.BaseType);
- RBT:=GetActualBaseType(RHS.BaseType);
- if rrfReadable in LHS.Flags then
- begin
- if not (rrfReadable in RHS.Flags) then
- RaiseIncompatibleTypeRes(20170420004759,nIncompatibleTypesGotExpected,
- [],RHS,LHS,Right);
- // array of values
- if LBT in btAllBooleans then
- begin
- if RBT in btAllBooleans then
- begin
- LHS.BaseType:=GetCombinedBoolean(LBT,RBT,Right);
- exit;
- end;
- RaiseXExpectedButYFound(20170420093015,'boolean',BaseTypeNames[RHS.BaseType],Right);
- end
- else if LBT in btAllInteger then
- begin
- if RBT in btAllInteger then
- begin
- LHS.BaseType:=GetCombinedInt(LHS,RHS,Right);
- exit;
- end;
- RaiseXExpectedButYFound(20170420093019,'integer',BaseTypeNames[RHS.BaseType],Right);
- end
- else if LBT in btAllChars then
- begin
- if RBT in btAllChars then
- begin
- LHS.BaseType:=GetCombinedChar(LHS,RHS,Right);
- exit;
- end;
- RaiseXExpectedButYFound(20170420093024,'char',BaseTypeNames[RHS.BaseType],Right);
- end
- else if LBT in btAllStrings then
- begin
- if RBT in btAllStringAndChars then
- begin
- LHS.BaseType:=GetCombinedString(LHS,RHS,Right);
- exit;
- end;
- RaiseXExpectedButYFound(20170420102832,'string',BaseTypeNames[RHS.BaseType],Right);
- end
- else if LBT=btNil then
- begin
- if RBT=btNil then
- exit
- else if RBT=btPointer then
- begin
- LHS:=RHS;
- exit;
- end
- else if RBT=btContext then
- begin
- C:=RHS.LoTypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasPointerType)
- or ((C=TPasArrayType) and IsDynArray(RHS.LoTypeEl))
- or (C=TPasProcedureType)
- or (C=TPasFunctionType) then
- begin
- LHS:=RHS;
- exit;
- end;
- end;
- end
- else if LBT=btContext then
- begin
- C:=LHS.LoTypeEl.ClassType;
- if C=TPasEnumType then
- begin
- if LHS.LoTypeEl=RHS.LoTypeEl then
- exit;
- end
- else if C=TPasClassType then
- begin
- // array of class instances
- if RHS.LoTypeEl.ClassType<>TPasClassType then
- RaiseIncompatibleTypeRes(20170420135637,nIncompatibleTypesGotExpected,
- [],RHS,LHS,Right);
- if CheckClassIsClass(LHS.LoTypeEl,RHS.LoTypeEl)<cIncompatible then
- begin
- // right class type is a left class type -> ok
- exit;
- end
- else if CheckClassIsClass(RHS.LoTypeEl,LHS.LoTypeEl)<cIncompatible then
- begin
- // left class type is a right class type -> right is the new base class type
- LHS:=RHS;
- exit;
- end;
- end;
- end;
- end
- else
- begin
- // array of types
- if rrfReadable in RHS.Flags then
- RaiseIncompatibleTypeRes(20170420004925,nIncompatibleTypesGotExpected,
- [],RHS,LHS,Right);
- if LBT=btContext then
- begin
- if LHS.LoTypeEl.ClassType=TPasClassType then
- begin
- // array of class type
- if RHS.LoTypeEl.ClassType<>TPasClassType then
- RaiseIncompatibleTypeRes(20170420091839,nIncompatibleTypesGotExpected,
- [],RHS,LHS,Right);
- if CheckClassIsClass(LHS.LoTypeEl,RHS.LoTypeEl)<cIncompatible then
- begin
- // right class type is a left class type -> ok
- exit;
- end
- else if CheckClassIsClass(RHS.LoTypeEl,LHS.LoTypeEl)<cIncompatible then
- begin
- // left class type is a right class type -> right is the new base class type
- LHS:=RHS;
- exit;
- end;
- end;
- end;
- end;
- // can't combine
- if LHS.LoTypeEl=nil then
- RaiseXExpectedButYFound(20170420004537,'array element',BaseTypeNames[LHS.BaseType],Left);
- if RHS.LoTypeEl=nil then
- RaiseXExpectedButYFound(20170420004602,'array element',BaseTypeNames[RHS.BaseType],Right);
- RaiseIncompatibleTypeRes(20170420092625,nIncompatibleTypesGotExpected,
- [],RHS,LHS,Right);
- end;
- procedure TPasResolver.ConvertRangeToElement(
- var ResolvedEl: TPasResolverResult);
- var
- TypeEl: TPasType;
- begin
- if ResolvedEl.BaseType<>btRange then
- RaiseInternalError(20161001155732);
- if ResolvedEl.LoTypeEl=nil then
- if ResolvedEl.IdentEl<>nil then
- RaiseNotYetImplemented(20161001155747,ResolvedEl.IdentEl)
- else
- RaiseNotYetImplemented(20161001155834,ResolvedEl.ExprEl);
- TypeEl:=ResolvedEl.LoTypeEl;
- if TypeEl is TPasRangeType then
- ComputeElement(TPasRangeType(TypeEl).RangeExpr.left,ResolvedEl,[rcConstant])
- else
- begin
- ResolvedEl.BaseType:=ResolvedEl.SubType;
- ResolvedEl.SubType:=btNone;
- end;
- end;
- function TPasResolver.IsCharLiteral(const Value: string; ErrorPos: TPasElement
- ): TResolverBaseType;
- // returns true if Value is a Pascal char literal
- // btAnsiChar: #65, #$50, ^G, 'a'
- // btWideChar: #10000, 'ä'
- var
- i: SizeInt;
- p, base, l: Integer;
- begin
- Result:=btNone;
- //writeln('TPasResolver.IsCharLiteral ',BaseTypeChar,' "',Value,'" l=',length(Value));
- l:=length(Value);
- if l=0 then exit;
- p:=1;
- case Value[1] of
- '''':
- begin
- inc(p);
- if p>l then exit;
- {$ifdef FPC_HAS_CPSTRING}
- case Value[2] of
- '''':
- if Value='''''''''' then
- Result:=btAnsiChar; // ''''
- #32..#38,#40..#191:
- if (l=3) and (Value[3]='''') then
- Result:=btAnsiChar; // e.g. 'a'
- #192..#255:
- if BaseTypeChar=btWideChar then
- begin
- // default char is widechar: UTF-8 'ä' is a widechar
- i:=Utf8CodePointLen(@Value[2],4,false);
- //writeln('TPasResolver.IsCharLiteral "',Value,'" ',length(Value),' i=',i);
- if i<2 then
- exit;
- p:=2+i;
- if (p=l) and (Value[p]='''') then
- // single UTF-8 codepoint
- Result:=btWideChar;
- end;
- end;
- {$else}
- case Value[p] of
- '''':
- if (p+2=l) and (Value[p+1]='''') and (Value[p+2]='''') then
- Result:=btWideChar; // ''''
- #$DC00..#$DFFF: ;
- else
- if (l=3) and (Value[3]='''') then
- Result:=btWideChar; // e.g. 'a'
- end;
- {$endif}
- end;
- '#':
- begin
- inc(p);
- if p>l then exit;
- case Value[p] of
- '$': begin base:=16; inc(p); end;
- '&': begin base:=8; inc(p); end;
- '%': begin base:=2; inc(p); end;
- '0'..'9': base:=10;
- else RaiseNotYetImplemented(20170728142709,ErrorPos);
- end;
- i:=0;
- while p<=l do
- begin
- case Value[p] of
- '0'..'9': i:=i*base+ord(Value[p])-ord('0');
- 'A'..'Z': i:=i*base+ord(Value[p])-ord('A')+10;
- 'a'..'z': i:=i*base+ord(Value[p])-ord('a')+10;
- end;
- inc(p);
- end;
- if p>l then
- begin
- {$ifdef FPC_HAS_CPSTRING}
- if i<256 then
- Result:=btAnsiChar
- else
- {$endif}
- Result:=btWideChar;
- end;
- end;
- '^':
- begin
- if (l=2) and (Value[2] in ['a'..'z','A'..'Z']) then
- Result:={$ifdef FPC_HAS_CPSTRING}btAnsiChar{$else}btWideChar{$endif};
- end;
- end;
- if Result in [{$ifdef FPC_HAS_CPSTRING}btAnsiChar,{$endif}btWideChar] then
- begin
- if FBaseTypes[Result]=nil then
- begin
- {$ifdef FPC_HAS_CPSTRING}
- if Result=btAnsiChar then
- Result:=btWideChar
- else
- {$endif}
- Result:=btChar;
- end;
- if Result=BaseTypeChar then
- Result:=btChar;
- end;
- end;
- function TPasResolver.CheckForIn(Loop: TPasImplForLoop; const VarResolved,
- InResolved: TPasResolverResult): boolean;
- begin
- Result:=false;
- if Loop=nil then ;
- if VarResolved.BaseType=btCustom then ;
- if InResolved.BaseType=btCustom then ;
- end;
- function TPasResolver.CheckForInClassOrRec(Loop: TPasImplForLoop; const VarResolved,
- InResolved: TPasResolverResult): boolean;
- var
- LoTypeEl: TPasType;
- EnumeratorClass: TPasClassType;
- EnumeratorScope: TPasDotClassScope;
- Getter, MoveNext, Current: TPasIdentifier;
- GetterFunc, MoveNextFunc: TPasFunction;
- ptm: TProcTypeModifier;
- ResultResolved, MoveNextResolved, CurrentResolved: TPasResolverResult;
- CurrentProp: TPasProperty;
- ForScope: TPasForLoopScope;
- DotScope: TPasDotBaseScope;
- begin
- Result:=false;
- if InResolved.IdentEl is TPasType then
- RaiseMsg(20190120180525,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
- [GetBaseDescription(InResolved)],Loop.StartExpr);
- if not (rrfReadable in InResolved.Flags) then
- RaiseMsg(20171221195421,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
- [GetBaseDescription(InResolved)],Loop.StartExpr);
- LoTypeEl:=InResolved.LoTypeEl;
- if LoTypeEl=nil then exit;
- // check function InVar.GetEnumerator
- DotScope:=PushDotScope(InResolved.HiTypeEl);
- if DotScope=nil then
- exit;
- // find aRecord.GetEnumerator
- Getter:=DotScope.FindIdentifier('GetEnumerator');
- PopScope;
- if Getter=nil then
- begin
- if LoTypeEl is TPasMembersType then
- RaiseIdentifierNotFound(20171221191511,'GetEnumerator',Loop.StartExpr)
- else
- exit;
- end;
- // check is function
- if Getter.Element.ClassType<>TPasFunction then
- RaiseContextXExpectedButYFound(20171221191638,'GetEnumerator','function',GetElementTypeName(Getter.Element),Loop.StartExpr);
- GetterFunc:=TPasFunction(Getter.Element);
- // check visibility
- if not (GetterFunc.Visibility in [visPublic,visPublished]) then
- RaiseContextXExpectedButYFound(20171221191824,'function GetEnumerator','public',VisibilityNames[GetterFunc.Visibility],Loop.StartExpr);
- // check arguments
- if GetterFunc.FuncType.Args.Count>0 then
- RaiseContextXExpectedButYFound(20171221191944,'function GetEnumerator','no arguments',IntToStr(GetterFunc.ProcType.Args.Count),Loop.StartExpr);
- // check proc type modifiers
- for ptm in GetterFunc.ProcType.Modifiers do
- if not (ptm in [ptmOfObject]) then
- RaiseContextXInvalidY(20171221193455,'function GetEnumerator','modifier '+ProcTypeModifiers[ptm],Loop.StartExpr);
- // check result type
- ComputeResultElement(GetterFunc.FuncType.ResultEl,ResultResolved,[rcCall]);
- if (ResultResolved.BaseType<>btContext) then
- RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved),Loop.StartExpr);
- LoTypeEl:=ResultResolved.LoTypeEl;
- if not (LoTypeEl is TPasClassType) then
- RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved.LoTypeEl),Loop.StartExpr);
- if not (rrfReadable in ResultResolved.Flags) then
- RaiseContextXExpectedButYFound(20171221195506,'function GetEnumerator','result class instance',GetTypeDescription(ResultResolved.LoTypeEl),Loop.StartExpr);
- // find function MoveNext: boolean in Enumerator class
- EnumeratorClass:=TPasClassType(LoTypeEl);
- EnumeratorScope:=PushClassDotScope(EnumeratorClass);
- MoveNext:=EnumeratorScope.FindIdentifier('MoveNext');
- if MoveNext=nil then
- RaiseIdentifierNotFound(20171221195632,'MoveNext',Loop.StartExpr);
- // check is function
- if MoveNext.Element.ClassType<>TPasFunction then
- RaiseContextXExpectedButYFound(20171221195651,'MoveNext','function',GetElementTypeName(MoveNext.Element),Loop.StartExpr);
- MoveNextFunc:=TPasFunction(MoveNext.Element);
- // check visibility
- if not (MoveNextFunc.Visibility in [visPublic,visPublished]) then
- RaiseContextXExpectedButYFound(20171221195712,'function MoveNext','public',VisibilityNames[MoveNextFunc.Visibility],Loop.StartExpr);
- // check arguments
- if MoveNextFunc.FuncType.Args.Count>0 then
- RaiseContextXExpectedButYFound(20171221195723,'function MoveNext','no arguments',IntToStr(MoveNextFunc.ProcType.Args.Count),Loop.StartExpr);
- // check proc type modifiers
- for ptm in MoveNextFunc.ProcType.Modifiers do
- if not (ptm in [ptmOfObject]) then
- RaiseContextXInvalidY(20171221195732,'function MoveNext','modifier '+ProcTypeModifiers[ptm],Loop.StartExpr);
- // check result type
- ComputeResultElement(MoveNextFunc.FuncType.ResultEl,MoveNextResolved,[rcCall]);
- if not (MoveNextResolved.BaseType in btAllBooleans) then
- RaiseContextXExpectedButYFound(20171221200337,'function MoveNext','result boolean',GetTypeDescription(MoveNextResolved),Loop.StartExpr);
- // check property Current
- Current:=EnumeratorScope.FindIdentifier('Current');
- if Current=nil then
- RaiseIdentifierNotFound(20171221200433,'Current',Loop.StartExpr);
- // check is property
- if Current.Element.ClassType<>TPasProperty then
- RaiseContextXExpectedButYFound(20171221200508,'Current','property',GetElementTypeName(Current.Element),Loop.StartExpr);
- CurrentProp:=TPasProperty(Current.Element);
- // check visibility
- if not (CurrentProp.Visibility in [visPublic,visPublished]) then
- RaiseContextXExpectedButYFound(20171221200546,'property Current','public',VisibilityNames[CurrentProp.Visibility],Loop.StartExpr);
- // check arguments
- if CurrentProp.Args.Count>0 then
- RaiseContextXExpectedButYFound(20171221200638,'property Current','no arguments',IntToStr(CurrentProp.Args.Count),Loop.StartExpr);
- // check readable
- if GetPasPropertyGetter(CurrentProp)=nil then
- RaiseContextXInvalidY(20171221200823,'property Current','read accessor',Loop.StartExpr);
- // check result type fits for-loop variable
- ComputeElement(CurrentProp,CurrentResolved,[rcType]);
- if CheckAssignResCompatibility(VarResolved,CurrentResolved,Loop.VariableName,false)=cIncompatible then
- RaiseIncompatibleTypeRes(20171221200018,nIncompatibleTypesGotExpected,[],VarResolved,CurrentResolved,Loop.VariableName);
- PopScope; // pop EnumeratorScope
- ForScope:=Loop.CustomData as TPasForLoopScope;
- ForScope.GetEnumerator:=GetterFunc;
- ForScope.MoveNext:=MoveNextFunc;
- ForScope.Current:=CurrentProp;
- Result:=true;
- end;
- function TPasResolver.CheckBuiltInMinParamCount(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; MinCount: integer; RaiseOnError: boolean): boolean;
- begin
- if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)<MinCount) then
- begin
- if RaiseOnError then
- RaiseMsg(20170216152248,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[Proc.Signature],Expr);
- exit(false);
- end;
- Result:=true;
- end;
- function TPasResolver.CheckBuiltInMaxParamCount(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; MaxCount: integer; RaiseOnError: boolean;
- Signature: string): integer;
- begin
- if length(Params.Params)>MaxCount then
- begin
- if RaiseOnError then
- begin
- if Signature='' then Signature:=Proc.Signature;
- RaiseMsg(20170329154348,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[Signature],Params.Params[MaxCount]);
- end;
- exit(cIncompatible);
- end;
- Result:=cExact;
- end;
- function TPasResolver.CheckRaiseTypeArgNo(id: TMaxPrecInt; ArgNo: integer;
- Param: TPasExpr; const ParamResolved: TPasResolverResult; Expected: string;
- RaiseOnError: boolean): integer;
- begin
- if RaiseOnError then
- RaiseMsg(id,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),GetResolverResultDescription(ParamResolved,true),Expected],Param);
- Result:=cIncompatible;
- end;
- function TPasResolver.FindUsedUnitnameInSection(const aName: string; Section: TPasSection): TPasModule;
- var
- Clause: TPasUsesClause;
- i: Integer;
- Use: TPasUsesUnit;
- ModName: String;
- begin
- Result:=nil;
- if (Section=nil) then exit;
- Clause:=Section.UsesClause;
- for i:=0 to length(Clause)-1 do
- begin
- Use:=Clause[i];
- if (Use.Module=nil) or not (Use.Module is TPasModule) then continue;
- ModName:=Use.Module.Name;
- if CompareText(ModName,aName)=0 then
- exit(TPasModule(Use.Module));
- end;
- end;
- function TPasResolver.FindUsedUnitname(const aName: string; aMod: TPasModule): TPasModule;
- var
- C: TClass;
- begin
- C:=aMod.ClassType;
- if C.InheritsFrom(TPasProgram) then
- Result:=FindUsedUnitnameInSection(aName,TPasProgram(aMod).ProgramSection)
- else if C.InheritsFrom(TPasLibrary) then
- Result:=FindUsedUnitnameInSection(aName,TPasLibrary(aMod).LibrarySection)
- else
- begin
- Result:=FindUsedUnitnameInSection(aName,aMod.InterfaceSection);
- if Result<>nil then exit;
- Result:=FindUsedUnitnameInSection(aName,aMod.ImplementationSection);
- end
- end;
- procedure TPasResolver.FinishAssertCall(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr);
- var
- aMod: TPasModule;
- ModScope: TPasModuleScope;
- aConstructor: TPasConstructor;
- begin
- if Proc=nil then ;
- aMod:=RootElement;
- ModScope:=aMod.CustomData as TPasModuleScope;
- if not (pmsfAssertSearched in ModScope.Flags) then
- FindAssertExceptionConstructors(nil); // no ErrorEl
- if ModScope.AssertClass=nil then exit;
- if length(Params.Params)>1 then
- aConstructor:=ModScope.AssertMsgConstructor
- else
- aConstructor:=ModScope.AssertDefConstructor;
- if aConstructor=nil then exit;
- CreateReference(aConstructor,Params,rraRead);
- end;
- function TPasResolver.FindSystemIdentifier(const aUnitName, aName: string;
- ErrorEl: TPasElement): TPasElement;
- var
- aMod, UtilsMod: TPasModule;
- SectionScope: TPasSectionScope;
- Identifier: TPasIdentifier;
- begin
- Result:=nil;
- // find unit in uses clauses
- aMod:=RootElement;
- UtilsMod:=FindUsedUnitname(aUnitName,aMod);
- if UtilsMod=nil then
- if ErrorEl<>nil then
- RaiseIdentifierNotFound(20200523224738,'unit '+aUnitName,ErrorEl)
- else
- exit;
- // find class in interface
- if UtilsMod.InterfaceSection=nil then
- if ErrorEl<>nil then
- RaiseIdentifierNotFound(20200523224831,aUnitName+'.'+aName,ErrorEl)
- else
- exit;
- SectionScope:=NoNil(UtilsMod.InterfaceSection.CustomData) as TPasSectionScope;
- Identifier:=SectionScope.FindLocalIdentifier(aName);
- if Identifier=nil then
- if ErrorEl<>nil then
- RaiseIdentifierNotFound(20200523224841,aUnitName+'.'+aName,ErrorEl)
- else
- exit;
- Result:=Identifier.Element;
- end;
- function TPasResolver.FindSystemClassType(const aUnitName, aClassName: string;
- ErrorEl: TPasElement): TPasClassType;
- var
- El: TPasElement;
- begin
- Result:=nil;
- El:=FindSystemIdentifier(aUnitName,aClassName,ErrorEl);
- if not (El is TPasClassType) then
- if ErrorEl<>nil then
- RaiseXExpectedButYFound(20180119172517,'class '+aClassName,GetElementTypeName(El),ErrorEl)
- else
- exit;
- Result:=TPasClassType(El);
- if Result.IsForward then
- if ErrorEl<>nil then
- RaiseXExpectedButYFound(20200523225546,'class '+aClassName,'forward '+GetTypeDescription(Result,true),ErrorEl)
- else
- exit;
- if Result.ObjKind<>okClass then
- if ErrorEl<>nil then
- RaiseXExpectedButYFound(20180321163200,'class '+aClassName,GetTypeDescription(Result,true),ErrorEl)
- else
- exit;
- end;
- function TPasResolver.FindSystemClassTypeAndConstructor(const aUnitName,
- aClassName: string; out aClass: TPasClassType; out
- aConstructor: TPasConstructor; ErrorEl: TPasElement): boolean;
- var
- Identifier: TPasIdentifier;
- ClassScope: TPasClassScope;
- begin
- Result:=false;
- aClass:=nil;
- aConstructor:=nil;
- aClass:=FindSystemClassType(aUnitName,aClassName,ErrorEl);
- if aClass=nil then exit;
- ClassScope:=NoNil(aClass.CustomData) as TPasClassScope;
- repeat
- Identifier:=ClassScope.FindIdentifier('create');
- while Identifier<>nil do
- begin
- if Identifier.Element.ClassType=TPasConstructor then
- begin
- aConstructor:=TPasConstructor(Identifier.Element);
- if aConstructor.ProcType.Args.Count=0 then
- exit(true);
- end;
- Identifier:=Identifier.NextSameIdentifier;
- end;
- ClassScope:=ClassScope.AncestorScope;
- until ClassScope=nil;
- aConstructor:=nil;
- if ErrorEl<>nil then
- RaiseIdentifierNotFound(20200523224856,'constructor '+aClassName,ErrorEl);
- end;
- procedure TPasResolver.FindAssertExceptionConstructors(ErrorEl: TPasElement);
- var
- aMod: TPasModule;
- ModScope: TPasModuleScope;
- Identifier: TPasIdentifier;
- aClass: TPasClassType;
- ClassScope: TPasClassScope;
- aConstructor: TPasConstructor;
- Arg: TPasArgument;
- ArgResolved: TPasResolverResult;
- begin
- aMod:=RootElement;
- ModScope:=aMod.CustomData as TPasModuleScope;
- if pmsfAssertSearched in ModScope.Flags then exit;
- Include(ModScope.Flags,pmsfAssertSearched);
- FindSystemClassTypeAndConstructor('sysutils','EAssertionFailed',aClass,aConstructor,ErrorEl);
- if aClass=nil then
- exit;
- ClassScope:=NoNil(aClass.CustomData) as TPasClassScope;
- ModScope.AssertClass:=aClass;
- repeat
- Identifier:=ClassScope.FindIdentifier('create');
- while Identifier<>nil do
- begin
- if Identifier.Element.ClassType=TPasConstructor then
- begin
- aConstructor:=TPasConstructor(Identifier.Element);
- //writeln('TPasResolver.FindAssertExceptionConstructors ',aConstructor.Name,' ',aConstructor.ProcType.Args.Count);
- if aConstructor.ProcType.Args.Count=0 then
- begin
- if ModScope.AssertDefConstructor=nil then
- ModScope.AssertDefConstructor:=aConstructor;
- end
- else if aConstructor.ProcType.Args.Count=1 then
- begin
- if ModScope.AssertMsgConstructor=nil then
- begin
- Arg:=TPasArgument(aConstructor.ProcType.Args[0]);
- //writeln('TPasResolver.FindAssertExceptionConstructors ',GetObjName(Arg.ArgType),' ',GetObjName(BaseTypes[BaseTypeString]));
- ComputeElement(Arg.ArgType,ArgResolved,[rcType]);
- if ArgResolved.BaseType in btAllStrings then
- ModScope.AssertMsgConstructor:=aConstructor;
- end;
- end;
- end;
- Identifier:=Identifier.NextSameIdentifier;
- end;
- ClassScope:=ClassScope.AncestorScope;
- until ClassScope=nil;
- end;
- procedure TPasResolver.FindRangeErrorConstructors(ErrorEl: TPasElement);
- var
- aMod: TPasModule;
- ModScope: TPasModuleScope;
- aClass: TPasClassType;
- aConstructor: TPasConstructor;
- begin
- aMod:=RootElement;
- ModScope:=aMod.CustomData as TPasModuleScope;
- if pmsfRangeErrorSearched in ModScope.Flags then exit;
- Include(ModScope.Flags,pmsfRangeErrorSearched);
- FindSystemClassTypeAndConstructor('sysutils','ERangeError',aClass,aConstructor,ErrorEl);
- ModScope.RangeErrorClass:=aClass;
- ModScope.RangeErrorConstructor:=aConstructor;
- end;
- function TPasResolver.FindTVarRec(ErrorEl: TPasElement): TPasRecordType;
- var
- aMod, UtilsMod: TPasModule;
- SectionScope: TPasSectionScope;
- Identifier: TPasIdentifier;
- El: TPasElement;
- ModScope: TPasModuleScope;
- begin
- aMod:=RootElement;
- ModScope:=aMod.CustomData as TPasModuleScope;
- Result:=ModScope.SystemTVarRec;
- if Result<>nil then exit;
- // find unit in uses clauses
- UtilsMod:=FindUsedUnitname('system',aMod);
- if UtilsMod=nil then
- RaiseIdentifierNotFound(20190215101210,'System.TVarRec',ErrorEl);
- // find class in interface
- if UtilsMod.InterfaceSection=nil then
- RaiseIdentifierNotFound(20190215101231,'System.TVarRec',ErrorEl);
- SectionScope:=NoNil(UtilsMod.InterfaceSection.CustomData) as TPasSectionScope;
- Identifier:=SectionScope.FindLocalIdentifier('TVarRec');
- if Identifier=nil then
- RaiseIdentifierNotFound(20190215101253,'System.TVarRec',ErrorEl);
- El:=Identifier.Element;
- if not (El is TPasRecordType) then
- RaiseXExpectedButYFound(20190215101310,'record TVarRec',GetElementTypeName(El),ErrorEl);
- Result:=TPasRecordType(El);
- ModScope.SystemTVarRec:=Result;
- end;
- function TPasResolver.GetTVarRec(El: TPasArrayType): TPasRecordType;
- var
- aModule: TPasModule;
- ModScope: TPasModuleScope;
- begin
- aModule:=El.GetModule;
- ModScope:=aModule.CustomData as TPasModuleScope;
- Result:=ModScope.SystemTVarRec;
- if Result=nil then
- RaiseNotYetImplemented(20190215111924,El,'missing System.TVarRec');
- end;
- function TPasResolver.FindDefaultConstructor(aClass: TPasClassType
- ): TPasConstructor;
- var
- ClassScope: TPasClassScope;
- Identifier: TPasIdentifier;
- El: TPasElement;
- HasOverload: Boolean;
- Proc: TPasProcedure;
- begin
- Result:=nil;
- if (aClass=nil) or aClass.IsExternal or (aClass.ObjKind<>okClass) then exit;
- ClassScope:=aClass.CustomData as TPasClassScope;
- repeat
- Identifier:=ClassScope.FindLocalIdentifier('create');
- if Identifier<>nil then
- begin
- HasOverload:=false;
- while Identifier<>nil do
- begin
- El:=Identifier.Element;
- if not (El is TPasProcedure) then exit;
- Proc:=TPasProcedure(El);
- if Proc.ClassType=TPasConstructor then
- begin
- if Proc.ProcType.Args.Count=0 then
- exit(TPasConstructor(El));
- end;
- if Proc.IsOverload then
- HasOverload:=true;
- Identifier:=Identifier.NextSameIdentifier;
- end;
- if not HasOverload then exit;
- end;
- ClassScope:=ClassScope.AncestorScope;
- until false;
- end;
- function TPasResolver.GetTypeInfoParamType(Param: TPasExpr; out
- ParamResolved: TPasResolverResult; LoType: boolean): TPasType;
- var
- Decl: TPasElement;
- begin
- Result:=nil;
- // check type or var
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- Decl:=ParamResolved.IdentEl;
- if Decl=nil then exit;
- if Decl is TPasType then
- Result:=TPasType(Decl)
- else if Decl is TPasVariable then
- Result:=TPasVariable(Decl).VarType
- else if Decl.ClassType=TPasArgument then
- Result:=TPasArgument(Decl).ArgType
- else if Decl.ClassType=TPasResultElement then
- Result:=TPasResultElement(Decl).ResultType
- else if (Decl is TPasProcedure)
- and (TPasProcedure(Decl).ProcType is TPasFunctionType) then
- Result:=TPasFunctionType(TPasProcedure(Decl).ProcType).ResultEl.ResultType;
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if Result=nil then
- writeln('TPasResolver.GetTypeInfoParamType Decl=',GetObjName(Decl),' ParamResolved=',GetResolverResultDbg(ParamResolved));
- {AllowWriteln-}
- {$ENDIF}
- if LoType then
- Result:=ResolveAliasType(Result);
- end;
- procedure TPasResolver.OnExprEvalLog(Sender: TResExprEvaluator;
- const id: TMaxPrecInt; MsgType: TMessageType; MsgNumber: integer;
- const Fmt: String; Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- PosEl: TPasElement);
- begin
- if MsgType<=mtError then
- RaiseMsg(id,MsgNumber,Fmt,Args,PosEl)
- else
- LogMsg(id,MsgType,MsgNumber,Fmt,Args,PosEl);
- if Sender=nil then ;
- end;
- function TPasResolver.OnExprEvalIdentifier(Sender: TResExprEvaluator;
- Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue;
- var
- Ref: TResolvedReference;
- Decl: TPasElement;
- C: TClass;
- ResolvedType: TPasResolverResult;
- EnumValue: TPasEnumValue;
- EnumType: TPasEnumType;
- EvalFlags: TResEvalFlags;
- begin
- Result:=nil;
- if not (Expr.CustomData is TResolvedReference) then
- RaiseNotYetImplemented(20170518203134,Expr,GetObjName(Expr.CustomData));
- Ref:=TResolvedReference(Expr.CustomData);
- Decl:=Ref.Declaration;
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalIdentifier Value=',Expr.Value,' Decl=',GetObjName(Decl));
- {$ENDIF}
- C:=Decl.ClassType;
- if C=TPasConst then
- begin
- if (TPasConst(Decl).Expr<>nil)
- and (TPasConst(Decl).IsConst or (TPasConst(Decl).VarType=nil)) then
- begin
- if TPasConst(Decl).VarType<>nil then
- begin
- // typed const
- ComputeElement(TPasConst(Decl).VarType,ResolvedType,[rcType]);
- end
- else
- ResolvedType.BaseType:=btNone;
- EvalFlags:=Flags;
- if not (refConstExt in EvalFlags) then
- Include(EvalFlags,refConst);
- Result:=fExprEvaluator.Eval(TPasConst(Decl).Expr,EvalFlags);
- if Result<>nil then
- begin
- if (Result.Element<>nil) and (Result.Element<>TPasConst(Decl).Expr) then
- Result:=Result.Clone;
- Result.IdentEl:=Decl;
- if TPasConst(Decl).VarType<>nil then
- begin
- // typed const
- if Result.Kind=revkInt then
- case ResolvedType.BaseType of
- btByte: TResEvalInt(Result).Typed:=reitByte;
- btShortInt: TResEvalInt(Result).Typed:=reitShortInt;
- btWord: TResEvalInt(Result).Typed:=reitWord;
- btSmallInt: TResEvalInt(Result).Typed:=reitSmallInt;
- btUIntSingle: TResEvalInt(Result).Typed:=reitUIntSingle;
- btIntSingle: TResEvalInt(Result).Typed:=reitIntSingle;
- btLongWord: TResEvalInt(Result).Typed:=reitLongWord;
- btLongint: TResEvalInt(Result).Typed:=reitLongInt;
- btUIntDouble: TResEvalInt(Result).Typed:=reitUIntDouble;
- {$ifdef HasInt64}
- btIntDouble: TResEvalInt(Result).Typed:=reitIntDouble;
- btInt64: TResEvalInt(Result).Typed:=reitNone; // default
- {$else}
- btIntDouble: TResEvalInt(Result).Typed:=reitNone; // default
- {$endif}
- else
- ReleaseEvalValue(Result);
- RaiseNotYetImplemented(20170624181050,TPasConst(Decl).VarType);
- end;
- end;
- exit;
- end;
- end
- else if vmExternal in TPasConst(Decl).VarModifiers then
- begin
- Result:=TResEvalExternal.Create;
- Result.IdentEl:=Decl;
- exit;
- end;
- if refConst in Flags then
- begin
- ReleaseEvalValue(Result);
- RaiseConstantExprExp(20170518214928,Expr);
- end;
- end
- else if C=TPasEnumValue then
- begin
- EnumValue:=TPasEnumValue(Decl);
- EnumType:=EnumValue.Parent as TPasEnumType;
- Result:=TResEvalEnum.CreateValue(EnumType.Values.IndexOf(EnumValue),EnumValue);
- exit;
- end
- else if C.InheritsFrom(TPasType) then
- Result:=EvalTypeRange(TPasType(Decl),Flags);
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalIdentifier END Result=',dbgs(Result),' refConst=',refConst in Flags,' refConstExt=',refConstExt in Flags);
- {$ENDIF}
- if (Result=nil) and ([refConst,refConstExt]*Flags<>[]) then
- RaiseConstantExprExp(20170518213616,Expr);
- if Sender=nil then ;
- end;
- function TPasResolver.OnExprEvalParams(Sender: TResExprEvaluator;
- Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
- var
- Ref: TResolvedReference;
- Decl: TPasElement;
- C: TClass;
- BuiltInProc: TResElDataBuiltInProc;
- bt: TResolverBaseType;
- ResolvedEl: TPasResolverResult;
- TypeEl: TPasType;
- begin
- Result:=nil;
- case Params.Kind of
- pekArrayParams: ;
- pekFuncParams:
- if Params.Value.CustomData is TResolvedReference then
- begin
- Ref:=TResolvedReference(Params.Value.CustomData);
- Decl:=Ref.Declaration;
- if Decl is TPasType then
- Decl:=ResolveAliasType(TPasType(Decl));
- C:=Decl.ClassType;
- if C=TPasUnresolvedSymbolRef then
- begin
- if Decl.CustomData is TResElDataBuiltInProc then
- begin
- BuiltInProc:=TResElDataBuiltInProc(Decl.CustomData);
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams Calling BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
- {$ENDIF}
- if BuiltInProc.Eval<>nil then
- BuiltInProc.Eval(BuiltInProc,Params,Flags,Result)
- else
- case BuiltInProc.BuiltIn of
- bfAssigned: Result:=nil;
- bfConcatArray: Result:=nil;
- bfCopyArray: Result:=nil;
- bfTypeInfo: Result:=nil;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams Unhandled BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
- {$ENDIF}
- RaiseNotYetImplemented(20170624192324,Params);
- end;
- {$IFDEF VerbosePasResEval}
- {AllowWriteln}
- if Result<>nil then
- writeln('TPasResolver.OnExprEvalParams Called BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn],' Result=',Result.AsString)
- else
- writeln('TPasResolver.OnExprEvalParams Called BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn],' Result=nil');
- {AllowWriteln-}
- {$ENDIF}
- exit;
- end
- else if Decl.CustomData is TResElDataBaseType then
- begin
- // typecast to basetype
- bt:=TResElDataBaseType(Decl.CustomData).BaseType;
- Result:=EvalBaseTypeCast(Params,bt);
- end;
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams BuiltInProc ',Decl.Name,' ',GetObjName(Decl.CustomData));
- {$ENDIF}
- end
- else if C=TPasEnumType then
- begin
- // typecast to enumtype
- Result:=fExprEvaluator.EnumTypeCast(TPasEnumType(Decl),Params.Params[0],Flags);
- end
- else if C=TPasRangeType then
- begin
- // typecast to custom range
- ComputeElement(TPasRangeType(Decl).RangeExpr.left,ResolvedEl,[rcConstant]);
- if ResolvedEl.BaseType=btContext then
- begin
- TypeEl:=ResolvedEl.LoTypeEl;
- if TypeEl.ClassType=TPasEnumType then
- begin
- // typecast to enumtype
- Result:=fExprEvaluator.EnumTypeCast(TPasEnumType(TypeEl),Params.Params[0],Flags);
- end
- else
- RaiseNotYetImplemented(20171009223403,Params);
- end
- else
- RaiseNotYetImplemented(20171009223303,Params);
- end;
- end;
- pekSet: ;
- end;
- if Flags=[] then ;
- if Sender=nil then ;
- end;
- procedure TPasResolver.OnRangeCheckEl(Sender: TResExprEvaluator;
- El: TPasElement; var MsgType: TMessageType);
- begin
- if El=nil then exit;
- if (MsgType=mtWarning)
- and (bsRangeChecks in CurrentParser.Scanner.CurrentBoolSwitches) then
- MsgType:=mtError;
- if Sender=nil then ;
- end;
- function TPasResolver.EvalBaseTypeCast(Params: TParamsExpr;
- bt: TResolverBaseType): TResEvalvalue;
- procedure TCFloatToInt(Value: TResEvalValue; Flo: TMaxPrecFloat);
- var
- Int, MinIntVal, MaxIntVal: TMaxPrecInt;
- begin
- if bt in btAllIntegerNoQWord then
- begin
- // float to int
- GetIntegerRange(bt,MinIntVal,MaxIntVal);
- if (Flo<MinIntVal) or (Flo>MaxIntVal) then
- fExprEvaluator.EmitRangeCheckConst(20170711001228,
- Value.AsString,MinIntVal,MaxIntVal,Params,mtError);
- {$R-}
- try
- Int:=Round(Flo);
- except
- RaiseMsg(20170711002218,nRangeCheckError,sRangeCheckError,[],Params);
- end;
- case bt of
- btByte: Result:=TResEvalInt.CreateValue(Int,reitByte);
- btShortInt: Result:=TResEvalInt.CreateValue(Int,reitShortInt);
- btWord: Result:=TResEvalInt.CreateValue(Int,reitWord);
- btSmallInt: Result:=TResEvalInt.CreateValue(Int,reitSmallInt);
- btUIntSingle: Result:=TResEvalInt.CreateValue(Int,reitUIntSingle);
- btIntSingle: Result:=TResEvalInt.CreateValue(Int,reitIntSingle);
- btLongWord: Result:=TResEvalInt.CreateValue(Int,reitLongWord);
- btLongint: Result:=TResEvalInt.CreateValue(Int,reitLongInt);
- btUIntDouble: Result:=TResEvalInt.CreateValue(Int,reitUIntDouble);
- {$ifdef HasInt64}
- btIntDouble: Result:=TResEvalInt.CreateValue(Int,reitIntDouble);
- btInt64: Result:=TResEvalInt.CreateValue(Int); // default
- {$else}
- btIntDouble: Result:=TResEvalInt.CreateValue(Int); // default
- {$endif}
- else
- RaiseNotYetImplemented(20170711001513,Params);
- end;
- {$IFDEF RangeCheckOn}{$R+}{$ENDIF}
- exit;
- end
- else if bt=btSingle then
- begin
- // float to single
- try
- Result:=TResEvalFloat.CreateValue({$ifdef pas2js}double{$else}single{$endif}(Flo));
- except
- RaiseMsg(20170711002315,nRangeCheckError,sRangeCheckError,[],Params);
- end;
- end
- else if bt=btDouble then
- begin
- // float to double
- try
- Result:=TResEvalFloat.CreateValue(double(Flo));
- except
- RaiseMsg(20170711002327,nRangeCheckError,sRangeCheckError,[],Params);
- end;
- end
- else if bt=btCurrency then
- begin
- // float to currency
- try
- Result:=TResEvalCurrency.CreateValue(Currency(Flo));
- except
- RaiseMsg(20180421171840,nRangeCheckError,sRangeCheckError,[],Params);
- end;
- end
- else
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams typecast float to ',bt);
- {$ENDIF}
- RaiseNotYetImplemented(20170711002542,Params);
- end;
- end;
- var
- Value: TResEvalValue;
- Int, MinIntVal, MaxIntVal: TMaxPrecInt;
- Flo: TMaxPrecFloat;
- w: WideChar;
- begin
- Result:=nil;
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.EvalBaseTypeCast bt=',bt);
- {$ENDIF}
- Value:=Eval(Params.Params[0],[refAutoConstExt]);
- if Value=nil then exit;
- try
- case Value.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(Value).Int;
- {$ifdef HasInt64}
- if bt=btQWord then
- begin
- // int to qword
- {$R-}
- Result:=TResEvalUInt.CreateValue(TMaxPrecUInt(Int));
- {$IFDEF RangeCheckOn}{$R+}{$ENDIF}
- end
- else
- {$endif}
- if bt in btAllIntegerNoQWord then
- begin
- // int to int
- GetIntegerRange(bt,MinIntVal,MaxIntVal);
- if (Int<MinIntVal) or (Int>MaxIntVal) then
- begin
- {$R-}
- case bt of
- btByte: Result:=TResEvalInt.CreateValue(byte(Int),reitByte);
- btShortInt: Result:=TResEvalInt.CreateValue(shortint(Int),reitShortInt);
- btWord: Result:=TResEvalInt.CreateValue(word(Int),reitWord);
- btSmallInt: Result:=TResEvalInt.CreateValue(smallint(Int),reitSmallInt);
- btLongWord: Result:=TResEvalInt.CreateValue(longword(Int),reitLongWord);
- btLongint: Result:=TResEvalInt.CreateValue(longint(Int),reitLongInt);
- {$ifdef HasInt64}
- btInt64: Result:=TResEvalInt.CreateValue(Int);
- {$endif}
- btUIntSingle,
- btIntSingle,
- btUIntDouble,
- btIntDouble:
- fExprEvaluator.EmitRangeCheckConst(20170624194534,
- Value.AsString,MinIntVal,MaxIntVal,Params,mtError);
- else
- RaiseNotYetImplemented(20170624200109,Params);
- end;
- {$IFDEF RangeCheckOn}{$R+}{$ENDIF}
- end
- else
- begin
- {$R-}
- case bt of
- btByte: Result:=TResEvalInt.CreateValue(Int,reitByte);
- btShortInt: Result:=TResEvalInt.CreateValue(Int,reitShortInt);
- btWord: Result:=TResEvalInt.CreateValue(Int,reitWord);
- btSmallInt: Result:=TResEvalInt.CreateValue(Int,reitSmallInt);
- btUIntSingle: Result:=TResEvalInt.CreateValue(Int,reitUIntSingle);
- btIntSingle: Result:=TResEvalInt.CreateValue(Int,reitIntSingle);
- btLongWord: Result:=TResEvalInt.CreateValue(Int,reitLongWord);
- btLongint: Result:=TResEvalInt.CreateValue(Int,reitLongInt);
- btUIntDouble: Result:=TResEvalInt.CreateValue(Int,reitUIntDouble);
- {$ifdef HasInt64}
- btIntDouble: Result:=TResEvalInt.CreateValue(Int,reitIntDouble);
- btInt64: Result:=TResEvalInt.CreateValue(Int); // default
- {$else}
- btIntDouble: Result:=TResEvalInt.CreateValue(Int); // default
- {$endif}
- else
- RaiseNotYetImplemented(20170624200109,Params);
- end;
- {$IFDEF RangeCheckOn}{$R+}{$ENDIF}
- end;
- exit;
- end
- else if bt in btAllBooleans then
- case Int of
- 0: Result:=TResEvalBool.CreateValue(false);
- 1: Result:=TResEvalBool.CreateValue(true);
- else
- fExprEvaluator.EmitRangeCheckConst(20170710203254,
- Value.AsString,0,1,Params,mtError);
- end
- {$ifdef FPC_HAS_CPSTRING}
- else if (bt=btAnsiChar) or ((bt=btChar) and (BaseTypeChar=btAnsiChar)) then
- try
- Result:=TResEvalString.CreateValue(Char(Int));
- except
- RaiseMsg(20180125112510,nRangeCheckError,sRangeCheckError,[],Params);
- end
- {$endif}
- else if (bt=btWideChar) or ((bt=btChar) and (BaseTypeChar=btWideChar)) then
- try
- w:=WideChar(Int);
- Result:=TResEvalUTF16.CreateValue(w);
- except
- RaiseMsg(20180125112716,nRangeCheckError,sRangeCheckError,[],Params);
- end
- else if bt=btSingle then
- try
- Result:=TResEvalFloat.CreateValue({$ifdef pas2js}double{$else}single{$endif}(Int));
- except
- RaiseMsg(20170711002015,nRangeCheckError,sRangeCheckError,[],Params);
- end
- else if bt=btDouble then
- try
- Result:=TResEvalFloat.CreateValue(Double(Int));
- except
- RaiseMsg(20170711002016,nRangeCheckError,sRangeCheckError,[],Params);
- end
- else if bt=btCurrency then
- try
- Result:=TResEvalCurrency.CreateValue(Currency(Int));
- except
- RaiseMsg(20180422093631,nRangeCheckError,sRangeCheckError,[],Params);
- end
- else
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams typecast int to ',bt);
- {$ENDIF}
- RaiseNotYetImplemented(20170624194308,Params);
- end;
- end;
- revkFloat:
- begin
- Flo:=TResEvalFloat(Value).FloatValue;
- TCFloatToInt(Value,Flo);
- end;
- revkCurrency:
- begin
- if bt=btCurrency then
- begin
- Result:=Value;
- Value:=nil;
- end
- else
- begin
- Flo:=TResEvalCurrency(Value).Value;
- TCFloatToInt(Value,Flo);
- end;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- begin
- if (bt=btAnsiChar) or ((bt=btChar) and (BaseTypeChar=btWideChar)) then
- begin
- // ansichar(ansistring)
- if fExprEvaluator.StringToOrd(Value,nil)>$ffff then
- RaiseXExpectedButYFound(20181005141025,'char','string',Params);
- Result:=Value;
- Value:=nil;
- end
- else if (bt=btWideChar) or ((bt=btChar) and (BaseTypeChar=btWideChar)) then
- begin
- // widechar(ansistring)
- if fExprEvaluator.GetWideChar(TResEvalString(Value).S,w) then
- begin
- Result:=Value;
- Value:=nil;
- end
- else
- RaiseXExpectedButYFound(20181005141058,'char','string',Params);
- end
- else if (bt=btAnsiString) or ((bt=btString) and (BaseTypeString=btAnsiString)) then
- begin
- // ansistring(ansistring)
- Result:=Value;
- Value:=nil;
- end
- else if (bt=btUnicodeString) or (bt=btWideString)
- or ((bt=btString) and (BaseTypeString=btUnicodeString)) then
- begin
- // unicodestring(ansistring)
- Result:=TResEvalUTF16.CreateValue(
- fExprEvaluator.GetUnicodeStr(TResEvalString(Value).S,Params));
- end
- else if bt=btRawByteString then
- begin
- // rawbytestring(ansistring)
- SetCodePage(TResEvalString(Value).S,CP_NONE,false);
- end;
- end;
- {$endif}
- revkUnicodeString:
- if (length(TResEvalUTF16(Value).S)=1) and (bt in btAllChars) then
- begin
- w:=TResEvalUTF16(Value).S[1];
- {$ifdef FPC_HAS_CPSTRING}
- if (bt=btAnsiChar) or ((bt=btChar) and (BaseTypeChar=btAnsiChar)) then
- begin
- // ansichar(unicodestring)
- if ord(w)<=255 then
- begin
- Result:=Value;
- Value:=nil;
- end
- else
- RaiseMsg(20181005141632,nRangeCheckError,sRangeCheckError,[],Params);
- end
- else
- {$endif}
- if (bt=btWideChar) or ((bt=btChar) and (BaseTypeChar=btWideChar)) then
- begin
- // widechar(unicodestring)
- Result:=Value;
- Value:=nil;
- end;
- end
- {$ifdef FPC_HAS_CPSTRING}
- else if (bt=btAnsiString) or ((bt=btString) and (BaseTypeString=btAnsiString)) then
- begin
- // ansistring(unicodestring)
- Result:=TResEvalString.CreateValue(
- fExprEvaluator.GetRawByteString(TResEvalUTF16(Value).S,CP_ACP,Params));
- end
- else if bt=btRawByteString then
- begin
- // rawbytestring(unicodestring)
- Result:=TResEvalString.CreateValue(
- fExprEvaluator.GetRawByteString(TResEvalUTF16(Value).S,CP_NONE,Params));
- end
- {$endif}
- else if (bt=btUnicodeString) or ((bt=btString) and (BaseTypeString=btUnicodeString)) then
- begin
- // unicodestring(unicodestring)
- Result:=Value;
- Value:=nil;
- end;
- revkExternal:
- exit;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams typecast to ',bt);
- {$ENDIF}
- RaiseNotYetImplemented(20170624193436,Params);
- end;
- finally
- ReleaseEvalValue(Value);
- end;
- end;
- procedure TPasResolver.AddGenericTemplateIdentifiers(
- GenericTemplateTypes: TFPList; Scope: TPasIdentifierScope);
- var
- TemplType: TPasGenericTemplateType;
- i: Integer;
- begin
- if GenericTemplateTypes=nil then exit;
- for i:=0 to GenericTemplateTypes.Count-1 do
- begin
- TemplType:=TPasGenericTemplateType(GenericTemplateTypes[i]);
- Scope.AddIdentifier(TemplType.Name,TemplType,pikSimple);
- end;
- end;
- procedure TPasResolver.AddSpecializedTemplateIdentifiers(
- GenericTemplateTypes: TFPList; SpecializedItem: TPRSpecializedItem;
- Scope: TPasIdentifierScope; CheckConstraints: boolean);
- var
- i: Integer;
- TemplType: TPasGenericTemplateType;
- ParamTypes: TPasTypeArray;
- ParamType: TPasType;
- ErrorPos: TPasElement;
- begin
- ParamTypes:=SpecializedItem.Params;
- ErrorPos:=SpecializedItem.FirstSpecialize;
- for i:=0 to length(ParamTypes)-1 do
- begin
- TemplType:=TPasGenericTemplateType(GenericTemplateTypes[i]);
- ParamType:=ParamTypes[i];
- if CheckConstraints then
- begin
- if ParamType is TPasGenericTemplateType then
- CheckTemplateFitsTemplate(TPasGenericTemplateType(ParamType),
- TemplType,ErrorPos)
- else
- CheckTemplateFitsParam(ParamType,TemplType,SpecializedItem,
- prtcoAssignToTempl,ErrorPos);
- end;
- AddIdentifier(Scope,TemplType.Name,ParamTypes[i],pikSimple);
- end;
- end;
- function TPasResolver.CreateInferenceTypesForCall(Params: TParamsExpr;
- TargetProc: TPasProcedure): TFPList;
- type
- TInferredType = record
- InferType: TPasType;
- IsVarOut: boolean;
- end;
- TInferredTypes = array of TInferredType;
- procedure RaiseInferTypeMismatch(const Id: TMaxPrecInt; ArgType: TPasType;
- ErrorPos: TPasElement);
- begin
- RaiseMsg(Id,nInferredTypeXFromDiffArgsMismatchFromMethodY,
- sInferredTypeXFromDiffArgsMismatchFromMethodY,
- [ArgType.Name,TargetProc.Name],ErrorPos);
- end;
- procedure Infer(ArgParent: TPasElement; ArgType, ParamLoType, ParamHiType: TPasType;
- NeedVar, IsSubType, IsDelphi: boolean;
- InferenceParams: TInferredTypes; TemplTypes: TFPList;
- ErrorPos: TPasElement);
- var
- C: TClass;
- i: Integer;
- OldInferType, ParamElType: TPasType;
- ResolveAlias: TPRResolveAlias;
- Arr: TPasArrayType;
- Param1Resolved, Param2Resolved: TPasResolverResult;
- NewBaseType, BaseType1, BaseType2: TResolverBaseType;
- begin
- if (ArgType=nil) or (ParamLoType=nil) then exit;
- C:=ArgType.ClassType;
- if C=TPasGenericTemplateType then
- begin
- i:=TemplTypes.IndexOf(ArgType);
- if i>=0 then
- begin
- // a generic type param corresponds to ParamType
- OldInferType:=InferenceParams[i].InferType;
- if OldInferType=nil then
- begin
- // template type inferred first time
- InferenceParams[i].InferType:=ParamHiType;
- InferenceParams[i].IsVarOut:=NeedVar;
- ParamHiType.AddRef{$IFDEF CheckPasTreeRefCount}(RefIdInferenceParamsExpr){$ENDIF};
- exit;
- end;
- // already inferred -> check compatibility
- ResolveAlias:=prraAlias;
- if IsDelphi and (NeedVar or InferenceParams[i].IsVarOut) then
- // Delphi allows passing alias, but not type alias to a var arg
- ResolveAlias:=prraSimple;
- if IsSameType(OldInferType,ParamHiType,ResolveAlias) then
- exit; // same types -> ok
- if IsSubType then
- begin
- if CheckElTypeCompatibility(OldInferType,InferenceParams[i].InferType,
- ResolveAlias)<=cGenericExact then
- exit;
- // e.g. "array of TA" and "array of TB"
- RaiseInferTypeMismatch(20191006215539,ArgType,ErrorPos);
- end;
- // top level type does not fit exactly
- if NeedVar then
- begin
- // second is var/out
- if InferenceParams[i].IsVarOut then
- // two var/out arguments mismatch
- RaiseInferTypeMismatch(20191006220355,ArgType,ErrorPos);
- if CheckAssignCompatibility(ParamHiType,OldInferType,
- false,ErrorPos)=cIncompatible then
- // second is var/out, and do not match
- RaiseInferTypeMismatch(20191006220402,ArgType,ErrorPos);
- // first can be widened to fit
- InferenceParams[i].InferType.Release{$IFDEF CheckPasTreeRefCount}(RefIdInferenceParamsExpr){$ENDIF};
- InferenceParams[i].InferType:=ParamHiType;
- InferenceParams[i].IsVarOut:=NeedVar;
- ParamHiType.AddRef{$IFDEF CheckPasTreeRefCount}(RefIdInferenceParamsExpr){$ENDIF};
- exit;
- end
- else if InferenceParams[i].IsVarOut then
- begin
- // first was var/out
- if CheckAssignCompatibility(OldInferType,ParamHiType,
- false,ErrorPos)=cIncompatible then
- // first was var/out, and do not match
- RaiseInferTypeMismatch(20191006220750,ArgType,ErrorPos);
- // second can be widened to fit
- exit;
- end;
- // None is var/out -> find a type compatible to both
- // widen type to some common base types to avoid high number of specialization
- ComputeElement(ParamHiType,Param1Resolved,[],ErrorPos);
- ComputeElement(InferenceParams[i].InferType,Param2Resolved,[],ErrorPos);
- NewBaseType:=btNone;
- BaseType1:=Param1Resolved.BaseType;
- BaseType2:=Param2Resolved.BaseType;
- if BaseType1 in btAllBooleans then
- begin
- if BaseType2 in btAllBooleans then
- if BaseTypes[btBoolean]<>nil then
- NewBaseType:=btBoolean
- else
- NewBaseType:=GetCombinedBoolean(BaseType1,BaseType2,ErrorPos);
- end
- else if BaseType1 in btAllInteger then
- begin
- NewBaseType:=TResolverBaseType(Max(ord(BaseType1),ord(BaseType2)));
- if (BaseTypes[btLongint]<>nil)
- and (NewBaseType in [btByte,btShortInt,btWord,btSmallInt,btIntSingle,btUIntSingle,btLongint])
- and (BaseType1<>btLongWord) and (BaseType2<>btLongWord) then
- NewBaseType:=btLongint
- {$ifdef HasInt64}
- else if (BaseTypes[btInt64]<>nil)
- and (NewBaseType<=btInt64)
- and (BaseType1<>btQWord) and (BaseType2<>btQWord) then
- NewBaseType:=btInt64
- {$endif}
- else if (BaseTypes[btIntDouble]<>nil)
- and (NewBaseType<=btIntDouble) then
- NewBaseType:=btIntDouble
- {$ifdef HasInt64}
- else if (BaseTypes[btQWord]<>nil)
- and not (NewBaseType in btAllSignedInteger) then
- NewBaseType:=btQWord
- {$endif}
- else
- NewBaseType:=GetCombinedInt(Param1Resolved,Param2Resolved,ErrorPos);
- end
- else if Param1Resolved.BaseType in btAllStringAndChars then
- begin
- if Param2Resolved.BaseType in btAllStringAndChars then
- if BaseTypes[btUnicodeString]<>nil then
- NewBaseType:=btUnicodeString
- else
- NewBaseType:=GetCombinedString(Param1Resolved,Param2Resolved,ErrorPos);
- end
- else if Param1Resolved.BaseType in btAllFloats then
- begin
- if BaseTypes[btDouble]<>nil then
- NewBaseType:=btDouble;
- end;
- if NewBaseType<>btNone then
- begin
- InferenceParams[i].InferType.Release{$IFDEF CheckPasTreeRefCount}(RefIdInferenceParamsExpr){$ENDIF};
- InferenceParams[i].InferType:=BaseTypes[NewBaseType];
- InferenceParams[i].IsVarOut:=NeedVar;
- BaseTypes[NewBaseType].AddRef{$IFDEF CheckPasTreeRefCount}(RefIdInferenceParamsExpr){$ENDIF};
- exit;
- end;
- // ToDo
- RaiseInferTypeMismatch(20191006220406,ArgType,ErrorPos);
- end;
- end
- else if ArgParent<>ArgType.Parent then
- // ArgType is a reference
- else if C=TPasArrayType then
- begin
- // e.g. Proc(a: array...)
- Arr:=TPasArrayType(ArgType);
- if ParamLoType.ClassType<>TPasArrayType then
- exit;
- ParamElType:=TPasArrayType(ParamLoType).ElType;
- Infer(Arr,Arr.ElType,ParamElType,ResolveAliasType(ParamElType),
- NeedVar,true,IsDelphi,InferenceParams,TemplTypes,ErrorPos);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('Infer ArgType=',GetObjName(ArgType),' ParamLoType=',GetObjName(ParamLoType));
- {$ENDIF}
- end;
- end;
- procedure InferParam(i: integer; NeedVar: boolean; ParamsExprs: TPasExprArray;
- ProcArgs: TFPList;
- InferenceParams: TInferredTypes; TemplTypes: TFPList; IsDelphi: boolean);
- var
- Arg: TPasArgument;
- ArgType: TPasType;
- ArgResolved, ExprResolved: TPasResolverResult;
- Expr: TPasExpr;
- begin
- //writeln('InferParam i=',i,' NeedVar=',NeedVar,' IsDelphi=',IsDelphi,' ProcArgs.Count=',ProcArgs.Count);
- Arg:=TPasArgument(ProcArgs[i]);
- ArgType:=Arg.ArgType;
- if ArgType=nil then
- exit; // untyped arg
- if (ArgType.Parent<>Arg) and (ArgType.ClassType<>TPasGenericTemplateType) then
- exit; // a reference -> no need to search for a template reference
- if NeedVar<>(Arg.Access in [argVar, argOut]) then
- exit;
- if i<length(ParamsExprs) then
- Expr:=ParamsExprs[i]
- else
- begin
- Expr:=Arg.ValueExpr;
- if Expr=nil then exit;
- end;
- ComputeArgumentAndExpr(Arg,ArgResolved,Expr,ExprResolved,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CreateInferenceTypesForCall Arg=',GetTreeDbg(Arg,2),' ArgResolved=',GetResolverResultDbg(ArgResolved));
- {$ENDIF}
- if ExprResolved.BaseType in btAllWithSubType then
- begin
- // passing a literal set or array or custom range
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CreateInferenceTypesForCall.InferParam ToDo: ',GetResolverResultDbg(ExprResolved));
- {$ENDIF}
- end
- else if (ExprResolved.SubType<>btNone) then
- RaiseNotYetImplemented(20191006203622,Expr)
- else
- Infer(Arg,ArgType,ExprResolved.LoTypeEl,ExprResolved.HiTypeEl,
- NeedVar,false,IsDelphi,
- InferenceParams,TemplTypes,Expr);
- end;
- var
- TemplTypes, ProcArgs: TFPList;
- InferenceTypes: TInferredTypes;
- ParamsExprs: TPasExprArray;
- IsDelphi: Boolean;
- i: Integer;
- begin
- Result:=nil;
- TemplTypes:=GetProcTemplateTypes(TargetProc);
- if (TemplTypes=nil) or (TemplTypes.Count=0) then
- RaiseNotYetImplemented(20191006174321,Params);
- ProcArgs:=TargetProc.ProcType.Args;
- ParamsExprs:=Params.Params;
- if ProcArgs.Count<length(ParamsExprs) then
- RaiseNotYetImplemented(20191006183021,Params);
- IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
- try
- SetLength(InferenceTypes{%H-},TemplTypes.Count);
- for i:=0 to TemplTypes.Count-1 do
- InferenceTypes[i]:=Default(TInferredType);
- // first infer from var/out args exact types
- for i:=0 to ProcArgs.Count-1 do
- InferParam(i,true,ParamsExprs,ProcArgs,InferenceTypes,TemplTypes,IsDelphi);
- // then infer from the other args
- for i:=0 to ProcArgs.Count-1 do
- InferParam(i,false,ParamsExprs,ProcArgs,InferenceTypes,TemplTypes,IsDelphi);
- // check that all types are inferred
- for i:=0 to TemplTypes.Count-1 do
- if InferenceTypes[i].InferType=nil then
- RaiseMsg(20191006175104,nCouldNotInferTypeArgXForMethodY,
- sCouldNotInferTypeArgXForMethodY,
- [TPasGenericTemplateType(TemplTypes[i]).Name,TargetProc.Name],Params);
- Result:=TFPList.Create;
- for i:=0 to length(InferenceTypes)-1 do
- begin
- Result.Add(InferenceTypes[i].InferType);
- InferenceTypes[i].InferType:=nil;
- end;
- finally
- if Result=nil then
- for i:=0 to length(InferenceTypes)-1 do
- if InferenceTypes[i].InferType<>nil then
- InferenceTypes[i].InferType.Release{$IFDEF CheckPasTreeRefCount}(RefIdInferenceParamsExpr){$ENDIF};
- end;
- end;
- function TPasResolver.CheckGenericConstraintFitsParam(ParamType: TPasType;
- SpecializedItem: TPRSpecializedItem; TemplType: TPasGenericTemplateType;
- ConEl: TPasElement; Operation: TPRTemplateCompOp; ErrorPos: TPasElement
- ): integer;
- function RaiseXExpButYFound(id: TMaxPrecInt; const X: string; Y: TPasType): integer;
- begin
- if ErrorPos<>nil then
- RaiseXExpectedButTypeYFound(id,X,Y,ErrorPos);
- Result:=cIncompatible;
- end;
- procedure RaiseNotValidConstraint(Id: TMaxPrecInt; ConEl: TPasElement);
- begin
- RaiseMsg(Id,nXIsNotAValidConstraint,sXIsNotAValidConstraint,
- [GetElementSourcePosStr(ConEl)],ErrorPos);
- end;
- function ElementReferencesTemplateTypes(El: TPasElement;
- GenericTemplateTypes: TFPList): boolean;
- var
- C: TClass;
- Prim: TPrimitiveExpr;
- Decl: TPasElement;
- Bin: TBinaryExpr;
- Spec: TPasSpecializeType;
- Arr: TPasArrayType;
- i: Integer;
- InlineSpec: TInlineSpecializeExpr;
- begin
- Result:=false;
- if El=nil then exit;
- C:=El.ClassType;
- if C=TPrimitiveExpr then
- begin
- Prim:=TPrimitiveExpr(El);
- if Prim.Kind=pekIdent then
- begin
- if Prim.CustomData is TResolvedReference then
- begin
- Decl:=TResolvedReference(Prim.CustomData).Declaration;
- exit(ElementReferencesTemplateTypes(Decl,GenericTemplateTypes));
- end;
- end
- else
- exit;
- end
- else if C=TBinaryExpr then
- begin
- Bin:=TBinaryExpr(El);
- Result:=ElementReferencesTemplateTypes(Bin.left,GenericTemplateTypes)
- or ElementReferencesTemplateTypes(Bin.right,GenericTemplateTypes);
- end
- else if C=TInlineSpecializeExpr then
- begin
- InlineSpec:=TInlineSpecializeExpr(El);
- if ElementReferencesTemplateTypes(InlineSpec.NameExpr,GenericTemplateTypes) then
- exit(true);
- for i:=0 to InlineSpec.Params.Count-1 do
- begin
- Decl:=TPasElement(InlineSpec.Params[i]);
- if Decl.Parent<>InlineSpec then continue;
- if ElementReferencesTemplateTypes(Decl,GenericTemplateTypes) then
- exit(true);
- end;
- end
- else if C=TPasGenericTemplateType then
- Result:=GenericTemplateTypes.IndexOf(El)>=0
- else if C.InheritsFrom(TPasType) then
- begin
- if TPasType(El).Name<>'' then exit;
- if C=TPasSpecializeType then
- begin
- Spec:=TPasSpecializeType(El);
- if ElementReferencesTemplateTypes(Spec.DestType,GenericTemplateTypes) then
- exit(true);
- for i:=0 to Spec.Params.Count-1 do
- if ElementReferencesTemplateTypes(TPasElement(Spec.Params[i]),GenericTemplateTypes) then
- exit(true);
- end
- else if C=TPasArrayType then
- begin
- Arr:=TPasArrayType(El);
- for i:=0 to length(Arr.Ranges)-1 do
- if ElementReferencesTemplateTypes(Arr.Ranges[i],GenericTemplateTypes) then exit(true);
- Result:=ElementReferencesTemplateTypes(Arr.ElType,GenericTemplateTypes);
- end
- else if C=TPasPointerType then
- Result:=ElementReferencesTemplateTypes(TPasPointerType(El).DestType,GenericTemplateTypes)
- else if C=TPasSetType then
- Result:=ElementReferencesTemplateTypes(TPasSetType(El).EnumType,GenericTemplateTypes)
- else if C=TPasEnumType then
- else
- RaiseNotYetImplemented(20190905110152,El);
- end
- else
- RaiseNotYetImplemented(20190905105648,El);
- end;
- var
- ConToken: TToken;
- aClass, ConstraintClass: TPasClassType;
- GenTempl: TPasGenericTemplateType;
- i: Integer;
- ResolvedEl: TPasResolverResult;
- ConType: TPasType;
- GenericTemplateTypes: TFPList;
- GenericEl: TPasElement;
- begin
- ConToken:=GetGenericConstraintKeyword(ConEl);
- case ConToken of
- tkrecord:
- begin
- if ParamType is TPasRecordType then exit(cExact);
- exit(RaiseXExpButYFound(20190725200015,'record type',ParamType));
- end;
- tkclass,tkconstructor:
- begin
- if not (ParamType is TPasClassType) then
- exit(RaiseXExpButYFound(20190726133231,'class type',ParamType));
- aClass:=TPasClassType(ParamType);
- if aClass.ObjKind<>okClass then
- exit(RaiseXExpButYFound(20190726133232,'class type',ParamType));
- if aClass.IsExternal then
- exit(RaiseXExpButYFound(20190726133233,'non external class type',ParamType));
- if ConToken=tkconstructor then
- begin
- if FindDefaultConstructor(aClass)=nil then
- exit(RaiseXExpButYFound(20190831000225,'class type with constructor create()',ParamType));
- end;
- exit;
- end;
- end;
- if not (ConEl is TPasType) then
- RaiseNotYetImplemented(20190912214727,ConEl,GetObjPath(ErrorPos));
- // constraint can be a class type, interface type or a template type
- // Param must be a class
- if SpecializedItem<>nil then
- begin
- GenericEl:=SpecializedItem.GenericEl;
- if GenericEl is TPasGenericType then
- GenericTemplateTypes:=TPasGenericType(GenericEl).GenericTemplateTypes
- else if GenericEl is TPasProcedure then
- GenericTemplateTypes:=GetProcTemplateTypes(TPasProcedure(GenericEl))
- else
- RaiseNotYetImplemented(20190920114755,ConEl);
- if ElementReferencesTemplateTypes(ConEl,GenericTemplateTypes) then
- begin
- // constraint contains templates -> specialize constraint
- if ConEl is TPasType then
- begin
- // type reference
- ConType:=TPasType(ConEl);
- i:=length(SpecializedItem.SpecializedConstraints);
- Setlength(SpecializedItem.SpecializedConstraints,i+1);
- SpecializedItem.SpecializedConstraints[i]:=nil;
- SpecializeElType(TemplType,SpecializedItem.SpecializedEl,ConType,
- TPasType(SpecializedItem.SpecializedConstraints[i]));
- ConEl:=SpecializedItem.SpecializedConstraints[i];
- end
- else
- // non type reference
- RaiseNotValidConstraint(20190915181137,ConEl);
- end;
- end;
- ComputeElement(ConEl,ResolvedEl,[rcType]);
- if ResolvedEl.BaseType<>btContext then
- RaiseNotValidConstraint(20190914105836,ConEl);
- if ResolvedEl.HiTypeEl.Name='' then
- RaiseNotValidConstraint(20190726134037,GetGenericConstraintErrorEl(ConEl,TemplType));
- if ResolvedEl.LoTypeEl is TPasGenericTemplateType then
- begin
- GenTempl:=TPasGenericTemplateType(ResolvedEl.LoTypeEl);
- if GenTempl=ConEl.Parent then
- RaiseNotYetImplemented(20190831213359,GenTempl);
- Result:=CheckTemplateFitsParam(ParamType,GenTempl,nil,Operation,ErrorPos);
- end
- else if ResolvedEl.LoTypeEl is TPasClassType then
- begin
- // constraint is classtype or interfacetype
- ConstraintClass:=TPasClassType(ResolvedEl.LoTypeEl);
- if not (ParamType is TPasClassType) then
- begin
- if ErrorPos<>nil then
- RaiseIncompatibleType(20190726135859,nIncompatibleTypesGotExpected,[''],
- ParamType,ConstraintClass,ErrorPos);
- exit(cIncompatible);
- end;
- if not (TPasClassType(ParamType).ObjKind in [okClass,okInterface]) then
- begin
- if ErrorPos<>nil then
- RaiseMsg(20190904175144,nXExpectedButYFound,sXExpectedButYFound,
- ['class',GetTypeDescription(ParamType)],ErrorPos);
- exit(cIncompatible);
- end;
- case ConstraintClass.ObjKind of
- okClass:
- case Operation of
- prtcoAssignToTempl:
- // TemplateClass:=ParamClassType
- if CheckClassIsClass(ParamType,ConstraintClass)=cIncompatible then
- begin
- // ParamType is not ConstraintClass
- if ErrorPos<>nil then
- RaiseIncompatibleType(20190726135309,nIncompatibleTypesGotExpected,[''],
- ParamType,ConstraintClass,ErrorPos);
- exit(cIncompatible);
- end;
- prtcoAssignFromTempl:
- // ParamClassType:=TemplateClass
- if CheckClassIsClass(ConstraintClass,ParamType)<>cIncompatible then
- begin
- // ConstraintClass is not ParamType
- if ErrorPos<>nil then
- RaiseIncompatibleType(20190915202812,nIncompatibleTypesGotExpected,[''],
- ConstraintClass,ParamType,ErrorPos);
- exit(cIncompatible);
- end;
- prtcoEqual:
- // TemplateClass=ParamClassType
- if (CheckClassIsClass(ParamType,ConstraintClass)=cIncompatible)
- and (CheckClassIsClass(ConstraintClass,ParamType)<>cIncompatible) then
- begin
- // ParamType is not related to ConstraintClass
- if ErrorPos<>nil then
- RaiseIncompatibleType(20190915203651,nIncompatibleTypesGotExpected,[''],
- ParamType,ConstraintClass,ErrorPos);
- exit(cIncompatible);
- end;
- else
- RaiseNotYetImplemented(20190915203439,ConEl);
- end;
- okInterface:
- case Operation of
- prtcoAssignToTempl:
- // TemplateClassWithIntf:=ParamClassType
- if GetClassImplementsIntf(TPasClassType(ParamType),ConstraintClass)=nil then
- begin
- // ParamType does not implement ConstraintClass
- if ErrorPos<>nil then
- RaiseIncompatibleType(20190726135458,nIncompatibleTypesGotExpected,[''],
- ParamType,ConstraintClass,ErrorPos);
- exit(cIncompatible);
- end;
- prtcoAssignFromTempl:
- // ParamClassType:=TemplateClassWithIntf
- begin
- // check when specialize
- end;
- prtcoEqual:
- // TemplateClassWithIntf=ParamClassType
- begin
- // check when specialize
- end;
- else
- RaiseNotYetImplemented(20190915203218,ConEl);
- end;
- else
- if ErrorPos<>nil then
- RaiseIncompatibleType(20190726135310,nIncompatibleTypesGotExpected,[''],
- ParamType,ConstraintClass,ErrorPos);
- exit(cIncompatible);
- end;
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckSpecializedParamFitsConstraintExpr ',GetObjPath(ResolvedEl.LoTypeEl));
- {$ENDIF}
- RaiseMsg(20190726134223,nXIsNotAValidConstraint,sXIsNotAValidConstraint,
- [GetElementSourcePosStr(GetGenericConstraintErrorEl(ConEl,ConEl.Parent))],
- ErrorPos);
- end;
- Result:=cExact;
- end;
- function TPasResolver.CheckTemplateFitsParam(ParamType: TPasType;
- GenTempl: TPasGenericTemplateType; SpecializedItem: TPRSpecializedItem;
- Operation: TPRTemplateCompOp; ErrorPos: TPasElement): integer;
- var
- i: Integer;
- begin
- // check if the ParamType fits the constraints
- for i:=0 to length(GenTempl.Constraints)-1 do
- begin
- Result:=CheckGenericConstraintFitsParam(ParamType,SpecializedItem,
- GenTempl,GenTempl.Constraints[i],Operation,ErrorPos);
- if Result=cIncompatible then exit;
- end;
- Result:=cExact;
- end;
- function TPasResolver.CheckTemplateFitsParamRes(
- GenTempl: TPasGenericTemplateType; const ResolvedEl: TPasResolverResult;
- Operation: TPRTemplateCompOp; ErrorPos: TPasElement): integer;
- var
- i: Integer;
- ConEl: TPasElement;
- ConToken: TToken;
- LoTypeEl: TPasType;
- begin
- if length(GenTempl.Constraints)=0 then
- exit(cGenericExact);
- if ResolvedEl.BaseType=btContext then
- begin
- LoTypeEl:=ResolvedEl.LoTypeEl;
- if LoTypeEl is TPasGenericTemplateType then
- begin
- if LoTypeEl=GenTempl then
- exit(cGenericExact);
- if (Operation=prtcoAssignToTempl) and (ErrorPos<>nil) then
- CheckTemplateFitsTemplate(TPasGenericTemplateType(LoTypeEl),GenTempl,ErrorPos);
- Result:=cGenericExact;
- end
- else
- Result:=CheckTemplateFitsParam(LoTypeEl,GenTempl,nil,Operation,ErrorPos);
- end
- else if ResolvedEl.BaseType=btNil then
- begin
- for i:=0 to length(GenTempl.Constraints)-1 do
- begin
- ConEl:=GenTempl.Constraints[i];
- ConToken:=GetGenericConstraintKeyword(ConEl);
- if ConToken=tkrecord then
- begin
- if ErrorPos<>nil then
- RaiseXExpectedButYFound(20190915211000,'record type','nil',ErrorPos);
- exit(cIncompatible);
- end;
- end;
- Result:=cGenericExact;
- end
- else
- begin
- if ErrorPos<>nil then
- RaiseNotYetImplemented(20190915205441,ErrorPos);
- Result:=cIncompatible;
- end;
- end;
- procedure TPasResolver.CheckTemplateFitsTemplate(ParamTemplType,
- GenTempl: TPasGenericTemplateType; ErrorPos: TPasElement);
- procedure RaiseNotValidConstraint(const Id: TMaxPrecInt; ConEl: TPasElement);
- begin
- RaiseMsg(Id,nXIsNotAValidConstraint,sXIsNotAValidConstraint,
- [GetElementTypeName(ConEl)],GetGenericConstraintErrorEl(ConEl,GenTempl));
- end;
- var
- ParamConstraints: TPasElementArray;
- j, k: Integer;
- ConToken: TToken;
- ConstraintClass, ParamClassType: TPasClassType;
- ConEl, ParamConstraintEl: TPasElement;
- ParamLoType, ParamHiType: TPasType;
- ResolvedEl: TPasResolverResult;
- begin
- ParamConstraints:=ParamTemplType.Constraints;
- for j:=0 to length(GenTempl.Constraints)-1 do
- begin
- ConEl:=GenTempl.Constraints[j];
- ConToken:=GetGenericConstraintKeyword(ConEl);
- if ConToken<>tkEOF then
- begin
- // constraint is keyword
- // -> check if keyword is in ParamConstraints
- k:=length(ParamConstraints)-1;
- while (k>=0) and (GetGenericConstraintKeyword(ParamConstraints[k])<>ConToken) do
- dec(k);
- if k<0 then
- RaiseMsg(20190816230021,nTypeParamXIsMissingConstraintY,
- sTypeParamXIsMissingConstraintY,
- [ParamTemplType.Name,TokenInfos[ConToken]],ErrorPos);
- end
- else if ConEl is TPasType then
- begin
- // constraint is a type
- ComputeElement(ConEl,ResolvedEl,[rcType]);
- if ResolvedEl.BaseType<>btContext then
- RaiseNotValidConstraint(20190816231846,ConEl);
- if not (ResolvedEl.LoTypeEl is TPasClassType) then
- RaiseNotValidConstraint(20190816231849,ConEl);
- ConstraintClass:=TPasClassType(ResolvedEl.LoTypeEl);
- // constraint is class/interface type
- // -> check if one of ParamConstraints fits the constraint type
- // i.e. ParamConstraints must be more strict than target constraints
- k:=length(ParamConstraints)-1;
- while k>=0 do
- begin
- ParamConstraintEl:=ParamConstraints[k];
- if ParamConstraintEl is TPasType then
- begin
- ParamHiType:=TPasType(ParamConstraintEl);
- ParamLoType:=ResolveAliasType(ParamHiType);
- if not (ParamLoType is TPasClassType) then
- RaiseMsg(20190816232459,nXExpectedButYFound,sXExpectedButYFound,
- ['type',GetTypeDescription(ParamHiType)],
- GetGenericConstraintErrorEl(ParamConstraintEl,ParamTemplType));
- ParamClassType:=TPasClassType(ParamLoType);
- if (ConstraintClass.ObjKind=okInterface)
- and (ParamClassType.ObjKind=okClass) then
- begin
- if GetClassImplementsIntf(ParamClassType,ConstraintClass)<>nil then
- break;
- end
- else
- begin
- if CheckClassIsClass(ParamClassType,ConstraintClass)<cIncompatible then
- break;
- end;
- end;
- dec(k);
- end;
- if k<0 then
- begin
- if ConstraintClass.ObjKind=okInterface then
- RaiseMsg(20190816233102,nTypeParamXMustSupportIntfY,
- sTypeParamXMustSupportIntfY,
- [ParamTemplType.Name,GetTypeDescription(ConstraintClass)],ErrorPos)
- else
- RaiseMsg(20190816230021,nTypeParamXIsNotCompatibleWithY,
- sTypeParamXIsNotCompatibleWithY,
- [ParamTemplType.Name,GetTypeDescription(ConstraintClass)],ErrorPos);
- end;
- end
- else
- RaiseNotYetImplemented(20190912215702,GetGenericConstraintErrorEl(ConEl,GenTempl));
- end;
- end;
- function TPasResolver.CreateSpecializedItem(El: TPasElement;
- GenericEl: TPasElement; const ParamsResolved: TPasTypeArray
- ): TPRSpecializedItem;
- var
- NewEl: TPasElement;
- GenScope: TPasGenericScope;
- SpecializedItems: TObjectList;
- procedure InsertBehind(List: TFPList);
- var
- Last: TPasElement;
- i, LastIndex: Integer;
- GenScope: TPasGenericScope;
- ProcScope: TPasProcedureScope;
- begin
- // insert in front of currently parsed elements
- // beware: specializing an element can create other specialized elements
- // add behind last finished specialized element of this GenericEl
- // for example: A = class(B<C<D>>)
- // =>
- // D
- // C<D>
- // B<C<D>>
- // A
- Last:=GenericEl;
- if SpecializedItems<>nil then
- begin
- i:=SpecializedItems.Count-2;
- if i>=0 then
- Last:=TPRSpecializedItem(SpecializedItems[i]).SpecializedEl;
- end;
- LastIndex:=List.IndexOf(Last);
- if (LastIndex<0) then
- if GenericEl is TPasProcedure then
- else
- RaiseNotYetImplemented(20200725093218,El);
- i:=List.Count-1;
- while i>LastIndex do
- begin
- Last:=TPasElement(List[i]);
- if Last is TPasGenericType then
- begin
- if (Last.CustomData<>nil) then
- begin
- GenScope:=Last.CustomData as TPasGenericScope;
- if GenScope.GenericStep>=psgsInterfaceParsed then
- break; // finished generic type
- end;
- // type is still parsed => insert in front
- dec(i);
- end
- else if Last is TPasProcedure then
- begin
- ProcScope:=Last.CustomData as TPasProcedureScope;
- if ProcScope.GenericStep>=psgsInterfaceParsed then
- break; // finished generic proc
- // proc is still parsed => insert in front
- dec(i);
- end
- else
- break;
- end;
- List.Insert(i+1,NewEl);
- end;
- var
- NewName: String;
- NewClass: TPTreeElement;
- SrcModule: TPasModule;
- SrcModuleScope: TPasModuleScope;
- SrcResolver: TPasResolver;
- NewParent: TPasElement;
- TypeItem: TPRSpecializedTypeItem;
- ProcItem: TPRSpecializedProcItem;
- begin
- Result:=nil;
- SrcModule:=GenericEl.GetModule;
- SrcModuleScope:=SrcModule.CustomData as TPasModuleScope;
- SrcResolver:=SrcModuleScope.Owner as TPasResolver;
- if SrcResolver<>Self then
- RaiseInternalError(20190728121705);
- GenScope:=TPasGenericScope(GenericEl.CustomData);
- SpecializedItems:=GenScope.SpecializedItems;
- TypeItem:=nil;
- ProcItem:=nil;
- if GenericEl is TPasGenericType then
- begin
- TypeItem:=TPRSpecializedTypeItem.Create;
- Result:=TypeItem;
- end
- else if GenericEl is TPasProcedure then
- begin
- ProcItem:=TPRSpecializedProcItem.Create;
- Result:=ProcItem;
- end
- else
- RaiseNotYetImplemented(20190920140756,GenericEl);
- Result.GenericEl:=GenericEl;
- Result.FirstSpecialize:=El;
- Result.Params:=ParamsResolved;
- Result.Index:=SpecializedItems.Count;
- SpecializedItems.Add(Result);
- NewName:=CreateSpecializedTypeName(Result);
- NewClass:=TPTreeElement(GenericEl.ClassType);
- NewParent:=GenericEl.Parent;
- NewEl:=TPasElement(NewClass.Create(NewName,NewParent));
- if TypeItem<>nil then
- TypeItem.SpecializedType:=TPasGenericType(NewEl) // this calls AddRef
- else
- ProcItem.SpecializedProc:=TPasProcedure(NewEl); // this calls AddRef
- if NewParent is TPasDeclarations then
- begin
- InsertBehind(TPasDeclarations(NewParent).Declarations);
- {$IFDEF CheckPasTreeRefCount}NewEl.RefIds.Add('TPasDeclarations.Children');{$ENDIF}
- end
- else if NewParent is TPasMembersType then
- begin
- InsertBehind(TPasMembersType(NewParent).Members);
- {$IFDEF CheckPasTreeRefCount}NewEl.RefIds.Add('TPasMembersType.Members');{$ENDIF}
- end
- else
- NewEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; // fix refcount
- if GenScope.GenericStep>=psgsInterfaceParsed then
- SpecializeGenericIntf(Result);
- if GenScope.GenericStep>=psgsImplementationParsed then
- SpecializeGenericImpl(Result);
- end;
- function TPasResolver.CreateSpecializedTypeName(Item: TPRSpecializedItem): string;
- function Get_ProcName(aProc: TPasProcedure): string; forward;
- function GetTypeName(aType: TPasType): string; forward;
- function GetParentName(El: TPasElement): string;
- begin
- if El.Parent is TPasType then
- Result:=GetTypeName(TPasType(El.Parent))
- else if El is TPasUnresolvedSymbolRef then
- Result:='System'
- else if El.Parent is TPasProcedure then
- Result:=Get_ProcName(TPasProcedure(El.Parent))
- else
- Result:=El.GetModule.Name;
- end;
- function Get_ProcName(aProc: TPasProcedure): string;
- begin
- Result:=GetParentName(aProc);
- if aProc.Name<>'' then
- Result:=Result+'.'+aProc.Name;
- end;
- function GetSpecParams(Item: TPRSpecializedItem): string;
- var
- i: Integer;
- begin
- Result:='<';
- for i:=0 to length(Item.Params)-1 do
- begin
- if i>0 then Result:=Result+',';
- Result:=Result+GetTypeName(Item.Params[i]);
- end;
- Result:=Result+'>';
- end;
- function GetTypeName(aType: TPasType): string;
- var
- Arr: TPasArrayType;
- ElType: TPasType;
- ChildItem: TPRSpecializedItem;
- begin
- if aType.Name='' then
- begin
- if aType is TPasArrayType then
- begin
- // e.g. TBird<array of word>
- Result:='array of ';
- Arr:=TPasArrayType(aType);
- if length(Arr.Ranges)>0 then
- RaiseNotYetImplemented(20200905173026,Item.FirstSpecialize);
- ElType:=ResolveAliasType(Arr.ElType,false);
- if ElType is TPasArrayType then
- RaiseNotYetImplemented(20200905173159,Arr,'multidimensional anonymous array as generic param');
- Result:=Result+GetTypeName(ElType);
- end
- else
- RaiseNotYetImplemented(20200905173241,aType);
- end
- else
- begin
- Result:=GetParentName(aType)+'.'+aType.Name;
- if (aType.CustomData is TPasGenericScope) and (Pos('<',aType.Name)<1) then
- begin
- ChildItem:=TPasGenericScope(aType.CustomData).SpecializedFromItem;
- if ChildItem<>nil then
- Result:=Result+GetSpecParams(ChildItem);
- end;
- end;
- end;
- begin
- if Pos('<',Item.GenericEl.Name)>0 then
- RaiseNotYetImplemented(20201203140102,Item.SpecializedEl,Item.GenericEl.Name);
- Result:=Item.GenericEl.Name+GetSpecParams(Item);
- if Pos('><',Result)>0 then
- RaiseNotYetImplemented(20201203140223,Item.SpecializedEl,Result);
- end;
- procedure TPasResolver.InitSpecializeScopes(El: TPasElement; out
- State: TScopeStashState);
- function PushParentScopes(CurEl: TPasElement): integer;
- var
- Keep: Integer;
- Scope: TPasScope;
- IntfSection: TInterfaceSection;
- begin
- {$IFDEF VerboseInitSpecializeScopes}
- writeln(' PushParentScopes START ',GetObjName(CurEl));
- {$ENDIF}
- if CurEl=nil then
- RaiseInternalError(20190728125025);
- if CurEl is TPasModule then
- begin
- if not (CurEl.CustomData is TPasModuleScope) then
- RaiseNotYetImplemented(20190728142609,El,GetObjName(CurEl)+' '+GetObjName(CurEl.CustomData));
- Keep:=0;
- if FScopeCount<=Keep then
- RaiseInternalError(20190728124857);
- if not (FScopes[Keep] is TPasDefaultScope) then
- RaiseInternalError(20190728124858);
- end
- else
- begin
- if CurEl.Parent=nil then
- RaiseInternalError(20190728130238,GetObjName(CurEl));
- if CurEl.CustomData=nil then
- exit(PushParentScopes(CurEl.Parent));
- if not (CurEl.CustomData is TPasIdentifierScope) then
- RaiseNotYetImplemented(20190728131934,El,GetObjName(CurEl)+' '+GetObjName(CurEl.CustomData));
- Keep:=PushParentScopes(CurEl.Parent);
- end;
- inc(Keep);
- Scope:=TPasScope(CurEl.CustomData);
- {$IFDEF VerboseInitSpecializeScopes}
- writeln(' PushParentScopes ',GetObjName(CurEl),' Scope=',GetObjName(Scope),' Keep=',Keep);
- {$ENDIF}
- if Scope.FreeOnPop then
- RaiseInternalError(20190728131153,GetObjName(CurEl));
- if (Keep<FScopeCount) and (FScopes[Keep]=Scope) then
- // Scope is already on the scopestack
- else
- begin
- if Keep<FScopeCount then
- begin
- // cannot use current scope stack -> stash
- {$IFDEF VerboseInitSpecializeScopes}
- writeln(' PushParentScopes StashScopes Keep=',Keep);
- {$ENDIF}
- StashScopes(Keep);
- if Keep<>FScopeCount then
- RaiseNotYetImplemented(20190813005130,El);
- State.ScopeCount:=ScopeCount;
- end;
- if (CurEl.ClassType=TImplementationSection) then
- begin
- // unit implementation -> push interface scope
- IntfSection:=CurEl.GetModule.InterfaceSection;
- if IntfSection=nil then
- RaiseNotYetImplemented(20190825112907,CurEl);
- if not (IntfSection.CustomData is TPasSectionScope) then
- RaiseNotYetImplemented(20190825112907,CurEl);
- PushScope(TPasSectionScope(IntfSection.CustomData));
- inc(Keep);
- end;
- PushScope(Scope);
- end;
- exit(Keep);
- end;
- var
- Keep: Integer;
- begin
- {$IFDEF VerboseInitSpecializeScopes}
- writeln('TPasResolver.InitSpecializeScopes START ',GetObjName(El));
- {$ENDIF}
- State.ScopeCount:=ScopeCount;
- State.StashCount:=FStashScopeCount;
- Keep:=PushParentScopes(El.Parent)+1;
- if Keep<FScopeCount then
- begin
- // cannot use current scope stack -> stash
- {$IFDEF VerboseInitSpecializeScopes}
- writeln('TPasResolver.InitSpecializeScopes StashScopes Keep=',Keep);
- {$ENDIF}
- StashScopes(Keep);
- if Keep<>FScopeCount then
- RaiseNotYetImplemented(20190813005859,El);
- end;
- {$IFDEF VerboseInitSpecializeScopes}
- WriteScopesShort('TPasResolver.InitSpecializeScopes END');
- {$ENDIF}
- end;
- procedure TPasResolver.RestoreSpecializeScopes(const State: TScopeStashState);
- begin
- while ScopeCount>State.ScopeCount do
- PopScope;
- RestoreStashedScopes(State.StashCount);
- end;
- procedure TPasResolver.SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem
- );
- var
- SpecEl, GenericEl: TPasElement;
- C: TClass;
- NewRecordType, GenRecordType: TPasRecordType;
- NewClassType, GenClassType: TPasClassType;
- NewArrayType, GenArrayType: TPasArrayType;
- GenProcType, NewProcType: TPasProcedureType;
- GenProc, NewProc: TPasProcedure;
- OldScopeState: TScopeStashState;
- begin
- if SpecializedItem.Step<>prssNone then
- exit;
- SpecializedItem.Step:=prssInterfaceBuilding;
- SpecEl:=SpecializedItem.SpecializedEl;
- GenericEl:=SpecializedItem.GenericEl;
- // change scope
- InitSpecializeScopes(GenericEl,OldScopeState);
- {$IFDEF VerbosePasResolver}
- WriteScopesShort('TPasResolver.SpecializeGenericIntf Init SpecEl='+SpecEl.FullName+' GenericEl='+GenericEl.FullName);
- {$ENDIF}
- SpecializePasElementProperties(GenericEl,SpecEl);
- C:=SpecEl.ClassType;
- if C=TPasRecordType then
- begin
- NewRecordType:=TPasRecordType(SpecEl);
- GenRecordType:=TPasRecordType(GenericEl);
- SpecializeRecordType(GenRecordType,NewRecordType,TPRSpecializedTypeItem(SpecializedItem));
- end
- else if C=TPasClassType then
- begin
- NewClassType:=TPasClassType(SpecEl);
- GenClassType:=TPasClassType(GenericEl);
- SpecializeClassType(GenClassType,NewClassType,TPRSpecializedTypeItem(SpecializedItem));
- end
- else if C=TPasArrayType then
- begin
- GenArrayType:=TPasArrayType(GenericEl);
- NewArrayType:=TPasArrayType(SpecEl);
- SpecializeArrayType(GenArrayType,NewArrayType,TPRSpecializedTypeItem(SpecializedItem));
- end
- else if (C=TPasProcedureType)
- or (C=TPasFunctionType) then
- begin
- GenProcType:=TPasProcedureType(GenericEl);
- NewProcType:=TPasProcedureType(SpecEl);
- SpecializeProcedureType(GenProcType,NewProcType,TPRSpecializedTypeItem(SpecializedItem));
- end
- else if C.InheritsFrom(TPasProcedure) then
- begin
- GenProc:=TPasProcedure(GenericEl);
- NewProc:=TPasProcedure(SpecEl);
- SpecializeProcedure(GenProc,NewProc,SpecializedItem);
- end
- else
- RaiseNotYetImplemented(20190728134933,GenericEl);
- {$IFDEF VerbosePasResolver}
- WriteScopesShort('TPasResolver.SpecializeGenericIntf Finish: '+SpecEl.FullName);
- {$ENDIF}
- RestoreSpecializeScopes(OldScopeState);
- {$IFDEF VerbosePasResolver}
- WriteScopesShort('TPasResolver.SpecializeGenericIntf RestoreStashedScopes: '+SpecEl.FullName);
- {$ENDIF}
- end;
- procedure TPasResolver.SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem
- );
- var
- GenericEl: TPasElement;
- GenScope: TPasGenericScope;
- SpecializedTypeItem: TPRSpecializedTypeItem;
- SpecializedProcItem: TPRSpecializedProcItem;
- GenImplProc, GenIntfProc, SpecDeclProc: TPasProcedure;
- GenDeclProcScope: TPasProcedureScope;
- OldScopeState: TScopeStashState;
- begin
- // check specialized type step
- if SpecializedItem.Step>prssInterfaceFinished then
- exit;
- GenericEl:=SpecializedItem.GenericEl;
- if SpecializedItem.Step<prssInterfaceFinished then
- if GenericEl is TPasType then
- RaiseMsg(20190804120128,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
- [GetTypeDescription(TPasType(GenericEl))],SpecializedItem.FirstSpecialize)
- else
- RaiseMsg(20190920190727,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
- [GenericEl.Name],SpecializedItem.FirstSpecialize);
- SpecializedItem.Step:=prssImplementationBuilding;
- // check generic type is resolved completely
- GenScope:=TPasGenericScope(GenericEl.CustomData);
- if GenScope.GenericStep<psgsImplementationParsed then
- RaiseNotYetImplemented(20190804174019,GenericEl,GetObjName(SpecializedItem.SpecializedEl));
- if GenericEl is TPasMembersType then
- begin
- // specialize all method bodies
- SpecializedTypeItem:=TPRSpecializedTypeItem(SpecializedItem);
- if SpecializedTypeItem.ImplProcs=nil then
- SpecializedTypeItem.ImplProcs:=TFPList.Create;
- SpecializeMembersImpl(TPasMembersType(GenericEl),
- TPasMembersType(SpecializedTypeItem.SpecializedType),
- SpecializedTypeItem);
- end
- else if GenericEl is TPasProcedure then
- begin
- // specialize proc implementation
- GenIntfProc:=TPasProcedure(GenericEl);
- if GenIntfProc.IsAbstract or GenIntfProc.IsExternal then
- //
- else
- begin
- SpecializedProcItem:=TPRSpecializedProcItem(SpecializedItem);
- GenDeclProcScope:=TPasProcedureScope(GenScope);
- GenImplProc:=GenDeclProcScope.ImplProc;
- if GenImplProc=nil then
- RaiseNotYetImplemented(20190920211609,SpecializedProcItem.SpecializedProc);
- if GenImplProc.Body=nil then
- RaiseNotYetImplemented(20190920192731,GenImplProc); // GenScope.GenericStep is wrong
- SpecDeclProc:=SpecializedProcItem.SpecializedProc;
- InitSpecializeScopes(GenImplProc,OldScopeState);
- SpecializeGenImplProc(GenIntfProc,SpecDeclProc,SpecializedProcItem);
- RestoreSpecializeScopes(OldScopeState);
- end;
- end;
- SpecializedItem.Step:=prssImplementationFinished;
- end;
- procedure TPasResolver.SpecializeMembers(GenMembersType,
- SpecMembersType: TPasMembersType);
- var
- i: Integer;
- GenEl, NewEl: TPasElement;
- NewClass: TPTreeElement;
- begin
- for i:=0 to GenMembersType.Members.Count-1 do
- begin
- GenEl:=TPasElement(GenMembersType.Members[i]);
- if GenEl.Parent<>GenMembersType then
- RaiseNotYetImplemented(20190728145634,GenEl,GetObjName(GenEl.Parent));
- NewClass:=TPTreeElement(GenEl.ClassType);
- NewEl:=TPasElement(NewClass.Create(GenEl.Name,SpecMembersType));
- SpecMembersType.Members.Add(NewEl);
- SpecializeElement(GenEl,NewEl);
- end;
- end;
- procedure TPasResolver.SpecializeMembersImpl(GenericType,
- SpecType: TPasMembersType; SpecializedItem: TPRSpecializedTypeItem);
- var
- GenClassOrRec, SpecClassOrRec: TPasMembersType;
- i: Integer;
- GenMember, SpecMember, ImplParent: TPasElement;
- GenIntfProc, GenImplProc, SpecIntfProc: TPasProcedure;
- GenIntfProcScope: TPasProcedureScope;
- OldScopeState: TScopeStashState;
- begin
- GenClassOrRec:=TPasMembersType(GenericType);
- SpecClassOrRec:=TPasMembersType(SpecType);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.SpecializeMembersImpl RestoreStashedScopes ',GetObjPath(SpecClassOrRec),' ',ScopeCount,' FStashScopeCount=',FStashScopeCount);
- {$ENDIF}
- // specialize member bodies
- ImplParent:=nil;
- OldScopeState:=default(TScopeStashState);
- for i:=0 to GenClassOrRec.Members.Count-1 do
- begin
- GenMember:=TPasElement(GenClassOrRec.Members[i]);
- SpecMember:=TPasElement(SpecClassOrRec.Members[i]);
- if SpecMember.ClassType<>GenMember.ClassType then
- RaiseNotYetImplemented(20190816002658,GenMember,GetObjName(SpecMember));
- if SpecMember.Name<>GenMember.Name then
- RaiseNotYetImplemented(20190804124220,GenMember,GetObjName(SpecMember));
- if GenMember is TPasProcedure then
- begin
- GenIntfProc:=TPasProcedure(GenMember);
- SpecIntfProc:=TPasProcedure(SpecMember);
- if GenIntfProc.IsAbstract or GenIntfProc.IsExternal then continue;
- GenIntfProcScope:=TPasProcedureScope(GenIntfProc.CustomData);
- GenImplProc:=GenIntfProcScope.ImplProc;
- if GenImplProc=nil then
- RaiseNotYetImplemented(20190921221246,GenIntfProc);
- if ImplParent=nil then
- begin
- // switch scope (e.g. unit implementation section)
- ImplParent:=GenImplProc.Parent;
- InitSpecializeScopes(GenImplProc,OldScopeState);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.SpecializeGenImplProc Specialize implprocs: SpecType=',GetObjName(SpecType),' ImplParent=',GetObjName(ImplParent),' ScopeCount=',ScopeCount,' FStashScopeCount=',FStashScopeCount,' TopScope=',GetObjName(TopScope));
- {$ENDIF}
- end
- else if ImplParent<>GenImplProc.Parent then
- RaiseNotYetImplemented(20190804130322,GenImplProc,GetObjName(ImplParent));
- SpecializeGenImplProc(GenIntfProc,SpecIntfProc,SpecializedItem);
- end
- else if GenMember is TPasMembersType then
- begin
- // nested record/class type
- SpecializeMembersImpl(TPasMembersType(GenMember),TPasMembersType(SpecMember),
- SpecializedItem);
- end;
- end;
- if ImplParent<>nil then
- begin
- // restore scope
- RestoreSpecializeScopes(OldScopeState);
- end;
- end;
- procedure TPasResolver.SpecializeGenImplProc(GenDeclProc,
- SpecDeclProc: TPasProcedure; SpecializedItem: TPRSpecializedItem);
- procedure InsertBehind(ParentElList: TFPList;
- SpecializedItems: TObjectList; GenImplProc, SpecImplProc: TPasProcedure);
- // insert SpecImplProc behind last specialized impl proc
- // Note: impl procs are not always specialized in order
- var
- Last: TPasProcedure;
- i: Integer;
- begin
- Last:=nil;
- if SpecializedItems<>nil then
- begin
- i:=SpecializedItems.Count-1;
- while i>=0 do
- begin
- Last:=TPRSpecializedProcItem(SpecializedItems[i]).ImplProc;
- if Last=SpecImplProc then
- Last:=nil
- else if Last<>nil then
- break;
- dec(i);
- end;
- end;
- if Last=nil then
- Last:=GenImplProc;
- i:=ParentElList.IndexOf(Last);
- if i<0 then
- begin
- {$IF defined(VerbosePasResolver) or defined(VerbosePas2JS)}
- {AllowWriteln}
- writeln('InsertBehind GenImplProc=',GetObjPath(GenImplProc),' Last=',GetObjPath(Last));
- for i:=0 to ParentElList.Count-1 do
- begin
- writeln(' ',GetObjName(TObject(ParentElList[i])));
- if TObject(ParentElList[i]) is TPasProcedure then
- writeln(' IsForward=',TPasProcedure(ParentElList[i]).IsForward);
- end;
- {AllowWriteln-}
- {$ENDIF}
- RaiseNotYetImplemented(20191017122900,GenDeclProc);
- end;
- ParentElList.Insert(i+1,SpecImplProc);
- SpecImplProc.AddRef{$IFDEF CheckPasTreeRefCount}('TPasDeclarations.Children'){$ENDIF};
- end;
- var
- GenDeclProcScope, GenImplProcScope, SpecDeclProcScope,
- SpecImplProcScope: TPasProcedureScope;
- GenImplProc, SpecImplProc: TPasProcedure;
- NewClass: TPTreeElement;
- SpecClassOrRec, GenClassOrRec: TPasMembersType;
- SpecClassOrRecScope: TPasClassOrRecordScope;
- NewImplProcName, OldClassname: String;
- p, LastDotP: Integer;
- SpecializedProcItem: TPRSpecializedProcItem;
- SpecializedTypeItem: TPRSpecializedTypeItem;
- Templates: TFPList;
- NewParent: TPasElement;
- begin
- SpecializedProcItem:=nil;
- SpecializedTypeItem:=nil;
- if SpecializedItem is TPRSpecializedProcItem then
- // impl proc of a specialized forward proc
- SpecializedProcItem:=TPRSpecializedProcItem(SpecializedItem)
- else if SpecializedItem is TPRSpecializedTypeItem then
- // method of a specialized class/record
- SpecializedTypeItem:=TPRSpecializedTypeItem(SpecializedItem)
- else
- RaiseNotYetImplemented(20190922145050,SpecDeclProc);
- GenDeclProcScope:=TPasProcedureScope(GenDeclProc.CustomData);
- GenImplProc:=GenDeclProcScope.ImplProc;
- if GenImplProc=nil then
- RaiseNotYetImplemented(20190804122134,GenDeclProc);
- if GenImplProc.Body=nil then
- RaiseNotYetImplemented(20190921220216,GenImplProc);
- GenImplProcScope:=TPasProcedureScope(GenImplProc.CustomData);
- SpecDeclProcScope:=TPasProcedureScope(SpecDeclProc.CustomData);
- if SpecDeclProc.Parent is TPasMembersType then
- begin
- SpecClassOrRec:=SpecDeclProc.Parent as TPasMembersType;
- SpecClassOrRecScope:=SpecClassOrRec.CustomData as TPasClassOrRecordScope;
- end
- else
- begin
- SpecClassOrRec:=nil;
- SpecClassOrRecScope:=nil;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.SpecializeGenImplProc Specialize GenImplProc: ',GetObjName(GenImplProc));
- {$ENDIF}
- // create impl proc name
- if SpecializedTypeItem<>nil then
- begin
- // method of a specialized class/record
- if SpecClassOrRecScope=nil then
- RaiseNotYetImplemented(20190921221839,SpecDeclProc);
- NewImplProcName:=GenImplProc.Name;
- LastDotP:=GetLastDotPos(NewImplProcName);
- if LastDotP<1 then
- RaiseNotYetImplemented(20190921221730,GenImplProc);
- // has classname -> replace generic classname with specialized classname
- p:=LastDotP;
- while (p>1) and (NewImplProcName[p-1]<>'.') do dec(p);
- OldClassname:=copy(NewImplProcName,p,LastDotP-p);
- GenClassOrRec:=GenDeclProc.Parent as TPasMembersType;
- if not SameText(OldClassname,GenClassOrRec.Name) then
- RaiseNotYetImplemented(20190814141833,GenImplProc);
- NewImplProcName:=LeftStr(NewImplProcName,p-1)+SpecClassOrRec.Name+copy(NewImplProcName,LastDotP,length(NewImplProcName));
- end
- else
- begin
- // use classname of GenImplProc and name of SpecDeclProc
- OldClassname:=GenImplProc.Name;
- p:=GetLastDotPos(OldClassname);
- if p>0 then
- NewImplProcName:=LeftStr(OldClassname,p)+SpecDeclProc.Name
- else
- NewImplProcName:=SpecDeclProc.Name;
- end;
- // create impl proc
- NewClass:=TPTreeElement(GenImplProc.ClassType);
- NewParent:=GenImplProc.Parent;
- SpecImplProc:=TPasProcedure(NewClass.Create(NewImplProcName,NewParent));
- SpecDeclProcScope.ImplProc:=SpecImplProc;
- if SpecializedProcItem<>nil then
- SpecializedProcItem.ImplProc:=SpecImplProc
- else
- SpecializedTypeItem.ImplProcs.Add(SpecImplProc);
- if (SpecializedProcItem<>nil) and (NewParent is TPasDeclarations) then
- InsertBehind(TPasDeclarations(NewParent).Declarations,
- GenDeclProcScope.SpecializedItems,GenImplProc,SpecImplProc);
- // create impl proc scope
- SpecImplProcScope:=TPasProcedureScope(CreateScope(SpecImplProc,FScopeClass_Proc));
- SpecImplProcScope.Flags:=[ppsfIsSpecialized];
- SpecImplProcScope.DeclarationProc:=SpecDeclProc;
- SpecImplProcScope.ModeSwitches:=GenImplProcScope.Modeswitches;
- SpecImplProcScope.BoolSwitches:=GenImplProcScope.BoolSwitches;
- SpecImplProcScope.VisibilityContext:=SpecClassOrRec;
- SpecImplProcScope.ClassRecScope:=SpecClassOrRecScope;
- if SpecializedProcItem<>nil then
- begin
- Templates:=GetProcTemplateTypes(GenDeclProc);
- AddSpecializedTemplateIdentifiers(Templates,SpecializedItem,SpecImplProcScope,
- false);
- end;
- // specialize props
- SpecializePasElementProperties(GenImplProc,SpecImplProc);
- AddProcedure(SpecImplProc,nil);
- SpecializeProcedure(GenImplProc,SpecImplProc,SpecializedItem);
- end;
- procedure TPasResolver.SpecializeElement(GenEl, SpecEl: TPasElement);
- var
- C: TClass;
- begin
- // first copy sourcefilename and linenumber needed by error messages
- SpecializePasElementProperties(GenEl,SpecEl);
- C:=GenEl.ClassType;
- // expressions
- if C=TPrimitiveExpr then
- SpecializePrimitiveExpr(TPrimitiveExpr(GenEl),TPrimitiveExpr(SpecEl))
- else if C=TUnaryExpr then
- SpecializeUnaryExpr(TUnaryExpr(GenEl),TUnaryExpr(SpecEl))
- else if C=TBinaryExpr then
- SpecializeBinaryExpr(TBinaryExpr(GenEl),TBinaryExpr(SpecEl))
- else if C=TBoolConstExpr then
- SpecializeBoolConstExpr(TBoolConstExpr(GenEl),TBoolConstExpr(SpecEl))
- else if C=TNilExpr then
- SpecializeExpr(TNilExpr(GenEl),TNilExpr(SpecEl))
- else if C=TInheritedExpr then
- SpecializeExpr(TInheritedExpr(GenEl),TInheritedExpr(SpecEl))
- else if C=TParamsExpr then
- SpecializeParamsExpr(TParamsExpr(GenEl),TParamsExpr(SpecEl))
- else if C=TRecordValues then
- SpecializeRecordValues(TRecordValues(GenEl),TRecordValues(SpecEl))
- else if C=TArrayValues then
- SpecializeArrayValues(TArrayValues(GenEl),TArrayValues(SpecEl))
- else if C=TInlineSpecializeExpr then
- SpecializeInlineSpecializeExpr(TInlineSpecializeExpr(GenEl),TInlineSpecializeExpr(SpecEl))
- else if C=TProcedureExpr then
- SpecializeProcedureExpr(TProcedureExpr(GenEl),TProcedureExpr(SpecEl))
- // TPasType
- else if (C=TPasAliasType)
- or (C=TPasTypeAliasType)
- or (C=TPasClassOfType) then
- begin
- AddType(TPasAliasType(SpecEl));
- SpecializeAliasType(TPasAliasType(GenEl),TPasAliasType(SpecEl));
- end
- else if C=TPasPointerType then
- begin
- AddType(TPasPointerType(SpecEl));
- SpecializePointerType(TPasPointerType(GenEl),TPasPointerType(SpecEl));
- end
- else if C=TPasRangeType then
- begin
- AddType(TPasRangeType(SpecEl));
- SpecializeRangeType(TPasRangeType(GenEl),TPasRangeType(SpecEl));
- end
- else if C=TPasArrayType then
- begin
- if GetTypeParameterCount(TPasArrayType(GenEl))>0 then
- RaiseNotYetImplemented(20190815201219,GenEl);
- AddArrayType(TPasArrayType(SpecEl),nil);
- SpecializeArrayType(TPasArrayType(GenEl),TPasArrayType(SpecEl),nil);
- end
- else if C=TPasEnumValue then
- begin
- AddEnumValue(TPasEnumValue(SpecEl));
- SpecializeEnumValue(TPasEnumValue(GenEl),TPasEnumValue(SpecEl));
- end
- else if C=TPasEnumType then
- begin
- AddEnumType(TPasEnumType(SpecEl));
- SpecializeEnumType(TPasEnumType(GenEl),TPasEnumType(SpecEl));
- end
- else if C=TPasSetType then
- SpecializeSetType(TPasSetType(GenEl),TPasSetType(SpecEl))
- else if C=TPasVariant then
- SpecializeVariant(TPasVariant(GenEl),TPasVariant(SpecEl))
- else if C=TPasRecordType then
- begin
- if GetTypeParameterCount(TPasRecordType(GenEl))>0 then
- RaiseNotYetImplemented(20190815201201,GenEl);
- AddRecordType(TPasRecordType(SpecEl),nil);
- SpecializeRecordType(TPasRecordType(GenEl),TPasRecordType(SpecEl),nil);
- end
- else if C=TPasClassType then
- begin
- if GetTypeParameterCount(TPasClassType(GenEl))>0 then
- RaiseNotYetImplemented(20190816214947,GenEl);
- AddClassType(TPasClassType(SpecEl),nil);
- SpecializeClassType(TPasClassType(GenEl),TPasClassType(SpecEl),nil);
- end
- else if C=TPasStringType then
- begin
- AddType(TPasStringType(SpecEl));
- SpecializeStringType(TPasStringType(GenEl),TPasStringType(SpecEl));
- end
- else if C=TPasSpecializeType then
- begin
- AddType(TPasSpecializeType(SpecEl));
- SpecializeSpecializeType(TPasSpecializeType(GenEl),TPasSpecializeType(SpecEl));
- end
- else if C=TPasGenericTemplateType then
- SpecializeGenericTemplateType(TPasGenericTemplateType(GenEl),TPasGenericTemplateType(SpecEl))
- // empty statement
- else if C=TPasImplCommand then
- // TPasImplBlock
- else if C=TPasImplBeginBlock then
- SpecializeImplBlock(TPasImplBeginBlock(GenEl),TPasImplBeginBlock(SpecEl))
- else if C=TPasImplAsmStatement then
- SpecializeImplAsmStatement(TPasImplAsmStatement(GenEl),TPasImplAsmStatement(SpecEl))
- else if C=TPasImplRepeatUntil then
- SpecializeImplRepeatUntil(TPasImplRepeatUntil(GenEl),TPasImplRepeatUntil(SpecEl))
- else if C=TPasImplIfElse then
- SpecializeImplIfElse(TPasImplIfElse(GenEl),TPasImplIfElse(SpecEl))
- else if C=TPasImplWhileDo then
- SpecializeImplWhileDo(TPasImplWhileDo(GenEl),TPasImplWhileDo(SpecEl))
- else if C=TPasImplWithDo then
- SpecializeImplWithDo(TPasImplWithDo(GenEl),TPasImplWithDo(SpecEl))
- else if C=TPasImplCaseOf then
- SpecializeImplCaseOf(TPasImplCaseOf(GenEl),TPasImplCaseOf(SpecEl))
- else if C=TPasImplCaseStatement then
- SpecializeImplCaseStatement(TPasImplCaseStatement(GenEl),TPasImplCaseStatement(SpecEl))
- else if C=TPasImplCaseElse then
- SpecializeImplBlock(TPasImplCaseElse(GenEl),TPasImplCaseElse(SpecEl))
- else if C=TPasImplAssign then
- SpecializeImplAssign(TPasImplAssign(GenEl),TPasImplAssign(SpecEl))
- else if C=TPasImplSimple then
- SpecializeImplSimple(TPasImplSimple(GenEl),TPasImplSimple(SpecEl))
- else if C=TPasImplForLoop then
- SpecializeImplForLoop(TPasImplForLoop(GenEl),TPasImplForLoop(SpecEl))
- else if C=TPasImplTry then
- SpecializeImplTry(TPasImplTry(GenEl),TPasImplTry(SpecEl))
- else if (C=TPasImplTryFinally)
- or (C=TPasImplTryExcept)
- or (C=TPasImplTryExceptElse) then
- SpecializeImplBlock(TPasImplTryHandler(GenEl),TPasImplTryHandler(SpecEl))
- else if C=TPasImplExceptOn then
- begin
- AddExceptOn(TPasImplExceptOn(SpecEl));
- SpecializeImplExceptOn(TPasImplExceptOn(GenEl),TPasImplExceptOn(SpecEl));
- end
- else if C=TPasImplRaise then
- SpecializeImplRaise(TPasImplRaise(GenEl),TPasImplRaise(SpecEl))
- // declaration
- else if C=TPasResString then
- begin
- AddResourceString(TPasResString(SpecEl));
- SpecializeResString(TPasResString(GenEl),TPasResString(SpecEl));
- end
- else if C=TPasVariable then
- begin
- AddVariable(TPasVariable(SpecEl));
- SpecializeVariable(TPasVariable(GenEl),TPasVariable(SpecEl),true);
- end
- else if C=TPasConst then
- begin
- AddVariable(TPasConst(SpecEl));
- SpecializeConst(TPasConst(GenEl),TPasConst(SpecEl));
- end
- else if C=TPasProperty then
- begin
- AddProperty(TPasProperty(SpecEl));
- SpecializeProperty(TPasProperty(GenEl),TPasProperty(SpecEl));
- end
- else if C=TPasAttributes then
- SpecializeAttributes(TPasAttributes(GenEl),TPasAttributes(SpecEl))
- else if C=TPasMethodResolution then
- SpecializeMethodResolution(TPasMethodResolution(GenEl),TPasMethodResolution(SpecEl))
- // procedure
- else if C=TPasArgument then
- begin
- AddArgument(TPasArgument(SpecEl));
- SpecializeArgument(TPasArgument(GenEl),TPasArgument(SpecEl));
- end
- else if C=TProcedureBody then
- begin
- AddProcedureBody(TProcedureBody(SpecEl));
- SpecializeProcedureBody(TProcedureBody(GenEl),TProcedureBody(SpecEl));
- end
- else if C=TPasOperator then
- begin
- AddProcedure(TPasOperator(SpecEl),nil);
- SpecializeOperator(TPasOperator(GenEl),TPasOperator(SpecEl));
- end
- else if C.InheritsFrom(TPasProcedure) then
- begin
- AddProcedure(TPasProcedure(SpecEl),nil);
- SpecializeProcedure(TPasProcedure(GenEl),TPasProcedure(SpecEl),nil);
- end
- else if C.InheritsFrom(TPasProcedureType) then
- begin
- AddProcedureType(TPasProcedureType(SpecEl),nil);
- SpecializeProcedureType(TPasProcedureType(GenEl),TPasProcedureType(SpecEl),nil);
- end
- else if C=TPasExportSymbol then
- RaiseMsg(20210101234958,nSymbolCannotExportedFromALibrary,sSymbolCannotExportedFromALibrary,[],GenEl)
- else
- RaiseNotYetImplemented(20190728151215,GenEl);
- end;
- procedure TPasResolver.SpecializePasElementProperties(GenEl, SpecEl: TPasElement
- );
- begin
- SpecEl.SourceFilename:=GenEl.SourceFilename;
- SpecEl.SourceLinenumber:=GenEl.SourceLinenumber;;
- SpecEl.SourceEndLinenumber:=GenEl.SourceEndLinenumber;
- SpecEl.Visibility:=GenEl.Visibility;
- SpecEl.Hints:=GenEl.Hints;
- SpecEl.HintMessage:=GenEl.HintMessage;
- SpecEl.DocComment:=GenEl.DocComment;
- end;
- procedure TPasResolver.SpecializeVariable(GenEl, SpecEl: TPasVariable;
- Finish: boolean);
- begin
- SpecializeElType(GenEl,SpecEl,GenEl.VarType,SpecEl.VarType);
- SpecEl.VarModifiers:=GenEl.VarModifiers;
- if GenEl.LibraryName<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.LibraryName,SpecEl.LibraryName);
- if GenEl.ExportName<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.ExportName,SpecEl.ExportName);
- SpecEl.Modifiers:=GenEl.Modifiers;
- if GenEl.AbsoluteExpr<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.AbsoluteExpr,SpecEl.AbsoluteExpr);
- if GenEl.Expr<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
- if Finish then
- FinishVariable(SpecEl);
- end;
- procedure TPasResolver.SpecializeConst(GenEl, SpecEl: TPasConst);
- begin
- SpecEl.IsConst:=GenEl.IsConst;
- SpecializeVariable(GenEl,SpecEl,true);
- end;
- procedure TPasResolver.SpecializeProperty(GenEl, SpecEl: TPasProperty);
- begin
- SpecializeVariable(GenEl,SpecEl,false);
- SpecializeElExpr(GenEl,SpecEl,GenEl.IndexExpr,SpecEl.IndexExpr);
- SpecializeElExpr(GenEl,SpecEl,GenEl.ReadAccessor,SpecEl.ReadAccessor);
- SpecializeElExpr(GenEl,SpecEl,GenEl.WriteAccessor,SpecEl.WriteAccessor);
- SpecializeElExpr(GenEl,SpecEl,GenEl.DispIDExpr,SpecEl.DispIDExpr);
- SpecializeExprArray(GenEl,SpecEl,GenEl.Implements,SpecEl.Implements);
- SpecializeElExpr(GenEl,SpecEl,GenEl.StoredAccessor,SpecEl.StoredAccessor);
- SpecializeElExpr(GenEl,SpecEl,GenEl.DefaultExpr,SpecEl.DefaultExpr);
- SpecEl.DispIDReadOnly:=GenEl.DispIDReadOnly;
- SpecEl.IsDefault:=GenEl.IsDefault;
- SpecEl.IsNodefault:=GenEl.IsNodefault;
- SpecializeElList(GenEl,SpecEl,GenEl.Args,SpecEl.Args,false
- {$IFDEF CheckPasTreeRefCount},'TPasProperty.Args'{$ENDIF});
- FinishProperty(SpecEl);
- end;
- function TPasResolver.SpecializeTypeRef(GenEl, SpecEl: TPasElement;
- GenTypeRef: TPasType): TPasType;
- var
- Ref: TPasElement;
- begin
- if GenTypeRef.Name='' then
- RaiseNotYetImplemented(20190813213555,GenEl,GetObjPath(GenTypeRef));
- Ref:=FindElement(GenTypeRef.Name);
- if not (Ref is TPasType) then
- RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
- if SpecEl=nil then ;
- Result:=TPasType(Ref);
- end;
- procedure TPasResolver.SpecializeElType(GenEl, SpecEl: TPasElement;
- GenElType: TPasType; var SpecElType: TPasType);
- var
- NewClass: TPTreeElement;
- begin
- if GenElType=nil then exit;
- if SpecElType<>nil then
- RaiseNotYetImplemented(20190812021617,GenEl);
- if (GenElType.Parent<>GenEl)
- or (GenElType.ClassType=TPasGenericTemplateType) then
- begin
- // reference
- GenElType:=SpecializeTypeRef(GenEl,SpecEl,GenElType);
- SpecElType:=GenElType;
- SpecElType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
- exit;
- end;
- // e.g. anonymous type
- if SpecElType<>nil then
- RaiseNotYetImplemented(20190808222744,SpecEl,GetObjName(SpecElType));
- NewClass:=TPTreeElement(GenElType.ClassType);
- SpecElType:=TPasType(NewClass.Create(GenElType.Name,SpecEl));
- SpecializeElement(GenElType,SpecElType);
- end;
- procedure TPasResolver.SpecializeElExpr(GenEl, SpecEl: TPasElement;
- GenElExpr: TPasExpr; var SpecElExpr: TPasExpr);
- var
- NewClass: TPTreeElement;
- begin
- if GenElExpr=nil then exit;
- if SpecElExpr<>nil then
- RaiseNotYetImplemented(20190803220248,SpecEl,GetObjName(SpecElExpr));
- if GenElExpr.Parent<>GenEl then
- RaiseNotYetImplemented(20190809160834,GenEl);
- // normal expression
- NewClass:=TPTreeElement(GenElExpr.ClassType);
- SpecElExpr:=TPasExpr(NewClass.Create(GenElExpr.Name,SpecEl));
- SpecializeElement(GenElExpr,SpecElExpr);
- end;
- procedure TPasResolver.SpecializeElImplEl(GenEl, SpecEl: TPasElement;
- GenImplEl: TPasImplElement; var SpecImplEl: TPasImplElement);
- var
- NewClass: TPTreeElement;
- begin
- if GenImplEl=nil then exit;
- if GenImplEl.Parent<>GenEl then
- RaiseNotYetImplemented(20190808222638,GenEl,GetObjName(GenImplEl.Parent));
- NewClass:=TPTreeElement(GenImplEl.ClassType);
- SpecImplEl:=TPasImplElement(NewClass.Create(GenImplEl.Name,SpecEl));
- SpecializeElement(GenImplEl,SpecImplEl);
- end;
- procedure TPasResolver.SpecializeElImplAlias(GenEl, SpecEl: TPasImplBlock;
- GenImplAlias: TPasImplElement; var SpecImplAlias: TPasImplElement
- {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
- var
- i: Integer;
- begin
- if GenImplAlias=nil then exit;
- i:=GenEl.Elements.IndexOf(GenImplAlias);
- if i<0 then
- RaiseNotYetImplemented(20190808225239,GenEl);
- SpecImplAlias:=TObject(SpecEl.Elements[i]) as TPasImplElement;
- if SpecImplAlias.ClassType<>GenImplAlias.ClassType then
- RaiseNotYetImplemented(20190808231616,GenImplAlias,GetObjName(SpecImplAlias));
- SpecImplAlias.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
- end;
- procedure TPasResolver.SpecializeElList(GenEl, SpecEl: TPasElement;
- GenList, SpecList: TFPList; AllowReferences: boolean
- {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
- var
- i: Integer;
- GenListItem, SpecListItem, Ref: TPasElement;
- NewClass: TPTreeElement;
- begin
- for i:=0 to GenList.Count-1 do
- begin
- GenListItem:=TPasElement(GenList[i]);
- if GenListItem.Parent<>GenEl then
- begin
- if not AllowReferences then
- RaiseNotYetImplemented(20190808212421,GenEl,IntToStr(i));
- if not (GenListItem is TPasType) then
- RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
- // reference
- Ref:=SpecializeTypeRef(GenEl,SpecEl,TpasType(GenListItem));
- Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
- SpecList.Add(Ref);
- continue;
- end;
- if GenListItem.ClassType=TPasGenericTemplateType then
- RaiseNotYetImplemented(20190812233309,GenEl);
- NewClass:=TPTreeElement(GenListItem.ClassType);
- SpecListItem:=TPasElement(NewClass.Create(GenListItem.Name,SpecEl));
- SpecList.Add(SpecListItem);
- SpecializeElement(GenListItem,SpecListItem);
- end;
- end;
- procedure TPasResolver.SpecializeElArray(GenEl, SpecEl: TPasElement;
- GenList: TPasElementArray; var SpecList: TPasElementArray;
- AllowReferences: boolean{$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
- var
- l, i: Integer;
- GenListItem, Ref, SpecListItem: TPasElement;
- NewClass: TPTreeElement;
- begin
- if length(SpecList)>0 then
- RaiseNotYetImplemented(20190914102814,GenEl,GetObjName(SpecEl));
- l:=length(GenList);
- SetLength(SpecList,l);
- for i:=0 to l-1 do
- SpecList[i]:=nil;
- for i:=0 to l-1 do
- begin
- GenListItem:=GenList[i];
- if GenListItem.Parent<>GenEl then
- begin
- if not AllowReferences then
- RaiseNotYetImplemented(20190914102952,GenEl,IntToStr(i));
- if not (GenListItem is TPasType) then
- RaiseNotYetImplemented(20190914102957,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
- // reference
- Ref:=SpecializeTypeRef(GenEl,SpecEl,TPasType(GenListItem));
- Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
- SpecList[i]:=Ref;
- continue;
- end;
- if GenListItem.ClassType=TPasGenericTemplateType then
- RaiseNotYetImplemented(20190914103040,GenEl);
- NewClass:=TPTreeElement(GenListItem.ClassType);
- SpecListItem:=TPasElement(NewClass.Create(GenListItem.Name,SpecEl));
- SpecList[i]:=SpecListItem;
- SpecializeElement(GenListItem,SpecListItem);
- end;
- end;
- procedure TPasResolver.SpecializeProcedure(GenEl, SpecEl: TPasProcedure;
- SpecializedItem: TPRSpecializedItem);
- var
- GenProcType: TPasProcedureType;
- NewClass: TPTreeElement;
- SpecProcScope, GenProcScope: TPasProcedureScope;
- i, j: Integer;
- GenPart, SpecPart: TProcedureNamePart;
- GenTempl, SpecTempl: TPasGenericTemplateType;
- Templates: TFPList;
- GenBody: TProcedureBody;
- begin
- GenProcScope:=GenEl.CustomData as TPasProcedureScope;
- SpecProcScope:=SpecEl.CustomData as TPasProcedureScope;
- if SpecProcScope<>nil then
- begin
- if TopScope<>SpecProcScope then
- RaiseNotYetImplemented(20190920194151,SpecEl);
- end
- else if SpecializedItem<>nil then
- begin
- // specialized generic/parametrized procedure
- SpecProcScope:=TPasProcedureScope(PushScope(SpecEl,ScopeClass_Procedure));
- SpecProcScope.SpecializedFromItem:=SpecializedItem;
- if GenProcScope.DeclarationProc<>nil then
- RaiseNotYetImplemented(20190920203700,SpecEl);
- if GenProcScope.OverriddenProc<>nil then
- RaiseNotYetImplemented(20190920203536,SpecEl);
- SpecProcScope.ClassRecScope:=GenProcScope.ClassRecScope;
- // SpecProcScope.Flags
- SpecProcScope.ModeSwitches:=GenProcScope.ModeSwitches;
- SpecProcScope.BoolSwitches:=GenProcScope.BoolSwitches;
- Templates:=GetProcTemplateTypes(GenEl);
- if (Templates=nil) or (Templates.Count=0) then
- RaiseNotYetImplemented(20190920183140,SpecEl);
- AddSpecializedTemplateIdentifiers(Templates,SpecializedItem,SpecProcScope,true);
- end
- else
- RaiseNotYetImplemented(20190922153918,SpecEl);
- Include(SpecProcScope.Flags,ppsfIsSpecialized);
- if GenEl.PublicName<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.PublicName,SpecEl.PublicName);
- if GenEl.LibrarySymbolName<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.LibrarySymbolName,SpecEl.LibrarySymbolName);
- if GenEl.LibraryExpr<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.LibraryExpr,SpecEl.LibraryExpr);
- if GenEl.DispIDExpr<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.DispIDExpr,SpecEl.DispIDExpr);
- if GenEl.MessageExpr<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.MessageExpr,SpecEl.MessageExpr);
- SpecEl.MessageName:=GenEl.MessageName;
- SpecEl.MessageType:=GenEl.MessageType;
- SpecEl.AliasName:=GenEl.AliasName;
- SpecEl.Modifiers:=GenEl.Modifiers;
- if GenEl.NameParts<>nil then
- begin
- if SpecEl.NameParts<>nil then
- RaiseNotYetImplemented(20190818125620,SpecEl);
- SpecEl.NameParts:=TFPList.Create;
- for i:=0 to GenEl.NameParts.Count-1 do
- begin
- GenPart:=TProcedureNamePart(GenEl.NameParts[i]);
- SpecPart:=TProcedureNamePart.Create;
- SpecEl.NameParts.Add(SpecPart);
- SpecPart.Name:=GenPart.Name;
- if GenPart.Templates<>nil then
- begin
- if (SpecializedItem<>nil) and (i=GenEl.NameParts.Count-1) then
- begin
- // the templates have been specialized to SpecializedItem.Params
- continue;
- end;
- SpecPart.Templates:=TFPList.Create;
- for j:=0 to GenPart.Templates.Count-1 do
- begin
- GenTempl:=TPasGenericTemplateType(GenPart.Templates[j]);
- if GenTempl.Parent<>GenEl then
- RaiseNotYetImplemented(20190818130001,GenEl,IntToStr(i)+','+IntToStr(j)+':'+GenTempl.Name+' GenParent='+GetObjName(GenTempl.Parent)+' GenEl='+GetObjName(GenEl));
- NewClass:=TPTreeElement(GenTempl.ClassType);
- SpecTempl:=TPasGenericTemplateType(NewClass.Create(GenTempl.Name,SpecEl));
- SpecPart.Templates.Add(SpecTempl);
- SpecializeElement(GenTempl,SpecTempl);
- end;
- end;
- end;
- end;
- if GenEl.ProcType<>nil then
- begin
- GenProcType:=GenEl.ProcType;
- if GenProcType.Parent<>GenEl then
- begin
- {$IFDEF defined(VerbosePCUFiler) or defined(VerbosePJUFiler)}
- writeln('TPasResolver.SpecializeProcedure GenEl=',GetObjPath(GenEl),' GenProcType.Parent=',GetObjPath(GenProcType.Parent));
- {$ENDIF}
- RaiseNotYetImplemented(20190803212426,GenEl,GetObjPath(GenProcType.Parent));
- end;
- NewClass:=TPTreeElement(GenProcType.ClassType);
- SpecEl.ProcType:=TPasProcedureType(NewClass.Create(GenProcType.Name,SpecEl));
- SpecializeElement(GenProcType,SpecEl.ProcType);
- end;
- SpecProcScope.GenericStep:=psgsInterfaceParsed;
- if GenEl.Body<>nil then
- begin
- // implementation proc
- if SpecializedItem<>nil then
- SpecializedItem.Step:=prssImplementationBuilding;
- GenBody:=GenEl.Body;
- if GenBody.Parent<>GenEl then
- RaiseNotYetImplemented(20190804183308,GenEl,GetObjName(GenBody.Parent));
- if SpecEl.Body<>nil then
- RaiseNotYetImplemented(20190920211853,SpecEl);
- NewClass:=TPTreeElement(GenBody.ClassType);
- SpecEl.Body:=TProcedureBody(NewClass.Create(GenBody.Name,SpecEl));
- SpecializeElement(GenBody,SpecEl.Body);
- FinishProcedure(SpecEl);
- end
- else if SpecializedItem=nil then
- // declaration proc, parent is specialized
- FinishProcedure(SpecEl)
- else
- begin
- // specialized generic procedure, body is not yet parsed
- SpecializedItem.Step:=prssInterfaceFinished;
- if TopScope<>SpecProcScope then
- RaiseNotYetImplemented(20190920190400,SpecEl);
- PopScope;
- end;
- end;
- procedure TPasResolver.SpecializeOperator(GenEl, SpecEl: TPasOperator);
- begin
- SpecEl.OperatorType:=GenEl.OperatorType;
- SpecEl.TokenBased:=GenEl.TokenBased;
- SpecializeProcedure(GenEl,SpecEl,nil);
- end;
- procedure TPasResolver.SpecializeProcedureType(GenEl,
- SpecEl: TPasProcedureType; SpecializedItem: TPRSpecializedItem);
- var
- GenResultEl, NewResultEl: TPasResultElement;
- NewClass: TPTreeElement;
- i: Integer;
- SpecScope: TPasGenericScope;
- begin
- if GenEl.GenericTemplateTypes<>nil then
- begin
- SpecScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_ProcType));
- if SpecializedItem<>nil then
- begin
- // specialized procedure type
- SpecScope.SpecializedFromItem:=SpecializedItem;
- AddSpecializedTemplateIdentifiers(GenEl.GenericTemplateTypes,
- SpecializedItem,SpecScope,true);
- end
- else
- begin
- // generic procedure type inside a generic type
- RaiseNotYetImplemented(20190813194550,GenEl);
- end;
- end;
- // Args
- SpecializeElList(GenEl,SpecEl,GenEl.Args,SpecEl.Args,false
- {$IFDEF CheckPasTreeRefCount},'TPasProcedureType.Args'{$ENDIF});
- for i:=0 to SpecEl.Args.Count-1 do
- FinishArgument(TPasArgument(SpecEl.Args[i]));
- // varargs
- SpecializeElType(GenEl,SpecEl,GenEl.VarArgsType,SpecEl.VarArgsType);
- // calling convention and proc type modifiers
- SpecEl.CallingConvention:=GenEl.CallingConvention;
- SpecEl.Modifiers:=GenEl.Modifiers;
- // function result
- if SpecEl is TPasFunctionType then
- begin
- GenResultEl:=TPasFunctionType(GenEl).ResultEl;
- if GenResultEl<>nil then
- begin
- if GenResultEl.Parent<>GenEl then
- RaiseNotYetImplemented(20190803212935,GenEl,GetObjName(GenResultEl.Parent));
- NewClass:=TPTreeElement(GenResultEl.ClassType);
- NewResultEl:=TPasResultElement(NewClass.Create(GenResultEl.Name,SpecEl));
- TPasFunctionType(SpecEl).ResultEl:=NewResultEl;
- AddFunctionResult(NewResultEl);
- SpecializeElType(GenResultEl,NewResultEl,GenResultEl.ResultType,NewResultEl.ResultType);
- end;
- end;
- FinishProcedureType(SpecEl);
- if SpecializedItem<>nil then
- SpecializedItem.Step:=prssImplementationFinished;
- end;
- procedure TPasResolver.SpecializeProcedureBody(GenEl, SpecEl: TProcedureBody);
- var
- GenBody, NewBody: TPasImplBlock;
- NewClass: TPTreeElement;
- begin
- SpecializeDeclarations(GenEl,SpecEl);
- FinishTypeSection(SpecEl);
- if GenEl.Body<>nil then
- begin
- GenBody:=GenEl.Body;
- if GenBody.Parent<>GenEl then
- RaiseNotYetImplemented(20190804184934,GenBody);
- NewClass:=TPTreeElement(GenBody.ClassType);
- NewBody:=TPasImplBlock(NewClass.Create(GenBody.Name,SpecEl));
- SpecEl.Body:=NewBody;
- SpecializeElement(GenBody,NewBody);
- end;
- end;
- procedure TPasResolver.SpecializeDeclarations(GenEl, SpecEl: TPasDeclarations);
- var
- i: Integer;
- GenDecl, NewDecl: TPasElement;
- NewClass: TPTreeElement;
- begin
- for i:=0 to GenEl.Declarations.Count-1 do
- begin
- GenDecl:=TPasElement(GenEl.Declarations[i]);
- if GenDecl.Parent<>GenEl then
- RaiseNotYetImplemented(20190806091336,GenEl,GetObjName(GenDecl));
- NewClass:=TPTreeElement(GenDecl.ClassType);
- NewDecl:=TPasElement(NewClass.Create(GenDecl.Name,SpecEl));
- SpecEl.Declarations.Add(NewDecl);
- if NewClass=TPasAttributes then
- SpecEl.Attributes.Add(NewDecl)
- else if (NewClass=TPasClassType)
- or (NewClass=TPasRecordType) then
- SpecEl.Classes.Add(NewDecl)
- else if NewClass=TPasConst then
- SpecEl.Consts.Add(NewDecl)
- else if NewClass=TPasExportSymbol then
- SpecEl.ExportSymbols.Add(NewDecl)
- else if NewClass.InheritsFrom(TPasProcedure) then
- SpecEl.Functions.Add(NewDecl)
- else if NewClass=TPasProperty then
- SpecEl.Properties.Add(NewDecl)
- else if NewClass=TPasResString then
- SpecEl.ResStrings.Add(NewDecl)
- else if NewClass.InheritsFrom(TPasType) then
- SpecEl.Types.Add(NewDecl)
- else if NewClass=TPasVariable then
- SpecEl.Variables.Add(NewDecl)
- else
- RaiseNotYetImplemented(20190804184718,GenDecl);
- SpecializeElement(GenDecl,NewDecl);
- end;
- end;
- procedure TPasResolver.SpecializeSpecializeType(GenEl,
- SpecEl: TPasSpecializeType);
- var
- GenDestType: TPasType;
- Ref: TPasElement;
- begin
- // search DestType<ParamCount>
- GenDestType:=GenEl.DestType;
- if GenDestType=nil then
- RaiseNotYetImplemented(20190812022211,GenEl);
- if GenDestType.Parent=GenEl then
- RaiseNotYetImplemented(20190812022251,GenEl);
- Ref:=FindElementFor(GenDestType.Name,GenEl.Parent,GenEl.Params.Count);
- if not (Ref is TPasGenericType) then
- RaiseNotYetImplemented(20190812022359,GenEl,GetObjName(Ref));
- SpecEl.DestType:=TPasGenericType(Ref);
- SpecEl.DestType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
- SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
- SpecializeElList(GenEl,SpecEl,GenEl.Params,SpecEl.Params,true
- {$IFDEF CheckPasTreeRefCount},'TPasSpecializeType.Params'{$ENDIF});
- FinishSpecializeType(SpecEl);
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.SpecializeSpecializeType ',GetObjName(SpecEl.DestType),' ',GetObjName(SpecEl.CustomData));
- {$ENDIF}
- end;
- procedure TPasResolver.SpecializeGenericTemplateType(GenEl,
- SpecEl: TPasGenericTemplateType);
- var
- GenConstraints, SpecConstraints: TPasElementArray;
- i: Integer;
- ConEl: TPasElement;
- begin
- GenConstraints:=GenEl.Constraints;
- if length(SpecEl.Constraints)>0 then
- RaiseNotYetImplemented(20190914070209,GenEl);
- SetLength(SpecEl.Constraints,length(GenConstraints));
- SpecConstraints:=SpecEl.Constraints;
- for i:=0 to length(SpecConstraints)-1 do
- SpecConstraints[i]:=nil;
- for i:=0 to length(GenConstraints)-1 do
- begin
- ConEl:=GenConstraints[i];
- if ConEl is TPasExpr then
- SpecializeElExpr(GenEl,SpecEl,TPasExpr(ConEl),TPasExpr(SpecConstraints[i]))
- else if ConEl is TPasType then
- SpecializeElType(GenEl,SpecEl,TPasType(ConEl),TPasType(SpecConstraints[i]))
- else
- RaiseNotYetImplemented(20190914070522,GenEl,IntToStr(i)+' '+GetObjName(ConEl));
- end;
- end;
- procedure TPasResolver.SpecializeArgument(GenEl, SpecEl: TPasArgument);
- begin
- SpecEl.Access:=GenEl.Access;
- SpecializeElType(GenEl,SpecEl,GenEl.ArgType,SpecEl.ArgType);
- if GenEl.ValueExpr<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.ValueExpr,SpecEl.ValueExpr);
- // FinishArgument is called when all arguments are ready
- end;
- procedure TPasResolver.SpecializeImplBlock(GenEl, SpecEl: TPasImplBlock);
- var
- i: Integer;
- GenImpl, NewImpl: TPasImplElement;
- NewClass: TPTreeElement;
- begin
- for i:=0 to GenEl.Elements.Count-1 do
- begin
- GenImpl:=TPasImplElement(GenEl.Elements[i]);
- if GenImpl.Parent<>GenEl then
- RaiseNotYetImplemented(20190806092151,GenEl,GetElementSourcePosStr(GenImpl));
- NewClass:=TPTreeElement(GenImpl.ClassType);
- NewImpl:=TPasImplElement(NewClass.Create(GenImpl.Name,SpecEl));
- SpecEl.Elements.Add(NewImpl);
- SpecializeElement(GenImpl,NewImpl);
- end;
- end;
- procedure TPasResolver.SpecializeImplAsmStatement(GenEl,
- SpecEl: TPasImplAsmStatement);
- begin
- SpecializeImplBlock(GenEl,SpecEl);
- SpecEl.Tokens.Assign(GenEl.Tokens);
- end;
- procedure TPasResolver.SpecializeImplRepeatUntil(GenEl,
- SpecEl: TPasImplRepeatUntil);
- begin
- SpecializeImplBlock(GenEl,SpecEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.ConditionExpr,SpecEl.ConditionExpr);
- end;
- procedure TPasResolver.SpecializeImplIfElse(GenEl, SpecEl: TPasImplIfElse);
- begin
- // do not call SpecializeImplBlock(GenEl,SpecEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.ConditionExpr,SpecEl.ConditionExpr);
- SpecializeElImplEl(GenEl,SpecEl,GenEl.IfBranch,SpecEl.IfBranch);
- SpecializeElImplEl(GenEl,SpecEl,GenEl.ElseBranch,SpecEl.ElseBranch);
- end;
- procedure TPasResolver.SpecializeImplWhileDo(GenEl, SpecEl: TPasImplWhileDo);
- begin
- // do not call SpecializeImplBlock(GenEl,SpecEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.ConditionExpr,SpecEl.ConditionExpr);
- SpecializeElImplEl(GenEl,SpecEl,GenEl.Body,SpecEl.Body);
- end;
- procedure TPasResolver.SpecializeImplWithDo(GenEl, SpecEl: TPasImplWithDo);
- var
- i: Integer;
- GenExpr, SpecExpr: TPasExpr;
- NewClass: TPTreeElement;
- begin
- if SpecEl.CustomData<>nil then
- RaiseNotYetImplemented(20200530201007,GenEl,GetObjName(SpecEl.CustomData));
- PushScope(SpecEl,TPasWithScope);
- for i:=0 to GenEl.Expressions.Count-1 do
- begin
- GenExpr:=TPasExpr(GenEl.Expressions[i]);
- if GenExpr.Parent<>GenEl then
- RaiseNotYetImplemented(20190808224343,GenEl,IntToStr(i));
- NewClass:=TPTreeElement(GenExpr.ClassType);
- SpecExpr:=TPasExpr(NewClass.Create(GenExpr.Name,SpecEl));
- SpecEl.Expressions.Add(SpecExpr);
- SpecializeElement(GenExpr,SpecExpr);
- BeginScope(stWithExpr,SpecExpr);
- end;
- SpecializeElImplEl(GenEl,SpecEl,GenEl.Body,SpecEl.Body);
- FinishWithDo(SpecEl);
- end;
- procedure TPasResolver.SpecializeImplCaseOf(GenEl, SpecEl: TPasImplCaseOf);
- begin
- SpecializeElExpr(GenEl,SpecEl,GenEl.CaseExpr,SpecEl.CaseExpr);
- SpecializeImplBlock(GenEl,SpecEl); // Elements
- if GenEl.ElseBranch<>nil then
- SpecializeElImplAlias(GenEl,SpecEl,GenEl.ElseBranch,TPasImplElement(SpecEl.ElseBranch)
- {$IFDEF CheckPasTreeRefCount},'TPasImplCaseOf.ElseBranch'{$ENDIF});
- end;
- procedure TPasResolver.SpecializeImplCaseStatement(GenEl,
- SpecEl: TPasImplCaseStatement);
- begin
- SpecializeElList(GenEl,SpecEl,GenEl.Expressions,SpecEl.Expressions,false
- {$IFDEF CheckPasTreeRefCount},'TPasImplCaseStatement.CaseExpr'{$ENDIF});
- SpecializeElImplEl(GenEl,SpecEl,GenEl.Body,SpecEl.Body);
- end;
- procedure TPasResolver.SpecializeImplAssign(GenEl, SpecEl: TPasImplAssign);
- begin
- if GenEl.Elements.Count>0 then
- RaiseNotYetImplemented(20190808142935,GenEl);
- SpecEl.Kind:=GenEl.Kind;
- SpecializeElExpr(GenEl,SpecEl,GenEl.left,SpecEl.left);
- SpecializeElExpr(GenEl,SpecEl,GenEl.right,SpecEl.right);
- end;
- procedure TPasResolver.SpecializeImplSimple(GenEl, SpecEl: TPasImplSimple);
- begin
- if GenEl.Elements.Count>0 then
- RaiseNotYetImplemented(20190808142935,GenEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
- end;
- procedure TPasResolver.SpecializeImplForLoop(GenEl, SpecEl: TPasImplForLoop);
- var
- i: Integer;
- GenImpl, NewImpl: TPasImplElement;
- NewClass: TPTreeElement;
- begin
- if GenEl.Variable<>nil then
- RaiseNotYetImplemented(20190808142627,GenEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.VariableName,SpecEl.VariableName);
- SpecEl.LoopType:=GenEl.LoopType;
- SpecializeElExpr(GenEl,SpecEl,GenEl.StartExpr,SpecEl.StartExpr);
- SpecializeElExpr(GenEl,SpecEl,GenEl.EndExpr,SpecEl.EndExpr);
- FinishForLoopHeader(SpecEl);
- // SpecEl.Body is set via AddElement
- for i:=0 to GenEl.Elements.Count-1 do
- begin
- GenImpl:=TPasImplElement(GenEl.Elements[i]);
- if GenImpl.Parent<>GenEl then
- RaiseNotYetImplemented(20190806092151,GenEl,GetElementSourcePosStr(GenImpl));
- NewClass:=TPTreeElement(GenImpl.ClassType);
- NewImpl:=TPasImplElement(NewClass.Create(GenImpl.Name,SpecEl));
- SpecEl.AddElement(NewImpl);
- SpecializeElement(GenImpl,NewImpl);
- end;
- end;
- procedure TPasResolver.SpecializeImplTry(GenEl, SpecEl: TPasImplTry);
- begin
- SpecializeImplBlock(GenEl,SpecEl); // clone elements
- if GenEl.FinallyExcept<>nil then
- SpecializeElImplEl(GenEl,SpecEl,GenEl.FinallyExcept,
- TPasImplElement(SpecEl.FinallyExcept));
- if GenEl.ElseBranch<>nil then
- SpecializeElImplEl(GenEl,SpecEl,GenEl.ElseBranch,
- TPasImplElement(SpecEl.ElseBranch));
- end;
- procedure TPasResolver.SpecializeImplExceptOn(GenEl, SpecEl: TPasImplExceptOn);
- var
- GenVar: TPasVariable;
- NewClass: TPTreeElement;
- begin
- GenVar:=GenEl.VarEl;
- if GenVar<>nil then
- begin
- if GenVar.Parent<>GenEl then
- RaiseNotYetImplemented(20190808232327,GenEl);
- NewClass:=TPTreeElement(GenVar.ClassType);
- SpecEl.VarEl:=TPasVariable(NewClass.Create(GenVar.Name,SpecEl));
- SpecializeElement(GenVar,SpecEl.VarEl);
- if GenVar.VarType<>GenEl.TypeEl then
- RaiseNotYetImplemented(20190808232601,GenEl);
- SpecEl.TypeEl:=SpecEl.VarEl.VarType;
- SpecEl.TypeEl.AddRef{$IFDEF CheckPasTreeRefCount}('TPasVariable.VarType'){$ENDIF};
- end
- else
- SpecializeElType(GenEl,SpecEl,GenEl.TypeEl,SpecEl.TypeEl);
- FinishExceptOnExpr;
- SpecializeElImplEl(GenEl,SpecEl,GenEl.Body,SpecEl.Body);
- FinishExceptOnStatement;
- end;
- procedure TPasResolver.SpecializeImplRaise(GenEl, SpecEl: TPasImplRaise);
- begin
- SpecializeElExpr(GenEl,SpecEl,GenEl.ExceptObject,SpecEl.ExceptObject);
- SpecializeElExpr(GenEl,SpecEl,GenEl.ExceptAddr,SpecEl.ExceptAddr);
- end;
- procedure TPasResolver.SpecializeExpr(GenEl, SpecEl: TPasExpr);
- begin
- SpecEl.Kind:=GenEl.Kind;
- SpecEl.OpCode:=GenEl.OpCode;
- SpecializeElExpr(GenEl,SpecEl,GenEl.format1,SpecEl.format1);
- SpecializeElExpr(GenEl,SpecEl,GenEl.format2,SpecEl.format2);
- end;
- procedure TPasResolver.SpecializeExprArray(GenEl, SpecEl: TPasElement;
- GenArray: TPasExprArray; var SpecArray: TPasExprArray);
- var
- i: Integer;
- begin
- if length(SpecArray)>0 then
- RaiseNotYetImplemented(20190808205855,GenEl);
- SetLength(SpecArray,length(GenArray));
- for i:=0 to length(SpecArray)-1 do
- SpecArray[i]:=nil;
- for i:=0 to length(GenArray)-1 do
- SpecializeElExpr(GenEl,SpecEl,GenArray[i],SpecArray[i]);
- end;
- procedure TPasResolver.SpecializePrimitiveExpr(GenEl, SpecEl: TPrimitiveExpr);
- begin
- SpecializeExpr(GenEl,SpecEl);
- SpecEl.Value:=GenEl.Value;
- end;
- procedure TPasResolver.SpecializeUnaryExpr(GenEl, SpecEl: TUnaryExpr);
- begin
- SpecializeExpr(GenEl,SpecEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.Operand,SpecEl.Operand);
- end;
- procedure TPasResolver.SpecializeBinaryExpr(GenEl, SpecEl: TBinaryExpr);
- begin
- SpecializeExpr(GenEl,SpecEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.left,SpecEl.left);
- SpecializeElExpr(GenEl,SpecEl,GenEl.right,SpecEl.right);
- end;
- procedure TPasResolver.SpecializeBoolConstExpr(GenEl, SpecEl: TBoolConstExpr);
- begin
- SpecializeExpr(GenEl,SpecEl);
- SpecEl.Value:=GenEl.Value;
- end;
- procedure TPasResolver.SpecializeParamsExpr(GenEl, SpecEl: TParamsExpr);
- begin
- SpecializeExpr(GenEl,SpecEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.Value,SpecEl.Value);
- SpecializeExprArray(GenEl,SpecEl,GenEl.Params,SpecEl.Params);
- end;
- procedure TPasResolver.SpecializeRecordValues(GenEl, SpecEl: TRecordValues);
- var
- GenField: TRecordValuesItem;
- i: Integer;
- SpecFieldP: PRecordValuesItem;
- begin
- SpecializeExpr(GenEl,SpecEl);
- // fields
- SetLength(SpecEl.Fields,length(GenEl.Fields));
- for i:=0 to length(SpecEl.Fields)-1 do
- with SpecEl.Fields[i] do
- begin
- NameExp:=nil;
- ValueExp:=nil;
- end;
- for i:=0 to length(GenEl.Fields)-1 do
- begin
- GenField:=GenEl.Fields[i];
- if GenField.NameExp.Parent<>GenEl then
- RaiseNotYetImplemented(20190808205128,GenEl);
- if GenField.ValueExp.Parent<>GenEl then
- RaiseNotYetImplemented(20190808205138,GenEl);
- SpecFieldP:[email protected][i];
- SpecializeElExpr(GenEl,SpecEl,GenField.NameExp,TPasExpr(SpecFieldP^.NameExp));
- SpecializeElExpr(GenEl,SpecEl,GenField.ValueExp,SpecFieldP^.ValueExp);
- end;
- end;
- procedure TPasResolver.SpecializeArrayValues(GenEl, SpecEl: TArrayValues);
- begin
- SpecializeExpr(GenEl,SpecEl);
- SpecializeExprArray(GenEl,SpecEl,GenEl.Values,SpecEl.Values);
- end;
- procedure TPasResolver.SpecializeInlineSpecializeExpr(GenEl,
- SpecEl: TInlineSpecializeExpr);
- begin
- SpecializeExpr(GenEl,SpecEl);
- SpecializeElExpr(GenEl,SpecEl,GenEl.NameExpr,SpecEl.NameExpr);
- SpecializeElList(GenEl,SpecEl,GenEl.Params,SpecEl.Params,
- true{$IFDEF CheckPasTreeRefCount},'TInlineSpecializeExpr.Params'{$ENDIF});
- end;
- procedure TPasResolver.SpecializeProcedureExpr(GenEl, SpecEl: TProcedureExpr);
- begin
- SpecializeExpr(GenEl,SpecEl);
- if GenEl.Proc=nil then
- RaiseNotYetImplemented(20190808221018,GenEl);
- RaiseNotYetImplemented(20190808221040,GenEl);
- end;
- procedure TPasResolver.SpecializeResString(GenEl, SpecEl: TPasResString);
- begin
- SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
- FinishResourcestring(SpecEl);
- end;
- procedure TPasResolver.SpecializeAliasType(GenEl, SpecEl: TPasAliasType);
- begin
- SpecializeElType(GenEl,SpecEl,GenEl.DestType,SpecEl.DestType);
- SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
- // not needed by specialize: FinishTypeAlias();
- FinishTypeDef(SpecEl);
- end;
- procedure TPasResolver.SpecializePointerType(GenEl, SpecEl: TPasPointerType);
- begin
- SpecializeElType(GenEl,SpecEl,GenEl.DestType,SpecEl.DestType);
- FinishPointerType(SpecEl);
- end;
- procedure TPasResolver.SpecializeRangeType(GenEl, SpecEl: TPasRangeType);
- begin
- SpecializeElExpr(GenEl,SpecEl,GenEl.RangeExpr,TPasExpr(SpecEl.RangeExpr));
- FinishRangeType(SpecEl);
- end;
- procedure TPasResolver.SpecializeArrayType(GenEl, SpecEl: TPasArrayType;
- SpecializedItem: TPRSpecializedTypeItem);
- var
- SpecScope: TPasGenericScope;
- begin
- SpecEl.IndexRange:=GenEl.IndexRange;
- SpecEl.PackMode:=GenEl.PackMode;
- if GenEl.GenericTemplateTypes<>nil then
- begin
- SpecScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_Array));
- if SpecializedItem<>nil then
- begin
- // specialized generic array
- SpecScope.SpecializedFromItem:=SpecializedItem;
- AddSpecializedTemplateIdentifiers(GenEl.GenericTemplateTypes,
- SpecializedItem,SpecScope,true);
- end
- else
- begin
- // generic arraytype inside a generic type
- RaiseNotYetImplemented(20190812225218,GenEl);
- end;
- end;
- SpecializeExprArray(GenEl,SpecEl,GenEl.Ranges,SpecEl.Ranges);
- SpecializeElType(GenEl,SpecEl,GenEl.ElType,SpecEl.ElType);
- FinishArrayType(SpecEl);
- if SpecializedItem<>nil then
- SpecializedItem.Step:=prssImplementationFinished;
- end;
- procedure TPasResolver.SpecializeRecordType(GenEl, SpecEl: TPasRecordType;
- SpecializedItem: TPRSpecializedTypeItem);
- var
- SpecScope: TPasGenericScope;
- begin
- SpecEl.PackMode:=GenEl.PackMode;
- if SpecializedItem<>nil then
- begin
- // specialized generic record
- if SpecEl.CustomData<>nil then
- RaiseNotYetImplemented(20190921204740,SpecEl);
- SpecScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_Record));
- SpecScope.VisibilityContext:=SpecEl;
- SpecScope.SpecializedFromItem:=SpecializedItem;
- AddSpecializedTemplateIdentifiers(GenEl.GenericTemplateTypes,
- SpecializedItem,SpecScope,true);
- if not (msDelphi in CurrentParser.CurrentModeswitches) then
- begin
- // ObjFPC: add canonical type alias
- SpecScope.AddIdentifier(GenEl.Name,SpecEl,pikSimple);
- end;
- end
- else if GenEl.GenericTemplateTypes.Count>0 then
- begin
- // generic recordtype inside a generic type
- if SpecEl.CustomData=nil then
- RaiseNotYetImplemented(20190815201634,SpecEl);
- SpecScope:=TPasGenericScope(SpecEl.CustomData);
- RaiseNotYetImplemented(20190815194327,GenEl);
- end;
- // specialize sub elements
- SpecializeMembers(GenEl,SpecEl);
- FinishRecordType(SpecEl);
- if SpecializedItem<>nil then
- SpecializedItem.Step:=prssInterfaceFinished;
- end;
- procedure TPasResolver.SpecializeClassType(GenEl, SpecEl: TPasClassType;
- SpecializedItem: TPRSpecializedTypeItem);
- var
- HeaderScope: TPasGenericParamsScope;
- TemplType: TPasGenericTemplateType;
- GenericTemplateTypes: TFPList;
- SpecClassScope: TPasClassScope;
- begin
- GenericTemplateTypes:=GenEl.GenericTemplateTypes;
- SpecEl.ObjKind:=GenEl.ObjKind;
- SpecEl.PackMode:=GenEl.PackMode;
- if GenEl.HelperForType<>nil then
- RaiseNotYetImplemented(20190730182758,GenEl,'');
- if GenEl.IsForward then
- RaiseNotYetImplemented(20190730182858,GenEl);
- SpecEl.IsExternal:=GenEl.IsExternal;
- SpecEl.IsShortDefinition:=GenEl.IsShortDefinition;
- if GenEl.GUIDExpr<>nil then
- SpecializeElExpr(GenEl,SpecEl,GenEl.GUIDExpr,SpecEl.GUIDExpr);
- SpecEl.Modifiers.Assign(GenEl.Modifiers);
- SpecEl.ExternalNameSpace:=GenEl.ExternalNameSpace;
- SpecEl.ExternalName:=GenEl.ExternalName;
- SpecEl.InterfaceType:=GenEl.InterfaceType;
- // ancestor+interfaces
- if SpecializedItem<>nil then
- begin
- // ancestor can be a specialized type. For example: = class(TAncestor<T>)
- // -> create a scope with the specialized parameters
- HeaderScope:=TPasGenericParamsScope.Create;
- SpecializedItem.HeaderScope:=HeaderScope;
- TemplType:=TPasGenericTemplateType(GenericTemplateTypes[0]);
- HeaderScope.Element:=TemplType;
- PushScope(HeaderScope);
- AddSpecializedTemplateIdentifiers(GenericTemplateTypes,
- SpecializedItem,HeaderScope,true);
- end
- else
- HeaderScope:=nil;
- SpecializeElType(GenEl,SpecEl,
- GenEl.AncestorType,SpecEl.AncestorType);
- SpecializeElList(GenEl,SpecEl,
- GenEl.Interfaces,SpecEl.Interfaces,true
- {$IFDEF CheckPasTreeRefCount},'TPasClassType.Interfaces'{$ENDIF});
- if HeaderScope<>nil then
- begin
- if TopScope<>HeaderScope then
- RaiseNotYetImplemented(20190813003056,GenEl);
- PopScope;
- SpecializedItem.HeaderScope:=nil;
- HeaderScope.Free;
- end;
- FinishAncestors(SpecEl);
- if GenEl.Interfaces.Count<>SpecEl.Interfaces.Count then
- RaiseNotYetImplemented(20200601125556,GenEl,IntToStr(GenEl.Interfaces.Count)+'<>'+IntToStr(SpecEl.Interfaces.Count));
- // Note: class scope was created by FinishAncestors
- SpecClassScope:=NoNil(SpecEl.CustomData) as TPasClassScope;
- if SpecClassScope.SpecializedFromItem<>nil then
- RaiseNotYetImplemented(20190816215413,SpecEl);
- if SpecializedItem<>nil then
- begin
- SpecClassScope.SpecializedFromItem:=SpecializedItem;
- AddSpecializedTemplateIdentifiers(GenericTemplateTypes,
- SpecializedItem,SpecClassScope,false);
- if not (msDelphi in CurrentParser.CurrentModeswitches) then
- begin
- // ObjFPC: add canonical type alias
- SpecClassScope.AddIdentifier(GenEl.Name,SpecEl,pikSimple);
- end;
- end;
- // specialize sub elements
- SpecializeMembers(GenEl,SpecEl);
- if SpecializedItem<>nil then
- SpecializedItem.Step:=prssInterfaceFinished;
- FinishClassType(SpecEl);
- end;
- procedure TPasResolver.SpecializeEnumValue(GenEl, SpecEl: TPasEnumValue);
- begin
- SpecializeElExpr(GenEl,SpecEl,GenEl.Value,SpecEl.Value);
- end;
- procedure TPasResolver.SpecializeEnumType(GenEl, SpecEl: TPasEnumType);
- begin
- SpecializeElList(GenEl,SpecEl,GenEl.Values,SpecEl.Values,false
- {$IFDEF CheckPasTreeRefCount},'TPasEnumType.Values'{$ENDIF});
- FinishEnumType(SpecEl);
- end;
- procedure TPasResolver.SpecializeSetType(GenEl, SpecEl: TPasSetType);
- begin
- SpecEl.IsPacked:=GenEl.IsPacked;
- SpecializeElType(GenEl,SpecEl,GenEl.EnumType,SpecEl.EnumType);
- FinishSetType(SpecEl);
- end;
- procedure TPasResolver.SpecializeVariant(GenEl, SpecEl: TPasVariant);
- begin
- SpecializeElList(GenEl,SpecEl,GenEl.Values,SpecEl.Values,false
- {$IFDEF CheckPasTreeRefCount},'TPasVariant.Values'{$ENDIF});
- RaiseNotYetImplemented(20190808214218,GenEl)
- //ToDo: Members: TPasRecordType;
- end;
- procedure TPasResolver.SpecializeStringType(GenEl, SpecEl: TPasStringType);
- begin
- SpecEl.LengthExpr:=GenEl.LengthExpr;
- FinishTypeDef(SpecEl);
- end;
- procedure TPasResolver.SpecializeAttributes(GenEl, SpecEl: TPasAttributes);
- begin
- SpecializeExprArray(GenEl,SpecEl,GenEl.Calls,SpecEl.Calls);
- FinishAttributes(SpecEl);
- end;
- procedure TPasResolver.SpecializeMethodResolution(GenEl,
- SpecEl: TPasMethodResolution);
- begin
- SpecEl.ProcClass:=GenEl.ProcClass;
- SpecializeElExpr(GenEl,SpecEl,GenEl.InterfaceName,SpecEl.InterfaceName);
- SpecializeElExpr(GenEl,SpecEl,GenEl.InterfaceProc,SpecEl.InterfaceProc);
- SpecializeElExpr(GenEl,SpecEl,GenEl.ImplementationProc,SpecEl.ImplementationProc);
- FinishMethodResolution(SpecEl);
- end;
- function TPasResolver.CheckAssignCompatibilityCustom(const LHS,
- RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean;
- var Handled: boolean): integer;
- // called when LHS or RHS BaseType is btCustom
- // if RaiseOnIncompatible=true you can raise an useful error.
- begin
- Result:=cIncompatible;
- if LHS.BaseType=btNone then ;
- if RHS.BaseType=btNone then ;
- if ErrorEl=nil then ;
- if RaiseOnIncompatible then ;
- if Handled then ;
- end;
- function TPasResolver.CheckEqualCompatibilityCustomType(const LHS,
- RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- begin
- Result:=cIncompatible;
- if LHS.BaseType=RHS.BaseType then;
- if ErrorEl=nil then;
- if RaiseOnIncompatible then ;
- end;
- function TPasResolver.BI_Length_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built in proc 'length'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- Ranges: TPasExprArray;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: string or dynamic array or type/const of static array
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if ParamResolved.BaseType in btAllStringAndChars then
- begin
- if rrfReadable in ParamResolved.Flags then
- Result:=cExact;
- end
- else if ParamResolved.BaseType=btContext then
- begin
- if (ParamResolved.LoTypeEl.ClassType=TPasArrayType) then
- begin
- Ranges:=TPasArrayType(ParamResolved.LoTypeEl).Ranges;
- if length(Ranges)=0 then
- begin
- if rrfReadable in ParamResolved.Flags then
- Result:=cExact;
- end
- else
- // static array
- Result:=cExact;
- end;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170329160335,1,Param,ParamResolved,
- 'string or dynamic array',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_Length_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- begin
- if Params=nil then ;
- SetResolverIdentifier(ResolvedEl,BaseTypeLength,Proc.Proc,
- FBaseTypes[BaseTypeLength],FBaseTypes[BaseTypeLength],[rrfReadable]);
- end;
- procedure TPasResolver.BI_Length_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- Param, Expr: TPasExpr;
- ParamResolved: TPasResolverResult;
- Value: TResEvalValue;
- Ranges: TPasExprArray;
- IdentEl: TPasElement;
- begin
- Evaluated:=nil;
- // first param: string or dynamic array or type/const of static array
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- if ParamResolved.BaseType in btAllStringAndChars then
- begin
- if rrfReadable in ParamResolved.Flags then
- begin
- Value:=Eval(Param,Flags);
- if Value=nil then exit;
- case Value.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- Evaluated:=TResEvalInt.CreateValue(length(TResEvalString(Value).S));
- {$endif}
- revkUnicodeString:
- Evaluated:=TResEvalInt.CreateValue(length(TResEvalUTF16(Value).S));
- end;
- ReleaseEvalValue(Value);
- end
- end
- else if ParamResolved.BaseType=btContext then
- begin
- if (ParamResolved.LoTypeEl.ClassType=TPasArrayType) then
- begin
- Ranges:=TPasArrayType(ParamResolved.LoTypeEl).Ranges;
- if length(Ranges)=0 then
- begin
- // open or dynamic array
- IdentEl:=ParamResolved.IdentEl;
- if (IdentEl is TPasVariable)
- and (TPasVariable(IdentEl).Expr is TPasExpr) then
- begin
- Expr:=TPasVariable(IdentEl).Expr;
- if Expr is TArrayValues then
- Evaluated:=TResEvalInt.CreateValue(length(TArrayValues(Expr).Values))
- else if (Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
- Evaluated:=TResEvalInt.CreateValue(length(TParamsExpr(Expr).Params));
- end;
- end
- else
- begin
- // static array
- Evaluated:=TResEvalInt.CreateValue(GetRangeLength(Ranges[0]));
- end;
- end;
- end;
- if Proc=nil then ;
- end;
- function TPasResolver.BI_SetLength_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built in proc 'setlength'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved, DimResolved: TPasResolverResult;
- ArgNo: Integer;
- DynArr: TPasArrayType;
- ElType: TPasType;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,2,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: string or array variable
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- Result:=cIncompatible;
- DynArr:=nil;
- if ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if ParamResolved.BaseType in btAllStrings then
- Result:=cExact
- else if ParamResolved.BaseType=btContext then
- begin
- if IsDynArray(ParamResolved.LoTypeEl) then
- begin
- Result:=cExact;
- DynArr:=NoNil(ParamResolved.LoTypeEl) as TPasArrayType;
- end;
- end;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170216152250,1,Param,ParamResolved,
- 'string or dynamic array variable',RaiseOnError));
- // second param: new length
- ArgNo:=2;
- repeat
- Param:=Params.Params[ArgNo-1];
- ComputeElement(Param,DimResolved,[]);
- Result:=cIncompatible;
- if (rrfReadable in DimResolved.Flags)
- and (DimResolved.BaseType in btAllInteger) then
- Result:=cExact;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170329160338,ArgNo,Param,DimResolved,
- 'integer',RaiseOnError));
- if (DynArr=nil) or (ArgNo=length(Params.Params)) then break;
- ElType:=ResolveAliasType(DynArr.ElType);
- if not IsDynArray(ElType) then break;
- DynArr:=NoNil(ElType) as TPasArrayType;
- inc(ArgNo);
- until false;
- Result:=CheckBuiltInMaxParamCount(Proc,Params,ArgNo,RaiseOnError);
- end;
- procedure TPasResolver.BI_SetLength_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- var
- P: TPasExprArray;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- if P=nil then ;
- FinishCallArgAccess(P[0],rraVarParam);
- FinishCallArgAccess(P[1],rraRead);
- end;
- function TPasResolver.BI_InExclude_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built in proc 'include'
- var
- Params: TParamsExpr;
- Param0, Param1: TPasExpr;
- Param0Resolved, Param1Resolved: TPasResolverResult;
- EnumType: TPasEnumType;
- C: TClass;
- LoTypeEl: TPasType;
- RgType: TPasRangeType;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,2,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first Param0: set variable
- // todo set of int, set of char, set of bool
- Param0:=Params.Params[0];
- ComputeElement(Param0,Param0Resolved,[rcNoImplicitProc]);
- Param1:=Params.Params[1];
- ComputeElement(Param1,Param1Resolved,[]);
- EnumType:=nil;
- RgType:=nil;
- if ([rrfReadable,rrfWritable]*Param0Resolved.Flags=[rrfReadable,rrfWritable])
- and (Param0Resolved.IdentEl<>nil) then
- begin
- C:=Param0Resolved.IdentEl.ClassType;
- if (C.InheritsFrom(TPasVariable)
- or (C=TPasArgument)
- or (C=TPasResultElement)) then
- begin
- if Param0Resolved.BaseType=btSet then
- begin
- LoTypeEl:=Param0Resolved.LoTypeEl;
- if LoTypeEl.ClassType=TPasEnumType then
- begin
- EnumType:=TPasEnumType(LoTypeEl);
- if (not (rrfReadable in Param0Resolved.Flags))
- or (Param0Resolved.LoTypeEl<>EnumType) then
- begin
- if RaiseOnError then
- RaiseIncompatibleType(20210201225926,nIncompatibleTypeArgNo,
- ['2'],Param0Resolved.LoTypeEl,EnumType,Param0);
- exit(cIncompatible);
- end;
- end
- else if LoTypeEl.ClassType=TPasRangeType then
- begin
- RgType:=TPasRangeType(LoTypeEl);
- ComputeElement(RgType.RangeExpr.left,Param0Resolved,[]);
- Result:=CheckAssignResCompatibility(Param0Resolved,Param1Resolved,Param1,RaiseOnError);
- end;
- end;
- end;
- end;
- if (EnumType=nil) and (RgType=nil) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnGetCallCompatibility_InExclude ',GetResolverResultDbg(Param0Resolved));
- {$ENDIF}
- exit(CheckRaiseTypeArgNo(20170216152301,1,Param0,Param0Resolved,
- 'variable of set of enumtype',RaiseOnError));
- end;
- Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError);
- end;
- procedure TPasResolver.BI_InExclude_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- var
- P: TPasExprArray;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- if P=nil then ;
- FinishCallArgAccess(P[0],rraVarParam);
- FinishCallArgAccess(P[1],rraRead);
- end;
- function TPasResolver.BI_Break_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- begin
- if GetLoop(Expr)=nil then
- RaiseMsg(20170216152306,nMustBeInsideALoop,sMustBeInsideALoop,['Break'],Expr);
- if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then
- exit(cExact);
- Params:=TParamsExpr(Expr);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnGetCallCompatibility_Break Params=',length(Params.Params));
- {$ENDIF}
- Result:=CheckBuiltInMaxParamCount(Proc,Params,0,RaiseOnError);
- end;
- function TPasResolver.BI_Continue_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- begin
- if GetLoop(Expr)=nil then
- RaiseMsg(20170216152309,nMustBeInsideALoop,sMustBeInsideALoop,['Continue'],Expr);
- if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then
- exit(cExact);
- Params:=TParamsExpr(Expr);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnGetCallCompatibility_Continue Params=',length(Params.Params));
- {$ENDIF}
- Result:=CheckBuiltInMaxParamCount(Proc,Params,0,RaiseOnError);
- end;
- function TPasResolver.BI_Exit_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved, ResultResolved: TPasResolverResult;
- i: Integer;
- ProcScope: TPasProcedureScope;
- ResultEl: TPasResultElement;
- Flags: TPasResolverComputeFlags;
- CtxProc: TPasProcedure;
- begin
- if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then
- exit(cExact);
- Params:=TParamsExpr(Expr);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnGetCallCompatibility_Exit Params=',length(Params.Params));
- {$ENDIF}
- // first param: result
- Param:=Params.Params[0];
- Result:=cIncompatible;
- i:=ScopeCount-1;
- while (i>0) and (not (Scopes[i] is TPasProcedureScope)) do dec(i);
- if i>0 then
- begin
- // inside procedure: first param is function result
- ProcScope:=TPasProcedureScope(Scopes[i]);
- if ProcScope.DeclarationProc<>nil then
- CtxProc:=ProcScope.DeclarationProc
- else
- CtxProc:=TPasProcedure(ProcScope.Element);
- if not (CtxProc.ProcType is TPasFunctionType) then
- begin
- if RaiseOnError then
- RaiseMsg(20170216152312,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,['procedure exit'],Params.Params[0]);
- exit(cIncompatible);
- end;
- ResultEl:=TPasFunctionType(CtxProc.ProcType).ResultEl;
- ComputeResultElement(ResultEl,ResultResolved,[],Expr);
- end
- else
- begin
- // default: main program, param is an integer
- SetResolverTypeExpr(ResultResolved,btLongint,FBaseTypes[btLongint],FBaseTypes[btLongint],
- [rrfReadable,rrfWritable]);
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnGetCallCompatibility_Exit ResultResolved=',GetResolverResultDbg(ResultResolved));
- {$ENDIF}
- Flags:=[];
- if IsProcedureType(ResultResolved,true) then
- Include(Flags,rcNoImplicitProc);
- ComputeElement(Param,ParamResolved,Flags);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnGetCallCompatibility_Exit ParamResolved=',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- if rrfReadable in ParamResolved.Flags then
- Result:=CheckAssignResCompatibility(ResultResolved,ParamResolved,Param,false);
- if Result=cIncompatible then
- begin
- if RaiseOnError then
- RaiseIncompatibleTypeRes(20170216152314,nIncompatibleTypeArgNo,
- ['1'],ParamResolved,ResultResolved,Param);
- exit;
- end;
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- function TPasResolver.BI_IncDec_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved, IncrResolved: TPasResolverResult;
- TypeEl: TPasType;
- bt: TResolverBaseType;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: var Integer
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_IncDec_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- Result:=cIncompatible;
- // Expr must be a variable
- if not ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if RaiseOnError then
- RaiseVarExpected(20170216152319,Expr,ParamResolved.IdentEl);
- exit;
- end;
- bt:=ParamResolved.BaseType;
- if bt=btRange then
- bt:=ParamResolved.SubType;
- if bt in btAllInteger then
- Result:=cExact
- else if bt=btPointer then
- begin
- if ElHasBoolSwitch(Expr,bsPointerMath) then
- Result:=cExact;
- end
- else if bt=btContext then
- begin
- TypeEl:=ParamResolved.LoTypeEl;
- if (TypeEl.ClassType=TPasPointerType)
- and ElHasBoolSwitch(Expr,bsPointerMath) then
- Result:=cExact
- else if TypeEl.ClassType=TPasRangeType then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170216152320,1,Param,ParamResolved,'integer',RaiseOnError));
- if length(Params.Params)=1 then
- exit;
- // second param: increment/decrement
- Param:=Params.Params[1];
- ComputeElement(Param,IncrResolved,[]);
- Result:=cIncompatible;
- if rrfReadable in IncrResolved.Flags then
- begin
- if IncrResolved.BaseType in btAllInteger then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170216152322,2,Param,IncrResolved,'integer',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError);
- end;
- procedure TPasResolver.BI_IncDec_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- var
- P: TPasExprArray;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- FinishCallArgAccess(P[0],rraVarParam);
- if Length(P)>1 then
- FinishCallArgAccess(P[1],rraRead);
- end;
- function TPasResolver.BI_Assigned_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built in proc 'Assigned'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- C: TClass;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: pointer, class, class instance, proc type or array
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProcType]);
- Result:=cIncompatible;
- if ParamResolved.BaseType in [btNil,btPointer] then
- Result:=cExact
- else if (ParamResolved.BaseType=btContext) then
- begin
- C:=ParamResolved.LoTypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or C.InheritsFrom(TPasProcedureType)
- or ((C=TPasArrayType) and (length(TPasArrayType(ParamResolved.LoTypeEl).Ranges)=0)) then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170216152329,1,Param,ParamResolved,'class or array',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_Assigned_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- begin
- SetResolverIdentifier(ResolvedEl,btBoolean,Proc.Proc,
- FBaseTypes[btBoolean],FBaseTypes[btBoolean],[rrfReadable]);
- if Params=nil then ;
- end;
- procedure TPasResolver.BI_Assigned_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- var
- P: TPasExpr;
- ResolvedEl: TPasResolverResult;
- begin
- if Proc=nil then ;
- P:=Params.Params[0];
- AccessExpr(P,rraRead);
- ComputeElement(P,ResolvedEl,[rcNoImplicitProcType,rcSetReferenceFlags]);
- end;
- function TPasResolver.BI_Chr_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: integer
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if rrfReadable in ParamResolved.Flags then
- begin
- if ParamResolved.BaseType in btAllInteger then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170325185321,1,Param,ParamResolved,'integer',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_Chr_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- begin
- SetResolverIdentifier(ResolvedEl,BaseTypeChar,Proc.Proc,
- FBaseTypes[BaseTypeChar],FBaseTypes[BaseTypeChar],[rrfReadable]);
- if Params=nil then ;
- end;
- procedure TPasResolver.BI_Chr_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- Param: TPasExpr;
- Value: TResEvalValue;
- begin
- Evaluated:=nil;
- Param:=Params.Params[0];
- Value:=Eval(Param,Flags);
- {$IFDEF VerbosePasResEval}
- {AllowWriteln}
- if Value=nil then
- writeln('TPasResolver.BI_Chr_OnEval Value=NIL')
- else
- writeln('TPasResolver.BI_Chr_OnEval Value=',Value.AsDebugString);
- {AllowWriteln-}
- {$ENDIF}
- if Value=nil then exit;
- try
- Evaluated:=fExprEvaluator.ChrValue(Value,Params);
- finally
- ReleaseEvalValue(Value);
- end;
- if Proc=nil then ;
- end;
- function TPasResolver.BI_Ord_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved, ResolvedEl: TPasResolverResult;
- TypeEl: TPasType;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: bool, integer, enum or char
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if rrfReadable in ParamResolved.Flags then
- begin
- if ParamResolved.BaseType in btArrayRangeTypes then
- Result:=cExact
- else if (ParamResolved.BaseType=btContext) and (ParamResolved.LoTypeEl is TPasEnumType) then
- Result:=cExact
- else if ParamResolved.BaseType=btRange then
- begin
- if ParamResolved.SubType in btArrayRangeTypes then
- Result:=cExact
- else if ParamResolved.SubType=btContext then
- begin
- TypeEl:=ParamResolved.LoTypeEl;
- if TypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(TypeEl).RangeExpr.left,ResolvedEl,[rcConstant]);
- if ResolvedEl.LoTypeEl.ClassType=TPasEnumType then
- exit(cExact);
- end;
- end;
- end;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170216152334,1,Param,ParamResolved,'enum or char',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_Ord_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- begin
- SetResolverIdentifier(ResolvedEl,btLongint,Proc.Proc,
- FBaseTypes[btLongint],FBaseTypes[btLongint],[rrfReadable]);
- if Params=nil then ;
- end;
- procedure TPasResolver.BI_Ord_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- Param: TPasExpr;
- Value: TResEvalValue;
- begin
- Evaluated:=nil;
- Param:=Params.Params[0];
- Value:=Eval(Param,Flags);
- {$IFDEF VerbosePasResEval}
- {AllowWriteln}
- if Value=nil then
- writeln('TPasResolver.BI_Ord_OnEval Value=NIL')
- else
- writeln('TPasResolver.BI_Ord_OnEval Value=',Value.AsDebugString);
- {AllowWriteln-}
- {$ENDIF}
- if Value=nil then exit;
- try
- Evaluated:=fExprEvaluator.OrdValue(Value,Params);
- finally
- ReleaseEvalValue(Value);
- end;
- if Proc=nil then ;
- end;
- function TPasResolver.BI_LowHigh_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built in proc 'Low' or 'High'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- C: TClass;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: enumtype, range, built-in ordinal type (char, longint, ...)
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if ParamResolved.BaseType in btAllRanges then
- // e.g. high(char)
- Result:=cExact
- else if ParamResolved.BaseType=btSet then
- Result:=cExact
- else if (ParamResolved.BaseType=btContext) then
- begin
- C:=ParamResolved.LoTypeEl.ClassType;
- if (C=TPasArrayType)
- or (C=TPasSetType)
- or (C=TPasEnumType) then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_LowHigh_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- exit(CheckRaiseTypeArgNo(20170216152338,1,Param,ParamResolved,'ordinal type, array or set',RaiseOnError));
- end;
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_LowHigh_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- var
- ArrayEl: TPasArrayType;
- Param: TPasExpr;
- TypeEl: TPasType;
- begin
- Param:=Params.Params[0];
- ComputeElement(Param,ResolvedEl,[]);
- if ResolvedEl.BaseType=btContext then
- begin
- TypeEl:=ResolvedEl.LoTypeEl;
- if TypeEl.ClassType=TPasArrayType then
- begin
- // array: result type is type of first dimension
- ArrayEl:=TPasArrayType(TypeEl);
- if length(ArrayEl.Ranges)=0 then
- SetResolverIdentifier(ResolvedEl,BaseTypeLength,Proc.Proc,
- FBaseTypes[BaseTypeLength],FBaseTypes[BaseTypeLength],[rrfReadable])
- else
- begin
- ComputeElement(ArrayEl.Ranges[0],ResolvedEl,[rcConstant]);
- if ResolvedEl.BaseType=btRange then
- ConvertRangeToElement(ResolvedEl);
- end;
- end
- else if TypeEl.ClassType=TPasSetType then
- begin
- ResolvedEl.LoTypeEl:=TPasSetType(TypeEl).EnumType;
- ResolvedEl.HiTypeEl:=ResolvedEl.LoTypeEl;
- end;
- end
- else if ResolvedEl.BaseType=btSet then
- begin
- ResolvedEl.BaseType:=ResolvedEl.SubType;
- ResolvedEl.SubType:=btNone;
- end
- else
- ;// ordinal: result type is argument type
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable]+[rrfReadable];
- end;
- procedure TPasResolver.BI_LowHigh_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- function IsDynArrayConstExpr(IdentEl: TPasElement): boolean;
- begin
- Result:=false;
- if not (IdentEl is TPasVariable) then exit;
- if not (TPasVariable(IdentEl).Expr is TPasExpr) then exit;
- if (IdentEl.ClassType=TPasConst) and TPasConst(IdentEl).IsConst then
- exit(true);
- if fExprEvaluator.IsConst(Params) then
- exit(true); // a const refers an initial value
- end;
- var
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- var
- TypeEl: TPasType;
- ArrayEl: TPasArrayType;
- Value: TResEvalValue;
- EnumType: TPasEnumType;
- aSet: TResEvalSet;
- bt: TResolverBaseType;
- Int, MinInt, MaxInt: TMaxPrecInt;
- i: Integer;
- Expr: TPasExpr;
- begin
- Evaluated:=nil;
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- TypeEl:=ParamResolved.LoTypeEl;
- if ParamResolved.BaseType=btContext then
- begin
- if TypeEl.ClassType=TPasArrayType then
- begin
- // array: low/high of first dimension
- ArrayEl:=TPasArrayType(TypeEl);
- if length(ArrayEl.Ranges)=0 then
- begin
- // dyn or open array
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalInt.CreateValue(0)
- else if IsDynArrayConstExpr(ParamResolved.IdentEl) then
- begin
- Expr:=TPasVariable(ParamResolved.IdentEl).Expr;
- if Expr is TArrayValues then
- Evaluated:=TResEvalInt.CreateValue(TMaxPrecInt(length(TArrayValues(Expr).Values))-1)
- else if (Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
- Evaluated:=TResEvalInt.CreateValue(TMaxPrecInt(length(TParamsExpr(Expr).Params))-1);
- if Evaluated=nil then
- RaiseXExpectedButYFound(20170601191003,'array constant','expression',Params);
- end
- else
- exit;
- end
- else
- begin
- // static array
- Evaluated:=EvalRangeLimit(ArrayEl.Ranges[0],Flags,Proc.BuiltIn=bfLow,Param);
- end;
- end
- else if TypeEl.ClassType=TPasSetType then
- begin
- // set: first/last enum
- TypeEl:=TPasSetType(TypeEl).EnumType;
- if TypeEl.ClassType=TPasEnumType then
- begin
- EnumType:=TPasEnumType(TPasSetType(TypeEl).EnumType);
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalEnum.CreateValue(0,TPasEnumValue(EnumType.Values[0]))
- else
- Evaluated:=TResEvalEnum.CreateValue(EnumType.Values.Count-1,
- TPasEnumValue(EnumType.Values[EnumType.Values.Count-1]));
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_LowHigh_OnEval ',GetResolverResultDbg(ParamResolved),' TypeEl=',TypeEl.ClassName);
- {$ENDIF}
- RaiseNotYetImplemented(20170601203026,Params);
- end;
- end
- else if TypeEl.ClassType=TPasEnumType then
- begin
- EnumType:=TPasEnumType(TypeEl);
- if Proc.BuiltIn=bfLow then
- i:=0
- else
- i:=EnumType.Values.Count-1;
- Evaluated:=TResEvalEnum.CreateValue(i,TPasEnumValue(EnumType.Values[i]))
- end;
- end
- else if ParamResolved.BaseType=btSet then
- begin
- Value:=Eval(Param,Flags);
- if Value=nil then exit;
- case Value.Kind of
- revkSetOfInt:
- begin
- aSet:=TResEvalSet(Value);
- if length(aSet.Ranges)=0 then
- RaiseXExpectedButYFound(20170601201637,'ordinal value',Value.AsString,Param);
- if Proc.BuiltIn=bfLow then
- Int:=aSet.RangeStart
- else
- Int:=aSet.RangeEnd;
- case aSet.ElKind of
- revskEnum:
- begin
- EnumType:=aSet.IdentEl as TPasEnumType;
- Evaluated:=TResEvalEnum.CreateValue(Int,TPasEnumValue(EnumType.Values[Int]));
- end;
- revskInt:
- Evaluated:=TResEvalInt.CreateValue(Int);
- revskChar:
- {$ifdef FPC_HAS_CPSTRING}
- if Int<256 then
- Evaluated:=TResEvalString.CreateValue(chr(Int))
- else
- {$endif}
- Evaluated:=TResEvalUTF16.CreateValue(widechar(Int));
- revskBool:
- if Int=0 then
- Evaluated:=TResEvalBool.CreateValue(false)
- else
- Evaluated:=TResEvalBool.CreateValue(true)
- end;
- end;
- else
- RaiseXExpectedButYFound(20170601201237,'ordinal value',Value.AsString,Param);
- end;
- end
- else if (TypeEl is TPasUnresolvedSymbolRef)
- and (TypeEl.CustomData is TResElDataBaseType) then
- begin
- // low,high(base type)
- bt:=TResElDataBaseType(TypeEl.CustomData).BaseType;
- bt:=GetActualBaseType(bt);
- if bt in btAllBooleans then
- Evaluated:=TResEvalBool.CreateValue(Proc.BuiltIn=bfHigh)
- {$ifdef HasInt64}
- else if bt=btQWord then
- begin
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalInt.CreateValue(0)
- else
- Evaluated:=TResEvalUInt.CreateValue(High(QWord));
- end
- {$endif}
- else if (bt in btAllIntegerNoQWord) and GetIntegerRange(bt,MinInt,MaxInt) then
- begin
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalInt.CreateValue(MinInt)
- else
- Evaluated:=TResEvalInt.CreateValue(MaxInt);
- end
- {$ifdef FPC_HAS_CPSTRING}
- else if bt=btAnsiChar then
- begin
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalString.CreateValue(#0)
- else
- Evaluated:=TResEvalString.CreateValue(#255);
- end
- {$endif}
- else if bt=btWideChar then
- begin
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalUTF16.CreateValue(#0)
- else
- Evaluated:=TResEvalUTF16.CreateValue(#$ffff);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_LowHigh_OnEval ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseNotYetImplemented(20170602070738,Params);
- end;
- end
- else if ParamResolved.LoTypeEl is TPasRangeType then
- begin
- // e.g. type t = 2..10;
- Evaluated:=EvalRangeLimit(TPasRangeType(TypeEl).RangeExpr,FLags,Proc.BuiltIn=bfLow,Param);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_LowHigh_OnEval ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseNotYetImplemented(20170601202353,Params);
- end;
- {$IFDEF VerbosePasResEval}
- {AllowWriteln}
- if Evaluated=nil then
- writeln('TPasResolver.BI_LowHigh_OnEval END ResolvedEl=',GetResolverResultDbg(ParamResolved),' Evaluated NO SET')
- else
- writeln('TPasResolver.BI_LowHigh_OnEval END ResolvedEl=',GetResolverResultDbg(ParamResolved),' Evaluated=',Evaluated.AsDebugString);
- {AllowWriteln-}
- {$ENDIF}
- end;
- function TPasResolver.BI_PredSucc_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built in proc 'Pred' or 'Succ'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: enum, range, set, char or integer
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if CheckIsOrdinal(ParamResolved,Param,false) then
- Result:=cExact;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170216152343,1,Param,ParamResolved,'ordinal',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_PredSucc_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- begin
- ComputeElement(Params.Params[0],ResolvedEl,[]);
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable];
- if Proc=nil then ;
- end;
- procedure TPasResolver.BI_PredSucc_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- Param: TPasExpr;
- begin
- //writeln('TPasResolver.BI_PredSucc_OnEval START');
- Evaluated:=nil;
- Param:=Params.Params[0];
- Evaluated:=Eval(Param,Flags);
- //writeln('TPasResolver.BI_PredSucc_OnEval Param=',Evaluated<>nil);
- if Evaluated=nil then exit;
- //writeln('TPasResolver.BI_PredSucc_OnEval Param=',Evaluated.AsString);
- if Evaluated.Element<>nil then
- Evaluated:=Evaluated.Clone;
- if Proc.BuiltIn=bfPred then
- fExprEvaluator.PredValue(Evaluated,Params)
- else
- fExprEvaluator.SuccValue(Evaluated,Params);
- end;
- function TPasResolver.BI_Str_CheckParam(IsFunc: boolean; Param: TPasExpr;
- const ParamResolved: TPasResolverResult; ArgNo: integer; RaiseOnError: boolean
- ): integer;
- function CheckFormat(FormatExpr: TPasExpr; Index: integer;
- const ParamResolved: TPasResolverResult): boolean;
- var
- ResolvedEl: TPasResolverResult;
- Ok: Boolean;
- begin
- if FormatExpr=nil then exit(true);
- Result:=false;
- Ok:=false;
- if ParamResolved.BaseType in btAllFloats then
- // floats supports value:Width:Precision
- Ok:=true
- else
- // all other only support value:Width
- Ok:=Index<2;
- if not Ok then
- begin
- if RaiseOnError then
- RaiseMsg(20170319222319,nIllegalExpression,sIllegalExpression,[],FormatExpr);
- exit;
- end;
- ComputeElement(FormatExpr,ResolvedEl,[]);
- if not (ResolvedEl.BaseType in btAllInteger) then
- begin
- if RaiseOnError then
- RaiseXExpectedButYFound(20170319221515,
- 'integer',GetResolverResultDescription(ResolvedEl,true),FormatExpr);
- exit;
- end;
- if not (rrfReadable in ResolvedEl.Flags) then
- begin
- if RaiseOnError then
- RaiseMsg(20170319221755,nNotReadable,sNotReadable,[],FormatExpr);
- exit;
- end;
- Result:=true;
- end;
- var
- bt: TResolverBaseType;
- C: TClass;
- begin
- Result:=cIncompatible;
- bt:=ParamResolved.BaseType;
- if bt=btRange then
- bt:=ParamResolved.SubType;
- if bt in (btAllInteger+btAllBooleans+btAllFloats) then
- Result:=cExact
- else if IsFunc and (bt in btAllStringAndChars) then
- Result:=cExact
- else if bt=btContext then
- begin
- C:=ParamResolved.LoTypeEl.ClassType;
- if (C=TPasEnumType) or (C=TPasRangeType) then
- Result:=cExact
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170319220517,ArgNo,Param,ParamResolved,'boolean, integer, enum value',RaiseOnError));
- if not CheckFormat(Param.format1,1,ParamResolved) then
- exit(cIncompatible);
- if not CheckFormat(Param.format2,2,ParamResolved) then
- exit(cIncompatible);
- end;
- function TPasResolver.BI_StrProc_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built-in procedure 'Str'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,2,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- if ParentNeedsExprResult(Params) then
- begin
- if RaiseOnError then
- RaiseMsg(20170326084331,nIncompatibleTypesGotExpected,
- sIncompatibleTypesGotExpected,['procedure str','function str'],Params);
- exit(cIncompatible);
- end;
- // first param: boolean, integer, enum, class instance
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=BI_Str_CheckParam(false,Param,ParamResolved,1,RaiseOnError);
- if Result=cIncompatible then
- exit;
- // second parameter: string variable
- Param:=Params.Params[1];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if ParamResolved.BaseType in btAllStrings then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170319220806,1,Param,ParamResolved,'string variable',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError);
- end;
- procedure TPasResolver.BI_StrProc_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr);
- var
- P: TPasExprArray;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- if P=nil then ;
- FinishCallArgAccess(P[0],rraRead);
- FinishCallArgAccess(P[1],rraVarParam);
- end;
- function TPasResolver.BI_StrFunc_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- i: Integer;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- if not ParentNeedsExprResult(Params) then
- begin
- // not in an expression -> the 'procedure str' is needed, not the 'function str'
- if RaiseOnError then
- RaiseMsg(20170326084622,nIncompatibleTypesGotExpected,
- sIncompatibleTypesGotExpected,['function str','procedure str'],Params);
- exit(cIncompatible);
- end;
- // param: string, boolean, integer, enum, class instance
- for i:=0 to length(Params.Params)-1 do
- begin
- Param:=Params.Params[i];
- ComputeElement(Param,ParamResolved,[]);
- Result:=BI_Str_CheckParam(true,Param,ParamResolved,i+1,RaiseOnError);
- if Result=cIncompatible then
- exit;
- end;
- Result:=cExact;
- end;
- procedure TPasResolver.BI_StrFunc_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- begin
- SetResolverIdentifier(ResolvedEl,btString,Proc.Proc,
- FBaseTypes[btString],FBaseTypes[btString],[rrfReadable]);
- if Params=nil then ;
- if Proc=nil then ;
- end;
- procedure TPasResolver.BI_StrFunc_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- begin
- Evaluated:=fExprEvaluator.EvalStrFunc(Params,Flags);
- if Proc=nil then ;
- end;
- function TPasResolver.BI_WriteStrProc_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built-in procedure 'Str'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- i: Integer;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,2,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first parameter: string variable
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if ParamResolved.BaseType in btAllStrings then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20180527190304,1,Param,ParamResolved,'string variable',RaiseOnError));
- // other parameters: boolean, integer, enum, class instance
- for i:=1 to length(Params.Params)-1 do
- begin
- Param:=Params.Params[i];
- ComputeElement(Param,ParamResolved,[]);
- Result:=BI_Str_CheckParam(false,Param,ParamResolved,i,RaiseOnError);
- if Result=cIncompatible then
- exit;
- end;
- end;
- procedure TPasResolver.BI_WriteStrProc_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- var
- P: TPasExprArray;
- i: Integer;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- if P=nil then ;
- FinishCallArgAccess(P[0],rraOutParam);
- for i:=0 to length(Params.Params)-1 do
- FinishCallArgAccess(P[i],rraRead);
- end;
- function TPasResolver.BI_Val_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built-in procedure 'Val(const s: string; out v: valtype; out code: integer)'
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- bt: TResolverBaseType;
- C: TClass;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,3,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first parameter: string
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if ParamResolved.BaseType in btAllStrings then
- Result:=cExact;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20181214141250,1,Param,ParamResolved,'string',RaiseOnError));
- // second parameter: var value
- Param:=Params.Params[1];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- bt:=ParamResolved.BaseType;
- if bt=btRange then
- bt:=ParamResolved.SubType;
- if bt in (btAllInteger+btAllBooleans+btAllFloats) then
- Result:=cExact
- else if bt=btContext then
- begin
- C:=ParamResolved.LoTypeEl.ClassType;
- if (C=TPasEnumType) or (C=TPasRangeType) then
- Result:=cExact;
- end;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20181214141704,2,Param,ParamResolved,
- 'boolean/integer/float/enum variable',RaiseOnError));
- // third parameter: out Code: integer
- Param:=Params.Params[2];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if ParamResolved.BaseType in btAllInteger then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20181214141511,3,Param,ParamResolved,'integer variable',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,3,RaiseOnError);
- end;
- procedure TPasResolver.BI_Val_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr);
- var
- P: TPasExprArray;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- if P=nil then ;
- FinishCallArgAccess(P[0],rraRead);
- FinishCallArgAccess(P[1],rraOutParam);
- FinishCallArgAccess(P[2],rraOutParam);
- end;
- function TPasResolver.BI_LoHi_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- Exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first Param: any integer type
- Param:=Params.params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if (rrfReadable in ParamResolved.Flags)
- and (ParamResolved.BaseType in btAllInteger)
- then
- Result:=cExact;
- if Result=cIncompatible then
- Exit(CheckRaiseTypeArgNo(20190128232600,1,Param,ParamResolved,'integer type',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_LoHi_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- var
- ResolvedParam: TPasResolverResult;
- BaseType: TResolverBaseType;
- Mask: LongWord;
- begin
- ComputeElement(Params.Params[0],ResolvedParam,[]);
- GetShiftAndMaskForLoHiFunc(ResolvedParam.BaseType, Proc.BuiltIn=bfLo, Mask);
- case Mask of
- $F, $FF: BaseType := btByte;
- $FFFF: BaseType := btWord;
- else { $FFFFFFFF } BaseType := btLongWord;
- end;
- SetResolverIdentifier(ResolvedEl,BaseType,Proc.Proc,
- FBaseTypes[BaseType],FBaseTypes[BaseType],[rrfReadable]);
- end;
- procedure TPasResolver.BI_LoHi_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- Param: TPasExpr;
- ResolvedParam: TPasResolverResult;
- Value: TResEvalValue;
- Shift: Integer;
- Mask: LongWord;
- begin
- Evaluated := nil;
- Param := Params.Params[0];
- Value := Eval(Param,Flags);
- {$IFDEF VerbosePasResEval}
- {AllowWriteln}
- if value=nil then
- writeln('TPasResolver.BI_LoHi_OnEval Value=NIL')
- else
- writeln('TPasResolver.BI_LoHi_OnEval Value=',value.AsDebugString);
- {AllowWriteln-}
- {$ENDIF}
- if Value=nil then exit;
- try
- ComputeElement(Param,ResolvedParam,[]);
- Shift := GetShiftAndMaskForLoHiFunc(ResolvedParam.BaseType, Proc.BuiltIn=bfLo, Mask);
- Evaluated := fExprEvaluator.LoHiValue(Value,Shift,Mask,Params);
- finally
- ReleaseEvalValue(Value);
- end;
- end;
- function TPasResolver.BI_ConcatArray_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved, ElTypeResolved, FirstElTypeResolved: TPasResolverResult;
- i: Integer;
- ArrType: TPasArrayType;
- ElType: TPasType;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- FirstElTypeResolved:=Default(TPasResolverResult);
- for i:=0 to length(Params.Params)-1 do
- begin
- // all params: array
- Param:=Params.Params[i];
- ComputeElement(Param,ParamResolved,[]);
- ElTypeResolved:=default(TPasResolverResult);
- if rrfReadable in ParamResolved.Flags then
- begin
- if ParamResolved.BaseType=btContext then
- begin
- if IsDynArray(ParamResolved.LoTypeEl) then
- begin
- ArrType:=TPasArrayType(ParamResolved.LoTypeEl);
- ElType:=GetArrayElType(ArrType);
- ComputeElement(ElType,ElTypeResolved,[rcType]);
- end;
- end
- else if ParamResolved.BaseType in [btArrayLit,btArrayOrSet] then
- SetResolverValueExpr(ElTypeResolved,ParamResolved.SubType,
- ParamResolved.LoTypeEl,ParamResolved.HiTypeEl,Param,ParamResolved.Flags);
- end;
- if ElTypeResolved.BaseType=btNone then
- exit(CheckRaiseTypeArgNo(20170329181206,i+1,Param,ParamResolved,'dynamic array',RaiseOnError));
- Include(ElTypeResolved.Flags,rrfReadable);
- if i=0 then
- begin
- FirstElTypeResolved:=ElTypeResolved;
- Include(FirstElTypeResolved.Flags,rrfWritable);
- end
- else if CheckAssignResCompatibility(FirstElTypeResolved,ElTypeResolved,Param,RaiseOnError)=cIncompatible then
- exit(cIncompatible);
- end;
- Result:=cExact;
- end;
- procedure TPasResolver.BI_ConcatArray_OnGetCallResult(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult);
- begin
- ComputeElement(Params.Params[0],ResolvedEl,[]);
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable];
- ResolvedEl.ExprEl:=Params;
- ResolvedEl.IdentEl:=nil;
- if ResolvedEl.BaseType=btArrayOrSet then
- ResolvedEl.BaseType:=btArrayLit;
- if Proc=nil then ;
- end;
- function TPasResolver.BI_ConcatString_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- i: Integer;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- for i:=0 to length(Params.Params)-1 do
- begin
- // all params: char or string
- Param:=Params.Params[i];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllStringAndChars) then
- exit(CheckRaiseTypeArgNo(20181219230329,i+1,Param,ParamResolved,'string',RaiseOnError));
- end;
- Result:=cExact;
- end;
- procedure TPasResolver.BI_ConcatString_OnGetCallResult(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult);
- var
- i: Integer;
- Param: TPasExpr;
- ParamResolved, CombinedResolved: TPasResolverResult;
- ParamsArr: TPasExprArray;
- begin
- if Proc=nil then ;
- ParamsArr:=Params.Params;
- for i:=0 to length(ParamsArr)-1 do
- begin
- // all params: char or string
- Param:=ParamsArr[i];
- ComputeElement(Param,ParamResolved,[]);
- if i=0 then
- ResolvedEl:=ParamResolved
- else
- begin
- ComputeAddStringRes(ResolvedEl,ParamResolved,Params,CombinedResolved);
- ResolvedEl:=CombinedResolved;
- end;
- end;
- end;
- procedure TPasResolver.BI_ConcatString_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- i: Integer;
- Param: TPasExpr;
- Value, NewValue: TResEvalValue;
- ok: Boolean;
- begin
- if Proc=nil then ;
- Value:=nil;
- Evaluated:=nil;
- ok:=false;
- try
- for i:=0 to length(Params.Params)-1 do
- begin
- // all params: char or string
- Param:=Params.Params[i];
- Value:=Eval(Param,Flags);
- if Value=nil then
- exit;
- if i=0 then
- begin
- Evaluated:=Value;
- Value:=nil;
- end
- else
- begin
- NewValue:=ExprEvaluator.EvalStringAddExpr(Param,Params.Params[i-1],Param,
- Evaluated,Value);
- ReleaseEvalValue(Evaluated);
- Evaluated:=NewValue;
- ReleaseEvalValue(Value);
- end;
- end;
- ok:=true;
- finally
- ReleaseEvalValue(Value);
- if not ok then
- ReleaseEvalValue(Evaluated);
- end;
- end;
- function TPasResolver.BI_CopyArray_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- // first param: array
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- if rrfReadable in ParamResolved.Flags then
- begin
- if ParamResolved.BaseType=btContext then
- begin
- if IsDynArray(ParamResolved.LoTypeEl) then
- Result:=cExact;
- end
- else if ParamResolved.BaseType in [btArrayLit,btArrayOrSet] then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170329153951,1,Param,ParamResolved,'dynamic array',RaiseOnError));
- if length(Params.Params)=1 then
- exit(cExact);
- // check optional Start index
- Param:=Params.Params[1];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllInteger) then
- exit(CheckRaiseTypeArgNo(20170329164210,2,Param,ParamResolved,'integer',RaiseOnError));
- if length(Params.Params)=2 then
- exit(cExact);
- // check optional Count
- Param:=Params.Params[2];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllInteger) then
- exit(CheckRaiseTypeArgNo(20170329164329,3,Param,ParamResolved,'integer',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,3,RaiseOnError);
- end;
- procedure TPasResolver.BI_CopyArray_OnGetCallResult(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult);
- begin
- if Proc=nil then ;
- ComputeElement(Params.Params[0],ResolvedEl,[]);
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable];
- ResolvedEl.ExprEl:=Params;
- ResolvedEl.IdentEl:=nil;
- if ResolvedEl.BaseType=btArrayOrSet then
- ResolvedEl.BaseType:=btArrayLit;
- end;
- function TPasResolver.BI_InsertArray_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // Insert(Item,var Array,Index)
- var
- Params: TParamsExpr;
- Param, ItemParam: TPasExpr;
- ItemResolved, ParamResolved, ElTypeResolved: TPasResolverResult;
- ArrType: TPasArrayType;
- ElType: TPasType;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,3,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- // check Item
- ItemParam:=Params.Params[0];
- ComputeElement(ItemParam,ItemResolved,[]);
- if not (rrfReadable in ItemResolved.Flags) then
- exit(CheckRaiseTypeArgNo(20170329171400,1,ItemParam,ItemResolved,'value',RaiseOnError));
- // check Array
- Param:=Params.Params[1];
- ComputeElement(Param,ParamResolved,[]);
- if not ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if RaiseOnError then
- RaiseVarExpected(20170329171514,Param,ParamResolved.IdentEl);
- exit;
- end;
- if (ParamResolved.BaseType<>btContext)
- or not IsDynArray(ParamResolved.LoTypeEl) then
- exit(CheckRaiseTypeArgNo(20170329172024,2,Param,ParamResolved,'dynamic array',RaiseOnError));
- ArrType:=TPasArrayType(ParamResolved.LoTypeEl);
- ElType:=GetArrayElType(ArrType);
- ComputeElement(ElType,ElTypeResolved,[rcType]);
- if CheckAssignResCompatibility(ElTypeResolved,ItemResolved,ItemParam,RaiseOnError)=cIncompatible then
- exit(cIncompatible);
- // check insert Index
- Param:=Params.Params[2];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllInteger) then
- exit(CheckRaiseTypeArgNo(20170329172348,3,Param,ParamResolved,'integer',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,3,RaiseOnError);
- end;
- procedure TPasResolver.BI_InsertArray_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- var
- P: TPasExprArray;
- Param0, Param1: TPasExpr;
- ArrayResolved, ElTypeResolved: TPasResolverResult;
- ElType: TPasType;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- Param0:=P[0];
- Param1:=P[1];
- FinishCallArgAccess(Param0,rraRead);
- FinishCallArgAccess(Param1,rraVarParam);
- FinishCallArgAccess(P[2],rraRead);
- if not (Param0 is TPrimitiveExpr) then
- begin
- // insert complex expression, e.g. insert([1],Arr,index)
- // -> mark array and set literals
- ComputeElement(Param1,ArrayResolved,[]);
- if (ArrayResolved.BaseType<>btContext)
- or not IsDynArray(ArrayResolved.LoTypeEl) then
- RaiseNotYetImplemented(20180622144039,Param1);
- ElType:=GetArrayElType(TPasArrayType(ArrayResolved.LoTypeEl));
- ComputeElement(ElType,ElTypeResolved,[rcType]);
- if (ElTypeResolved.BaseType=btContext)
- and (ElTypeResolved.LoTypeEl.ClassType=TPasArrayType) then
- MarkArrayExprRecursive(Param0,TPasArrayType(ElTypeResolved.LoTypeEl));
- end;
- end;
- function TPasResolver.BI_DeleteArray_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // DeleteScope(var Array; Start, Count: integer)
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,3,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- // check Array
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- if not ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if RaiseOnError then
- RaiseVarExpected(20170329173421,Param,ParamResolved.IdentEl);
- exit;
- end;
- if (ParamResolved.BaseType<>btContext)
- or not IsDynArray(ParamResolved.LoTypeEl) then
- exit(CheckRaiseTypeArgNo(20170329173434,1,Param,ParamResolved,'dynamic array',RaiseOnError));
- // check param Start
- Param:=Params.Params[1];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllInteger) then
- exit(CheckRaiseTypeArgNo(20170329173613,2,Param,ParamResolved,'integer',RaiseOnError));
- // check param Count
- Param:=Params.Params[2];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllInteger) then
- exit(CheckRaiseTypeArgNo(20170329172348,3,Param,ParamResolved,'integer',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,3,RaiseOnError);
- end;
- procedure TPasResolver.BI_DeleteArray_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- var
- P: TPasExprArray;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- if P=nil then ;
- FinishCallArgAccess(P[0],rraVarParam);
- FinishCallArgAccess(P[1],rraRead);
- FinishCallArgAccess(P[2],rraRead);
- end;
- function TPasResolver.BI_TypeInfo_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- aType: TPasType;
- ParamResolved: TPasResolverResult;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- Param:=Params.Params[0];
- aType:=GetTypeInfoParamType(Param,ParamResolved,true);
- if aType=nil then
- RaiseMsg(20170411100259,nTypeIdentifierExpected,sTypeIdentifierExpected,[],Param);
- aType:=ResolveAliasType(aType);
- if not HasTypeInfo(aType) then
- RaiseMsg(20170413200118,nSymbolCannotBePublished,sSymbolCannotBePublished,[],Param);
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- begin
- if Proc=nil then;
- if Params=nil then ;
- SetResolverTypeExpr(ResolvedEl,btPointer,
- FBaseTypes[btPointer],FBaseTypes[btPointer],[rrfReadable]);
- end;
- function TPasResolver.BI_GetTypeKind_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- aType: TPasType;
- ParamResolved: TPasResolverResult;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- Param:=Params.Params[0];
- aType:=GetTypeInfoParamType(Param,ParamResolved,true);
- if aType=nil then
- RaiseMsg(20200826205441,nTypeIdentifierExpected,sTypeIdentifierExpected,[],Param);
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_GetTypeKind_OnGetCallResult(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult);
- var
- El: TPasElement;
- EnumType: TPasEnumType;
- begin
- El:=FindSystemIdentifier('system','ttypekind',Params);
- if not (El is TPasEnumType) then
- RaiseXExpectedButYFound(20200826211458,'enum type System.TTypeKind',GetElementTypeName(El),Params);
- EnumType:=TPasEnumType(El);
- SetResolverTypeExpr(ResolvedEl,btContext,EnumType,EnumType,[rrfReadable]);
- if Proc=nil then ;
- end;
- procedure TPasResolver.BI_GetTypeKind_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- aType: TPasType;
- El: TPasElement;
- TypeKindType: TPasEnumType;
- C: TClass;
- aClass: TPasClassType;
- bt: TResolverBaseType;
- Value: TPasEnumValue;
- aName: String;
- i: Integer;
- ParamResolved: TPasResolverResult;
- begin
- Evaluated:=nil;
- aType:=GetTypeInfoParamType(Params.Params[0],ParamResolved,true);
- C:=aType.ClassType;
- aName:='tkUnknown';
- if C=TPasEnumType then
- aName:='tkEnumeration'
- else if C=TPasSetType then
- aName:='tkSet'
- else if C=TPasRecordType then
- aName:='tkRecord'
- else if C=TPasClassType then
- begin
- aClass:=TPasClassType(aType);
- case aClass.ObjKind of
- okObject: aName:='tkObject';
- okInterface:
- case aClass.InterfaceType of
- citCom: aName:='tkInterface';
- else aName:='tkInterfaceRaw';
- end;
- okClassHelper, okRecordHelper, okTypeHelper: aName:='tkHelper';
- else
- aName:='tkClass';
- end;
- end
- else if C=TPasClassOfType then
- aName:='tkClassRef'
- else if C.InheritsFrom(TPasProcedure) then
- aName:='tkMethod'
- else if C.InheritsFrom(TPasProcedureType) then
- aName:='tkProcVar'
- else
- begin
- bt:=ParamResolved.BaseType;
- case bt of
- btChar: {$ifdef FPC_HAS_CPSTRING}if BaseTypeChar=btAnsiChar then aName:='tkChar' else {$ENDIF}aName:='tkWChar';
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar: aName:='tkChar';
- {$endif}
- btWideChar: aName:='tkWChar';
- btString: {$ifdef FPC_HAS_CPSTRING}if BaseTypeString=btAnsiString then aName:='tkAString' else {$ENDIF}aName:='tkUString';
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiString,
- btShortString,
- btRawByteString: aName:='tkAString';
- {$endif}
- btWideString: aName:='tkWString';
- btUnicodeString: aName:='tkUString';
- btPointer: aName:='tkPointer';
- {$ifdef HasInt64}
- btQWord,
- btInt64,
- btComp: aName:='tkInt64';
- {$endif}
- else
- if bt in btAllBooleans then
- aName:='tkBool'
- else if bt in btAllInteger then
- aName:='tkInteger'
- else if bt in btAllFloats then
- aName:='tkFloat';
- end;
- end;
- El:=FindSystemIdentifier('system','ttypekind',Params);
- TypeKindType:=El as TPasEnumType;
- for i:=0 to TypeKindType.Values.Count-1 do
- begin
- Value:=TPasEnumValue(TypeKindType.Values[i]);
- if SameText(aName,Value.Name) then
- begin
- Evaluated:=TResEvalEnum.CreateValue(i,Value);
- exit;
- end;
- end;
- if Proc=nil then ;
- if Flags=[] then ;
- end;
- function TPasResolver.BI_Assert_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // check params of built-in procedure 'Assert'
- // Assert(bool)
- // Assert(bool,string)
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: boolean
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllBooleans) then
- exit(CheckRaiseTypeArgNo(20180117123819,1,Param,ParamResolved,'boolean',RaiseOnError));
- // optional second parameter: string
- if length(Params.Params)>1 then
- begin
- Param:=Params.Params[1];
- ComputeElement(Param,ParamResolved,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or not (ParamResolved.BaseType in btAllStringAndChars) then
- exit(CheckRaiseTypeArgNo(20180117123932,2,Param,ParamResolved,'string',RaiseOnError));
- end;
- Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError);
- end;
- procedure TPasResolver.BI_Assert_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- begin
- FinishAssertCall(Proc,Params);
- end;
- function TPasResolver.BI_New_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- TypeEl, SubTypeEl: TPasType;
- ParamResolved: TPasResolverResult;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: var PRecord
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_New_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- Result:=cIncompatible;
- // Expr must be a variable
- if not ResolvedElCanBeVarParam(ParamResolved,Expr) then
- begin
- if RaiseOnError then
- RaiseVarExpected(20180425005303,Expr,ParamResolved.IdentEl);
- exit;
- end;
- if ParamResolved.BaseType=btContext then
- begin
- TypeEl:=ParamResolved.LoTypeEl;
- if TypeEl.ClassType=TPasPointerType then
- begin
- SubTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
- if SubTypeEl.ClassType=TPasRecordType then
- Result:=cExact;
- end;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20180425005421,1,Param,ParamResolved,'pointer of record',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_New_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- begin
- if Proc=nil then ;
- FinishCallArgAccess(Params.Params[0],rraOutParam);
- end;
- function TPasResolver.BI_Dispose_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- TypeEl, SubTypeEl: TPasType;
- ParamResolved: TPasResolverResult;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: var PRecord
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_Dispose_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- Result:=cIncompatible;
- if (rrfReadable in ParamResolved.Flags) then
- if ParamResolved.BaseType=btContext then
- begin
- TypeEl:=ParamResolved.LoTypeEl;
- if TypeEl.ClassType=TPasPointerType then
- begin
- SubTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
- if SubTypeEl.ClassType=TPasRecordType then
- Result:=cExact;
- end;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20180425010620,1,Param,ParamResolved,'pointer of record',RaiseOnError));
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_Dispose_OnFinishParamsExpr(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr);
- begin
- if Proc=nil then ;
- FinishCallArgAccess(Params.Params[0],rraRead);
- end;
- function TPasResolver.BI_Default_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- Decl: TPasElement;
- aType: TPasType;
- begin
- Result:=cIncompatible;
- if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
- exit;
- Params:=TParamsExpr(Expr);
- // check type or var
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- Decl:=ParamResolved.IdentEl;
- aType:=nil;
- if (Decl<>nil) and (ParamResolved.LoTypeEl<>nil) then
- begin
- if Decl is TPasType then
- aType:=TPasType(Decl)
- else if Decl is TPasVariable then
- aType:=TPasVariable(Decl).VarType
- else if Decl.ClassType=TPasArgument then
- aType:=TPasArgument(Decl).ArgType;
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if aType=nil then
- writeln('TPasResolver.BI_Default_OnGetCallCompatibility Decl=',GetObjName(Decl));
- {AllowWriteln-}
- {$ENDIF}
- end;
- if aType=nil then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_Default_OnGetCallCompatibility ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseMsg(20180501004009,nTypeIdentifierExpected,sTypeIdentifierExpected,[],Param);
- end;
- Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
- end;
- procedure TPasResolver.BI_Default_OnGetCallResult(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
- var
- Param: TPasExpr;
- begin
- if Proc=nil then ;
- Param:=Params.Params[0];
- ComputeElement(Param,ResolvedEl,[rcNoImplicitProc]);
- ResolvedEl.Flags:=[rrfReadable];
- ResolvedEl.IdentEl:=nil;
- end;
- procedure TPasResolver.BI_Default_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- var
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- TypeEl: TPasType;
- EnumType: TPasEnumType;
- i: Integer;
- ArrayEl: TPasArrayType;
- bt: TResolverBaseType;
- MinInt, MaxInt: TMaxPrecInt;
- begin
- if Proc=nil then ;
- Evaluated:=nil;
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- TypeEl:=ParamResolved.LoTypeEl;
- if ParamResolved.BaseType=btContext then
- begin
- if TypeEl.ClassType=TPasArrayType then
- begin
- // array: []
- RaiseNotYetImplemented(20180501005214,Param);
- ArrayEl:=TPasArrayType(TypeEl);
- if length(ArrayEl.Ranges)=0 then
- begin
- // dyn or open array
- end
- else
- begin
- // static array
- end;
- end
- else if TypeEl.ClassType=TPasSetType then
- begin
- // set: first/last enum
- TypeEl:=TPasSetType(TypeEl).EnumType;
- if TypeEl.ClassType=TPasEnumType then
- begin
- EnumType:=TPasEnumType(TPasSetType(TypeEl).EnumType);
- Evaluated:=TResEvalSet.CreateEmpty(revskEnum,EnumType);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_Default_OnEval ',GetResolverResultDbg(ParamResolved),' TypeEl=',TypeEl.ClassName);
- {$ENDIF}
- RaiseNotYetImplemented(20180501005348,Params);
- end;
- end
- else if TypeEl.ClassType=TPasEnumType then
- begin
- EnumType:=TPasEnumType(TypeEl);
- i:=0;
- Evaluated:=TResEvalEnum.CreateValue(i,TPasEnumValue(EnumType.Values[i]))
- end;
- end
- else if (TypeEl is TPasUnresolvedSymbolRef)
- and (TypeEl.CustomData is TResElDataBaseType) then
- begin
- // default(base type)
- bt:=TResElDataBaseType(TypeEl.CustomData).BaseType;
- bt:=GetActualBaseType(bt);
- if bt in btAllBooleans then
- Evaluated:=TResEvalBool.CreateValue(false)
- {$ifdef HasInt64}
- else if bt=btQWord then
- Evaluated:=TResEvalInt.CreateValue(0)
- {$endif}
- else if (bt in btAllIntegerNoQWord) and GetIntegerRange(bt,MinInt,MaxInt) then
- Evaluated:=TResEvalInt.CreateValue(MinInt)
- {$ifdef FPC_HAS_CPSTRING}
- else if bt in [btAnsiString,btShortString] then
- Evaluated:=TResEvalString.CreateValue('')
- {$endif}
- else if bt in [btUnicodeString,btWideString] then
- Evaluated:=TResEvalUTF16.CreateValue('')
- {$ifdef FPC_HAS_CPSTRING}
- else if bt=btAnsiChar then
- Evaluated:=TResEvalString.CreateValue(#0)
- {$endif}
- else if bt=btWideChar then
- Evaluated:=TResEvalUTF16.CreateValue(#0)
- else if bt in btAllFloats then
- Evaluated:=TResEvalFloat.CreateValue(0.0)
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_Default_OnEval ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseNotYetImplemented(20180501005645,Params);
- end;
- end
- else if ParamResolved.LoTypeEl is TPasRangeType then
- begin
- // e.g. type t = 2..10;
- Evaluated:=EvalRangeLimit(TPasRangeType(TypeEl).RangeExpr,FLags,true,Param);
- end
- else if ParamResolved.BaseType=btSet then
- begin
- if ParamResolved.SubType=btContext then
- begin
- if ParamResolved.LoTypeEl.ClassType=TPasEnumType then
- Evaluated:=TResEvalSet.CreateEmpty(revskEnum,TPasEnumType(ParamResolved.LoTypeEl))
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_Default_OnEval ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseNotYetImplemented(20180501125138,Param);
- end;
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_Default_OnEval ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseNotYetImplemented(20180501125014,Param);
- end;
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_Default_OnEval ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseNotYetImplemented(20180501004839,Param);
- end;
- end;
- constructor TPasResolver.Create;
- begin
- inherited Create;
- FDefaultScope:=TPasDefaultScope.Create;
- FPendingForwardProcs:=TFPList.Create;
- FBaseTypeChar:={$ifdef FPC_HAS_CPSTRING}btAnsiChar{$else}btWideChar{$endif};
- FBaseTypeString:={$ifdef FPC_HAS_CPSTRING}btAnsiString{$else}btUnicodeString{$endif};
- FBaseTypeExtended:=btDouble;
- FBaseTypeLength:={$ifdef HasInt64}btInt64{$else}btIntDouble{$endif};
- FDynArrayMinIndex:=0;
- FDynArrayMaxIndex:=High(TMaxPrecInt);
- cTGUIDToString:=cTypeConversion+1;
- cStringToTGUID:=cTypeConversion+1;
- cInterfaceToTGUID:=cTypeConversion+1;
- cInterfaceToString:=cTypeConversion+2;
- FScopeClass_Array:=TPasArrayScope;
- FScopeClass_Class:=TPasClassScope;
- FScopeClass_InitialFinalization:=TPasInitialFinalizationScope;
- FScopeClass_Module:=TPasModuleScope;
- FScopeClass_Proc:=TPasProcedureScope;
- FScopeClass_ProcType:=TPasProcTypeScope;
- FScopeClass_Record:=TPasRecordScope;
- FScopeClass_Section:=TPasSectionScope;
- FScopeClass_WithExpr:=TPasWithExprScope;
- fExprEvaluator:=TResExprEvaluator.Create;
- fExprEvaluator.OnLog:=@OnExprEvalLog;
- fExprEvaluator.OnEvalIdentifier:=@OnExprEvalIdentifier;
- fExprEvaluator.OnEvalParams:=@OnExprEvalParams;
- fExprEvaluator.OnRangeCheckEl:=@OnRangeCheckEl;
- PushScope(FDefaultScope);
- end;
- function TPasResolver.CreateElement(AClass: TPTreeElement; const AName: String;
- AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
- var
- aScanner: TPascalScanner;
- SrcPos: TPasSourcePos;
- begin
- // get source position for good error messages
- aScanner:=CurrentParser.Scanner;
- if (ASourceFilename='') or StoreSrcColumns then
- begin
- SrcPos.FileName:=aScanner.CurFilename;
- SrcPos.Row:=aScanner.CurRow;
- SrcPos.Column:=aScanner.CurColumn;
- end
- else
- begin
- SrcPos.FileName:=ASourceFilename;
- SrcPos.Row:=ASourceLinenumber;
- SrcPos.Column:=0;
- end;
- Result:=CreateElement(AClass,AName,AParent,AVisibility,SrcPos);
- end;
- function TPasResolver.CreateElement(AClass: TPTreeElement; const AName: String;
- AParent: TPasElement; AVisibility: TPasMemberVisibility;
- const ASrcPos: TPasSourcePos; TypeParams: TFPList): TPasElement;
- var
- El: TPasElement;
- SrcY: integer;
- SectionScope: TPasSectionScope;
- begin
- Result:=nil;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CreateElement ',AClass.ClassName,' Name=',AName,' Parent=',GetObjName(AParent),' (',ASrcPos.Row,',',ASrcPos.Column,')');
- {$ENDIF}
- if (AParent=nil) and (FRootElement<>nil) then
- RaiseInternalError(20160922163535,'more than one root element Class="'+AClass.ClassName+'" Root='+GetObjName(FRootElement));
- if ASrcPos.FileName='' then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CreateElement ',AClass.ClassName,' Name=',AName,' Parent=',GetObjName(AParent),' (',ASrcPos.Row,',',ASrcPos.Column,')');
- {$ENDIF}
- RaiseInternalError(20160922163541,'missing filename');
- end;
- SrcY:=ASrcPos.Row;
- if StoreSrcColumns then
- SrcY:=MangleSourceLineNumber(SrcY,ASrcPos.Column);
- if AClass=TSelfExpr then
- RaiseInternalError(20190131154235);
- // create element
- El:=AClass.Create(AName,AParent);
- {$IFDEF CheckPasTreeRefCount}El.RefIds.Add('CreateElement');{$ENDIF}
- FLastElement:=El;
- try
- El.Visibility:=AVisibility;
- El.SourceFilename:=ASrcPos.FileName;
- El.SourceLinenumber:=SrcY;
- if FRootElement=nil then
- begin
- RootElement:=El as TPasModule;
- if FStep=prsInit then
- FStep:=prsParsing;
- end
- else if (AParent is TPasSection) and (TPasSection(AParent).Declarations.Count=0) then
- begin
- // first element of section
- SectionScope:=TPasSectionScope(AParent.CustomData);
- SectionScope.BoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
- SectionScope.ModeSwitches:=CurrentParser.Scanner.CurrentModeSwitches;
- end;
- if IsElementSkipped(El) then exit;
- // create scope
- if AClass.InheritsFrom(TPasExpr) then
- // resolved when finished
- else if (AClass=TPasVariable)
- or (AClass=TPasConst) then
- AddVariable(TPasVariable(El))
- else if AClass=TPasResString then
- AddResourceString(TPasResString(El))
- else if (AClass=TPasProperty) then
- AddProperty(TPasProperty(El))
- else if AClass=TPasArgument then
- AddArgument(TPasArgument(El))
- else if AClass=TPasEnumType then
- AddEnumType(TPasEnumType(El))
- else if AClass=TPasEnumValue then
- AddEnumValue(TPasEnumValue(El))
- else if (AClass=TUnresolvedPendingRef) then
- else if (AClass=TPasAliasType)
- or (AClass=TPasTypeAliasType)
- or (AClass=TPasClassOfType)
- or (AClass=TPasPointerType)
- or (AClass=TPasSetType)
- or (AClass=TPasRangeType)
- or (AClass=TPasSpecializeType) then
- AddType(TPasType(El))
- else if AClass=TPasArrayType then
- AddArrayType(TPasArrayType(El),TypeParams)
- else if (AClass=TPasProcedureType)
- or (AClass=TPasFunctionType) then
- AddProcedureType(TPasProcedureType(El),TypeParams)
- else if AClass=TPasGenericTemplateType then
- AddGenericTemplateType(TPasGenericTemplateType(El))
- else if AClass=TPasStringType then
- begin
- AddType(TPasType(El));
- {$ifdef FPC_HAS_CPSTRING}
- if BaseTypes[btShortString]=nil then
- {$endif}
- RaiseMsg(20170419203043,nIllegalQualifier,sIllegalQualifier,['['],El);
- end
- else if AClass=TPasRecordType then
- AddRecordType(TPasRecordType(El),TypeParams)
- else if AClass=TPasClassType then
- AddClassType(TPasClassType(El),TypeParams)
- else if AClass=TPasVariant then
- else if AClass.InheritsFrom(TPasProcedure) then
- AddProcedure(TPasProcedure(El),TypeParams)
- else if AClass=TPasResultElement then
- AddFunctionResult(TPasResultElement(El))
- else if AClass=TProcedureBody then
- AddProcedureBody(TProcedureBody(El))
- else if AClass=TPasMethodResolution then
- else if AClass=TPasImplExceptOn then
- AddExceptOn(TPasImplExceptOn(El))
- else if AClass=TPasImplWithDo then
- AddWithDo(TPasImplWithDo(El))
- else if AClass=TPasImplLabelMark then
- else if AClass=TPasOverloadedProc then
- else if (AClass=TInterfaceSection)
- or (AClass=TImplementationSection)
- or (AClass=TProgramSection)
- or (AClass=TLibrarySection) then
- AddSection(TPasSection(El))
- else if (AClass=TPasModule)
- or (AClass=TPasProgram)
- or (AClass=TPasLibrary) then
- AddModule(TPasModule(El))
- else if AClass=TPasUsesUnit then
- else if AClass=TInitializationSection then
- AddInitialFinalizationSection(TInitializationSection(El))
- else if AClass=TFinalizationSection then
- AddInitialFinalizationSection(TFinalizationSection(El))
- else if AClass=TPasImplCommand then
- else if AClass.InheritsFrom(TPasImplBlock) then
- // resolved when finished
- else if AClass=TPasAttributes then
- else if AClass=TPasExportSymbol then
- AddExportSymbol(TPasExportSymbol(El))
- else if AClass=TPasUnresolvedUnitRef then
- RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El)
- else
- RaiseNotYetImplemented(20160922163544,El);
- Result:=El;
- finally
- if Result=nil then
- El.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- end;
- end;
- function TPasResolver.FindModule(const AName: String; NameExpr,
- InFileExpr: TPasExpr): TPasModule;
- var
- InFilename, FileUnitName: String;
- begin
- if InFileExpr<>nil then
- begin
- InFilename:=GetUsesUnitInFilename(InFileExpr);
- if InFilename='' then
- RaiseXExpectedButYFound(20180222001220,
- 'file path','empty string',InFileExpr);
- if msDelphi in CurrentParser.CurrentModeswitches then
- begin
- // in delphi the last unit name must match the filename
- FileUnitName:=ChangeFileExt(ExtractFileName(InFilename),'');
- if CompareText(AName,FileUnitName)<>0 then
- RaiseXExpectedButYFound(20180222230400,AName,FileUnitName,InFileExpr);
- end;
- end;
- Result:=FindUnit(AName,InFilename,NameExpr,InFileExpr);
- if Result=nil then
- begin
- if InFileExpr<>nil then
- RaiseMsg(20180223140434,nCantFindUnitX,sCantFindUnitX,[InFilename],InFileExpr)
- else
- RaiseMsg(20180223140409,nCantFindUnitX,sCantFindUnitX,[AName],NameExpr);
- end;
- end;
- function TPasResolver.FindElement(const aName: String): TPasElement;
- begin
- Result:=FindElementFor(aName,nil,0);
- end;
- function TPasResolver.FindElementFor(const aName: String; AParent: TPasElement;
- TypeParamCount: integer): TPasElement;
- // called by TPasParser for direct types, e.g. type t = ns1.unit1.tobj.tsub
- var
- ErrorEl: TPasElement;
- procedure CheckGenericRefWithoutParams(GenEl: TPasGenericType);
- // called when TypeParamCount=0 check if reference to a generic type is allowed with
- begin
- if (GenEl.GenericTemplateTypes=nil) or (GenEl.GenericTemplateTypes.Count=0) then
- exit;
- // referrring to a generic type without params
- if not (msDelphi in CurrentParser.CurrentModeswitches)
- and (AParent<>nil)
- and AParent.HasParent(GenEl) then
- exit; // mode objfpc: inside the generic type it can be referred without params
- RaiseMsg(20201129005025,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,['variable'],ErrorEl);
- end;
- var
- p: SizeInt;
- RightPath, CurName, LeftPath: String;
- NeedPop: Boolean;
- CurScopeEl, NextEl, BestEl: TPasElement;
- CurSection: TPasSection;
- i: Integer;
- UsesUnit: TPasUsesUnit;
- CurScope: TPasDotBaseScope;
- FindData: TPRFindData;
- begin
- Result:=nil;
- ErrorEl:=nil; // use nil to use scanner position as error position
- RightPath:=aName;
- LeftPath:='';
- p:=1;
- CurScopeEl:=nil;
- repeat
- p:=Pos('.',RightPath);
- if p<1 then
- begin
- CurName:=RightPath;
- RightPath:='';
- end
- else
- begin
- CurName:=LeftStr(RightPath,p-1);
- Delete(RightPath,1,p);
- if RightPath='' then
- RaiseMsg(20170328003146,nIllegalExpression,sIllegalExpression,[],ErrorEl);
- end;
- if LeftPath='' then
- LeftPath:=CurName
- else
- LeftPath:=LeftPath+'.'+CurName;
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if RightPath<>'' then
- writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ...');
- {AllowWriteln-}
- {$ENDIF}
- // Note: CurName can be a non Pascal name, when specializing an autogenerated anonymous type
- //if not IsValidIdent(CurName) then ;
- if CurScopeEl<>nil then
- begin
- NeedPop:=true;
- if CurScopeEl is TPasType then
- begin
- if (CurScopeEl is TPasGenericType)
- and not IsFullySpecialized(TPasGenericType(CurScopeEl)) then
- RaiseMsg(20200217131215,nGenericsWithoutSpecializationAsType,
- sGenericsWithoutSpecializationAsType,['reference'],ErrorEl);
- CurScope:=PushDotScope(TPasType(CurScopeEl));
- if CurScope=nil then
- RaiseMsg(20190122122529,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['.',LeftPath],ErrorEl);
- CurScope.OnlyTypeMembers:=true;
- end
- else if CurScopeEl is TPasModule then
- PushModuleDotScope(TPasModule(CurScopeEl))
- else
- RaiseMsg(20170504174021,nIllegalQualifierAfter,sIllegalQualifierAfter,
- ['.',LeftPath],ErrorEl);
- end
- else
- NeedPop:=false;
- if (RightPath='') and (TypeParamCount>0) then
- begin
- NextEl:=FindGenericEl(CurName,TypeParamCount,FindData,ErrorEl);
- if (FindData.StartScope<>nil) and (FindData.StartScope.ClassType=ScopeClass_WithExpr)
- and (wesfNeedTmpVar in TPasWithExprScope(FindData.StartScope).Flags) then
- RaiseInternalError(20190801104033); // caller forgot to handle "With"
- end
- else
- begin
- NextEl:=FindElementWithoutParams(CurName,ErrorEl,true,true);
- if (NextEl is TPasGenericType) and (RightPath='') then
- CheckGenericRefWithoutParams(TPasGenericType(NextEl));
- end;
- {$IFDEF VerbosePasResolver}
- //if RightPath<>'' then
- // writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ... NextEl=',GetObjName(NextEl));
- {$ENDIF}
- if NextEl=nil then
- RaiseIdentifierNotFound(20201129004745,CurName,ErrorEl);
- if NextEl is TPasModule then
- begin
- if CurScopeEl is TPasModule then
- RaiseXExpectedButYFound(20170328001619,'class',GetElementTypeName(NextEl)+' '+NextEl.Name,ErrorEl);
- if Pos('.',NextEl.Name)>0 then
- begin
- // dotted module name -> check if the full module name is in aName
- if CompareText(NextEl.Name+'.',LeftStr(aName,length(NextEl.Name)+1))<>0 then
- begin
- if CompareText(NextEl.Name,aName)=0 then
- RaiseXExpectedButYFound(20170504165825,'type',GetElementTypeName(NextEl),ErrorEl)
- else
- RaiseIdentifierNotFound(20170504165412,aName,ErrorEl);
- end;
- RightPath:=copy(aName,length(NextEl.Name)+2,length(aName));
- end;
- CurScopeEl:=NextEl;
- end
- else if NextEl.ClassType=TPasUsesUnit then
- begin
- // the first name of a used unit matches -> find longest match
- CurSection:=NextEl.Parent as TPasSection;
- i:=length(CurSection.UsesClause)-1;
- BestEl:=nil;
- while i>=0 do
- begin
- UsesUnit:=CurSection.UsesClause[i];
- CurName:=UsesUnit.Name;
- if IsDottedIdentifierPrefix(CurName,aName)
- and ((BestEl=nil) or (length(CurName)>length(BestEl.Name))) then
- BestEl:=UsesUnit;
- dec(i);
- if (i<0) and (CurSection.ClassType=TImplementationSection) then
- begin
- CurSection:=(CurSection.Parent as TPasModule).InterfaceSection;
- if CurSection=nil then break;
- i:=length(CurSection.UsesClause)-1;
- end;
- end;
- // check module name too
- CurName:=RootElement.Name;
- if IsDottedIdentifierPrefix(CurName,aName)
- and ((BestEl=nil) or (length(CurName)>length(BestEl.Name))) then
- BestEl:=RootElement;
- if BestEl=nil then
- RaiseIdentifierNotFound(20170504172440,aName,ErrorEl);
- RightPath:=copy(aName,length(BestEl.Name)+2,length(aName));
- if BestEl.ClassType=TPasUsesUnit then
- CurScopeEl:=TPasUsesUnit(BestEl).Module
- else
- CurScopeEl:=BestEl;
- end
- else
- CurScopeEl:=NextEl;
- // restore scope
- if NeedPop then
- PopScope;
- if RightPath='' then
- exit(NextEl);
- until false;
- if AParent=nil then ;;
- end;
- function TPasResolver.FindElementWithoutParams(const AName: String;
- ErrorPosEl: TPasElement; NoProcsWithArgs, NoGenerics: boolean): TPasElement;
- // ErrorPosEl=nil means to use scanner position as error position
- var
- Data: TPRFindData;
- begin
- Result:=FindElementWithoutParams(AName,Data,ErrorPosEl,NoProcsWithArgs,NoGenerics);
- if Data.Found=nil then exit; // forward type: class-of or ^
- CheckFoundElement(Data,nil);
- if (Data.StartScope<>nil) and (Data.StartScope.ClassType=ScopeClass_WithExpr)
- and (wesfNeedTmpVar in TPasWithExprScope(Data.StartScope).Flags) then
- RaiseInternalError(20160923111727); // caller forgot to handle "With", use the other FindElementWithoutParams instead
- end;
- function TPasResolver.FindElementWithoutParams(const AName: String; out
- Data: TPRFindData; ErrorPosEl: TPasElement; NoProcsWithArgs,
- NoGenerics: boolean): TPasElement;
- // ErrorPosEl=nil means to use scanner position as error position
- var
- Abort: boolean;
- begin
- //writeln('TPasResolver.FindIdentifier Name="',AName,'"');
- Result:=Nil;
- Abort:=false;
- Data:=Default(TPRFindData);
- Data.ErrorPosEl:=ErrorPosEl;
- Data.SkipGenerics:=NoGenerics;
- IterateElements(AName,@OnFindFirst_PreferNoParams,@Data,Abort);
- Result:=Data.Found;
- if Result=nil then
- begin
- if (ErrorPosEl=nil) and (LastElement<>nil) then
- begin
- if (LastElement.ClassType=TPasClassOfType)
- and (TPasClassOfType(LastElement).DestType=nil) then
- begin
- // 'class of' of a not yet defined class
- Result:=CreateElement(TUnresolvedPendingRef,AName,LastElement,visDefault,
- CurrentParser.CurSourcePos);
- exit;
- end
- else if (LastElement.ClassType=TPasPointerType)
- and (TPasPointerType(LastElement).DestType=nil) then
- begin
- // pointer of a not yet defined type
- Result:=CreateElement(TUnresolvedPendingRef,AName,LastElement,visDefault,
- CurrentParser.CurSourcePos);
- exit;
- end
- end;
- RaiseIdentifierNotFound(20170216152722,AName,ErrorPosEl);
- end;
- if NoProcsWithArgs and (Result is TPasProcedure)
- and ProcNeedsParams(TPasProcedure(Result).ProcType)
- then
- // proc needs parameters
- RaiseMsg(20170216152347,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(TPasProcedure(Result).ProcType)],ErrorPosEl);
- end;
- function TPasResolver.FindFirstEl(const AName: String; out Data: TPRFindData;
- ErrorPosEl: TPasElement): TPasElement;
- var
- Abort: boolean;
- begin
- Abort:=false;
- Data:=Default(TPRFindData);
- Data.ErrorPosEl:=ErrorPosEl;
- IterateElements(AName,@OnFindFirst,@Data,Abort);
- Result:=Data.Found;
- end;
- procedure TPasResolver.FindLongestUnitName(var El: TPasElement; Expr: TPasExpr);
- // Input: El is TPasUsesUnit
- // Output: El is either a TPasUsesUnit or the root module
- var
- CurUsesUnit: TPasUsesUnit;
- BestEl: TPasElement;
- aName, CurName: String;
- Clause: TPasUsesClause;
- i: Integer;
- Section: TPasSection;
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FindLongestUnitName El=',GetObjName(El),' Expr=',GetObjName(Expr));
- {$ENDIF}
- if not (El is TPasUsesUnit) then
- RaiseInternalError(20170503000945);
- aName:=GetNameExprValue(Expr);
- if aName='' then
- RaiseNotYetImplemented(20170503110217,Expr);
- repeat
- Expr:=GetNextDottedExpr(Expr);
- if Expr=nil then break;
- CurName:=GetNameExprValue(Expr);
- if CurName='' then
- RaiseNotYetImplemented(20170502164242,Expr);
- aName:=aName+'.'+CurName;
- until false;
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FindLongestUnitName Dotted="',aName,'"');
- {$ENDIF}
- // search in uses clause
- BestEl:=nil;
- Section:=TPasUsesUnit(El).Parent as TPasSection;
- repeat
- Clause:=Section.UsesClause;
- for i:=0 to length(Clause)-1 do
- begin
- CurUsesUnit:=Clause[i];
- CurName:=CurUsesUnit.Name;
- if IsDottedIdentifierPrefix(CurName,aName)
- and ((BestEl=nil) or (length(CurName)>length(BestEl.Name))) then
- BestEl:=CurUsesUnit; // a better match
- end;
- if Section is TImplementationSection then
- begin
- // search in interface uses clause too
- Section:=(Section.Parent as TPasModule).InterfaceSection;
- end
- else
- break;
- until Section=nil;
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FindLongestUnitName LongestUnit="',GetObjName(BestEl),'"');
- {$ENDIF}
- // check module name
- CurName:=El.GetModule.Name;
- if IsDottedIdentifierPrefix(CurName,aName)
- and ((BestEl=nil) or (length(CurName)>length(BestEl.Name))) then
- BestEl:=El.GetModule; // a better match
- if BestEl=nil then
- begin
- // no dotted module name fits the expression
- RaiseIdentifierNotFound(20170503140643,GetNameExprValue(Expr),Expr);
- end;
- El:=BestEl;
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FindLongestUnitName END Best="',GetObjName(El),'"');
- {$ENDIF}
- end;
- function TPasResolver.FindGenericEl(const AName: string;
- TemplateCount: integer; out Find: TPRFindData; ErrorPosEl: TPasElement
- ): TPasElement;
- var
- Data: TPRFindGenericData;
- Abort: boolean;
- begin
- Data:=Default(TPRFindGenericData);
- Data.TemplateCount:=TemplateCount;
- Data.Find.ErrorPosEl:=ErrorPosEl;
- Abort:=false;
- IterateElements(AName,@OnFindFirst_GenericEl,@Data,Abort);
- Find:=Data.Find;
- Result:=Find.Found;
- if Result=nil then
- begin
- {$IFDEF VerbosePasResolver}
- WriteScopesShort('TPasResolver.FindGenericType');
- {$ENDIF}
- RaiseMsg(20190801104759,nIdentifierNotFound,sIdentifierNotFound,[AName+GetGenericParamCommas(TemplateCount)],ErrorPosEl);
- end;
- CheckFoundElement(Find,nil);
- end;
- procedure TPasResolver.IterateElements(const aName: string;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean);
- var
- i: Integer;
- Scope: TPasScope;
- begin
- for i:=FScopeCount-1 downto 0 do
- begin
- Scope:=Scopes[i];
- Scope.IterateElements(AName,Scope,OnIterateElement,Data,Abort);
- if Abort then
- exit;
- if Scope is TPasSubExprScope then break;
- end;
- end;
- procedure TPasResolver.CheckFoundElement(
- const FindData: TPRFindData; Ref: TResolvedReference);
- // check visibility rules
- // Call this method after finding an element by searching the scopes.
- function IsFieldInheritingConst(aRef: TResolvedReference): boolean;
- // returns true if aRef is a TPasVariable that inherits its const from parent.
- // For example
- // type TRecord = record
- // a: word; // inherits const
- // const b: word = 3; // does not inherit const
- // class var c: word; // does not inherit const
- // end;
- // procedure DoIt(const r:TRecord)
- var
- El: TPasElement;
- begin
- El:=aRef.Declaration;
- Result:=(El.ClassType=TPasVariable)
- and (TPasVariable(El).VarModifiers*[vmClass, vmStatic]=[]);
- //writeln('IsFieldInheritingConst ',GetObjName(El),' ',Result,' vmClass=',vmClass in TPasVariable(El).VarModifiers);
- end;
- var
- Proc: TPasProcedure;
- StartScope: TPasScope;
- OnlyTypeMembers, IsClassOf: Boolean;
- C: TClass;
- ClassRecScope: TPasClassOrRecordScope;
- i: Integer;
- AbstractProcs: TArrayOfPasProcedure;
- TypeEl: TPasType;
- begin
- StartScope:=FindData.StartScope;
- OnlyTypeMembers:=false;
- IsClassOf:=false;
- if StartScope is TPasDotBaseScope then
- begin
- OnlyTypeMembers:=TPasDotBaseScope(StartScope).OnlyTypeMembers;
- if StartScope.ClassType=TPasDotClassScope then
- IsClassOf:=TPasDotClassScope(StartScope).IsClassOf;
- if Ref<>nil then
- begin
- Include(Ref.Flags,rrfDotScope);
- if TPasDotBaseScope(StartScope).ConstParent
- and IsFieldInheritingConst(Ref) then
- Include(Ref.Flags,rrfConstInherited);
- end;
- end
- else if StartScope.ClassType=FScopeClass_WithExpr then
- begin
- OnlyTypeMembers:=wesfOnlyTypeMembers in TPasWithExprScope(StartScope).Flags;
- IsClassOf:=wesfIsClassOf in TPasWithExprScope(StartScope).Flags;
- if Ref<>nil then
- begin
- Include(Ref.Flags,rrfDotScope);
- if (wesfConstParent in TPasWithExprScope(StartScope).Flags)
- and IsFieldInheritingConst(Ref) then
- Include(Ref.Flags,rrfConstInherited);
- end;
- end
- else if StartScope.ClassType=FScopeClass_Proc then
- begin
- Proc:=TPasProcedureScope(StartScope).Element as TPasProcedure;
- //writeln('TPasResolver.CheckFoundElement ',GetObjName(Proc),' ',IsClassMethod(Proc),' ElScope=',GetObjName(FindData.ElScope));
- if (FindData.ElScope<>StartScope) and IsClassMethod(Proc) then
- OnlyTypeMembers:=true;
- end
- else if StartScope.ClassType=TPasGroupScope then
- OnlyTypeMembers:=TPasGroupScope(StartScope).OnlyTypeMembers;
- //writeln('TPasResolver.CheckFoundElOnStartScope StartScope=',StartScope.ClassName,
- // ' StartIsDot=',StartScope is TPasDotBaseScope,
- // ' OnlyTypeMembers=',(StartScope is TPasDotBaseScope)
- // and TPasDotBaseScope(StartScope).OnlyTypeMembers,
- // ' FindData.Found=',GetObjName(FindData.Found));
- if OnlyTypeMembers then
- begin
- //writeln('TPasResolver.CheckFoundElOnStartScope ',GetObjName(FindData.Found),' ',(FindData.Found is TPasVariable)
- // and (vmClass in TPasVariable(FindData.Found).VarModifiers));
- // only class vars/procs allowed
- if FindData.Found.ClassType=TPasConstructor then
- // constructor: ok
- else if IsClassMethod(FindData.Found)
- then
- // class proc: ok
- else if (FindData.Found is TPasVariable)
- and (vmClass in TPasVariable(FindData.Found).VarModifiers) then
- // class var/const/property: ok
- else if FindData.Found is TPasType then
- // nested type: ok
- else if FindData.Found is TPasEnumValue then
- // e.g. enumtype.enumvalue: ok
- else
- begin
- RaiseMsg(20170216152348,nInstanceMemberXInaccessible,
- sInstanceMemberXInaccessible,[FindData.Found.Name],FindData.ErrorPosEl);
- end;
- end
- else if (proExtClassInstanceNoTypeMembers in Options)
- and (StartScope is TPasDotClassScope)
- and TPasClassType(TPasDotClassScope(StartScope).ClassRecScope.Element).IsExternal then
- begin
- // e.g. ExtClassInstance.Member
- C:=FindData.Found.ClassType;
- if (C=TPasProcedure) or (C=TPasFunction) then
- // ok
- else if (C=TPasConst) then
- // ok
- else if ((C=TPasVariable) or (C=TPasProperty))
- and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then
- // ok
- else if IsHelper(FindData.Found.Parent) then
- // ok
- else
- begin
- RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX,
- sExternalClassInstanceCannotAccessStaticX,
- [GetElementTypeName(FindData.Found)+' '+FindData.Found.Name],
- FindData.ErrorPosEl);
- end;
- end;
- if (FindData.Found is TPasProcedure) then
- begin
- Proc:=TPasProcedure(FindData.Found);
- if Proc.IsVirtual or Proc.IsOverride then
- begin
- if StartScope.ClassType=TPasInheritedScope then
- begin
- // inherited expr -> call directly
- if Proc.IsAbstract then
- RaiseMsg(20170216152352,nAbstractMethodsCannotBeCalledDirectly,
- sAbstractMethodsCannotBeCalledDirectly,[],FindData.ErrorPosEl);
- end
- else
- begin
- // call via virtual method table
- if Ref<>nil then
- Ref.Flags:=Ref.Flags+[rrfVMT];
- end;
- end;
- // constructor: NewInstance or normal call
- // it is a NewInstance iff the scope is a class/record, e.g. TObject.Create
- if (Proc.ClassType=TPasConstructor)
- and (Ref<>nil) then
- begin
- if OnlyTypeMembers then
- Ref.Flags:=Ref.Flags+[rrfNewInstance]-[rrfConstInherited];
- // store the class in Ref.Context
- if Ref.Context<>nil then
- RaiseInternalError(20170131141936);
- Ref.Context:=TResolvedRefCtxConstructor.Create;
- TypeEl:=nil;
- ClassRecScope:=nil;
- C:=StartScope.ClassType;
- if C.InheritsFrom(TPasDotClassOrRecordScope) then
- ClassRecScope:=TPasDotClassOrRecordScope(StartScope).ClassRecScope
- else if C=ScopeClass_WithExpr then
- begin
- ClassRecScope:=TPasWithExprScope(StartScope).ClassRecScope;
- if ClassRecScope=nil then
- TypeEl:=TPasWithExprScope(StartScope).Scope.Element as TPasType;
- end
- else if C=ScopeClass_Procedure then
- ClassRecScope:=TPasProcedureScope(StartScope).ClassRecScope
- else if C=TPasDotHelperScope then
- TypeEl:=NoNil(TPasDotHelperScope(StartScope).Element) as TPasType
- else
- RaiseInternalError(20170131150855,GetObjName(StartScope));
- if TypeEl<>nil then
- TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl
- else
- begin
- if ClassRecScope=nil then
- RaiseInternalError(20190123120156,GetObjName(StartScope));
- TypeEl:=ClassRecScope.Element as TPasMembersType;
- if (TypeEl.ClassType=TPasClassType)
- and (TPasClassType(TypeEl).HelperForType<>nil) then
- TypeEl:=ResolveAliasType(TPasClassType(TypeEl).HelperForType) as TPasType;
- TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
- if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then
- begin
- if (TypeEl.ClassType=TPasClassType) and TPasClassType(TypeEl).IsAbstract then
- LogMsg(20190224153450,mtWarning,nCreatingAnInstanceOfAbstractClassY,
- sCreatingAnInstanceOfAbstractClassY,[TypeEl.Name],FindData.ErrorPosEl)
- else
- begin
- AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
- if (length(AbstractProcs)>0) then
- begin
- if IsClassOf then
- // aClass.Create: do not warn
- else
- for i:=0 to length(AbstractProcs)-1 do
- LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
- sConstructingClassXWithAbstractMethodY,
- [TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
- end;
- end;
- end;
- end;
- end;
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if (Proc.ClassType=TPasConstructor) then
- begin
- write('TPasResolver.CheckFoundElement ',GetObjName(Proc));
- if Ref=nil then
- write(' no ref!')
- else
- begin
- write(' rrfNewInstance=',rrfNewInstance in Ref.Flags,
- ' StartScope=',GetObjName(StartScope),
- ' OnlyTypeMembers=',OnlyTypeMembers);
- end;
- writeln;
- end;
- {AllowWriteln-}
- {$ENDIF}
- // destructor: FreeInstance or normal call
- // it is a normal call if 'inherited'
- if (Proc.ClassType=TPasDestructor) and (Ref<>nil) then
- if not (StartScope is TPasInheritedScope) then
- Ref.Flags:=Ref.Flags+[rrfFreeInstance];
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if (Proc.ClassType=TPasDestructor) then
- begin
- write('TPasResolver.CheckFoundElement ',GetObjName(Proc));
- if Ref=nil then
- write(' no ref!')
- else
- begin
- write(' rrfFreeInstance=',rrfFreeInstance in Ref.Flags,
- ' StartScope=',GetObjName(StartScope));
- if StartScope is TPasDotClassOrRecordScope then
- write(' InheritedExpr=',StartScope is TPasInheritedScope);
- end;
- writeln;
- end;
- {AllowWriteln-}
- {$ENDIF}
- end;
- CheckFoundElementVisibility(FindData,Ref);
- end;
- procedure TPasResolver.CheckFoundElementVisibility(const FindData: TPRFindData;
- Ref: TResolvedReference);
- var
- Context: TPasElement;
- FoundContext: TPasMembersType;
- CurScope: TPasScope;
- {$IFDEF VerbosePasResolver}
- i: Integer;
- {$ENDIF}
- begin
- // check class visibility
- if FindData.Found.Visibility in [visPrivate,visProtected,visStrictPrivate,visStrictProtected] then
- begin
- Context:=GetVisibilityContext;
- FoundContext:=FindData.Found.Parent as TPasMembersType;
- case FindData.Found.Visibility of
- visPrivate:
- // private members can only be accessed in same module
- if FoundContext.GetModule<>Context.GetModule then
- RaiseMsg(20170216152354,nCantAccessXMember,sCantAccessXMember,
- ['private',FindData.Found.Name],FindData.ErrorPosEl);
- visProtected:
- begin
- // protected members can only be accessed in same module
- // or descendant classes
- CurScope:=TopScope;
- if FoundContext.GetModule=Context.GetModule then
- // same module -> ok
- else if (Context is TPasType)
- and (CheckClassIsClass(TPasType(Context),FoundContext)<>cIncompatible) then
- // context in class or descendant
- else if (CurScope is TPasDotClassOrRecordScope)
- and (TPasDotClassOrRecordScope(CurScope).ClassRecScope.Element.GetModule=Context.GetModule) then
- // e.g. aClassInThisModule.identifier
- else if (CurScope is TPasWithExprScope)
- and (TPasWithExprScope(CurScope).Scope.Element<>nil)
- and (TPasWithExprScope(CurScope).Scope.Element.GetModule=Context.GetModule) then
- // e.g. with aClassInThisModule do identifier
- else
- RaiseMsg(20170216152356,nCantAccessXMember,sCantAccessXMember,
- ['protected',FindData.Found.Name],FindData.ErrorPosEl);
- end;
- visStrictPrivate:
- // strict private members can only be accessed in their class
- if Context<>FoundContext then
- begin
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- writeln('TPasResolver.CheckFoundElement Context=',GetElementDbgPath(Context),' FoundContext=',GetElementDbgPath(FoundContext));
- for i:=ScopeCount-1 downto 0 do
- writeln(' ',i,' ',Scopes[i].ClassName,' Element=',GetObjName(Scopes[i].Element),' VisibilityContext=',GetObjName(Scopes[i].VisibilityContext));
- {AllowWriteln-}
- {$ENDIF}
- RaiseMsg(20170216152357,nCantAccessXMember,sCantAccessXMember,
- ['strict private',FindData.Found.Name],FindData.ErrorPosEl);
- end;
- visStrictProtected:
- // strict protected members can only be accessed in their and descendant classes
- if (Context is TPasType)
- and (CheckClassIsClass(TPasType(Context),FoundContext)<>cIncompatible) then
- // context in class or descendant
- else
- RaiseMsg(20170216152400,nCantAccessXMember,sCantAccessXMember,
- ['strict protected',FindData.Found.Name],FindData.ErrorPosEl);
- end;
- end;
- if Ref=nil then ;
- end;
- function TPasResolver.GetVisibilityContext: TPasElement;
- var
- i: Integer;
- begin
- for i:=ScopeCount-1 downto 0 do
- begin
- Result:=Scopes[i].VisibilityContext;
- if Result<>nil then exit;
- end;
- Result:=nil;
- end;
- procedure TPasResolver.BeginScope(ScopeType: TPasScopeType; El: TPasElement);
- begin
- case ScopeType of
- stWithExpr: PushWithExprScope(El as TPasExpr);
- else
- RaiseMsg(20181210163324,nNotYetImplemented,sNotYetImplemented+' BeginScope',[IntToStr(ord(ScopeType))],nil);
- end;
- end;
- procedure TPasResolver.FinishScope(ScopeType: TPasScopeType; El: TPasElement);
- begin
- if IsElementSkipped(El) then exit;
- case ScopeType of
- stModule: FinishModule(El as TPasModule);
- stUsesClause: FinishUsesClause;
- stTypeSection: FinishTypeSection(El);
- stTypeDef: FinishTypeDef(El as TPasType);
- stResourceString: FinishResourcestring(El as TPasResString);
- stProcedure: FinishProcedure(El as TPasProcedure);
- stProcedureHeader: FinishProcedureType(El as TPasProcedureType);
- stExceptOnExpr: FinishExceptOnExpr;
- stExceptOnStatement: FinishExceptOnStatement;
- stWithExpr: FinishWithDo(El as TPasImplWithDo);
- stForLoopHeader: FinishForLoopHeader(El as TPasImplForLoop);
- stDeclaration: FinishDeclaration(El);
- stAncestors: FinishAncestors(El as TPasClassType);
- stInitialFinalization: FinishInitialFinalization(El as TPasImplBlock);
- else
- RaiseMsg(20170216152401,nNotYetImplemented,sNotYetImplemented+' FinishScope',[IntToStr(ord(ScopeType))],nil);
- end;
- end;
- procedure TPasResolver.FinishTypeAlias(var NewType: TPasType);
- var
- TypeEl, DestType: TPasType;
- AncestorClass, aClass: TPasClassType;
- Scope: TPasIdentifierScope;
- OldType: TPasTypeAliasType;
- LocalScope: TPasScope;
- begin
- DestType:=TPasTypeAliasType(NewType).DestType;
- TypeEl:=ResolveSimpleAliasType(DestType);
- if TypeEl is TPasClassType then
- begin
- // change "=type aClassType" to "=class(aClassType)"
- // or change "=type aInterfaceType" to "=interface(aInterfaceType)"
- AncestorClass := TPasClassType(TypeEl);
- // remove aliastype from scope
- LocalScope:=GetLocalScope;
- Scope:=LocalScope as TPasIdentifierScope;
- Scope.RemoveLocalIdentifier(NewType);
- // create class or interface
- aClass := TPasClassType(CreateElement(TPasClassType,
- NewType.Name,NewType.Parent,NewType.Visibility,
- NewType.SourceFilename,NewType.SourceLinenumber));
- aClass.ObjKind := AncestorClass.ObjKind;
- // release old alias type
- OldType := TPasTypeAliasType(NewType);
- NewType := aClass;
- TPasTypeAliasType(OldType).DestType:=nil; // clear reference
- OldType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
- // set ancestor
- aClass.AncestorType := DestType;
- {$IFDEF CheckPasTreeRefCount}DestType.ChangeRefId('ResolveTypeReference','TPasClassType.AncestorType');{$ENDIF}
- FinishScope(stAncestors,aClass);
- end;
- end;
- function TPasResolver.IsUnitIntfFinished(AModule: TPasModule): boolean;
- var
- CurIntf: TInterfaceSection;
- begin
- CurIntf:=AModule.InterfaceSection;
- Result:=(CurIntf<>nil)
- and (CurIntf.CustomData is TPasSectionScope)
- and TPasSectionScope(CurIntf.CustomData).Finished;
- end;
- procedure TPasResolver.NotifyPendingUsedInterfaces;
- // called after unit interface is ready to be used by other modules
- var
- ModuleScope: TPasModuleScope;
- i: Integer;
- PendingResolver: TPasResolver;
- PendingSection: TPasSection;
- begin
- // call all PendingResolvers
- // Note that a waiting resolver might continue parsing
- ModuleScope:=RootElement.CustomData as TPasModuleScope;
- i:=ModuleScope.PendingResolvers.Count-1;
- while i>=0 do
- begin
- PendingResolver:=TObject(ModuleScope.PendingResolvers[i]) as TPasResolver;
- PendingSection:=PendingResolver.GetLastSection;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.NotifyPendingUsedInterfaces "',ModuleScope.Element.Name,'" Pending="',PendingResolver.RootElement.Name,'"');
- {$ENDIF}
- if PendingSection=nil then
- RaiseInternalError(20180305141421);
- PendingResolver.CheckPendingUsedInterface(PendingSection); // beware: this might alter the ModuleScope.PendingResolvers
- dec(i);
- if i>=ModuleScope.PendingResolvers.Count then
- i:=ModuleScope.PendingResolvers.Count-1;
- end;
- end;
- function TPasResolver.GetPendingUsedInterface(Section: TPasSection
- ): TPasUsesUnit;
- var
- i: Integer;
- UseUnit: TPasUsesUnit;
- begin
- Result:=nil;
- for i:=0 to length(Section.UsesClause)-1 do
- begin
- UseUnit:=Section.UsesClause[i];
- if not (UseUnit.Module is TPasModule) then continue;
- if not IsUnitIntfFinished(TPasModule(UseUnit.Module)) then
- exit(UseUnit);
- end;
- end;
- function TPasResolver.CheckPendingUsedInterface(Section: TPasSection): boolean;
- var
- PendingModule: TPasModule;
- PendingModuleScope: TPasModuleScope;
- List: TFPList;
- WasPending: Boolean;
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.CheckPendingUsedInterface START "',RootElement.Name,'" Section.PendingUsedIntf=',Section.PendingUsedIntf<>nil);
- {$ENDIF}
- WasPending:=Section.PendingUsedIntf<>nil;
- if WasPending then
- begin
- PendingModule:=Section.PendingUsedIntf.Module as TPasModule;
- if not IsUnitIntfFinished(PendingModule) then
- exit; // still pending
- // other unit interface is finished
- {$IF defined(VerbosePasResolver) or defined(VerboseUnitQueue)}
- writeln('TPasResolver.CheckPendingUsedInterface "',RootElement.Name,'" UnitIntf finished of "',PendingModule.Name,'"');
- {$ENDIF}
- PendingModuleScope:=NoNil(PendingModule.CustomData) as TPasModuleScope;
- PendingModuleScope.PendingResolvers.Remove(Self);
- Section.PendingUsedIntf:=nil;
- end;
- Section.PendingUsedIntf:=GetPendingUsedInterface(Section);
- //writeln('TPasResolver.CheckPendingUsedInterface ',GetObjName(RootElement),' Section=',GetObjName(Section),' PendingUsedIntf=',GetObjName(Section.PendingUsedIntf));
- if Section.PendingUsedIntf<>nil then
- begin
- // module not yet finished due to pending used interfaces
- PendingModule:=Section.PendingUsedIntf.Module as TPasModule;
- PendingModuleScope:=NoNil(PendingModule.CustomData) as TPasModuleScope;
- {$IF defined(VerbosePasResolver) or defined(VerboseUnitQueue)}
- writeln('TPasResolver.CheckPendingUsedInterface "',RootElement.Name,'" waiting for unit intf of "',PendingModule.Name,'"');
- {$ENDIF}
- List:=PendingModuleScope.PendingResolvers;
- if List.IndexOf(Self)<0 then
- List.Add(Self);
- Result:=not WasPending;
- end
- else
- begin
- {$IF defined(VerbosePasResolver) or defined(VerboseUnitQueue)}
- {AllowWriteln}
- if WasPending then
- writeln('TPasResolver.CheckPendingUsedInterface "',RootElement.Name,'" uses section complete: ',Section.ClassName);
- {AllowWriteln-}
- {$ENDIF}
- Result:=WasPending;
- if Result then
- UsedInterfacesFinished(Section);
- end;
- end;
- procedure TPasResolver.UsedInterfacesFinished(Section: TPasSection);
- // if there is a unit cycle that stopped parsing this unit
- // this method is called after the needed used unit interfaces have finished
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.UsesSectionFinished ',Section.ElementTypeName,' "',RootElement.Name,'"...');
- {$ENDIF}
- CurrentParser.ParseContinue;
- if Section=nil then ;
- end;
- function TPasResolver.NeedArrayValues(El: TPasElement): boolean;
- // called by the parser when reading DoParseConstValueExpression
- var
- C: TClass;
- V: TPasVariable;
- TypeEl: TPasType;
- begin
- Result:=false;
- if El=nil then exit;
- C:=El.ClassType;
- if (C=TPasConst) or (C=TPasVariable) then
- begin
- V:=TPasVariable(El);
- if V.VarType=nil then exit;
- TypeEl:=ResolveAliasType(V.VarType);
- Result:=TypeEl.ClassType=TPasArrayType;
- end;
- //writeln('TPasResolver.NeedArrayValues ',GetObjName(El));
- end;
- function TPasResolver.GetDefaultClassVisibility(AClass: TPasClassType
- ): TPasMemberVisibility;
- var
- ClassScope: TPasClassScope;
- begin
- if AClass.CustomData=nil then
- exit(visDefault);
- ClassScope:=(AClass.CustomData as TPasClassScope);
- if pcsfPublished in ClassScope.Flags then
- Result:=visPublished
- else
- Result:=visPublic;
- end;
- procedure TPasResolver.ModeChanged(Sender: TObject; NewMode: TModeSwitch;
- Before: boolean; var Handled: boolean);
- begin
- inherited ModeChanged(Sender, NewMode, Before, Handled);
- if not Before then
- begin
- if LastElement is TPasSection then
- TPasSectionScope(LastElement.CustomData).ModeSwitches:=CurrentParser.CurrentModeswitches;
- end;
- end;
- class procedure TPasResolver.UnmangleSourceLineNumber(LineNumber: integer; out
- Line, Column: integer);
- begin
- Line:=Linenumber;
- Column:=0;
- if Line<0 then begin
- Line:=-Line;
- Column:=Line mod ParserMaxEmbeddedColumn;
- Line:=Line div ParserMaxEmbeddedColumn;
- end;
- end;
- class function TPasResolver.GetDbgSourcePosStr(El: TPasElement): string;
- var
- Line, Column: integer;
- begin
- if El=nil then exit('nil');
- UnmangleSourceLineNumber(El.SourceLinenumber,Line,Column);
- Result:=El.SourceFilename+'('+IntToStr(Line);
- if Column>0 then
- Result:=Result+','+IntToStr(Column);
- Result:=Result+')';
- end;
- function TPasResolver.GetElementSourcePosStr(El: TPasElement): string;
- var
- Line, Column: integer;
- begin
- if El=nil then exit('nil');
- UnmangleSourceLineNumber(El.SourceLinenumber,Line,Column);
- if (Line=0) then
- begin
- if El is TPasUnresolvedSymbolRef then
- exit('intrinsic');
- end;
- Result:=CurrentParser.Scanner.FormatPath(El.SourceFilename)+'('+IntToStr(Line);
- if Column>0 then
- Result:=Result+','+IntToStr(Column);
- Result:=Result+')';
- end;
- destructor TPasResolver.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasResolver.Destroy START ',ClassName);
- {$ENDIF}
- Clear;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasResolver.Destroy PopScope...');
- {$ENDIF}
- PopScope; // free default scope
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasResolver.Destroy FPendingForwards...');
- {$ENDIF}
- FreeAndNil(FPendingForwardProcs);
- FreeAndNil(fExprEvaluator);
- ClearBuiltInIdentifiers;
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasResolver.Destroy END ',ClassName);
- {$ENDIF}
- end;
- procedure TPasResolver.Clear;
- begin
- ClearHelperList(FActiveHelpers);
- RestoreStashedScopes(0);
- // clear stack, keep DefaultScope
- while (FScopeCount>0) and (FTopScope<>DefaultScope) do
- PopScope;
- ClearResolveDataList(lkModule);
- end;
- procedure TPasResolver.ClearBuiltInIdentifiers;
- var
- bt: TResolverBaseType;
- bp: TResolverBuiltInProc;
- begin
- ClearResolveDataList(lkBuiltIn);
- for bt in TResolverBaseType do
- ReleaseAndNil(TPasElement(FBaseTypes[bt]){$IFDEF CheckPasTreeRefCount},'TPasResolver.AddBaseType'{$ENDIF});
- for bp in TResolverBuiltInProc do
- FBuiltInProcs[bp]:=nil;
- end;
- procedure TPasResolver.AddObjFPCBuiltInIdentifiers(
- const TheBaseTypes: TResolveBaseTypes;
- const TheBaseProcs: TResolverBuiltInProcs);
- var
- bt: TResolverBaseType;
- begin
- for bt in TheBaseTypes do
- AddBaseType(BaseTypeNames[bt],bt);
- if bfLength in TheBaseProcs then
- AddBuiltInProc('Length','function Length(const String or Array): sizeint',
- @BI_Length_OnGetCallCompatibility,@BI_Length_OnGetCallResult,
- @BI_Length_OnEval,nil,bfLength);
- if bfSetLength in TheBaseProcs then
- AddBuiltInProc('SetLength','procedure SetLength(var String or Array; NewLength: sizeint)',
- @BI_SetLength_OnGetCallCompatibility,nil,nil,
- @BI_SetLength_OnFinishParamsExpr,bfSetLength,[bipfCanBeStatement]);
- if bfInclude in TheBaseProcs then
- AddBuiltInProc('Include','procedure Include(var Set of Enum; const Enum)',
- @BI_InExclude_OnGetCallCompatibility,nil,nil,
- @BI_InExclude_OnFinishParamsExpr,bfInclude,[bipfCanBeStatement]);
- if bfExclude in TheBaseProcs then
- AddBuiltInProc('Exclude','procedure Exclude(var Set of Enum; const Enum)',
- @BI_InExclude_OnGetCallCompatibility,nil,nil,
- @BI_InExclude_OnFinishParamsExpr,bfExclude,[bipfCanBeStatement]);
- if bfBreak in TheBaseProcs then
- AddBuiltInProc('Break','procedure Break',
- @BI_Break_OnGetCallCompatibility,nil,nil,nil,bfBreak,[bipfCanBeStatement]);
- if bfContinue in TheBaseProcs then
- AddBuiltInProc('Continue','procedure Continue',
- @BI_Continue_OnGetCallCompatibility,nil,nil,nil,bfContinue,[bipfCanBeStatement]);
- if bfExit in TheBaseProcs then
- AddBuiltInProc('Exit','procedure Exit(result)',
- @BI_Exit_OnGetCallCompatibility,nil,nil,nil,bfExit,[bipfCanBeStatement]);
- if bfInc in TheBaseProcs then
- AddBuiltInProc('Inc','procedure Inc(var Integer; const Incr: Integer = 1)',
- @BI_IncDec_OnGetCallCompatibility,nil,nil,
- @BI_IncDec_OnFinishParamsExpr,bfInc,[bipfCanBeStatement]);
- if bfDec in TheBaseProcs then
- AddBuiltInProc('Dec','procedure Dec(var Integer; const Decr: Integer = 1)',
- @BI_IncDec_OnGetCallCompatibility,nil,nil,
- @BI_IncDec_OnFinishParamsExpr,bfDec,[bipfCanBeStatement]);
- if bfAssigned in TheBaseProcs then
- AddBuiltInProc('Assigned','function Assigned(const Pointer or Class or Class-of): boolean',
- @BI_Assigned_OnGetCallCompatibility,@BI_Assigned_OnGetCallResult,
- nil,@BI_Assigned_OnFinishParamsExpr,bfAssigned);
- if bfChr in TheBaseProcs then
- AddBuiltInProc('Chr','function Chr(const Integer): char',
- @BI_Chr_OnGetCallCompatibility,@BI_Chr_OnGetCallResult,
- @BI_Chr_OnEval,nil,bfChr);
- if bfOrd in TheBaseProcs then
- AddBuiltInProc('Ord','function Ord(const Enum or Char): integer',
- @BI_Ord_OnGetCallCompatibility,@BI_Ord_OnGetCallResult,
- @BI_Ord_OnEval,nil,bfOrd);
- if bfLow in TheBaseProcs then
- AddBuiltInProc('Low','function Low(const array or ordinal): ordinal or integer',
- @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,
- @BI_LowHigh_OnEval,nil,bfLow);
- if bfHigh in TheBaseProcs then
- AddBuiltInProc('High','function High(const array or ordinal): ordinal or integer',
- @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,
- @BI_LowHigh_OnEval,nil,bfHigh);
- if bfPred in TheBaseProcs then
- AddBuiltInProc('Pred','function Pred(const ordinal): ordinal',
- @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
- @BI_PredSucc_OnEval,nil,bfPred);
- if bfSucc in TheBaseProcs then
- AddBuiltInProc('Succ','function Succ(const ordinal): ordinal',
- @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
- @BI_PredSucc_OnEval,nil,bfSucc);
- if bfStrProc in TheBaseProcs then
- AddBuiltInProc('Str','procedure Str(const var; var String)',
- @BI_StrProc_OnGetCallCompatibility,nil,nil,
- @BI_StrProc_OnFinishParamsExpr,bfStrProc,[bipfCanBeStatement]);
- if bfStrFunc in TheBaseProcs then
- AddBuiltInProc('Str','function Str(const var): String',
- @BI_StrFunc_OnGetCallCompatibility,@BI_StrFunc_OnGetCallResult,
- @BI_StrFunc_OnEval,nil,bfStrFunc);
- if bfWriteStr in TheBaseProcs then
- AddBuiltInProc('WriteStr','procedure WriteStr(out String; params...)',
- @BI_WriteStrProc_OnGetCallCompatibility,nil,nil,
- @BI_WriteStrProc_OnFinishParamsExpr,bfWriteStr,[bipfCanBeStatement]);
- if bfVal in TheBaseProcs then
- AddBuiltInProc('Val','procedure Val(const String; var Value: bool|int|float|enum; out Int)',
- @BI_Val_OnGetCallCompatibility,nil,nil,
- @BI_Val_OnFinishParamsExpr,bfVal,[bipfCanBeStatement]);
- if bfLo in TheBaseProcs then
- AddBuiltInProc('Lo','function Lo(X: any integer type): Byte|Word)',
- @BI_LoHi_OnGetCallCompatibility,@BI_LoHi_OnGetCallResult,
- @BI_LoHi_OnEval,nil,bfLo);
- if bfHi in TheBaseProcs then
- AddBuiltInProc('Hi','function Hi(X: any integer type): Byte|Word)',
- @BI_LoHi_OnGetCallCompatibility,@BI_LoHi_OnGetCallResult,
- @BI_LoHi_OnEval,nil,bfHi);
- if bfConcatArray in TheBaseProcs then
- AddBuiltInProc('Concat','function Concat(const Array1, Array2, ...): Array',
- @BI_ConcatArray_OnGetCallCompatibility,@BI_ConcatArray_OnGetCallResult,
- nil,nil,bfConcatArray);
- if bfConcatString in TheBaseProcs then
- AddBuiltInProc('Concat','function Concat(const String1, String2, ...): String',
- @BI_ConcatString_OnGetCallCompatibility,@BI_ConcatString_OnGetCallResult,
- @BI_ConcatString_OnEval,nil,bfConcatString);
- if bfCopyArray in TheBaseProcs then
- AddBuiltInProc('Copy','function Copy(const Array; Start: integer = 0; Count: integer = all): Array',
- @BI_CopyArray_OnGetCallCompatibility,@BI_CopyArray_OnGetCallResult,
- nil,nil,bfCopyArray);
- if bfInsertArray in TheBaseProcs then
- AddBuiltInProc('Insert','procedure Insert(const Element; var Array; Index: integer)',
- @BI_InsertArray_OnGetCallCompatibility,nil,nil,
- @BI_InsertArray_OnFinishParamsExpr,bfInsertArray,[bipfCanBeStatement]);
- if bfDeleteArray in TheBaseProcs then
- AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)',
- @BI_DeleteArray_OnGetCallCompatibility,nil,nil,
- @BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]);
- if bfTypeInfo in TheBaseProcs then
- AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer',
- @BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult,
- nil,nil,bfTypeInfo);
- if bfGetTypeKind in TheBaseProcs then
- AddBuiltInProc('GetTypeKind','function GetTypeKind(type or var identifier): System.TTypeKind',
- @BI_GetTypeKind_OnGetCallCompatibility,@BI_GetTypeKind_OnGetCallResult,
- @BI_GetTypeKind_OnEval,nil,bfGetTypeKind);
- if bfAssert in TheBaseProcs then
- AddBuiltInProc('Assert','procedure Assert(bool[,string])',
- @BI_Assert_OnGetCallCompatibility,nil,nil,
- @BI_Assert_OnFinishParamsExpr,bfAssert,[bipfCanBeStatement]);
- if bfNew in TheBaseProcs then
- AddBuiltInProc('New','procedure New(out ^record)',
- @BI_New_OnGetCallCompatibility,nil,nil,
- @BI_New_OnFinishParamsExpr,bfNew,[bipfCanBeStatement]);
- if bfDispose in TheBaseProcs then
- AddBuiltInProc('Dispose','procedure Dispose(var ^record)',
- @BI_Dispose_OnGetCallCompatibility,nil,nil,
- @BI_Dispose_OnFinishParamsExpr,bfDispose,[bipfCanBeStatement]);
- if bfDefault in TheBaseProcs then
- AddBuiltInProc('Default','function Default(T): T',
- @BI_Default_OnGetCallCompatibility,@BI_Default_OnGetCallResult,
- @BI_Default_OnEval,nil,bfDefault,[]);
- end;
- function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType
- ): TResElDataBaseType;
- var
- El: TPasUnresolvedSymbolRef;
- begin
- El:=TPasUnresolvedSymbolRef.Create(aName,nil);
- {$IFDEF CheckPasTreeRefCount}El.RefIds.Add('TPasResolver.AddBaseType');{$ENDIF}
- if not (Typ in [btNone,btCustom]) then
- FBaseTypes[Typ]:=El;
- Result:=TResElDataBaseType.Create;
- Result.BaseType:=Typ;
- AddResolveData(El,Result,lkBuiltIn);
- FDefaultScope.AddIdentifier(aName,El,pikBaseType);
- end;
- function TPasResolver.AddCustomBaseType(const aName: string;
- aClass: TResElDataBaseTypeClass): TPasUnresolvedSymbolRef;
- var
- CustomData: TResElDataBaseType;
- begin
- Result:=TPasUnresolvedSymbolRef.Create(aName,nil);
- {$IFDEF CheckPasTreeRefCount}Result.RefIds.Add('TPasResolver.AddCustomBaseType');{$ENDIF}
- CustomData:=aClass.Create;
- CustomData.BaseType:=btCustom;
- AddResolveData(Result,CustomData,lkBuiltIn);
- FDefaultScope.AddIdentifier(aName,Result,pikBaseType);
- end;
- function TPasResolver.IsBaseType(aType: TPasType; BaseType: TResolverBaseType;
- ResolveAlias: boolean): boolean;
- begin
- Result:=false;
- if aType=nil then exit;
- if ResolveAlias then
- aType:=ResolveAliasType(aType);
- if aType.ClassType<>TPasUnresolvedSymbolRef then exit;
- Result:=CompareText(aType.Name,BaseTypeNames[BaseType])=0;
- end;
- function TPasResolver.AddBuiltInProc(const aName: string; Signature: string;
- const GetCallCompatibility: TOnGetCallCompatibility;
- const GetCallResult: TOnGetCallResult; const EvalConst: TOnEvalBIFunction;
- const FinishParamsExpr: TOnFinishParamsExpr;
- const BuiltIn: TResolverBuiltInProc; const Flags: TBuiltInProcFlags
- ): TResElDataBuiltInProc;
- var
- El: TPasUnresolvedSymbolRef;
- begin
- El:=TPasUnresolvedSymbolRef.Create(aName,nil);
- Result:=TResElDataBuiltInProc.Create;
- Result.Proc:=El;
- {$IFDEF CheckPasTreeRefCount}El.RefIds.Add('TResElDataBuiltInProc.Proc');{$ENDIF}
- Result.Signature:=Signature;
- Result.BuiltIn:=BuiltIn;
- Result.GetCallCompatibility:=GetCallCompatibility;
- Result.GetCallResult:=GetCallResult;
- Result.Eval:=EvalConst;
- Result.FinishParamsExpression:=FinishParamsExpr;
- Result.Flags:=Flags;
- AddResolveData(El,Result,lkBuiltIn);
- FDefaultScope.AddIdentifier(aName,El,pikBuiltInProc);
- if BuiltIn<>bfCustom then
- FBuiltInProcs[BuiltIn]:=Result;
- end;
- procedure TPasResolver.AddResolveData(El: TPasElement; Data: TResolveData;
- Kind: TResolveDataListKind);
- begin
- if Data.Element<>nil then
- RaiseInternalError(20171111162227);
- if El.CustomData<>nil then
- RaiseInternalError(20171111162236);
- Data.Element:=El;
- Data.Owner:=Self;
- Data.Next:=FLastCreatedData[Kind];
- FLastCreatedData[Kind]:=Data;
- El.CustomData:=Data;
- end;
- function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement;
- Access: TResolvedRefAccess; FindData: PPRFindData): TResolvedReference;
- procedure RaiseAlreadySet;
- var
- FormerDeclEl: TPasElement;
- begin
- {AllowWriteln}
- writeln('RaiseAlreadySet RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl));
- writeln(' RefEl at ',GetElementSourcePosStr(RefEl));
- writeln(' RefEl.CustomData=',GetObjName(RefEl.CustomData));
- if RefEl.CustomData is TResolvedReference then
- begin
- FormerDeclEl:=TResolvedReference(RefEl.CustomData).Declaration;
- writeln(' TResolvedReference(RefEl.CustomData).Declaration=',GetObjName(FormerDeclEl),
- ' IsSame=',FormerDeclEl=DeclEl);
- end;
- {AllowWriteln-}
- RaiseInternalError(20160922163554,'customdata<>nil');
- end;
- begin
- if RefEl.CustomData<>nil then
- RaiseAlreadySet;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl));
- {$ENDIF}
- Result:=TResolvedReference.Create;
- if FindData<>nil then
- begin
- if FindData^.StartScope.ClassType=ScopeClass_WithExpr then
- Result.WithExprScope:=TPasWithExprScope(FindData^.StartScope);
- end;
- AddResolveData(RefEl,Result,lkModule);
- Result.Declaration:=DeclEl;
- if RefEl is TPasExpr then
- SetResolvedRefAccess(TPasExpr(RefEl),Result,Access);
- EmitElementHints(RefEl,DeclEl);
- end;
- procedure TPasResolver.WriteScopesShort(Title: string);
- var
- i: Integer;
- begin
- {AllowWriteln}
- writeln(Title,' ScopeCount=',ScopeCount,' FStashScopeCount=',FStashScopeCount);
- for i:=0 to FScopeCount-1 do
- writeln(' ',i,'/',FScopeCount,' ',GetObjName(FScopes[i]));
- {AllowWriteln-}
- end;
- function TPasResolver.CreateScope(El: TPasElement; ScopeClass: TPasScopeClass
- ): TPasScope;
- begin
- if not ScopeClass.IsStoredInElement then
- RaiseInternalError(20160923121858);
- if El.CustomData<>nil then
- RaiseInternalError(20160923121849);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CreateScope El=',GetObjName(El),' ScopeClass=',ScopeClass.ClassName);
- {$ENDIF}
- Result:=ScopeClass.Create;
- if Result.FreeOnPop then
- begin
- Result.Element:=El;
- El.CustomData:=Result;
- Result.Owner:=Self;
- end
- else
- // add to free list
- AddResolveData(El,Result,lkModule);
- end;
- function TPasResolver.CreateGroupScope(HiType: TPasType; WithTopHelpers: boolean
- ): TPasGroupScope;
- begin
- Result:=TPasGroupScope.Create;
- Result.Element:=HiType;
- GroupScope_AddTypeAndAncestors(Result,HiType,WithTopHelpers);
- end;
- procedure TPasResolver.GroupScope_AddTypeAndAncestors(Scope: TPasGroupScope;
- HiType: TPasType; WithTopHelpers: boolean);
- var
- IsClass: Boolean;
- i: Integer;
- Entry: TPRHelperEntry;
- HelperForType, LoType: TPasType;
- AncestorScope, HelperScope: TPasClassScope;
- C: TClass;
- begin
- HiType:=ResolveAliasType(HiType,false);
- LoType:=ResolveAliasType(HiType);
- IsClass:=LoType.ClassType=TPasClassType;
- if IsClass and (TPasClassType(LoType).HelperForType<>nil) then
- begin
- // start in a helper
- WithTopHelpers:=false;
- // first add helper and its ancestors
- HelperScope:=TPasClassScope(LoType.CustomData);
- while HelperScope<>nil do
- begin
- Scope.Add(HelperScope);
- HelperScope:=HelperScope.AncestorScope;
- end;
- // then add the HelperForType and its ancestors
- HiType:=ResolveAliasType(TPasClassType(HiType).HelperForType,false);
- LoType:=ResolveAliasType(HiType);
- IsClass:=LoType.ClassType=TPasClassType;
- end;
- repeat
- // first add helper(s)
- if WithTopHelpers then
- begin
- for i:=length(FActiveHelpers)-1 downto 0 do
- begin
- Entry:=FActiveHelpers[i];
- HelperForType:=Entry.HelperForType;
- if IsSameType(HelperForType,HiType,prraNone) then
- begin
- // add Helper and its ancestors
- HelperScope:=TPasClassScope(Entry.Helper.CustomData);
- while HelperScope<>nil do
- begin
- Scope.Add(HelperScope);
- HelperScope:=HelperScope.AncestorScope;
- end;
- if not (msMultiHelpers in CurrentParser.CurrentModeswitches) then
- break;
- end;
- end;
- end
- else
- WithTopHelpers:=true;
- // then add scope of LoType
- C:=LoType.ClassType;
- if (C=TPasClassType) or (C=TPasRecordType) then
- Scope.Add(LoType.CustomData as TPasIdentifierScope);
- // continue with ancestor
- if not IsClass then break;
- AncestorScope:=(LoType.CustomData as TPasClassScope).AncestorScope;
- if AncestorScope=nil then break;
- HiType:=TPasClassType(AncestorScope.Element);
- LoType:=HiType;
- until LoType=nil;
- end;
- procedure TPasResolver.PopScope;
- var
- Scope: TPasScope;
- begin
- if FScopeCount=0 then
- RaiseInternalError(20160922163557);
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- //writeln('TPasResolver.PopScope ',FScopeCount,' ',FTopScope<>nil,' IsDefault=',FTopScope=FDefaultScope);
- writeln('TPasResolver.PopScope ',FTopScope.ClassName,' IsStoredInElement=',FTopScope.IsStoredInElement,' Element=',GetObjName(FTopScope.Element),' FreeOnPop=',FTopScope.FreeOnPop);
- {AllowWriteln-}
- {$ENDIF}
- dec(FScopeCount);
- if FTopScope.FreeOnPop then
- begin
- Scope:=FScopes[FScopeCount];
- if (Scope.Element<>nil) and (Scope.Element.CustomData=Scope) then
- Scope.Element.CustomData:=nil;
- if Scope=FDefaultScope then
- FDefaultScope:=nil;
- FScopes[FScopeCount]:=nil;
- Scope.Free;
- end;
- if FScopeCount>0 then
- FTopScope:=FScopes[FScopeCount-1]
- else
- FTopScope:=nil;
- end;
- procedure TPasResolver.PopWithScope(El: TPasImplWithDo);
- var
- WithScope: TPasWithScope;
- i: Integer;
- begin
- WithScope:=El.CustomData as TPasWithScope;
- for i:=WithScope.ExpressionScopes.Count-1 downto 0 do
- begin
- CheckTopScope(ScopeClass_WithExpr);
- if TopScope<>WithScope.ExpressionScopes[i] then
- RaiseInternalError(20160923102846);
- PopScope;
- end;
- CheckTopScope(TPasWithScope);
- PopScope;
- end;
- procedure TPasResolver.PopGenericParamScope(El: TPasGenericType);
- var
- TemplType: TPasGenericTemplateType;
- begin
- if (El.GenericTemplateTypes<>nil) and (El.GenericTemplateTypes.Count>0) then
- begin
- TemplType:=TPasGenericTemplateType(El.GenericTemplateTypes[0]);
- if not (TopScope is TPasGenericParamsScope) then
- RaiseNotYetImplemented(20190831204109,El,GetObjName(TopScope));
- if TopScope.Element<>TemplType then
- RaiseNotYetImplemented(20190831204134,El,GetObjName(TopScope.Element));
- PopScope;
- end
- else
- begin
- if TopScope is TPasGenericParamsScope then
- RaiseNotYetImplemented(20190831204213,El,GetObjName(TopScope.Element));
- end;
- end;
- procedure TPasResolver.PushScope(Scope: TPasScope);
- begin
- if Scope=nil then
- RaiseInternalError(20160922163601);
- if length(FScopes)=FScopeCount then
- SetLength(FScopes,FScopeCount*2+10);
- FScopes[FScopeCount]:=Scope;
- inc(FScopeCount);
- FTopScope:=Scope;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.PushScope ScopeCount=',ScopeCount,' ',GetObjName(FTopScope));
- {$ENDIF}
- end;
- function TPasResolver.PushScope(El: TPasElement; ScopeClass: TPasScopeClass
- ): TPasScope;
- begin
- Result:=CreateScope(El,ScopeClass);
- PushScope(Result);
- end;
- function TPasResolver.PushGroupScope(HiType: TPasType): TPasGroupScope;
- begin
- Result:=CreateGroupScope(HiType);
- PushScope(Result);
- end;
- function TPasResolver.PushModuleDotScope(aModule: TPasModule): TPasModuleDotScope;
- begin
- Result:=TPasModuleDotScope.Create;
- Result.Owner:=Self;
- Result.Module:=aModule;
- if aModule is TPasProgram then
- begin // program
- if TPasProgram(aModule).ProgramSection<>nil then
- Result.InterfaceScope:=
- NoNil(TPasProgram(aModule).ProgramSection.CustomData) as TPasSectionScope;
- end
- else if aModule is TPasLibrary then
- begin // library
- if TPasLibrary(aModule).LibrarySection<>nil then
- Result.InterfaceScope:=
- NoNil(TPasLibrary(aModule).LibrarySection.CustomData) as TPasSectionScope;
- end
- else
- begin // unit
- if aModule.InterfaceSection<>nil then
- Result.InterfaceScope:=
- NoNil(aModule.InterfaceSection.CustomData) as TPasSectionScope;
- if (aModule=RootElement)
- and (aModule.ImplementationSection<>nil)
- and (aModule.ImplementationSection.CustomData<>nil)
- then
- Result.ImplementationScope:=NoNil(aModule.ImplementationSection.CustomData) as TPasSectionScope;
- if CompareText(aModule.Name,'system')=0 then
- Result.SystemScope:=DefaultScope;
- end;
- PushScope(Result);
- end;
- function TPasResolver.PushClassDotScope(var CurClassType: TPasClassType;
- WithTopHelpers: boolean): TPasDotClassScope;
- var
- ClassScope: TPasClassScope;
- Ref: TResolvedReference;
- begin
- if CurClassType.IsForward then
- begin
- Ref:=CurClassType.CustomData as TResolvedReference;
- CurClassType:=Ref.Declaration as TPasClassType;
- end;
- if CurClassType.CustomData=nil then
- RaiseInternalError(20160922163611);
- ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope;
- Result:=TPasDotClassScope.Create;
- Result.Owner:=Self;
- Result.ClassRecScope:=ClassScope;
- Result.GroupScope:=CreateGroupScope(CurClassType,WithTopHelpers);
- PushScope(Result);
- end;
- function TPasResolver.PushRecordDotScope(CurRecordType: TPasRecordType): TPasDotClassOrRecordScope;
- var
- RecScope: TPasRecordScope;
- begin
- RecScope:=NoNil(CurRecordType.CustomData) as TPasRecordScope;
- Result:=TPasDotClassOrRecordScope.Create;
- Result.Owner:=Self;
- Result.ClassRecScope:=RecScope;
- Result.GroupScope:=CreateGroupScope(CurRecordType);
- PushScope(Result);
- end;
- function TPasResolver.PushInheritedScope(ClassOrRec: TPasMembersType;
- WithTopHelpers: boolean; AncestorScope: TPasClassScope): TPasInheritedScope;
- begin
- Result:=TPasInheritedScope.Create;
- Result.Owner:=Self;
- Result.ClassRecScope:=NoNil(ClassOrRec.CustomData) as TPasClassOrRecordScope;
- Result.AncestorScope:=AncestorScope;
- Result.GroupScope:=CreateGroupScope(ClassOrRec,WithTopHelpers);
- PushScope(Result);
- end;
- function TPasResolver.PushEnumDotScope(HiType: TPasType;
- EnumLoType: TPasEnumType): TPasDotEnumTypeScope;
- begin
- Result:=TPasDotEnumTypeScope.Create;
- Result.Owner:=Self;
- Result.EnumScope:=NoNil(EnumLoType.CustomData) as TPasEnumTypeScope;
- Result.GroupScope:=CreateGroupScope(HiType);
- PushScope(Result);
- end;
- function TPasResolver.PushHelperDotScope(HiType: TPasType): TPasDotBaseScope;
- var
- Group: TPasGroupScope;
- begin
- Group:=CreateGroupScope(HiType);
- if Group.Count=0 then
- begin
- Group.Free;
- exit(nil);
- end;
- Result:=TPasDotHelperScope.Create;
- Result.Element:=HiType;
- Result.Owner:=Self;
- Result.GroupScope:=Group;
- PushScope(Result);
- end;
- function TPasResolver.PushTemplateDotScope(TemplType: TPasGenericTemplateType;
- ErrorEl: TPasElement): TPasDotBaseScope;
- procedure PushConstraintScope(ConEl: TPasElement);
- var
- ConToken: TToken;
- DotClassScope: TPasDotClassScope;
- MemberType: TPasMembersType;
- GenTempl: TPasGenericTemplateType;
- aClass: TPasClassType;
- aConstructor: TPasConstructor;
- i: Integer;
- ResolvedEl: TPasResolverResult;
- begin
- ConToken:=GetGenericConstraintKeyword(ConEl);
- case ConToken of
- tkrecord: ;
- tkclass, tkconstructor:
- begin
- if Result<>nil then
- RaiseNotYetImplemented(20190831005217,TemplType);
- if not FindSystemClassTypeAndConstructor('system','tobject',aClass,aConstructor,ErrorEl) then
- RaiseIdentifierNotFound(20190831002421,'system.TObject.Create()',ErrorEl);
- DotClassScope:=TPasDotClassScope.Create;
- Result:=DotClassScope;
- PushScope(Result);
- DotClassScope.Owner:=Self;
- DotClassScope.ClassRecScope:=aClass.CustomData as TPasClassScope;
- Result.GroupScope:=CreateGroupScope(aClass,false);
- end;
- else
- if not (ConEl is TPasType) then
- RaiseNotYetImplemented(20190914070842,TemplType,GetObjName(ConEl));
- ComputeElement(ConEl,ResolvedEl,[rcType]);
- if ResolvedEl.BaseType<>btContext then
- RaiseNotYetImplemented(20190915183241,ConEl);
- if ResolvedEl.IdentEl=nil then
- RaiseNotYetImplemented(20190831214135,ConEl);
- if ResolvedEl.LoTypeEl is TPasGenericTemplateType then
- begin
- GenTempl:=TPasGenericTemplateType(ResolvedEl.LoTypeEl);
- if ConEl.HasParent(GenTempl) then
- RaiseNotYetImplemented(20190831214258,ConEl);
- for i:=0 to length(GenTempl.Constraints)-1 do
- PushConstraintScope(GenTempl.Constraints[i]);
- end
- else if ResolvedEl.LoTypeEl is TPasMembersType then
- begin
- MemberType:=TPasMembersType(ResolvedEl.LoTypeEl);
- if Result=nil then
- begin
- DotClassScope:=TPasDotClassScope.Create;
- Result:=DotClassScope;
- PushScope(Result);
- DotClassScope.Owner:=Self;
- DotClassScope.ClassRecScope:=MemberType.CustomData as TPasClassScope;
- Result.GroupScope:=CreateGroupScope(ResolvedEl.HiTypeEl,false);
- end
- else
- GroupScope_AddTypeAndAncestors(Result.GroupScope,MemberType,false);
- end
- else
- RaiseNotYetImplemented(20190831001450, ConEl);
- end;
- end;
- var
- i: Integer;
- begin
- Result:=nil;
- for i:=0 to length(TemplType.Constraints)-1 do
- PushConstraintScope(TemplType.Constraints[i]);
- end;
- function TPasResolver.PushDotScope(HiType: TPasType): TPasDotBaseScope;
- var
- C: TClass;
- LoType: TPasType;
- begin
- LoType:=ResolveAliasType(HiType);
- C:=LoType.ClassType;
- if C=TPasClassType then
- Result:=PushClassDotScope(TPasClassType(LoType))
- else if C=TPasRecordType then
- Result:=PushRecordDotScope(TPasRecordType(LoType))
- else if C=TPasEnumType then
- Result:=PushEnumDotScope(HiType,TPasEnumType(LoType))
- else if C=TPasGenericTemplateType then
- Result:=PushTemplateDotScope(TPasGenericTemplateType(LoType),HiType)
- else
- Result:=PushHelperDotScope(HiType);
- end;
- function TPasResolver.PushWithExprScope(Expr: TPasExpr): TPasWithExprScope;
- var
- WithEl: TPasImplWithDo;
- WithScope: TPasWithScope;
- ExprResolved: TPasResolverResult;
- ErrorEl: TPasExpr;
- LoType, HiType, DestType: TPasType;
- ExprScope: TPasGroupScope;
- ClassEl: TPasClassType;
- WithExprScope: TPasWithExprScope;
- Flags: TPasWithExprScopeFlags;
- ClassRecScope: TPasClassOrRecordScope;
- begin
- if not (Expr.Parent is TPasImplWithDo) then
- RaiseInternalError(20181210163412,GetObjName(Expr.Parent));
- WithEl:=TPasImplWithDo(Expr.Parent);
- if not (WithEl.CustomData is TPasWithScope) then
- RaiseInternalError(20181210175526);
- WithScope:=TPasWithScope(WithEl.CustomData);
- ResolveExpr(Expr,rraRead);
- ComputeElement(Expr,ExprResolved,[rcSetReferenceFlags]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.PushWithExprScope ExprResolved=',GetResolverResultDbg(ExprResolved));
- {$ENDIF}
- ErrorEl:=Expr;
- HiType:=ExprResolved.HiTypeEl;
- LoType:=ExprResolved.LoTypeEl;
- // ToDo: use last element in Expr for error position
- if LoType=nil then
- RaiseMsg(20170216152004,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
- [BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
- if (ExprResolved.BaseType in btAllIntrinsicTypes) then
- // ok
- else if (ExprResolved.BaseType=btContext) then
- // ok
- else
- RaiseMsg(20190210143257,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
- [BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
- Flags:=[];
- CheckUseAsType(LoType,20190123113957,Expr);
- ClassRecScope:=nil;
- ExprScope:=nil;
- if LoType.ClassType=TPasClassOfType then
- begin
- // e.g. with ImageClass do FindHandlerFromExtension()
- DestType:=TPasClassOfType(LoType).DestType;
- ClassEl:=ResolveAliasType(DestType) as TPasClassType;
- ExprScope:=CreateGroupScope(DestType);
- ClassRecScope:=TPasClassOrRecordScope(ClassEl.CustomData);
- Include(Flags,wesfOnlyTypeMembers);
- Include(Flags,wesfIsClassOf);
- end
- else if LoType is TPasMembersType then
- ClassRecScope:=TPasClassOrRecordScope(LoType.CustomData);
- if ExprScope=nil then
- begin
- ExprScope:=CreateGroupScope(HiType);
- if ExprScope.Count=0 then
- begin
- ExprScope.Free;
- RaiseMsg(20170216152007,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
- [GetElementTypeName(LoType)],ErrorEl);
- end;
- if ExprResolved.IdentEl is TPasType then
- // e.g. with TPoint do PointInCircle
- Include(Flags,wesfOnlyTypeMembers);
- end;
- WithExprScope:=ScopeClass_WithExpr.Create;
- WithExprScope.WithScope:=WithScope;
- WithExprScope.Index:=WithEl.Expressions.Count;
- WithExprScope.Expr:=Expr;
- WithExprScope.Scope:=ExprScope;
- WithExprScope.ClassRecScope:=ClassRecScope;
- if not (ExprResolved.IdentEl is TPasType) then
- Include(Flags,wesfNeedTmpVar);
- if (not (rrfWritable in ExprResolved.Flags))
- and (ExprResolved.BaseType=btContext)
- and (ExprResolved.LoTypeEl.ClassType=TPasRecordType) then
- Include(Flags,wesfConstParent);
- WithExprScope.Flags:=Flags;
- WithScope.ExpressionScopes.Add(WithExprScope);
- PushScope(WithExprScope);
- Result:=WithExprScope;
- end;
- function TPasResolver.StashScopes(NewScopeCnt: integer): integer;
- begin
- Result:=FStashScopeCount;
- if NewScopeCnt>ScopeCount then
- RaiseInternalError(20190728125505);
- while ScopeCount>NewScopeCnt do
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.StashScopes moving ',TopScope.ClassName,' ScopeCount=',ScopeCount,' StashScopeCount=',FStashScopeCount);
- {$ENDIF}
- if FStashScopeCount=length(FStashScopes) then
- SetLength(FStashScopes,FStashScopeCount+4);
- FStashScopes[FStashScopeCount]:=TopScope;
- inc(FStashScopeCount);
- dec(FScopeCount);
- FScopes[FScopeCount]:=nil;
- if FScopeCount>0 then
- FTopScope:=FScopes[FScopeCount-1]
- else
- FTopScope:=nil;
- end;
- end;
- function TPasResolver.StashSubExprScopes: integer;
- // move all subexpr scopes from Scopes to StashScopes
- var
- NewScopeCnt: Integer;
- begin
- NewScopeCnt:=FScopeCount;
- while (NewScopeCnt>0) and (FScopes[NewScopeCnt-1] is TPasSubExprScope) do
- dec(NewScopeCnt);
- Result:=StashScopes(NewScopeCnt);
- end;
- procedure TPasResolver.RestoreStashedScopes(StashDepth: integer);
- // restore sub scopes
- begin
- while FStashScopeCount>StashDepth do
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.RestoreStashScopes moving ',FStashScopes[FStashScopeCount-1].ClassName,' ScopeCount=',ScopeCount,' StashScopeCount=',FStashScopeCount);
- {$ENDIF}
- if FScopeCount=length(FScopes) then
- SetLength(FScopes,FScopeCount+4);
- dec(FStashScopeCount);
- FScopes[FScopeCount]:=FStashScopes[FStashScopeCount];
- FTopScope:=FScopes[FScopeCount];
- FStashScopes[FStashScopeCount]:=nil;
- inc(FScopeCount);
- end;
- end;
- procedure TPasResolver.DeleteScope(Index: integer);
- {$IF defined(fpc) and (FPC_FULLVERSION<30101)}
- procedure Delete(var A: TPasScopeArray; Index, Count: integer); overload;
- var
- i: Integer;
- begin
- if Index<0 then
- raise Exception.Create('20191014232344');
- if Index+Count>length(A) then
- raise Exception.Create('20191014232345');
- for i:=Index+Count to length(A)-1 do
- A[i-Count]:=A[i];
- SetLength(A,length(A)-Count);
- end;
- {$ENDIF}
- begin
- Delete(FScopes,Index,1);
- dec(FScopeCount);
- end;
- procedure TPasResolver.InsertScope(Scope: TPasScope; Index: integer);
- {$IF defined(fpc) and (FPC_FULLVERSION<30101)}
- procedure Insert(Item: TPasScope; var A: TPasScopeArray; Index: integer); overload;
- var
- i: Integer;
- begin
- if Index<0 then
- raise Exception.Create('20191014232355');
- if Index>length(A) then
- raise Exception.Create('20191014232356');
- SetLength(A,length(A)+1);
- for i:=length(A)-1 downto Index+1 do
- A[i]:=A[i-1];
- A[Index]:=Item;
- end;
- {$ENDIF}
- begin
- Insert(Scope,FScopes,Index);
- inc(FScopeCount);
- end;
- function TPasResolver.GetCurrentProcScope(ErrorEl: TPasElement
- ): TPasProcedureScope;
- var
- Scope: TPasScope;
- i: Integer;
- begin
- i:=ScopeCount;
- repeat
- dec(i);
- if i<0 then
- RaiseMsg(20171006001229,nIllegalExpression,sIllegalExpression,[],ErrorEl);
- Scope:=Scopes[i];
- if Scope is TPasProcedureScope then
- exit(TPasProcedureScope(Scope));
- until false;
- Result:=nil;
- end;
- function TPasResolver.GetProcScope(El: TPasElement): TPasProcedureScope;
- var
- CurEl: TPasElement;
- begin
- CurEl:=El;
- while CurEl<>nil do
- begin
- if CurEl is TPasProcedure then
- exit(TPasProcedureScope(CurEl.CustomData));
- CurEl:=CurEl.Parent;
- end;
- Result:=nil;
- end;
- function TPasResolver.GetCurrentSelfScope(ErrorEl: TPasElement): TPasProcedureScope;
- begin
- Result:=GetCurrentProcScope(ErrorEl);
- Result:=Result.GetSelfScope;
- end;
- function TPasResolver.GetSelfScope(El: TPasElement): TPasProcedureScope;
- begin
- Result:=GetProcScope(El);
- if Result<>nil then
- Result:=Result.GetSelfScope;
- end;
- procedure TPasResolver.AddHelper(Helper: TPasClassType;
- var List: TPRHelperEntryArray);
- var
- NewEntry: TPRHelperEntry;
- Added: Integer;
- HelperForType: TPasType;
- begin
- HelperForType:=ResolveAliasType(Helper.HelperForType,false);
- NewEntry:=TPRHelperEntry.Create;
- NewEntry.Helper:=Helper;
- NewEntry.HelperForType:=HelperForType;
- Added:=length(List);
- NewEntry.Added:=Added;
- SetLength(List,Added+1);
- List[Added]:=NewEntry;
- end;
- procedure TPasResolver.AddActiveHelper(Helper: TPasClassType);
- begin
- AddHelper(Helper,FActiveHelpers);
- end;
- class function TPasResolver.MangleSourceLineNumber(Line, Column: integer
- ): integer;
- begin
- if (Column<ParserMaxEmbeddedColumn)
- and (Line<ParserMaxEmbeddedRow) then
- Result:=-(Line*ParserMaxEmbeddedColumn+integer(Column))
- else
- Result:=Line;
- end;
- procedure TPasResolver.SetLastMsg(const id: TMaxPrecInt; MsgType: TMessageType;
- MsgNumber: integer; const Fmt: String;
- Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- PosEl: TPasElement);
- var
- {$IFDEF VerbosePasResolver}
- s: string;
- {$ENDIF}
- Column, Row: integer;
- begin
- FLastMsgId := id;
- FLastMsgType := MsgType;
- FLastMsgNumber := MsgNumber;
- FLastMsgPattern := Fmt;
- FLastMsg := SafeFormat(Fmt,Args);
- FLastElement := PosEl;
- if PosEl=nil then
- FLastSourcePos:=CurrentParser.CurSourcePos
- else
- begin
- FLastSourcePos.FileName:=PosEl.SourceFilename;
- UnmangleSourceLineNumber(PosEl.SourceLinenumber,Row,Column);
- if Row>=0 then
- FLastSourcePos.Row:=Row
- else
- FLastSourcePos.Row:=0;
- if Column>=0 then
- FLastSourcePos.Column:=Column
- else
- FLastSourcePos.Column:=0;
- end;
- CreateMsgArgs(FLastMsgArgs,Args);
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- write('TPasResolver.SetLastMsg ',id,' ',GetElementSourcePosStr(PosEl),' ');
- s:='';
- str(MsgType,s);
- write(s);
- writeln(': [',MsgNumber,'] ',FLastMsg);
- {AllowWriteln-}
- {$ENDIF}
- end;
- procedure TPasResolver.RaiseMsg(const Id: TMaxPrecInt; MsgNumber: integer;
- const Fmt: String; Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- ErrorPosEl: TPasElement);
- var
- E: EPasResolve;
- begin
- SetLastMsg(Id,mtError,MsgNumber,Fmt,Args,ErrorPosEl);
- E:=EPasResolve.Create(FLastMsg);
- E.Id:=Id;
- E.MsgType:=mtError;
- E.MsgNumber:=MsgNumber;
- E.MsgPattern:=Fmt;
- E.PasElement:=ErrorPosEl;
- E.Args:=FLastMsgArgs;
- E.SourcePos:=FLastSourcePos;
- raise E;
- end;
- procedure TPasResolver.RaiseNotYetImplemented(id: TMaxPrecInt; El: TPasElement;
- Msg: string);
- var
- s: String;
- begin
- s:=sNotYetImplemented+' ['+IntToStr(id)+']';
- if Msg<>'' then
- s:=s+' "'+Msg+'"';
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.RaiseNotYetImplemented s="',s,'" El=',GetObjName(El));
- {$ENDIF}
- RaiseMsg(id,nNotYetImplemented,s,[GetObjName(El)],El);
- end;
- procedure TPasResolver.RaiseInternalError(id: TMaxPrecInt; const Msg: string);
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.RaiseInternalError [',id,'] ',Msg);
- {$ENDIF}
- raise Exception.Create('Internal error: ['+IntToStr(id)+'] '+Msg);
- end;
- procedure TPasResolver.RaiseInvalidScopeForElement(id: TMaxPrecInt; El: TPasElement;
- const Msg: string);
- var
- i: Integer;
- s: String;
- begin
- s:='['+IntToStr(id)+'] invalid scope for "'+GetObjName(El)+'": ';
- for i:=0 to ScopeCount-1 do
- begin
- if i>0 then s:=s+',';
- s:=s+Scopes[i].ClassName;
- end;
- if Msg<>'' then
- s:=s+': '+Msg;
- RaiseInternalError(id,s);
- end;
- procedure TPasResolver.RaiseIdentifierNotFound(id: TMaxPrecInt; Identifier: string;
- El: TPasElement);
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.RaiseIdentifierNotFound START "',Identifier,'" ErrorEl=',GetObjName(El));
- WriteScopes;
- {$ENDIF}
- RaiseMsg(id,nIdentifierNotFound,sIdentifierNotFound,[Identifier],El);
- end;
- procedure TPasResolver.RaiseXExpectedButYFound(id: TMaxPrecInt; const X, Y: string;
- El: TPasElement);
- begin
- RaiseMsg(id,nXExpectedButYFound,sXExpectedButYFound,[X,Y],El);
- end;
- procedure TPasResolver.RaiseXExpectedButTypeYFound(id: TMaxPrecInt;
- const X: string; Y: TPasType; El: TPasElement);
- begin
- RaiseMsg(id,nXExpectedButYFound,sXExpectedButYFound,
- [x,GetTypeDescription(Y)],El);
- end;
- procedure TPasResolver.RaiseContextXExpectedButYFound(id: TMaxPrecInt; const C, X,
- Y: string; El: TPasElement);
- begin
- RaiseMsg(id,nContextExpectedXButFoundY,sContextExpectedXButFoundY,[C,X,Y],El);
- end;
- procedure TPasResolver.RaiseContextXInvalidY(id: TMaxPrecInt; const X, Y: string;
- El: TPasElement);
- begin
- RaiseMsg(id,nContextXInvalidY,sContextXInvalidY,[X,Y],El);
- end;
- procedure TPasResolver.RaiseConstantExprExp(id: TMaxPrecInt; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nConstantExpressionExpected,sConstantExpressionExpected,[],ErrorEl);
- end;
- procedure TPasResolver.RaiseVarExpected(id: TMaxPrecInt; ErrorEl: TPasElement;
- IdentEl: TPasElement);
- begin
- if IdentEl is TPasProperty then
- RaiseMsg(id,nNoMemberIsProvidedToAccessProperty,
- sNoMemberIsProvidedToAccessProperty,[],ErrorEl)
- else
- RaiseMsg(id,nVariableIdentifierExpected,sVariableIdentifierExpected,[],ErrorEl);
- end;
- procedure TPasResolver.RaiseRangeCheck(id: TMaxPrecInt; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nRangeCheckError,sRangeCheckError,[],ErrorEl);
- end;
- procedure TPasResolver.RaiseIncompatibleTypeDesc(id: TMaxPrecInt; MsgNumber: integer;
- const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- const GotDesc, ExpDesc: String; ErrorEl: TPasElement);
- function GetString(ArgNo: integer): string;
- begin
- if ArgNo>High(Args) then
- exit('invalid param '+IntToStr(ArgNo));
- {$ifdef pas2js}
- if isString(Args[ArgNo]) then
- Result:=String(Args[ArgNo])
- else
- Result:='invalid param '+jsTypeOf(Args[ArgNo]);
- {$else}
- case Args[ArgNo].VType of
- vtAnsiString: Result:=AnsiString(Args[ArgNo].VAnsiString);
- else
- Result:='invalid param '+IntToStr(Ord(Args[ArgNo].VType));
- end;
- {$endif}
- end;
- begin
- case MsgNumber of
- nIllegalTypeConversionTo:
- RaiseMsg(id,MsgNumber,sIllegalTypeConversionTo,[GotDesc,ExpDesc],ErrorEl);
- nIncompatibleTypesGotExpected:
- RaiseMsg(id,MsgNumber,sIncompatibleTypesGotExpected,[GotDesc,ExpDesc],ErrorEl);
- nIncompatibleTypeArgNo:
- RaiseMsg(id,MsgNumber,sIncompatibleTypeArgNo,[GetString(0),GotDesc,ExpDesc],ErrorEl);
- nIncompatibleTypeArgNoVarParamMustMatchExactly:
- RaiseMsg(id,MsgNumber,sIncompatibleTypeArgNoVarParamMustMatchExactly,
- [GetString(0),GotDesc,ExpDesc],ErrorEl);
- nResultTypeMismatchExpectedButFound:
- RaiseMsg(id,MsgNumber,sResultTypeMismatchExpectedButFound,[GotDesc,ExpDesc],ErrorEl);
- nXExpectedButYFound:
- RaiseMsg(id,MsgNumber,sXExpectedButYFound,[GotDesc,ExpDesc],ErrorEl);
- nOperatorIsNotOverloadedAOpB:
- RaiseMsg(id,MsgNumber,sOperatorIsNotOverloadedAOpB,[GotDesc,GetString(0),ExpDesc],ErrorEl);
- nTypesAreNotRelatedXY:
- RaiseMsg(id,MsgNumber,sTypesAreNotRelatedXY,[GotDesc,ExpDesc],ErrorEl);
- else
- RaiseInternalError(20170329112911);
- end;
- end;
- procedure TPasResolver.RaiseIncompatibleType(id: TMaxPrecInt; MsgNumber: integer;
- const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- GotType, ExpType: TPasType; ErrorEl: TPasElement);
- var
- GotDesc, ExpDesc: String;
- begin
- GetIncompatibleTypeDesc(GotType,ExpType,GotDesc,ExpDesc);
- RaiseIncompatibleTypeDesc(id,MsgNumber,Args,GotDesc,ExpDesc,ErrorEl);
- end;
- procedure TPasResolver.RaiseIncompatibleTypeRes(id: TMaxPrecInt; MsgNumber: integer;
- const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- const GotType, ExpType: TPasResolverResult;
- ErrorEl: TPasElement);
- var
- GotDesc, ExpDesc: String;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.RaiseIncompatibleTypeRes Got={',GetResolverResultDbg(GotType),'} Expected={',GetResolverResultDbg(ExpType),'}');
- {$ENDIF}
- GetIncompatibleTypeDesc(GotType,ExpType,GotDesc,ExpDesc);
- RaiseIncompatibleTypeDesc(id,MsgNumber,Args,GotDesc,ExpDesc,ErrorEl);
- end;
- procedure TPasResolver.RaiseHelpersCannotBeUsedAsType(id: TMaxPrecInt;
- ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nHelpersCannotBeUsedAsTypes,sHelpersCannotBeUsedAsTypes,[],ErrorEl);
- end;
- procedure TPasResolver.RaiseInvalidProcTypeModifier(id: TMaxPrecInt;
- ProcType: TPasProcedureType; ptm: TProcTypeModifier; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(ProcType),
- ProcTypeModifiers[ptm]],ErrorEl);
- end;
- procedure TPasResolver.RaiseInvalidProcModifier(id: TMaxPrecInt; Proc: TPasProcedure;
- pm: TProcedureModifier; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(Proc),
- ModifierNames[pm]],ErrorEl);
- end;
- procedure TPasResolver.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType;
- MsgNumber: integer; const Fmt: String;
- Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
- PosEl: TPasElement);
- var
- Scanner: TPascalScanner;
- State: TWarnMsgState;
- {$IFDEF VerbosePasResolver}
- s: String;
- {$ENDIF}
- begin
- Scanner:=CurrentParser.Scanner;
- if (Scanner<>nil) then
- begin
- if (FStep<prsFinishingModule)
- and (Scanner.IgnoreMsgType(MsgType)) then
- exit; // during parsing consider directives like $Hints on|off
- if MsgType>=mtWarning then
- begin
- State:=Scanner.WarnMsgState[MsgNumber];
- case State of
- wmsOff:
- begin
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- write('TPasResolver.LogMsg ignoring ',id,' ',GetElementSourcePosStr(PosEl),' ');
- s:='';
- str(MsgType,s);
- write(s);
- writeln(': [',MsgNumber,'] ',SafeFormat(Fmt,Args));
- {AllowWriteln-}
- {$ENDIF}
- exit; // ignore
- end;
- wmsError:
- begin
- RaiseMsg(id,MsgNumber,Fmt,Args,PosEl);
- exit;
- end;
- end;
- end;
- end;
- SetLastMsg(id,MsgType,MsgNumber,Fmt,Args,PosEl);
- if Assigned(OnLog) then
- OnLog(Self,FLastMsg)
- else if Assigned(CurrentParser.OnLog) then
- CurrentParser.OnLog(Self,FLastMsg);
- end;
- class function TPasResolver.GetWarnIdentifierNumbers(Identifier: string; out
- MsgNumbers: TIntegerDynArray): boolean;
- procedure SetNumber(Number: integer);
- begin
- {$IF FPC_FULLVERSION>=30101}
- MsgNumbers:=[Number];
- {$ELSE}
- Setlength(MsgNumbers,1);
- MsgNumbers[0]:=Number;
- {$ENDIF}
- end;
- procedure SetNumbers(Numbers: array of integer);
- var
- i: Integer;
- begin
- Setlength(MsgNumbers,length(Numbers));
- for i:=0 to high(Numbers) do
- MsgNumbers[i]:=Numbers[i];
- end;
- begin
- if Identifier='' then exit(false);
- if Identifier[1] in ['0'..'9'] then exit(false);
- Result:=true;
- case UpperCase(Identifier) of
- // FPC:
- 'CONSTRUCTING_ABSTRACT': SetNumber(nConstructingClassXWithAbstractMethodY); // Constructing an instance of a class with abstract methods.
- //'IMPLICIT_VARIANTS': ; // Implicit use of the variants unit.
- // useanalyzer: 'NO_RETVAL': ; // Function result is not set.
- 'SYMBOL_DEPRECATED': SetNumber(nSymbolXIsDeprecated); // Deprecated symbol.
- 'SYMBOL_EXPERIMENTAL': SetNumber(nSymbolXIsExperimental); // Experimental symbol
- 'SYMBOL_LIBRARY': SetNumber(nSymbolXBelongsToALibrary); // Not used.
- 'SYMBOL_PLATFORM': SetNumber(nSymbolXIsNotPortable); // Platform-dependent symbol.
- 'SYMBOL_UNIMPLEMENTED': SetNumber(nSymbolXIsNotImplemented); // Unimplemented symbol.
- //'UNIT_DEPRECATED': ; // Deprecated unit.
- //'UNIT_EXPERIMENTAL': ; // Experimental unit.
- //'UNIT_LIBRARY': ; //
- //'UNIT_PLATFORM': ; // Platform dependent unit.
- //'UNIT_UNIMPLEMENTED': ; // Unimplemented unit.
- //'ZERO_NIL_COMPAT': ; // Converting 0 to NIL
- //'IMPLICIT_STRING_CAST': ; // Implicit string type conversion
- //'IMPLICIT_STRING_CAST_LOSS': ; // Implicit string typecast with potential data loss from ”$1” to ”$2”
- //'EXPLICIT_STRING_CAST': ; // Explicit string type conversion
- //'EXPLICIT_STRING_CAST_LOSS': ; // Explicit string typecast with potential data loss from ”$1” to ”$2”
- //'CVT_NARROWING_STRING_LOST': ; // Unicode constant cast with potential data loss
- // Delphi:
- 'HIDDEN_VIRTUAL': SetNumber(nMethodHidesMethodOfBaseType); // method hides virtual method of ancestor
- 'GARBAGE': SetNumber(nTextAfterFinalIgnored); // text after final end.
- 'BOUNDS_ERROR': SetNumbers([nRangeCheckError,
- nHighRangeLimitLTLowRangeLimit,
- nRangeCheckEvaluatingConstantsVMinMax,
- nRangeCheckInSetConstructor]);
- 'MESSAGE_DIRECTIVE': SetNumber(nUserDefined); // $message directive
- else
- Result:=false;
- end;
- end;
- procedure TPasResolver.GetIncompatibleTypeDesc(const GotType,
- ExpType: TPasResolverResult; out GotDesc, ExpDesc: String);
- var
- NeedProcSignature: Boolean;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.GetIncompatibleTypeDesc Got={',GetResolverResultDbg(GotType),'} Expected={',GetResolverResultDbg(ExpType),'}');
- {$ENDIF}
- if (GotType.BaseType<>ExpType.BaseType)
- and (GotType.BaseType<>btContext) and (ExpType.BaseType<>btContext) then
- begin
- GotDesc:=GetBaseDescription(GotType);
- if ExpType.BaseType=btNil then
- ExpDesc:=BaseTypeNames[btPointer]
- else
- ExpDesc:=GetBaseDescription(ExpType);
- if GotDesc<>ExpDesc then
- exit;
- GotDesc:=GetBaseDescription(GotType,true);
- ExpDesc:=GetBaseDescription(ExpType,true);
- end
- else if (GotType.LoTypeEl<>nil) and (ExpType.LoTypeEl<>nil) then
- begin
- NeedProcSignature:=(GotType.LoTypeEl is TPasProcedureType)
- and (ExpType.LoTypeEl is TPasProcedureType);
- if NeedProcSignature then
- begin
- // procedural types
- GetIncompatibleProcParamsDesc(TPasProcedureType(GotType.LoTypeEl),
- TPasProcedureType(ExpType.LoTypeEl),GotDesc,ExpDesc);
- if GotDesc<>ExpDesc then
- exit;
- end;
- GotDesc:=GetTypeDescription(GotType);
- ExpDesc:=GetTypeDescription(ExpType);
- if GotDesc<>ExpDesc then
- exit;
- if GotType.HiTypeEl<>ExpType.HiTypeEl then
- begin
- GotDesc:=GetTypeDescription(GotType.HiTypeEl);
- ExpDesc:=GetTypeDescription(ExpType.HiTypeEl);
- if GotDesc<>ExpDesc then
- exit;
- end;
- GotDesc:=GetTypeDescription(GotType,true);
- ExpDesc:=GetTypeDescription(ExpType,true);
- end
- else
- begin
- GotDesc:=GetResolverResultDescription(GotType,true);
- ExpDesc:=GetResolverResultDescription(ExpType,true);
- if GotDesc<>ExpDesc then
- exit;
- GotDesc:=GetResolverResultDescription(GotType,false);
- ExpDesc:=GetResolverResultDescription(ExpType,false);
- end;
- end;
- procedure TPasResolver.GetIncompatibleTypeDesc(const GotType,
- ExpType: TPasType; out GotDesc, ExpDesc: String);
- var
- GotLoType, ExpLoType: TPasType;
- begin
- GotLoType:=ResolveAliasType(GotType);
- ExpLoType:=ResolveAliasType(ExpType);
- if (GotLoType<>nil) and (ExpLoType<>nil) then
- begin
- if (GotLoType.ClassType=ExpLoType.ClassType)
- and (GotLoType is TPasProcedureType) then
- begin
- // procedural types
- GetIncompatibleProcParamsDesc(TPasProcedureType(GotLoType),
- TPasProcedureType(ExpLoType),GotDesc,ExpDesc);
- if GotDesc<>ExpDesc then
- exit;
- end;
- end;
- GotDesc:=GetTypeDescription(GotType);
- ExpDesc:=GetTypeDescription(ExpType);
- if GotDesc<>ExpDesc then exit;
- GotDesc:=GetTypeDescription(GotType,true);
- ExpDesc:=GetTypeDescription(ExpType,true);
- end;
- procedure TPasResolver.GetIncompatibleProcParamsDesc(GotType,
- ExpType: TPasProcedureType; out GotDesc, ExpDesc: string);
- procedure AppendClass(ProcType: TPasProcedureType; var Desc: string);
- var
- C: TClass;
- begin
- C:=ProcType.ClassType;
- if C=TPasProcedureType then
- Desc:=Desc+'procedure'
- else if C=TPasFunctionType then
- Desc:=Desc+'function'
- else
- RaiseNotYetImplemented(20200216114419,ProcType,ProcType.ClassName);
- end;
- var
- i: Integer;
- GotArg, ExpArg: TPasArgument;
- GotArgs, ExpArgs: TFPList;
- GotArgDesc, ExpArgDesc: String;
- GotArgType, ExpArgType: TPasType;
- begin
- GotDesc:='';
- ExpDesc:='';
- // reference to
- if (ptmReferenceTo in GotType.Modifiers) and not (ptmReferenceTo in ExpType.Modifiers) then
- GotDesc:='reference to '
- else if not (ptmReferenceTo in GotType.Modifiers) and (ptmReferenceTo in ExpType.Modifiers) then
- ExpDesc:='reference to ';
- // type
- AppendClass(GotType,GotDesc);
- AppendClass(ExpType,ExpDesc);
- // Args
- GotDesc:=GotDesc+'(';
- ExpDesc:=ExpDesc+'(';
- GotArgs:=GotType.Args;
- ExpArgs:=ExpType.Args;
- for i:=0 to GotArgs.Count-1 do
- begin
- if i>0 then
- GotDesc:=GotDesc+';';
- GotArg:=TPasArgument(GotArgs[i]);
- GotArgType:=ResolveAliasType(GotArg.ArgType);
- if i<ExpArgs.Count then
- begin
- if i>0 then
- ExpDesc:=ExpDesc+';';
- ExpArg:=TPasArgument(ExpArgs[i]);
- ExpArgType:=ResolveAliasType(ExpArg.ArgType);
- if GotArgType=ExpArgType then
- begin
- GotDesc:=GotDesc+GetTypeDescription(GotArgType);
- ExpDesc:=ExpDesc+GetTypeDescription(ExpArgType);
- end
- else
- begin
- GetIncompatibleTypeDesc(GotArgType,ExpArgType,GotArgDesc,ExpArgDesc);
- GotDesc:=GotDesc+GotArgDesc;
- ExpDesc:=ExpDesc+ExpArgDesc;
- end;
- end
- else
- begin
- // GotType has more args than ExpType
- GotDesc:=GotDesc+GetTypeDescription(GotArgType);
- end;
- end;
- for i:=GotArgs.Count to ExpArgs.Count-1 do
- begin
- // ExpType has more args then GotType
- if i>0 then
- ExpDesc:=ExpDesc+';';
- ExpArg:=TPasArgument(ExpArgs[i]);
- ExpArgType:=ResolveAliasType(ExpArg.ArgType);
- ExpDesc:=ExpDesc+GetTypeDescription(ExpArgType);
- end;
- GotDesc:=GotDesc+')';
- ExpDesc:=ExpDesc+')';
- // function result
- if GotType is TPasFunctionType then
- GotDesc:=GotDesc+': '+GetTypeDescription(ResolveAliasType(TPasFunctionType(GotType).ResultEl.ResultType));
- if ExpType is TPasFunctionType then
- ExpDesc:=ExpDesc+': '+GetTypeDescription(ResolveAliasType(TPasFunctionType(ExpType).ResultEl.ResultType));
- // modifiers
- if (ptmOfObject in GotType.Modifiers) and not (ptmOfObject in ExpType.Modifiers) then
- GotDesc:=GotDesc+' of Object'
- else if not (ptmOfObject in GotType.Modifiers) and (ptmOfObject in ExpType.Modifiers) then
- ExpDesc:=ExpDesc+' of Object';
- if (ptmIsNested in GotType.Modifiers) and not (ptmIsNested in ExpType.Modifiers) then
- GotDesc:=GotDesc+' is nested'
- else if not (ptmIsNested in GotType.Modifiers) and (ptmIsNested in ExpType.Modifiers) then
- ExpDesc:=ExpDesc+' is nested';
- if (ptmStatic in GotType.Modifiers) and not (ptmStatic in ExpType.Modifiers) then
- GotDesc:=GotDesc+'; static'
- else if not (ptmStatic in GotType.Modifiers) and (ptmStatic in ExpType.Modifiers) then
- ExpDesc:=ExpDesc+'; static';
- if (ptmAsync in GotType.Modifiers) and not (ptmAsync in ExpType.Modifiers) then
- GotDesc:=GotDesc+'; async'
- else if not (ptmAsync in GotType.Modifiers) and (ptmAsync in ExpType.Modifiers) then
- ExpDesc:=ExpDesc+'; async';
- if (ptmVarargs in GotType.Modifiers) and not (ptmVarargs in ExpType.Modifiers) then
- GotDesc:=GotDesc+'; varargs'
- else if not (ptmVarargs in GotType.Modifiers) and (ptmVarargs in ExpType.Modifiers) then
- ExpDesc:=ExpDesc+'; varargs'
- else
- begin
- if GotType.VarArgsType<>nil then
- GotDesc:=GotDesc+'; varargs of '+GetTypeDescription(ResolveAliasType(GotType.VarArgsType));
- if ExpType.VarArgsType<>nil then
- ExpDesc:=ExpDesc+'; varargs of '+GetTypeDescription(ResolveAliasType(ExpType.VarArgsType));
- end;
- // calling convention
- if GotType.CallingConvention<>ExpType.CallingConvention then
- begin
- GotDesc:=GotDesc+';'+cCallingConventions[GotType.CallingConvention];
- ExpDesc:=ExpDesc+';'+cCallingConventions[ExpType.CallingConvention];
- end;
- if GotDesc=ExpDesc then
- begin
- if GotType.Parent is TPasAnonymousProcedure then
- GotDesc:='anonymous '+GotDesc;
- if ExpType.Parent is TPasAnonymousProcedure then
- ExpDesc:='anonymous '+ExpDesc;
- end;
- end;
- function TPasResolver.CheckCallProcCompatibility(ProcType: TPasProcedureType;
- Params: TParamsExpr; RaiseOnError: boolean; SetReferenceFlags: boolean
- ): integer;
- var
- ProcArgs: TFPList;
- i, ParamCnt, ParamCompatibility: Integer;
- Param, Value: TPasExpr;
- ParamResolved, ArgResolved: TPasResolverResult;
- Flags: TPasResolverComputeFlags;
- begin
- Result:=cExact;
- ProcArgs:=ProcType.Args;
- Value:=Params.Value;
- if Value is TBinaryExpr then
- Value:=TBinaryExpr(Value).right; // Note: parser guarantees that this is the rightmost
- // check args
- ParamCnt:=length(Params.Params);
- ArgResolved.BaseType:=btNone;
- i:=0;
- while i<ParamCnt do
- begin
- Param:=Params.Params[i];
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckCallProcCompatibility ',i,'/',ParamCnt);
- {$ENDIF}
- if i<ProcArgs.Count then
- begin
- ParamCompatibility:=CheckParamCompatibility(Param,
- TPasArgument(ProcArgs[i]),i,RaiseOnError,SetReferenceFlags);
- if ParamCompatibility=cIncompatible then
- exit(cIncompatible);
- end
- else
- begin
- if ptmVarargs in ProcType.Modifiers then
- begin
- if ProcType.VarArgsType<>nil then
- begin
- if ArgResolved.BaseType=btNone then
- ComputeElement(ProcType.VarArgsType,ArgResolved,[rcType]);
- ComputeArgumentExpr(ArgResolved,argConst,
- Param,ParamResolved,SetReferenceFlags);
- ParamCompatibility:=CheckParamResCompatibility(Param,ParamResolved,
- ArgResolved,i,RaiseOnError,SetReferenceFlags);
- if ParamCompatibility=cIncompatible then
- exit(cIncompatible);
- end
- else
- begin
- if SetReferenceFlags then
- Flags:=[rcNoImplicitProcType,rcSetReferenceFlags]
- else
- Flags:=[rcNoImplicitProcType];
- ComputeElement(Param,ParamResolved,Flags,Param);
- if not (rrfReadable in ParamResolved.Flags) then
- begin
- if RaiseOnError then
- RaiseVarExpected(20180712001415,Param,ParamResolved.IdentEl);
- exit(cIncompatible);
- end;
- ParamCompatibility:=cExact;
- end;
- end
- else
- begin
- // too many arguments
- if RaiseOnError then
- RaiseMsg(20170216152408,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(ProcType)],Param);
- exit(cIncompatible);
- end;
- end;
- if Result<cTypeConversion then
- inc(Result,ParamCompatibility)
- else
- Result:=Max(Result,ParamCompatibility);
- inc(i);
- end;
- if (i<ProcArgs.Count) then
- if (TPasArgument(ProcArgs[i]).ValueExpr=nil) then
- begin
- // not enough arguments
- if RaiseOnError then
- // ToDo: position cursor on identifier
- RaiseMsg(20170216152410,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(ProcType)],Params.Value);
- exit(cIncompatible);
- end
- else
- begin
- // the rest are default params
- end;
- end;
- function TPasResolver.CheckCallPropertyCompatibility(PropEl: TPasProperty;
- Params: TParamsExpr; RaiseOnError: boolean): integer;
- var
- PropArg: TPasArgument;
- ArgNo, ParamComp: Integer;
- Param: TPasExpr;
- PropArgs: TFPList;
- begin
- Result:=cExact;
- PropArgs:=GetPasPropertyArgs(PropEl);
- if PropArgs.Count<length(Params.Params) then
- begin
- if not RaiseOnError then exit(cIncompatible);
- RaiseMsg(20170216152412,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
- [PropEl.Name],Params)
- end
- else if PropArgs.Count>length(Params.Params) then
- begin
- if not RaiseOnError then exit(cIncompatible);
- RaiseMsg(20170216152413,nMissingParameterX,sMissingParameterX,
- [TPasArgument(PropArgs[length(Params.Params)]).Name],Params);
- end;
- for ArgNo:=0 to PropArgs.Count-1 do
- begin
- PropArg:=TPasArgument(PropArgs[ArgNo]);
- Param:=Params.Params[ArgNo];
- ParamComp:=CheckParamCompatibility(Param,PropArg,ArgNo,RaiseOnError);
- if ParamComp=cIncompatible then
- exit(cIncompatible);
- inc(Result,ParamComp);
- end;
- end;
- function TPasResolver.CheckCallArrayCompatibility(ArrayEl: TPasArrayType;
- Params: TParamsExpr; RaiseOnError: boolean; EmitHints: boolean): integer;
- var
- ArgNo: Integer;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- procedure GetNextParam;
- begin
- if ArgNo>=length(Params.Params) then
- RaiseMsg(20170216152415,nWrongNumberOfParametersForArray,sWrongNumberOfParametersForArray,
- [],Params);
- Param:=Params.Params[ArgNo];
- ComputeElement(Param,ParamResolved,[]);
- inc(ArgNo);
- end;
- var
- DimNo: integer;
- RangeResolved, OrigRangeResolved, OrigParamResolved: TPasResolverResult;
- bt: TResolverBaseType;
- NextType, TypeEl: TPasType;
- RangeExpr: TPasExpr;
- TypeFits: Boolean;
- ParamValue: TResEvalValue;
- begin
- ArgNo:=0;
- repeat
- if length(ArrayEl.Ranges)=0 then
- begin
- // dynamic/open array -> needs exactly one integer
- GetNextParam;
- if (not (rrfReadable in ParamResolved.Flags))
- or not (ParamResolved.BaseType in btAllInteger) then
- exit(CheckRaiseTypeArgNo(20170216152417,ArgNo,Param,ParamResolved,'integer',RaiseOnError));
- if EmitHints then
- begin
- ParamValue:=Eval(Param,[refAutoConstExt]);
- if ParamValue<>nil then
- try // has const value -> check range
- if ParamValue.Kind=revkExternal then
- // ignore
- else if (ParamValue.Kind<>revkInt)
- or (TResEvalInt(ParamValue).Int<DynArrayMinIndex)
- or (TResEvalInt(ParamValue).Int>DynArrayMaxIndex) then
- fExprEvaluator.EmitRangeCheckConst(20170520202212,ParamValue.AsString,
- DynArrayMinIndex,DynArrayMaxIndex,Param);
- finally
- ReleaseEvalValue(ParamValue);
- end;
- end;
- end
- else
- begin
- // static array
- for DimNo:=0 to length(ArrayEl.Ranges)-1 do
- begin
- GetNextParam;
- RangeExpr:=ArrayEl.Ranges[DimNo];
- ComputeElement(RangeExpr,RangeResolved,[]);
- bt:=RangeResolved.BaseType;
- if not (rrfReadable in ParamResolved.Flags) then
- begin
- if not RaiseOnError then exit(cIncompatible);
- RaiseIncompatibleTypeRes(20170216152421,nIncompatibleTypeArgNo,
- [IntToStr(ArgNo)],ParamResolved,RangeResolved,Param);
- end;
- TypeFits:=false;
- OrigRangeResolved:=RangeResolved;
- OrigParamResolved:=ParamResolved;
- if bt=btRange then
- begin
- ConvertRangeToElement(RangeResolved);
- bt:=RangeResolved.BaseType;
- end;
- if ParamResolved.BaseType=btRange then
- begin
- ConvertRangeToElement(ParamResolved);
- end;
- if (bt in btAllBooleans) then
- begin
- if (ParamResolved.BaseType in btAllBooleans) then
- TypeFits:=true;
- end
- else if (bt in btAllInteger) then
- begin
- if (ParamResolved.BaseType in btAllInteger) then
- TypeFits:=true;
- end
- else if (bt in btAllChars) then
- begin
- if (ParamResolved.BaseType in btAllChars) then
- TypeFits:=true;
- end
- else if (bt=btContext) then
- begin
- TypeEl:=RangeResolved.LoTypeEl;
- if ParamResolved.BaseType=btContext then
- begin
- if (TypeEl.ClassType=TPasEnumType)
- and IsSameType(TypeEl,ParamResolved.LoTypeEl,prraNone) then
- TypeFits:=true;
- end;
- end;
- if not TypeFits then
- begin
- // incompatible
- if not RaiseOnError then exit(cIncompatible);
- RaiseIncompatibleTypeRes(20170216152422,nIncompatibleTypeArgNo,
- [IntToStr(ArgNo)],OrigParamResolved,OrigRangeResolved,Param);
- end;
- if EmitHints then
- fExprEvaluator.IsInRange(Param,RangeExpr,true);
- end;
- end;
- if ArgNo=length(Params.Params) then exit(cExact);
- // there are more parameters -> continue in sub array
- NextType:=ResolveAliasType(ArrayEl.ElType);
- if NextType.ClassType<>TPasArrayType then
- RaiseMsg(20170216152424,nWrongNumberOfParametersForArray,sWrongNumberOfParametersForArray,
- [],Params);
- ArrayEl:=TPasArrayType(NextType);
- until false;
- Result:=cIncompatible;
- end;
- function TPasResolver.CheckProcOverloadCompatibility(Proc1, Proc2: TPasProcedure): boolean;
- // returns if number and type of arguments fit
- // does not check calling convention
- var
- ProcArgs1, ProcArgs2, TemplTypes1, TemplTypes2: TFPList;
- i, Comp: Integer;
- begin
- Result:=false;
- if (Proc1.NameParts<>nil) or (Proc2.NameParts<>nil) then
- begin
- TemplTypes1:=GetProcTemplateTypes(Proc1);
- TemplTypes2:=GetProcTemplateTypes(Proc2);
- if TemplTypes1=nil then
- begin
- if TemplTypes2<>nil then
- exit;
- end
- else if TemplTypes2=nil then
- exit
- else if TemplTypes1.Count<>TemplTypes2.Count then
- exit;
- end;
- ProcArgs1:=Proc1.ProcType.Args;
- ProcArgs2:=Proc2.ProcType.Args;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckProcOverloadCompatibility START Count=',ProcArgs1.Count,' ',ProcArgs2.Count);
- {$ENDIF}
- // check args
- if ProcArgs1.Count<>ProcArgs2.Count then
- exit;
- for i:=0 to ProcArgs1.Count-1 do
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckProcOverloadCompatibility ',i,'/',ProcArgs1.Count);
- {$ENDIF}
- Comp:=CheckProcArgCompatibility(TPasArgument(ProcArgs1[i]),TPasArgument(ProcArgs2[i]));
- if Comp>cExact then
- exit;
- end;
- Result:=true;
- end;
- function TPasResolver.CheckProcTypeCompatibility(Proc1,
- Proc2: TPasProcedureType; IsAssign: boolean; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): boolean;
- // if RaiseOnIncompatible=true, then Expected=Proc1 Actual=Proc2
- function ModifierError(Modifier: TProcTypeModifier): boolean;
- begin
- Result:=false;
- if not RaiseOnIncompatible then exit;
- RaiseMsg(20170402112049,nXModifierMismatchY,sXModifierMismatchY,
- [GetElementTypeName(Proc1),ProcTypeModifiers[Modifier]],ErrorEl);
- end;
- var
- ProcArgs1, ProcArgs2: TFPList;
- i: Integer;
- Result1Resolved, Result2Resolved: TPasResolverResult;
- ExpectedArg, ActualArg: TPasArgument;
- begin
- Result:=false;
- if Proc1.ClassType<>Proc2.ClassType then
- begin
- if RaiseOnIncompatible then
- RaiseXExpectedButYFound(20170402112353,GetElementTypeName(Proc1),GetElementTypeName(Proc2),ErrorEl);
- exit;
- end;
- if Proc1.IsReferenceTo then
- begin
- if IsAssign then
- // aRefTo:=aproc -> any IsNested/OfObject is allowed
- else
- ; // aRefTo = AnyProc -> ok
- end
- else if Proc2.IsReferenceTo then
- begin
- if IsAssign then
- // NonRefTo := aRefTo -> not possible
- exit(ModifierError(ptmReferenceTo))
- else
- ; // AnyProc = aRefTo -> ok
- end
- else if Proc2.Parent is TPasAnonymousProcedure then
- begin
- if IsAssign then
- // NonRefTo := AnonymousProc -> not possible
- exit(ModifierError(ptmReferenceTo))
- else
- ; // AnyProc = AnonymousProc -> ok
- end
- else
- begin
- // neither Proc1 nor Proc2 is a reference-to -> check isNested and OfObject
- if Proc1.IsNested<>Proc2.IsNested then
- exit(ModifierError(ptmIsNested));
- if Proc1.IsOfObject<>Proc2.IsOfObject then
- begin
- if (proProcTypeWithoutIsNested in Options) then
- exit(ModifierError(ptmOfObject))
- else if Proc1.IsNested then
- // "is nested" can handle both, proc and method.
- else
- exit(ModifierError(ptmOfObject))
- end;
- end;
- if Proc1.CallingConvention<>Proc2.CallingConvention then
- begin
- if (proSafecallAllowsDefault in Options)
- and (Proc1.CallingConvention=ccSafeCall)
- and (Proc2.CallingConvention=ccDefault) then
- // ok
- else
- begin
- if RaiseOnIncompatible then
- RaiseMsg(20170402112253,nCallingConventionMismatch,sCallingConventionMismatch,
- [],ErrorEl);
- exit;
- end;
- end;
- ProcArgs1:=Proc1.Args;
- ProcArgs2:=Proc2.Args;
- if ProcArgs1.Count<>ProcArgs2.Count then
- begin
- if RaiseOnIncompatible then
- RaiseMsg(20170902142829,nIncompatibleTypesGotParametersExpected,
- sIncompatibleTypesGotParametersExpected,
- [IntToStr(ProcArgs1.Count),IntToStr(ProcArgs2.Count)],ErrorEl);
- exit;
- end;
- for i:=0 to ProcArgs1.Count-1 do
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckProcTypeCompatibility ',i,'/',ProcArgs1.Count);
- {$ENDIF}
- ExpectedArg:=TPasArgument(ProcArgs1[i]);
- ActualArg:=TPasArgument(ProcArgs2[i]);
- if CheckProcArgCompatibility(ExpectedArg,ActualArg)>cGenericExact then
- begin
- if RaiseOnIncompatible then
- begin
- if ExpectedArg.Access<>ActualArg.Access then
- RaiseMsg(20170404151541,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(i+1),'access modifier '+AccessDescriptions[ActualArg.Access],
- AccessDescriptions[ExpectedArg.Access]],
- ErrorEl);
- RaiseIncompatibleType(20170404151538,nIncompatibleTypeArgNo,
- [IntToStr(i+1)],ExpectedArg.ArgType,ActualArg.ArgType,ErrorEl);
- end;
- exit;
- end;
- end;
- if Proc1 is TPasFunctionType then
- begin
- ComputeResultElement(TPasFunctionType(Proc1).ResultEl,Result1Resolved,[]);
- ComputeResultElement(TPasFunctionType(Proc2).ResultEl,Result2Resolved,[]);
- if (Result1Resolved.BaseType<>Result2Resolved.BaseType)
- or not IsSameType(Result1Resolved.HiTypeEl,Result2Resolved.HiTypeEl,prraSimple) then
- begin
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170402112648,nResultTypeMismatchExpectedButFound,
- [],Result1Resolved,Result2Resolved,ErrorEl);
- exit;
- end;
- if Proc1.IsAsync<>Proc2.IsAsync then
- RaiseMsg(20200524112519,nXModifierMismatchY,sXModifierMismatchY,['procedure type','async'],ErrorEl);
- end;
- Result:=true;
- end;
- function TPasResolver.CheckProcArgCompatibility(Arg1, Arg2: TPasArgument
- ): integer;
- begin
- // check access: var, const, ...
- if Arg1.Access<>Arg2.Access then exit(cIncompatible);
- Result:=CheckElTypeCompatibility(Arg1.ArgType,Arg2.ArgType,prraSimple);
- end;
- function TPasResolver.CheckElTypeCompatibility(Arg1, Arg2: TPasType;
- ResolveAlias: TPRResolveAlias): integer;
- var
- Arg1Resolved, Arg2Resolved: TPasResolverResult;
- C: TClass;
- Arr1, Arr2: TPasArrayType;
- TemplType1, TemplType2: TPasGenericTemplateType;
- Templates1, Templates2, ProcArgs1, ProcArgs2: TFPList;
- i: Integer;
- Proc1, Proc2: TPasProcedureType;
- begin
- if Arg1=Arg2 then exit(cExact);
- ComputeElement(Arg1,Arg1Resolved,[rcType]);
- ComputeElement(Arg2,Arg2Resolved,[rcType]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckElTypeCompatibility Arg1=',GetResolverResultDbg(Arg1Resolved),' Arg2=',GetResolverResultDbg(Arg2Resolved));
- {$ENDIF}
- if IsGenericTemplType(Arg1Resolved) then
- begin
- Result:=cGenericExact;
- if Arg1Resolved.LoTypeEl=Arg2Resolved.LoTypeEl then
- exit(cExact)
- else if IsGenericTemplType(Arg2Resolved) then
- begin
- TemplType1:=TPasGenericTemplateType(Arg1Resolved.LoTypeEl);
- TemplType2:=TPasGenericTemplateType(Arg2Resolved.LoTypeEl);
- if (TemplType1.Parent is TPasProcedure)
- and (TemplType2.Parent is TPasProcedure) then
- begin
- Templates1:=GetProcTemplateTypes(TPasProcedure(TemplType1.Parent));
- Templates2:=GetProcTemplateTypes(TPasProcedure(TemplType2.Parent));
- i:=Templates1.IndexOf(TemplType1);
- if (i>=0) and (i=Templates2.IndexOf(TemplType2)) then
- exit(cExact);
- end;
- end;
- exit;
- end
- else if IsGenericTemplType(Arg2Resolved) then
- exit(cGenericExact);
- if (Arg1Resolved.BaseType<>Arg2Resolved.BaseType)
- or (Arg1Resolved.LoTypeEl=nil)
- or (Arg2Resolved.LoTypeEl=nil) then
- exit(cIncompatible);
- if ResolveAlias=prraSimple then
- begin
- if IsSameType(Arg1Resolved.HiTypeEl,Arg2Resolved.HiTypeEl,prraSimple) then
- exit(cExact);
- end
- else
- begin
- if IsSameType(Arg1Resolved.LoTypeEl,Arg2Resolved.LoTypeEl,prraNone) then
- exit(cExact);
- end;
- if Arg1Resolved.BaseType=btContext then
- begin
- C:=Arg1Resolved.LoTypeEl.ClassType;
- if C<>Arg2Resolved.LoTypeEl.ClassType then
- exit(cIncompatible);
- if C=TPasArrayType then
- begin
- Arr1:=TPasArrayType(Arg1Resolved.LoTypeEl);
- Arr2:=TPasArrayType(Arg2Resolved.LoTypeEl);
- if length(Arr1.Ranges)<>length(Arr2.Ranges) then
- exit(cIncompatible);
- if length(Arr1.Ranges)>0 then
- RaiseNotYetImplemented(20170328093733,Arr1.Ranges[0],'anonymous static array');
- Result:=CheckElTypeCompatibility(GetArrayElType(Arr1),GetArrayElType(Arr2),ResolveAlias);
- exit;
- end
- else if (C.InheritsFrom(TPasProcedureType))
- and not (msDelphi in CurrentParser.CurrentModeswitches) then
- begin
- // FPC checks proc types arguments by signature, Delphi checks by type
- Proc1:=TPasProcedureType(Arg1Resolved.LoTypeEl);
- Proc2:=TPasProcedureType(Arg2Resolved.LoTypeEl);
- if Proc1.CallingConvention<>Proc2.CallingConvention then
- exit(cIncompatible);
- if Proc1.Modifiers<>Proc2.Modifiers then
- exit(cIncompatible);
- if Proc1.VarArgsType<>Proc2.VarArgsType then
- begin
- Result:=CheckElTypeCompatibility(Proc1.VarArgsType,Proc2.VarArgsType,ResolveAlias);
- if Result=cIncompatible then exit;
- end;
- ProcArgs1:=Proc1.Args;
- ProcArgs2:=Proc2.Args;
- if ProcArgs1.Count<>ProcArgs2.Count then
- exit(cIncompatible);
- for i:=0 to ProcArgs1.Count-1 do
- begin
- Result:=CheckProcArgCompatibility(TPasArgument(ProcArgs1[i]),TPasArgument(ProcArgs2[i]));
- if Result>cGenericExact then
- exit(cIncompatible);
- end;
- exit(cExact);
- end;
- end;
- Result:=cIncompatible;
- end;
- function TPasResolver.CheckCanBeLHS(const ResolvedEl: TPasResolverResult;
- ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean;
- var
- El: TPasElement;
- begin
- Result:=false;
- El:=ResolvedEl.IdentEl;
- if El=nil then
- begin
- if (ResolvedEl.ExprEl is TUnaryExpr)
- and (TUnaryExpr(ResolvedEl.ExprEl).OpCode=eopDeref) then
- begin
- // e.g. p^:=
- end
- else
- begin
- if ErrorOnFalse then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckCanBeLHS no identifier: ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- if (ResolvedEl.LoTypeEl<>nil) and (ResolvedEl.ExprEl<>nil) then
- RaiseXExpectedButYFound(20170216152727,'identifier',GetElementTypeName(ResolvedEl.LoTypeEl),ResolvedEl.ExprEl)
- else
- RaiseVarExpected(20170216152426,ErrorEl,ResolvedEl.IdentEl);
- end;
- exit;
- end;
- end;
- if [rrfWritable,rrfAssignable]*ResolvedEl.Flags<>[] then
- exit(not IsVariableConst(El,ErrorEl,ErrorOnFalse));
- // not writable
- if not ErrorOnFalse then exit;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckCanBeLHS not writable: ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- if ResolvedEl.IdentEl is TPasProperty then
- RaiseMsg(20170216152427,nPropertyNotWritable,sPropertyNotWritable,[],ErrorEl)
- else if ResolvedEl.IdentEl is TPasConst then
- RaiseMsg(20180430012042,nCantAssignValuesToConstVariable,sCantAssignValuesToConstVariable,[],ErrorEl)
- else
- RaiseMsg(20170216152429,nVariableIdentifierExpected,sVariableIdentifierExpected,[],ErrorEl);
- end;
- function TPasResolver.CheckAssignCompatibility(const LHS, RHS: TPasElement;
- RaiseOnIncompatible: boolean; ErrorEl: TPasElement): integer;
- var
- LeftResolved, RightResolved: TPasResolverResult;
- Flags: TPasResolverComputeFlags;
- IsProcType: Boolean;
- begin
- if ErrorEl=nil then
- ErrorEl:=RHS;
- ComputeElement(LHS,LeftResolved,[rcNoImplicitProc]);
- Flags:=[];
- IsProcType:=IsProcedureType(LeftResolved,true);
- if IsProcType then
- if msDelphi in CurrentParser.CurrentModeswitches then
- Include(Flags,rcNoImplicitProc)
- else
- Include(Flags,rcNoImplicitProcType);
- ComputeElement(RHS,RightResolved,Flags);
- Result:=CheckAssignResCompatibility(LeftResolved,RightResolved,ErrorEl,RaiseOnIncompatible);
- if RHS is TPasExpr then
- CheckAssignExprRange(LeftResolved,TPasExpr(RHS));
- end;
- procedure TPasResolver.CheckAssignExprRange(
- const LeftResolved: TPasResolverResult; RHS: TPasExpr);
- // if RHS is a constant check if it fits into range LeftResolved
- var
- LRangeValue, RValue: TResEvalValue;
- Int, MinVal, MaxVal: TMaxPrecInt;
- RangeExpr: TBinaryExpr;
- C: TClass;
- EnumType: TPasEnumType;
- bt: TResolverBaseType;
- LTypeEl: TPasType;
- begin
- LTypeEl:=LeftResolved.LoTypeEl;
- if (LTypeEl<>nil)
- and ((LTypeEl.ClassType=TPasArrayType)
- or (LTypeEl.ClassType=TPasRecordType)) then
- exit; // arrays and records are checked by element, not by the whole value
- if LTypeEl is TPasClassOfType then
- exit; // class-of are checked only by type, not by value
- RValue:=Eval(RHS,[refAutoConstExt]);
- if RValue=nil then
- exit; // not a const expression
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.CheckAssignExprRange Left=',GetResolverResultDbg(LeftResolved),' RValue=',RValue.AsDebugString);
- {$ENDIF}
- LRangeValue:=nil;
- try
- if RValue.Kind=revkExternal then
- // skip
- else if LeftResolved.BaseType=btCustom then
- CheckAssignExprRangeToCustom(LeftResolved,RValue,RHS)
- else if LeftResolved.BaseType=btSet then
- begin
- // assign to a set
- C:=LTypeEl.ClassType;
- if C=TPasRangeType then
- begin
- RangeExpr:=TPasRangeType(LTypeEl).RangeExpr;
- LRangeValue:=Eval(RangeExpr,[refConst],false);
- end
- else if C=TPasEnumType then
- begin
- EnumType:=TPasEnumType(LTypeEl);
- LRangeValue:=TResEvalRangeInt.CreateValue(revskEnum,EnumType,
- 0,TMaxPrecInt(EnumType.Values.Count)-1);
- end
- else if C=TPasUnresolvedSymbolRef then
- begin
- // set of basetype
- if LTypeEl.CustomData is TResElDataBaseType then
- begin
- bt:=GetActualBaseType(TResElDataBaseType(LTypeEl.CustomData).BaseType);
- if (bt in btAllIntegerNoQWord) and GetIntegerRange(bt,MinVal,MaxVal) then
- LRangeValue:=TResEvalRangeInt.CreateValue(revskInt,nil,MinVal,MaxVal)
- else if bt=btBoolean then
- LRangeValue:=TResEvalRangeInt.CreateValue(revskBool,nil,0,1)
- {$ifdef FPC_HAS_CPSTRING}
- else if bt=btAnsiChar then
- LRangeValue:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff)
- {$endif}
- else if bt=btWideChar then
- LRangeValue:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ffff)
- else
- RaiseNotYetImplemented(20170714205110,RHS);
- end
- else
- RaiseNotYetImplemented(20170714204803,RHS);
- end
- else
- RaiseNotYetImplemented(20170714193100,RHS);
- fExprEvaluator.IsSetCompatible(RValue,RHS,LRangeValue,true);
- end
- else if LTypeEl is TPasRangeType then
- begin
- RangeExpr:=TPasRangeType(LTypeEl).RangeExpr;
- LRangeValue:=Eval(RangeExpr,[refConst]);
- if LeftResolved.BaseType=btSet then
- fExprEvaluator.IsSetCompatible(RValue,RHS,LRangeValue,true)
- else
- fExprEvaluator.IsInRange(RValue,RHS,LRangeValue,RangeExpr,true);
- end
- else if (LeftResolved.BaseType in btAllIntegerNoQWord)
- and GetIntegerRange(LeftResolved.BaseType,MinVal,MaxVal) then
- case RValue.Kind of
- revkInt:
- if (MinVal>TResEvalInt(RValue).Int)
- or (MaxVal<TResEvalInt(RValue).Int) then
- fExprEvaluator.EmitRangeCheckConst(20170530093126,
- IntToStr(TResEvalInt(RValue).Int),MinVal,MaxVal,RHS);
- revkUInt:
- if (TResEvalUInt(RValue).UInt>High(TMaxPrecInt))
- or (MinVal>TMaxPrecInt(TResEvalUInt(RValue).UInt))
- or (MaxVal<TMaxPrecInt(TResEvalUInt(RValue).UInt)) then
- fExprEvaluator.EmitRangeCheckConst(20170530093616,
- IntToStr(TResEvalUInt(RValue).UInt),IntToStr(MinVal),IntToStr(MaxVal),RHS);
- revkFloat:
- if TResEvalFloat(RValue).IsInt(Int) then
- begin
- if (MinVal>Int) or (MaxVal<Int) then
- fExprEvaluator.EmitRangeCheckConst(20170802133307,
- IntToStr(Int),MinVal,MaxVal,RHS,mtError);
- end
- else
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.CheckAssignExprRange ',Frac(TResEvalFloat(RValue).FloatValue),' ',TResEvalFloat(RValue).FloatValue<TMaxPrecFloat(low(TMaxPrecInt)),' ',TResEvalFloat(RValue).FloatValue>TMaxPrecFloat(high(TMaxPrecInt)),' ',TResEvalFloat(RValue).FloatValue,' ',high(TMaxPrecInt));
- {$ENDIF}
- RaiseRangeCheck(20170802133750,RHS);
- end;
- revkCurrency:
- if TResEvalCurrency(RValue).IsInt(Int) then
- begin
- if (MinVal>Int) or (MaxVal<Int) then
- fExprEvaluator.EmitRangeCheckConst(20180421171325,
- IntToStr(Int),MinVal,MaxVal,RHS,mtError);
- end
- else
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.CheckAssignExprRange ',Frac(TResEvalCurrency(RValue).Value),' ',TResEvalCurrency(RValue).Value,' ',high(TMaxPrecInt));
- {$ENDIF}
- RaiseRangeCheck(20180421171438,RHS);
- end;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.CheckAssignExprRange ',RValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530092731,RHS);
- end
- {$ifdef HasInt64}
- else if LeftResolved.BaseType=btQWord then
- case RValue.Kind of
- revkInt:
- if (TResEvalInt(RValue).Int<0) then
- fExprEvaluator.EmitRangeCheckConst(20170530094316,
- IntToStr(TResEvalUInt(RValue).UInt),'0',IntToStr(High(QWord)),RHS);
- revkUInt: ;
- else
- RaiseNotYetImplemented(20170530094311,RHS);
- end
- {$endif}
- else if RValue.Kind in [revkNil,revkBool] then
- // simple type check is enough
- else if LeftResolved.BaseType in [btSingle,btDouble,btCurrency] then
- // simple type check is enough
- // ToDo: warn if precision loss
- else if LeftResolved.BaseType in btAllChars then
- begin
- case RValue.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString,
- {$endif}
- revkUnicodeString:
- Int:=fExprEvaluator.StringToOrd(RValue,RHS);
- else
- RaiseNotYetImplemented(20170714171218,RHS);
- end;
- case GetActualBaseType(LeftResolved.BaseType) of
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar: MaxVal:=$ff;
- {$endif}
- btWideChar: MaxVal:=$ffff;
- end;
- if (Int>MaxVal) then
- fExprEvaluator.EmitRangeCheckConst(20170714171911,
- '#'+IntToStr(Int),'#0','#'+IntToStr(MaxVal),RHS);
- end
- else if LeftResolved.BaseType in btAllStrings then
- // simple type check is enough
- // ToDo: warn if unicode to non-utf8
- else if LeftResolved.BaseType=btContext then
- // simple type check is enough
- else if LeftResolved.BaseType=btRange then
- begin
- if (LeftResolved.ExprEl is TBinaryExpr)
- and (TBinaryExpr(LeftResolved.ExprEl).Kind=pekRange) then
- begin
- LRangeValue:=Eval(LeftResolved.ExprEl,[refConst]);
- try
- case LRangeValue.Kind of
- revkRangeInt:
- case TResEvalRangeInt(LRangeValue).ElKind of
- revskEnum:
- if (RValue.Kind<>revkEnum) then
- RaiseNotYetImplemented(20171009171251,RHS)
- else if (TResEvalEnum(RValue).Index<TResEvalRangeInt(LRangeValue).RangeStart)
- or (TResEvalEnum(RValue).Index>TResEvalRangeInt(LRangeValue).RangeEnd) then
- fExprEvaluator.EmitRangeCheckConst(20171009171442,
- TResEvalEnum(RValue).AsString,
- TResEvalRangeInt(LRangeValue).ElementAsString(TResEvalRangeInt(LRangeValue).RangeStart),
- TResEvalRangeInt(LRangeValue).ElementAsString(TResEvalRangeInt(LRangeValue).RangeEnd),
- RHS);
- else
- RaiseNotYetImplemented(20171009165348,LeftResolved.ExprEl);
- end;
- else
- RaiseNotYetImplemented(20171009165326,LeftResolved.ExprEl);
- end;
- finally
- ReleaseEvalValue(LRangeValue);
- end;
- end
- else
- RaiseNotYetImplemented(20171009171005,RHS);
- end
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignExprRange LeftResolved=',GetResolverResultDbg(LeftResolved));
- {$ENDIF}
- RaiseNotYetImplemented(20170530095243,RHS);
- end;
- finally
- ReleaseEvalValue(RValue);
- ReleaseEvalValue(LRangeValue);
- end;
- end;
- procedure TPasResolver.CheckAssignExprRangeToCustom(
- const LeftResolved: TPasResolverResult; RValue: TResEvalValue; RHS: TPasExpr);
- begin
- if LeftResolved.BaseType<>btCustom then exit;
- if RValue=nil then exit;
- if RHS=nil then ;
- end;
- function TPasResolver.CheckAssignResCompatibility(const LHS,
- RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- var
- LTypeEl, RTypeEl: TPasType;
- Handled: Boolean;
- C: TClass;
- LBT, RBT: TResolverBaseType;
- LRange, RValue, Value: TResEvalValue;
- RightSubResolved: TPasResolverResult;
- wc: WideChar;
- begin
- // check if the RHS can be converted to LHS
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignResCompatibility START LHS='+GetResolverResultDbg(LHS)+' RHS='+GetResolverResultDbg(RHS));
- {$ENDIF}
- Result:=-1;
- Handled:=false;
- Result:=CheckAssignCompatibilityCustom(LHS,RHS,ErrorEl,RaiseOnIncompatible,Handled);
- if Handled and (Result>=cExact) and (Result<cIncompatible) then
- exit;
- if not Handled then
- begin
- LBT:=GetActualBaseType(LHS.BaseType);
- RBT:=GetActualBaseType(RHS.BaseType);
- if IsGenericTemplType(LHS) then
- begin
- // Template := RHS
- if not RaiseOnIncompatible then
- ErrorEl:=nil;
- Result:=CheckTemplateFitsParamRes(TPasGenericTemplateType(LHS.LoTypeEl),
- RHS,prtcoAssignToTempl,ErrorEl);
- exit;
- end
- else if IsGenericTemplType(RHS) then
- begin
- // LHS := Template
- if not RaiseOnIncompatible then
- ErrorEl:=nil;
- Result:=CheckTemplateFitsParamRes(TPasGenericTemplateType(RHS.LoTypeEl),
- LHS,prtcoAssignFromTempl,ErrorEl);
- exit;
- end;
- if LHS.LoTypeEl=nil then
- begin
- if LBT=btUntyped then
- begin
- // untyped parameter
- Result:=cTypeConversion;
- end
- else
- RaiseNotYetImplemented(20160922163631,LHS.IdentEl);
- end
- else if LBT=RBT then
- begin
- if LBT=btContext then
- exit(CheckAssignCompatibilityUserType(LHS,RHS,ErrorEl,RaiseOnIncompatible))
- else
- begin
- // same base type, maybe not same type (e.g. longint and integer)
- if IsSameType(LHS.HiTypeEl,RHS.HiTypeEl,prraSimple)
- and HasExactType(RHS) then
- Result:=cExact
- else
- Result:=cAliasExact;
- end;
- end
- else if (LBT in btAllBooleans)
- and (RBT in btAllBooleans) then
- Result:=cCompatible
- else if (LBT in btAllChars) then
- begin
- if (RBT in btAllChars) then
- case LBT of
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar:
- Result:=cLossyConversion;
- {$endif}
- btWideChar:
- {$ifdef FPC_HAS_CPSTRING}
- if RBT=btAnsiChar then
- Result:=cCompatible
- else
- {$endif}
- Result:=cLossyConversion;
- else
- RaiseNotYetImplemented(20170728132440,ErrorEl,BaseTypeNames[LBT]);
- end
- else if (RBT=btRange) and (RHS.SubType in btAllChars) then
- begin
- if LBT=btWideChar then
- exit(cCompatible);
- {$ifdef FPC_HAS_CPSTRING}
- // LHS is ansichar
- if GetActualBaseType(RHS.SubType)=btAnsiChar then
- exit(cExact);
- RValue:=Eval(RHS,[refAutoConstExt]);
- if RValue<>nil then
- try
- // ansichar:=constvalue
- case RValue.Kind of
- revkString:
- if not ExprEvaluator.GetWideChar(TResEvalString(RValue).S,wc) then
- exit(cIncompatible);
- revkUnicodeString:
- begin
- if length(TResEvalUTF16(RValue).S)<>1 then
- exit(cIncompatible);
- wc:=TResEvalUTF16(RValue).S[1];
- end;
- revkExternal:
- exit(cCompatible);
- else
- RaiseNotYetImplemented(20171108194650,ErrorEl);
- end;
- if ord(wc)>255 then
- exit(cIncompatible);
- exit(cCompatible);
- finally
- ReleaseEvalValue(RValue);
- end;
- // LHS is ansichar, RHS is not a const
- if (RHS.ExprEl is TBinaryExpr) and (TBinaryExpr(RHS.ExprEl).Kind=pekRange) then
- begin
- RValue:=Eval(RHS.ExprEl,[refConst]);
- try
- if RValue.Kind<>revkRangeInt then
- RaiseNotYetImplemented(20171108195035,ErrorEl);
- if TResEvalRangeInt(RValue).RangeStart>255 then
- exit(cIncompatible);
- if TResEvalRangeInt(RValue).RangeEnd>255 then
- exit(cLossyConversion);
- exit(cCompatible);
- finally
- ReleaseEvalValue(RValue);
- end;
- end;
- {$endif}
- RaiseNotYetImplemented(20171108195216,ErrorEl);
- end;
- end
- else if (LBT in btAllStrings) then
- begin
- if (RBT in btAllStringAndChars) then
- case LBT of
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiString:
- if RBT in [btAnsiChar,btShortString,btRawByteString] then
- Result:=cCompatible
- else
- Result:=cLossyConversion;
- btShortString:
- if RBT=btAnsiChar then
- Result:=cCompatible
- else
- Result:=cLossyConversion;
- btRawByteString:
- if RBT in [btAnsiChar,btAnsiString,btShortString] then
- Result:=cCompatible
- else
- Result:=cLossyConversion;
- {$endif}
- btWideString,btUnicodeString:
- Result:=cCompatible;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignResCompatibility ',{$ifdef pas2js}str(LBT){$else}LBT{$ENDIF});
- {$ENDIF}
- RaiseNotYetImplemented(20170417195208,ErrorEl,BaseTypeNames[LBT]);
- end
- else if RBT=btContext then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if RTypeEl.ClassType=TPasClassType then
- begin
- if (TPasClassType(RTypeEl).ObjKind=okInterface)
- and IsTGUIDString(LHS) then
- // aGUIDString:=IntfTypeOrVar
- exit(cInterfaceToString); // no check for rrfReadable
- end
- else if RTypeEl.ClassType=TPasRecordType then
- begin
- if IsTGUID(TPasRecordType(RTypeEl)) then
- // aString:=GUID
- Result:=cTGUIDToString;
- end;
- end;
- end
- else if (LBT in btAllInteger)
- and (RBT in btAllInteger) then
- begin
- Result:=cIntToIntConversion+ord(LBT)-ord(RBT);
- case LBT of
- btByte,
- btShortInt: inc(Result,cLossyConversion);
- btWord,
- btSmallInt:
- if not (RBT in [btByte,btShortInt]) then
- inc(Result,cLossyConversion);
- btUIntSingle:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt]) then
- inc(Result,cLossyConversion);
- btIntSingle:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btUIntSingle]) then
- inc(Result,cLossyConversion);
- btLongWord,
- btLongint:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btUIntSingle,btIntSingle]) then
- inc(Result,cLossyConversion);
- btUIntDouble:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btLongWord,btLongint]) then
- inc(Result,cLossyConversion);
- btIntDouble:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btLongWord,btLongint,btUIntDouble]) then
- inc(Result,cLossyConversion);
- {$ifdef HasInt64}
- btQWord,
- btInt64,btComp:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btUIntSingle,btIntSingle,
- btLongWord,btLongint,btUIntDouble,btIntDouble]) then
- inc(Result,cLossyConversion);
- {$endif}
- else
- RaiseNotYetImplemented(20170417205301,ErrorEl,BaseTypeNames[LBT]);
- end;
- end
- else if (LBT in btAllFloats)
- and (RBT in btAllFloats) then
- begin
- Result:=cFloatToFloatConversion+ord(LBT)-ord(RBT);
- case LBT of
- btSingle:
- if RBT>btSingle then
- inc(Result,cLossyConversion);
- btDouble:
- if RBT>btDouble then
- inc(Result,cLossyConversion);
- btExtended,btCExtended:
- if RBT>btCExtended then
- inc(Result,cLossyConversion);
- btCurrency:
- inc(Result,cLossyConversion);
- else
- RaiseNotYetImplemented(20170417205910,ErrorEl,BaseTypeNames[LBT]);
- end;
- end
- else if (LBT in btAllFloats)
- and (RBT in btAllInteger) then
- begin
- Result:=cIntToFloatConversion+ord(LBT)-ord(RBT);
- case LBT of
- btSingle:
- if RBT>btUIntSingle then
- inc(Result,cLossyConversion);
- btDouble:
- if RBT>btUIntDouble then
- inc(Result,cLossyConversion);
- btExtended,btCExtended:
- if RBT>btCExtended then
- inc(Result,cLossyConversion);
- btCurrency:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
- btIntSingle,btUIntSingle,
- btLongWord,btLongint]) then
- inc(Result,cLossyConversion);
- else
- RaiseNotYetImplemented(20170417205911,ErrorEl,BaseTypeNames[LBT]);
- end;
- end
- else if LBT=btNil then
- begin
- if RaiseOnIncompatible then
- RaiseMsg(20170216152431,nCantAssignValuesToAnAddress,sCantAssignValuesToAnAddress,
- [],ErrorEl);
- exit(cIncompatible);
- end
- else if LBT=btRange then
- begin
- if (LHS.ExprEl is TBinaryExpr) and (TBinaryExpr(LHS.ExprEl).Kind=pekRange) then
- begin
- LRange:=Eval(LHS.ExprEl,[refConst]);
- RValue:=nil;
- try
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.CheckAssignResCompatibility LeftRange=',LRange.AsDebugString);
- {$ENDIF}
- case LRange.Kind of
- revkRangeInt:
- case TResEvalRangeInt(LRange).ElKind of
- revskEnum:
- if RHS.BaseType=btContext then
- begin
- if IsSameType(TResEvalRangeInt(LRange).ElType,RHS.LoTypeEl,prraAlias) then
- begin
- // same enum type
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignResCompatibility LeftRange=',LRange.AsDebugString,' Left.ElType=',GetObjName(TResEvalRangeInt(LRange).ElType),' RHS.TypeEl=',GetObjName(RHS.LoTypeEl));
- {$ENDIF}
- // ToDo: check if LRange is smaller than Range of RHS (cLossyConversion)
- exit(cExact);
- end;
- end;
- revskInt:
- if RHS.BaseType in btAllInteger then
- begin
- RValue:=Eval(RHS,[refAutoConstExt]);
- if RValue<>nil then
- begin
- // ToDo: check range
- end;
- exit(cCompatible);
- end;
- revskChar:
- if RHS.BaseType in btAllStringAndChars then
- begin
- RValue:=Eval(RHS,[refAutoConstExt]);
- if RValue<>nil then
- begin
- case RValue.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- if not fExprEvaluator.GetWideChar(TResEvalString(RValue).S,wc) then
- exit(cIncompatible);
- {$endif}
- revkUnicodeString:
- begin
- if length(TResEvalUTF16(RValue).S)<>1 then
- exit(cIncompatible);
- wc:=TResEvalUTF16(RValue).S[1];
- end;
- revkExternal:
- exit(cCompatible);
- else
- RaiseNotYetImplemented(20171108192232,ErrorEl);
- end;
- if (ord(wc)<TResEvalRangeInt(LRange).RangeStart)
- or (ord(wc)>TResEvalRangeInt(LRange).RangeEnd) then
- exit(cIncompatible);
- end;
- exit(cCompatible);
- end;
- revskBool:
- if RHS.BaseType=btBoolean then
- begin
- RValue:=Eval(RHS,[refAutoConstExt]);
- if RValue<>nil then
- begin
- // ToDo: check range
- end;
- exit(cCompatible);
- end;
- end;
- end;
- finally
- ReleaseEvalValue(LRange);
- ReleaseEvalValue(RValue);
- end;
- end;
- end
- else if LBT=btSet then
- begin
- if RBT=btArrayOrSet then
- begin
- if RHS.SubType=btNone then
- // a:=[]
- Result:=cExact
- else if IsSameType(LHS.HiTypeEl,RHS.HiTypeEl,prraSimple)
- and HasExactType(RHS) then
- Result:=cExact
- else if LHS.SubType=RHS.SubType then
- Result:=cAliasExact
- else if (LHS.SubType in btAllBooleans) and (RHS.SubType in btAllBooleans) then
- Result:=cCompatible
- else if (LHS.SubType in btAllInteger) and (RHS.SubType in btAllInteger) then
- begin
- // ToDo: range check
- Result:=cCompatible;
- end
- else if (LHS.SubType in btAllChars) and (RHS.SubType in btAllChars) then
- begin
- // ToDo: range check
- Result:=cCompatible;
- end;
- end;
- end
- else if LBT in [btArrayLit,btArrayOrSet,btModule,btProc] then
- begin
- if RaiseOnIncompatible then
- RaiseMsg(20170216152432,nIllegalExpression,sIllegalExpression,[],ErrorEl);
- exit(cIncompatible);
- end
- else if (LHS.IdentEl=nil) and (LHS.ExprEl=nil) then
- begin
- if RaiseOnIncompatible then
- RaiseMsg(20170216152434,nIllegalExpression,sIllegalExpression,[],ErrorEl);
- exit(cIncompatible);
- end
- else if RBT=btNil then
- begin
- if LBT=btPointer then
- Result:=cExact
- else if LBT=btContext then
- begin
- LTypeEl:=LHS.LoTypeEl;
- C:=LTypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasPointerType)
- or C.InheritsFrom(TPasProcedureType)
- or IsDynArray(LTypeEl) then
- Result:=cExact;
- end;
- end
- else if RBT=btProc then
- begin
- if (msDelphi in CurrentParser.CurrentModeswitches)
- and (LHS.LoTypeEl is TPasProcedureType)
- and (RHS.IdentEl is TPasProcedure) then
- begin
- // for example ProcVar:=Proc
- if CheckProcTypeCompatibility(TPasProcedureType(LHS.LoTypeEl),
- TPasProcedure(RHS.IdentEl).ProcType,true,ErrorEl,RaiseOnIncompatible) then
- exit(cExact);
- end
- else if (LHS.LoTypeEl is TPasProcedureType)
- and (RHS.ExprEl is TProcedureExpr) then
- begin
- // for example ProcVar:=anonymous-procedure...
- if CheckProcTypeCompatibility(TPasProcedureType(LHS.LoTypeEl),
- TProcedureExpr(RHS.ExprEl).Proc.ProcType,true,ErrorEl,RaiseOnIncompatible) then
- exit(cExact);
- end
- end
- else if LBT=btPointer then
- begin
- if RBT=btPointer then
- begin
- LTypeEl:=LHS.LoTypeEl;
- RTypeEl:=RHS.LoTypeEl;
- if IsBaseType(LTypeEl,btPointer) then
- Result:=cExact // btPointer can take any pointer
- else if IsBaseType(RTypeEl,btPointer) then
- Result:=cTypeConversion // any pointer can take a btPointer
- else if IsSameType(LTypeEl,RTypeEl,prraAlias) then
- Result:=cExact // pointer of same type
- else if (LTypeEl.ClassType=TPasPointerType)
- and (RTypeEl.ClassType=TPasPointerType) then
- Result:=CheckAssignCompatibility(TPasPointerType(LTypeEl).DestType,
- TPasPointerType(RTypeEl).DestType,RaiseOnIncompatible);
- end
- else if IsBaseType(LHS.LoTypeEl,btPointer) then
- begin
- // UntypedPointer:=...
- if RBT=btContext then
- begin
- RTypeEl:=RHS.LoTypeEl;
- C:=RTypeEl.ClassType;
- if C=TPasClassType then
- // UntypedPointer:=ClassTypeOrInstance
- exit(cTypeConversion)
- else if C=TPasClassOfType then
- // UntypedPointer:=ClassOfVar
- Result:=cTypeConversion
- else if C=TPasArrayType then
- begin
- if IsDynArray(RTypeEl) then
- // UntypedPointer:=DynArray
- Result:=cTypeConversion;
- end
- else if (C=TPasProcedureType) or (C=TPasFunctionType) then
- // UntypedPointer:=procvar
- Result:=cLossyConversion
- else if C=TPasPointerType then
- // UntypedPointer:=TypedPointer
- Result:=cExact;
- end;
- end;
- end
- else if (LBT=btContext) then
- begin
- LTypeEl:=LHS.LoTypeEl;
- if (LTypeEl.ClassType=TPasArrayType) then
- Result:=CheckAssignCompatibilityArrayType(LHS,RHS,ErrorEl,RaiseOnIncompatible)
- else if LTypeEl.ClassType=TPasEnumType then
- begin
- if (RHS.BaseType=btRange) and (RHS.SubType=btContext) then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if RTypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(RTypeEl).RangeExpr.left,RightSubResolved,[rcConstant]);
- if (RightSubResolved.BaseType=btContext)
- and IsSameType(LTypeEl,RightSubResolved.LoTypeEl,prraAlias) then
- begin
- // enumtype := enumrange
- Result:=cExact;
- end;
- end;
- end;
- end
- else if LTypeEl.ClassType=TPasRecordType then
- begin
- if (RBT in btAllStrings) and IsTGUID(TPasRecordType(LTypeEl))
- and (rrfReadable in RHS.Flags) then
- begin
- // GUIDVar := string, e.g. IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}'
- Value:=Eval(RHS,[refConstExt]);
- try
- if Value=nil then
- if RaiseOnIncompatible then
- RaiseXExpectedButYFound(20180414105916,'string literal','string', ErrorEl)
- else
- exit(cIncompatible);
- finally
- ReleaseEvalValue(Value);
- end;
- Result:=cStringToTGUID;
- end;
- end
- else if LTypeEl.ClassType=TPasPointerType then
- begin
- // TypedPointer:=
- if RHS.BaseType=btPointer then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if IsBaseType(RTypeEl,btPointer) then
- // TypedPointer:=UntypedPointer
- Result:=cTypeConversion
- else
- begin
- // TypedPointer:=@Var
- Result:=CheckAssignCompatibilityPointerType(
- TPasPointerType(LTypeEl).DestType,RTypeEl,ErrorEl,false);
- end;
- end;
- end;
- end;
- end;
- if (Result>=0) and (Result<cIncompatible) then
- begin
- // type fits -> check readable
- if not (rrfReadable in RHS.Flags) then
- begin
- if RaiseOnIncompatible then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignResCompatibility RHS not readable. LHS='+GetResolverResultDbg(LHS)+' RHS='+GetResolverResultDbg(RHS));
- {$ENDIF}
- RaiseVarExpected(20170318235637,ErrorEl,RHS.IdentEl);
- end;
- exit(cIncompatible);
- end;
- exit;
- end;
- // incompatible
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignResCompatibility incompatible LHS='+GetResolverResultDbg(LHS)+' RHS='+GetResolverResultDbg(RHS));
- {$ENDIF}
- if not RaiseOnIncompatible then
- exit(cIncompatible);
- // create error messages
- RaiseIncompatibleTypeRes(20170216152437,nIncompatibleTypesGotExpected,
- [],RHS,LHS,ErrorEl);
- end;
- function TPasResolver.CheckEqualElCompatibility(Left, Right: TPasElement;
- ErrorEl: TPasElement; RaiseOnIncompatible: boolean; SetReferenceFlags: boolean
- ): integer;
- // check if the RightResolved is type compatible to LeftResolved
- var
- LFlags, RFlags: TPasResolverComputeFlags;
- LeftResolved, RightResolved: TPasResolverResult;
- LeftErrorEl, RightErrorEl: TPasElement;
- begin
- Result:=cIncompatible;
- // Delphi resolves both sides, so it forbids "if procvar=procvar then"
- // FPC is more clever. It supports "if procvar=@proc then", "function=value"
- if msDelphi in CurrentParser.CurrentModeswitches then
- LFlags:=[]
- else
- LFlags:=[rcNoImplicitProcType];
- if SetReferenceFlags then
- Include(LFlags,rcSetReferenceFlags);
- ComputeElement(Left,LeftResolved,LFlags);
- if (msDelphi in CurrentParser.CurrentModeswitches) then
- RFlags:=LFlags
- else
- begin
- if LeftResolved.BaseType=btNil then
- RFlags:=[rcNoImplicitProcType]
- else if IsProcedureType(LeftResolved,true) then
- RFlags:=[rcNoImplicitProcType]
- else
- RFlags:=[];
- end;
- if SetReferenceFlags then
- Include(RFlags,rcSetReferenceFlags);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckEqualElCompatibility LFlags=',dbgs(LFlags),' Left=',GetResolverResultDbg(LeftResolved),' Delphi=',msDelphi in CurrentParser.CurrentModeswitches,' RFlags=',dbgs(RFlags));
- {$ENDIF}
- ComputeElement(Right,RightResolved,RFlags);
- if ErrorEl=nil then
- begin
- LeftErrorEl:=Left;
- RightErrorEl:=Right;
- end
- else
- begin
- LeftErrorEl:=ErrorEl;
- RightErrorEl:=ErrorEl;
- end;
- Result:=CheckEqualResCompatibility(LeftResolved,RightResolved,LeftErrorEl,
- RaiseOnIncompatible,RightErrorEl);
- end;
- function TPasResolver.CheckEqualResCompatibility(const LHS,
- RHS: TPasResolverResult; LErrorEl: TPasElement; RaiseOnIncompatible: boolean;
- RErrorEl: TPasElement): integer;
- var
- LTypeEl, RTypeEl: TPasType;
- ResolvedEl: TPasResolverResult;
- begin
- Result:=cIncompatible;
- if RErrorEl=nil then RErrorEl:=LErrorEl;
- // check if the RHS is type compatible to LHS
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckEqualResCompatibility LHS=',GetResolverResultDbg(LHS),' RHS=',GetResolverResultDbg(RHS));
- {$ENDIF}
- if not (rrfReadable in LHS.Flags) then
- begin
- if (LHS.BaseType=btContext) then
- begin
- LTypeEl:=LHS.LoTypeEl;
- if (LTypeEl.ClassType=TPasClassType)
- and (ResolveAliasTypeEl(LHS.IdentEl)=LTypeEl) then
- begin
- // LHS is class type, e.g. TObject or IInterface
- if RHS.BaseType=btNil then
- exit(cExact)
- else if RHS.BaseType in btAllStrings then
- begin
- if (rrfReadable in RHS.Flags)
- and (TPasClassType(LTypeEl).ObjKind=okInterface)
- and IsTGUIDString(RHS) then
- // e.g. IUnknown=aGUIDString
- exit(cInterfaceToString);
- end
- else if (RHS.BaseType=btContext) then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if (RTypeEl.ClassType=TPasClassOfType)
- and (rrfReadable in RHS.Flags)
- and (TPasClassType(LTypeEl).ObjKind=okClass) then
- // for example if TImage=ImageClass then
- exit(cExact)
- else if (RTypeEl.ClassType=TPasRecordType)
- and (rrfReadable in RHS.Flags)
- and (TPasClassType(LTypeEl).ObjKind=okInterface)
- and IsTGUID(TPasRecordType(RTypeEl)) then
- // e.g. if IUnknown=TGuidVar then
- exit(cInterfaceToTGUID);
- end;
- end;
- end;
- RaiseMsg(20170216152438,nNotReadable,sNotReadable,[],LErrorEl);
- end;
- if not (rrfReadable in RHS.Flags) then
- begin
- if (RHS.BaseType=btContext) then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if (RTypeEl.ClassType=TPasClassType)
- and (ResolveAliasTypeEl(RHS.IdentEl)=RTypeEl) then
- begin
- // RHS is class type, e.g. TObject or IInterface
- if LHS.BaseType=btNil then
- exit(cExact)
- else if LHS.BaseType in btAllStrings then
- begin
- if (rrfReadable in LHS.Flags)
- and (TPasClassType(RTypeEl).ObjKind=okInterface)
- and IsTGUIDString(LHS) then
- // e.g. aGUIDString=IUnknown
- exit(cInterfaceToString);
- end
- else if (LHS.BaseType=btContext) then
- begin
- LTypeEl:=LHS.LoTypeEl;
- if (LTypeEl.ClassType=TPasClassOfType)
- and (rrfReadable in LHS.Flags)
- and (TPasClassType(RTypeEl).ObjKind=okClass) then
- // for example if ImageClass=TImage then
- exit(cExact)
- else if (LTypeEl.ClassType=TPasRecordType)
- and (rrfReadable in LHS.Flags)
- and (TPasClassType(RTypeEl).ObjKind=okInterface)
- and IsTGUID(TPasRecordType(LTypeEl)) then
- // e.g. if TGuidVar=IUnknown then
- exit(cInterfaceToTGUID);
- end;
- end;
- end;
- RaiseMsg(20170216152440,nNotReadable,sNotReadable,[],RErrorEl);
- end;
- if IsGenericTemplType(LHS) then
- begin
- // TemplateVar = x
- Result:=CheckTemplateFitsParamRes(TPasGenericTemplateType(LHS.LoTypeEl),RHS,prtcoEqual,nil);
- if Result<>cIncompatible then exit;
- end
- else if IsGenericTemplType(RHS) then
- begin
- // x = TemplateVar
- Result:=CheckTemplateFitsParamRes(TPasGenericTemplateType(RHS.LoTypeEl),LHS,prtcoEqual,nil);
- if Result<>cIncompatible then exit;
- end;
- if (LHS.BaseType=btCustom) or (RHS.BaseType=btCustom) then
- begin
- Result:=CheckEqualCompatibilityCustomType(LHS,RHS,LErrorEl,RaiseOnIncompatible);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170330010727,nIncompatibleTypesGotExpected,
- [],RHS,LHS,LErrorEl);
- exit;
- end
- else if LHS.BaseType=RHS.BaseType then
- begin
- if LHS.BaseType=btContext then
- exit(CheckEqualCompatibilityUserType(LHS,RHS,LErrorEl,RaiseOnIncompatible))
- else
- exit(cExact); // same base type, maybe not same type name (e.g. longint and integer)
- end
- else if LHS.BaseType in btAllInteger then
- begin
- if RHS.BaseType in btAllInteger+btAllFloats then
- exit(cCompatible)
- else if (RHS.BaseType=btRange) and (RHS.SubType in btAllInteger) then
- exit(cCompatible);
- end
- else if LHS.BaseType in btAllFloats then
- begin
- if RHS.BaseType in btAllInteger+btAllFloats then
- exit(cCompatible);
- end
- else if LHS.BaseType in btAllBooleans then
- begin
- if RHS.BaseType in btAllBooleans then
- exit(cCompatible)
- else if (RHS.BaseType=btRange) and (RHS.SubType in btAllBooleans) then
- exit(cCompatible);
- end
- else if LHS.BaseType in btAllStringAndChars then
- begin
- if RHS.BaseType in btAllStringAndChars then
- exit(cCompatible)
- else if (RHS.BaseType=btRange) and (RHS.SubType in btAllChars) then
- exit(cCompatible)
- else if RHS.BaseType=btContext then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if (RTypeEl.ClassType=TPasClassType) then
- begin
- if (TPasClassType(RTypeEl).ObjKind=okInterface)
- and IsTGUIDString(LHS) then
- // e.g. aGUIDString=IntfVar
- exit(cInterfaceToString);
- end
- else if (RTypeEl.ClassType=TPasRecordType)
- and IsTGUID(TPasRecordType(RTypeEl)) then
- // e.g. aString=GuidVar
- exit(cTGUIDToString);
- end;
- end
- else if LHS.BaseType=btNil then
- begin
- if RHS.BaseType in [btPointer,btNil] then
- exit(cExact)
- else if RHS.BaseType=btContext then
- begin
- LTypeEl:=RHS.LoTypeEl;
- if (LTypeEl.ClassType=TPasClassType)
- or (LTypeEl.ClassType=TPasClassOfType)
- or (LTypeEl.ClassType=TPasPointerType)
- or (LTypeEl is TPasProcedureType)
- or IsDynArray(LTypeEl) then
- exit(cExact);
- end;
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152442,nIncompatibleTypesGotExpected,
- [],RHS,LHS,RErrorEl)
- else
- exit(cIncompatible);
- end
- else if RHS.BaseType=btNil then
- begin
- if LHS.BaseType=btPointer then
- exit(cExact)
- else if LHS.BaseType=btContext then
- begin
- LTypeEl:=LHS.LoTypeEl;
- if (LTypeEl.ClassType=TPasClassType)
- or (LTypeEl.ClassType=TPasClassOfType)
- or (LTypeEl.ClassType=TPasPointerType)
- or (LTypeEl is TPasProcedureType)
- or IsDynArray(LTypeEl) then
- exit(cExact);
- end;
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152444,nIncompatibleTypesGotExpected,
- [],RHS,LHS,LErrorEl)
- else
- exit(cIncompatible);
- end
- else if LHS.BaseType=btPointer then
- begin
- if RHS.BaseType=btContext then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if RTypeEl.ClassType=TPasPointerType then
- // @Something=TypedPointer
- exit(cExact)
- else if RTypeEl.ClassType=TPasClassType then
- // @Something=ClassOrInterface
- exit(cCompatible)
- else if RTypeEl.ClassType=TPasClassOfType then
- // @Something=ClassOf
- exit(cCompatible);
- end;
- end
- else if LHS.BaseType in [btSet,btArrayOrSet] then
- begin
- if RHS.BaseType in [btSet,btArrayOrSet] then
- begin
- if LHS.LoTypeEl=nil then
- exit(cExact); // empty set
- if RHS.LoTypeEl=nil then
- exit(cExact); // empty set
- if IsSameType(LHS.LoTypeEl,RHS.LoTypeEl,prraAlias) then
- exit(cExact);
- if (LHS.SubType=RHS.SubType) and (LHS.SubType in (btAllBooleans+btAllInteger+btAllChars)) then
- exit(cExact);
- if ((LHS.SubType in btAllBooleans) and (RHS.SubType in btAllBooleans))
- or ((LHS.SubType in btAllInteger) and (RHS.SubType in btAllInteger)) then
- exit(cCompatible);
- if RaiseOnIncompatible then
- RaiseMsg(20170216152446,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['set of '+BaseTypeNames[LHS.SubType],'set of '+BaseTypeNames[RHS.SubType]],LErrorEl)
- else
- exit(cIncompatible);
- end;
- end
- else if LHS.BaseType=btRange then
- begin
- if LHS.SubType in btAllInteger then
- begin
- // e.g. 2..4
- if RHS.BaseType in btAllInteger then
- exit(cCompatible)
- else if (RHS.BaseType=btRange) and (RHS.SubType in btAllInteger) then
- exit(cCompatible);
- end
- else if LHS.SubType in btAllBooleans then
- begin
- if RHS.BaseType in btAllBooleans then
- exit(cCompatible)
- else if (RHS.BaseType=btRange) and (RHS.SubType in btAllBooleans) then
- exit(cCompatible);
- end
- else if LHS.SubType in btAllChars then
- begin
- if RHS.BaseType in btAllStringAndChars then
- exit(cCompatible)
- else if (RHS.BaseType=btRange) and (RHS.SubType in btAllChars) then
- exit(cCompatible);
- end
- else if LHS.SubType=btContext then
- begin
- LTypeEl:=LHS.LoTypeEl;
- if LTypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(LTypeEl).RangeExpr.left,ResolvedEl,[rcConstant]);
- if ResolvedEl.BaseType=btContext then
- begin
- LTypeEl:=ResolvedEl.LoTypeEl;
- if LTypeEl.ClassType=TPasEnumType then
- begin
- if RHS.BaseType=btContext then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if (LTypeEl=RTypeEl) then
- exit(cCompatible);
- end;
- end;
- end;
- end;
- end;
- end
- else if LHS.BaseType=btContext then
- begin
- LTypeEl:=LHS.LoTypeEl;
- if LTypeEl.ClassType=TPasEnumType then
- begin
- if RHS.BaseType=btRange then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if RTypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(RTypeEl).RangeExpr.left,ResolvedEl,[rcConstant]);
- if ResolvedEl.BaseType=btContext then
- begin
- RTypeEl:=ResolvedEl.LoTypeEl;
- if LTypeEl=RTypeEl then
- exit(cCompatible);
- end;
- end;
- end;
- end
- else if LTypeEl.ClassType=TPasClassType then
- begin
- if RHS.BaseType=btPointer then
- exit(cCompatible)
- else if TPasClassType(LTypeEl).ObjKind=okInterface then
- begin
- if RHS.BaseType in btAllStrings then
- begin
- if IsTGUIDString(RHS) then
- // e.g. IntfVar=aGUIDString
- exit(cInterfaceToString);
- end
- else if RHS.BaseType=btContext then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if (RTypeEl.ClassType=TPasRecordType)
- and IsTGUID(TPasRecordType(RTypeEl)) then
- // e.g. IntfVar=GuidVar
- exit(cInterfaceToTGUID);
- end;
- end;
- end
- else if LTypeEl.ClassType=TPasClassOfType then
- begin
- if RHS.BaseType=btPointer then
- exit(cCompatible);
- end
- else if LTypeEl.ClassType=TPasRecordType then
- begin
- if IsTGUID(TPasRecordType(LTypeEl)) then
- begin
- // LHS is TGUID
- if (RHS.BaseType in btAllStrings) then
- // GuidVar=aString
- exit(cTGUIDToString)
- else if RHS.BaseType=btContext then
- begin
- RTypeEl:=RHS.LoTypeEl;
- if (RTypeEl.ClassType=TPasClassType)
- and (TPasClassType(RTypeEl).ObjKind=okInterface) then
- // GUIDVar=IntfVar
- exit(cInterfaceToTGUID);
- end;
- end;
- end
- else if LTypeEl.ClassType=TPasPointerType then
- begin
- if RHS.BaseType=btPointer then
- // TypedPointer=@Something
- exit(cExact);
- end;
- end;
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152449,nIncompatibleTypesGotExpected,
- [],RHS,LHS,RErrorEl)
- else
- exit(cIncompatible);
- end;
- function TPasResolver.IsVariableConst(El, PosEl: TPasElement;
- RaiseIfConst: boolean): boolean;
- var
- CurEl: TPasElement;
- VarResolved: TPasResolverResult;
- Loop: TPasImplForLoop;
- begin
- Result:=false;
- CurEl:=PosEl;
- while CurEl<>nil do
- begin
- if (CurEl.ClassType=TPasImplForLoop) then
- begin
- Loop:=TPasImplForLoop(CurEl);
- if (Loop.VariableName<>PosEl) then
- begin
- ComputeElement(Loop.VariableName,VarResolved,[rcNoImplicitProc]);
- if VarResolved.IdentEl=El then
- begin
- if RaiseIfConst then
- RaiseMsg(20180430100719,nIllegalAssignmentToForLoopVar,
- sIllegalAssignmentToForLoopVar,[El.Name],PosEl);
- exit(true);
- end;
- end;
- end;
- CurEl:=CurEl.Parent;
- end;
- end;
- function TPasResolver.ResolvedElCanBeVarParam(
- const ResolvedEl: TPasResolverResult; PosEl: TPasElement;
- RaiseIfConst: boolean): boolean;
- function NotLocked(El: TPasElement): boolean;
- begin
- Result:=not IsVariableConst(El,PosEl,RaiseIfConst);
- end;
- var
- IdentEl: TPasElement;
- begin
- Result:=false;
- if [rrfReadable,rrfWritable]*ResolvedEl.Flags<>[rrfReadable,rrfWritable] then
- exit;
- if ResolvedEl.IdentEl=nil then
- exit(true);
- IdentEl:=ResolvedEl.IdentEl;
- if IdentEl.ClassType=TPasVariable then
- exit(NotLocked(IdentEl));
- if (IdentEl.ClassType=TPasConst) then
- begin
- if TPasConst(IdentEl).IsConst then
- begin
- if RaiseIfConst then
- RaiseMsg(20180430100719,nCantAssignValuesToConstVariable,sCantAssignValuesToConstVariable,[],PosEl);
- exit(false);
- end;
- exit(NotLocked(IdentEl));
- end;
- if (IdentEl.ClassType=TPasArgument) then
- begin
- if TPasArgument(IdentEl).Access in [argConst,argConstRef] then
- begin
- if RaiseIfConst then
- RaiseMsg(20180430100843,nCantAssignValuesToConstVariable,sCantAssignValuesToConstVariable,[],PosEl);
- exit(false);
- end;
- Result:=(TPasArgument(IdentEl).Access in [argDefault, argVar, argOut]);
- exit(Result and NotLocked(IdentEl));
- end;
- if IdentEl.ClassType=TPasResultElement then
- exit(NotLocked(IdentEl));
- if (proPropertyAsVarParam in Options)
- and (IdentEl.ClassType=TPasProperty) then
- exit(NotLocked(IdentEl));
- end;
- function TPasResolver.ResolvedElIsClassOrRecordInstance(
- const ResolvedEl: TPasResolverResult): boolean;
- var
- TypeEl: TPasType;
- begin
- Result:=false;
- if ResolvedEl.BaseType<>btContext then exit;
- TypeEl:=ResolvedEl.LoTypeEl;
- if TypeEl=nil then exit;
- if TypeEl.ClassType=TPasClassType then
- begin
- if TPasClassType(TypeEl).ObjKind<>okClass then exit;
- end
- else if TypeEl.ClassType=TPasRecordType then
- else
- exit;
- if (ResolvedEl.IdentEl is TPasVariable)
- or (ResolvedEl.IdentEl.ClassType=TPasArgument)
- or (ResolvedEl.IdentEl.ClassType=TPasResultElement) then
- exit(true);
- end;
- function TPasResolver.GetResolver(El: TPasElement): TPasResolver;
- var
- Module: TPasModule;
- Scope: TPasModuleScope;
- begin
- Result:=nil;
- if El=nil then exit;
- Module:=El.GetModule;
- if Module=nil then exit;
- Scope:=Module.CustomData as TPasModuleScope;
- if Scope=nil then exit;
- Result:=Scope.Owner as TPasResolver;
- end;
- function TPasResolver.ElHasModeSwitch(El: TPasElement; ms: TModeSwitch
- ): boolean;
- begin
- Result:=ms in GetElModeSwitches(El);
- end;
- function TPasResolver.GetElModeSwitches(El: TPasElement): TModeSwitches;
- var
- C: TClass;
- begin
- while El<>nil do
- begin
- if El.CustomData<>nil then
- begin
- C:=El.CustomData.ClassType;
- if C.InheritsFrom(TPasProcedureScope) then
- exit(TPasProcedureScope(El.CustomData).ModeSwitches)
- else if C.InheritsFrom(TPasSectionScope) then
- exit(TPasSectionScope(El.CustomData).ModeSwitches);
- end;
- El:=El.Parent;
- end;
- Result:=CurrentParser.CurrentModeswitches;
- end;
- function TPasResolver.ElHasBoolSwitch(El: TPasElement; bs: TBoolSwitch
- ): boolean;
- begin
- Result:=bs in GetElBoolSwitches(El);
- end;
- function TPasResolver.GetElBoolSwitches(El: TPasElement): TBoolSwitches;
- var
- C: TClass;
- begin
- Result:=CurrentParser.Scanner.CurrentBoolSwitches;
- while El<>nil do
- begin
- if El.CustomData<>nil then
- begin
- C:=El.CustomData.ClassType;
- if C.InheritsFrom(TPasProcedureScope) then
- exit(TPasProcedureScope(El.CustomData).BoolSwitches)
- else if C.InheritsFrom(TPasSectionScope) then
- exit(TPasSectionScope(El.CustomData).BoolSwitches)
- else if C.InheritsFrom(TPasModuleScope) then
- exit(TPasModuleScope(El.CustomData).BoolSwitches);
- end;
- El:=El.Parent;
- end;
- end;
- function TPasResolver.GetProcTypeDescription(ProcType: TPasProcedureType;
- Flags: TPRProcTypeDescFlags): string;
- var
- Args, Templates: TFPList;
- i: Integer;
- Arg: TPasArgument;
- ArgType: TPasType;
- Proc: TPasProcedure;
- begin
- if ProcType=nil then exit('nil');
- Result:=ProcType.TypeName;
- if ProcType.IsReferenceTo then
- Result:=ProcTypeModifiers[ptmReferenceTo]+' '+Result;
- if ProcType.Parent is TPasProcedure then
- begin
- Proc:=TPasProcedure(ProcType.Parent);
- if (prptdUseName in Flags) then
- begin
- if prptdAddPaths in Flags then
- Result:=Result+' '+Proc.FullName
- else
- Result:=Result+' '+Proc.Name;
- end;
- Templates:=GetProcTemplateTypes(Proc);
- if Templates<>nil then
- Result:=Result+GetGenericParamCommas(Templates.Count);
- end;
- Args:=ProcType.Args;
- if Args.Count>0 then
- begin
- Result:=Result+'(';
- for i:=0 to Args.Count-1 do
- begin
- if i>0 then Result:=Result+';';
- Arg:=TPasArgument(Args[i]);
- if AccessNames[Arg.Access]<>'' then
- Result:=Result+AccessNames[Arg.Access];
- if Arg.ArgType=nil then
- Result:=Result+'untyped'
- else
- begin
- ArgType:=Arg.ArgType;
- if prptdResolveSimpleAlias in Flags then
- ArgType:=ResolveSimpleAliasType(ArgType);
- Result:=Result+GetTypeDescription(ArgType,prptdAddPaths in Flags);
- end;
- end;
- Result:=Result+')';
- end;
- if ProcType.IsOfObject then
- Result:=Result+' '+ProcTypeModifiers[ptmOfObject];
- if ProcType.IsNested then
- Result:=Result+' '+ProcTypeModifiers[ptmIsNested];
- if cCallingConventions[ProcType.CallingConvention]<>'' then
- Result:=Result+';'+cCallingConventions[ProcType.CallingConvention];
- end;
- function TPasResolver.GetResolverResultDescription(const T: TPasResolverResult;
- OnlyType: boolean): string;
- function GetSubTypeName: string;
- begin
- if (T.LoTypeEl<>nil) and (T.LoTypeEl.Name<>'') then
- Result:=T.LoTypeEl.Name
- else
- Result:=BaseTypeNames[T.SubType];
- end;
- var
- ArrayEl: TPasArrayType;
- begin
- case T.BaseType of
- btModule: exit(GetElementTypeName(T.IdentEl)+' '+T.IdentEl.Name);
- btNil: exit('nil');
- btRange:
- Result:='range of '+GetSubTypeName;
- btSet:
- Result:='set of '+GetSubTypeName;
- btArrayLit:
- Result:='array of '+GetSubTypeName;
- btArrayOrSet:
- Result:='set/array literal of '+GetSubTypeName;
- btContext:
- begin
- if T.LoTypeEl.ClassType=TPasClassOfType then
- Result:='class of '+TPasClassOfType(T.LoTypeEl).DestType.Name
- else if T.LoTypeEl.ClassType=TPasAliasType then
- Result:=TPasAliasType(T.LoTypeEl).DestType.Name
- else if T.LoTypeEl.ClassType=TPasTypeAliasType then
- Result:='type '+TPasAliasType(T.LoTypeEl).DestType.Name
- else if T.LoTypeEl.ClassType=TPasArrayType then
- begin
- ArrayEl:=TPasArrayType(T.LoTypeEl);
- if length(ArrayEl.Ranges)=0 then
- begin
- if ArrayEl.ElType=nil then
- Result:='array of const'
- else
- begin
- Result:='array of '+ArrayEl.ElType.Name;
- if IsOpenArray(ArrayEl) then
- Result:='open '+Result;
- end;
- end
- else
- Result:='static array[] of '+ArrayEl.ElType.Name;
- end
- else if T.LoTypeEl is TPasProcedureType then
- Result:=GetProcTypeDescription(TPasProcedureType(T.LoTypeEl),[])
- else if T.LoTypeEl.Name<>'' then
- Result:=T.LoTypeEl.Name
- else
- Result:=T.LoTypeEl.ElementTypeName;
- end;
- btCustom:
- Result:=T.LoTypeEl.Name;
- else
- Result:=BaseTypeNames[T.BaseType];
- end;
- if (not OnlyType) and (T.LoTypeEl<>T.IdentEl) and (T.IdentEl<>nil) then
- Result:=T.IdentEl.Name+':'+Result;
- end;
- function TPasResolver.GetTypeDescription(aType: TPasType; AddPath: boolean): string;
- function GetName: string;
- var
- s: String;
- Spec: TPasSpecializeType;
- P: TPasElement;
- i: Integer;
- GenScope: TPasGenericScope;
- Params: TPasTypeArray;
- begin
- Result:=aType.Name;
- if Result='' then
- begin
- if aType is TPasArrayType then
- begin
- if length(TPasArrayType(aType).Ranges)>0 then
- Result:='static array'
- else if TPasArrayType(aType).ElType=nil then
- Result:='array of const'
- else if IsOpenArray(aType) then
- Result:='open array'
- else
- Result:='dynamic array';
- end
- else if aType is TPasSpecializeType then
- begin
- Spec:=TPasSpecializeType(aType);
- if Spec.CustomData is TPasSpecializeTypeData then
- exit(GetTypeDescription(TPasSpecializeTypeData(Spec.CustomData).SpecializedType));
- Result:=GetTypeDescription(Spec.DestType,true)+'<';
- for i:=0 to Spec.Params.Count-1 do
- begin
- P:=TPasElement(Spec.Params[i]);
- if P is TPasType then
- Result:=Result+GetTypeDescription(TPasType(P));
- if i>0 then
- Result:=Result+',';
- end;
- Result:=Result+'>';
- end
- else
- Result:=GetElementTypeName(aType);
- end
- else if aType is TPasGenericType then
- begin
- i:=GetTypeParameterCount(TPasGenericType(aType));
- if i>0 then
- // generic, not specialized
- Result:=Result+GetGenericParamCommas(GetTypeParameterCount(TPasGenericType(aType)))
- else if aType.CustomData is TPasGenericScope then
- begin
- GenScope:=TPasGenericScope(aType.CustomData);
- if (GenScope.SpecializedFromItem<>nil) and IsValidIdent(aType.Name) then
- begin
- // specialized without params in name -> append params
- Params:=GenScope.SpecializedFromItem.Params;
- Result:=Result+'<';
- for i:=0 to length(Params)-1 do
- begin
- Result:=Result+GetTypeDescription(Params[i],AddPath);
- if i>0 then
- Result:=Result+',';
- end;
- Result:=Result+'>';
- end
- end;
- end;
- if AddPath then
- begin
- s:=aType.ParentPath;
- if (s<>'') and (s<>'.') then
- Result:=s+'.'+Result;
- end;
- end;
- begin
- if aType=nil then exit('untyped');
- Result:=GetName;
- if (aType.ClassType=TPasUnresolvedSymbolRef) then
- begin
- if TPasUnresolvedSymbolRef(aType).CustomData is TResElDataBuiltInProc then
- Result:=Result+'()';
- exit;
- end;
- end;
- function TPasResolver.GetTypeDescription(const R: TPasResolverResult;
- AddPath: boolean): string;
- var
- s: String;
- begin
- Result:=GetTypeDescription(R.LoTypeEl,AddPath);
- if R.BaseType in [btSet,btArrayLit,btArrayOrSet] then
- Result:=BaseTypeNames[R.BaseType]+' of '+Result;
- if (R.LoTypeEl<>nil) and (R.IdentEl=R.LoTypeEl) then
- begin
- s:=GetElementTypeName(R.LoTypeEl);
- if s<>'' then
- Result:=s+' '+Result
- else
- Result:='type '+Result;
- end;
- end;
- function TPasResolver.GetBaseDescription(const R: TPasResolverResult;
- AddPath: boolean): string;
- begin
- if R.BaseType=btContext then
- Result:=GetTypeDescription(R,AddPath)
- else if (R.BaseType=btPointer) and not IsBaseType(R.LoTypeEl,btPointer) then
- Result:='^'+GetTypeDescription(R,AddPath)
- else
- Result:=BaseTypeNames[R.BaseType];
- end;
- function TPasResolver.GetProcFirstImplEl(Proc: TPasProcedure): TPasImplElement;
- var
- Scope: TPasProcedureScope;
- Body: TPasImplBlock;
- begin
- Result:=nil;
- if Proc=nil then exit;
- if Proc.Body<>nil then
- Body:=Proc.Body.Body
- else
- Body:=nil;
- if Body=nil then
- begin
- if Proc.CustomData=nil then exit;
- Scope:=Proc.CustomData as TPasProcedureScope;
- Proc:=Scope.ImplProc;
- if Proc=nil then exit;
- if Proc.Body=nil then exit;
- Body:=Proc.Body.Body;
- if Body=nil then exit;
- end;
- if Body.Elements=nil then exit;
- if Body.Elements.Count=0 then exit;
- Result:=TPasImplElement(Body.Elements[0]);
- end;
- function TPasResolver.GetProcTemplateTypes(Proc: TPasProcedure): TFPList;
- var
- NameParts: TProcedureNamePart;
- begin
- if Proc.NameParts=nil then
- exit(nil);
- NameParts:=TProcedureNamePart(Proc.NameParts[Proc.NameParts.Count-1]);
- Result:=NameParts.Templates;
- if (Result<>nil) and (Result.Count=0) then
- exit(nil);
- end;
- function TPasResolver.GetProcName(Proc: TPasProcedure; WithTemplates: boolean
- ): string;
- var
- NameParts: TProcedureNameParts;
- i, j: Integer;
- NamePart: TProcedureNamePart;
- TemplType: TPasGenericTemplateType;
- Templates: TFPList;
- begin
- if Proc=nil then exit('(nil)');
- Result:=Proc.Name;
- if WithTemplates then
- begin
- NameParts:=Proc.NameParts;
- if NameParts=nil then exit;
- Result:='';
- for i:=0 to NameParts.Count-1 do
- begin
- NamePart:=TProcedureNamePart(NameParts[i]);
- if i>0 then
- Result:=Result+'.';
- Result:=Result+NamePart.Name;
- Templates:=NamePart.Templates;
- if (Templates<>nil) and (Templates.Count>0) then
- begin
- for j:=0 to Templates.Count-1 do
- begin
- TemplType:=TPasGenericTemplateType(NamePart.Templates[j]);
- if j=0 then
- Result:=Result+'<'
- else
- Result:=Result+',';
- Result:=Result+TemplType.Name;
- end;
- Result:=Result+'>';
- end;
- end;
- end;
- end;
- function TPasResolver.GetPasPropertyAncestor(El: TPasProperty;
- WithRedeclarations: boolean): TPasProperty;
- begin
- Result:=nil;
- if El=nil then exit;
- if (not WithRedeclarations) and (El.VarType<>nil) then exit;
- if El.CustomData=nil then exit;
- Result:=TPasPropertyScope(El.CustomData).AncestorProp;
- end;
- function TPasResolver.GetPasPropertyType(El: TPasProperty): TPasType;
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El.VarType<>nil then
- exit(El.VarType);
- El:=GetPasPropertyAncestor(El);
- end;
- end;
- function TPasResolver.GetPasPropertyArgs(El: TPasProperty): TFPList;
- begin
- while El<>nil do
- begin
- if El.VarType<>nil then
- exit(El.Args);
- El:=GetPasPropertyAncestor(El);
- end;
- Result:=nil;
- end;
- function TPasResolver.GetPasPropertyGetter(El: TPasProperty): TPasElement;
- // search the member variable or getter function of a property
- var
- DeclEl: TPasElement;
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El.ReadAccessor<>nil then
- begin
- DeclEl:=(El.ReadAccessor.CustomData as TResolvedReference).Declaration;
- Result:=DeclEl;
- exit;
- end;
- El:=GetPasPropertyAncestor(El);
- end;
- end;
- function TPasResolver.GetPasPropertySetter(El: TPasProperty): TPasElement;
- // search the member variable or setter procedure of a property
- var
- DeclEl: TPasElement;
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El.WriteAccessor<>nil then
- begin
- DeclEl:=(El.WriteAccessor.CustomData as TResolvedReference).Declaration;
- Result:=DeclEl;
- exit;
- end;
- El:=GetPasPropertyAncestor(El);
- end;
- end;
- function TPasResolver.GetPasPropertyIndex(El: TPasProperty): TPasExpr;
- // search the index expression of a property
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El.IndexExpr<>nil then
- begin
- Result:=El.IndexExpr;
- exit;
- end;
- El:=GetPasPropertyAncestor(El);
- end;
- end;
- function TPasResolver.GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
- // search the stored expression of a property
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El.StoredAccessor<>nil then
- begin
- Result:=El.StoredAccessor;
- exit;
- end;
- El:=GetPasPropertyAncestor(El);
- end;
- end;
- function TPasResolver.GetPasPropertyDefaultExpr(El: TPasProperty): TPasExpr;
- // search the stored expression of a property
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El.DefaultExpr<>nil then
- begin
- Result:=El.DefaultExpr;
- exit;
- end
- else if El.IsNodefault then
- exit(nil);
- El:=GetPasPropertyAncestor(El);
- end;
- end;
- function TPasResolver.CheckParamCompatibility(Expr: TPasExpr;
- Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean;
- SetReferenceFlags: boolean): integer;
- var
- ExprResolved, ParamResolved: TPasResolverResult;
- NeedVar: Boolean;
- begin
- Result:=cIncompatible;
- ComputeArgumentAndExpr(Param,ParamResolved,Expr,ExprResolved,SetReferenceFlags);
- NeedVar:=Param.Access in [argVar, argOut];
- if NeedVar then
- begin
- // Expr must be a variable
- if not ResolvedElCanBeVarParam(ExprResolved,Expr) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckParamCompatibility NeedWritable: ',GetResolverResultDbg(ExprResolved));
- {$ENDIF}
- if RaiseOnError then
- begin
- if ExprResolved.IdentEl is TPasConst then
- RaiseMsg(20180430012609,nCantAssignValuesToConstVariable,sCantAssignValuesToConstVariable,[],Expr)
- else
- RaiseVarExpected(20180430012457,Expr,ExprResolved.IdentEl);
- end;
- exit;
- end;
- if (Param.ArgType=nil) then
- exit(cExact); // untyped argument
- if GetActualBaseType(ParamResolved.BaseType)=GetActualBaseType(ExprResolved.BaseType) then
- begin
- if msDelphi in CurrentParser.CurrentModeswitches then
- begin
- // Delphi allows passing alias, but not type alias to a var arg
- if IsSameType(ParamResolved.HiTypeEl,ExprResolved.HiTypeEl,prraSimple) then
- exit(cExact);
- end
- else if IsSameType(ParamResolved.LoTypeEl,ExprResolved.LoTypeEl,prraNone) then
- begin
- // ObjFPC allows passing type alias to a var arg, but simple alias wins
- if IsSameType(ParamResolved.HiTypeEl,ExprResolved.HiTypeEl,prraSimple) then
- exit(cExact)
- else
- exit(cAliasExact);
- end;
- if (ParamResolved.BaseType=btContext)
- and (ParamResolved.LoTypeEl.ClassType=TPasArrayType)
- and (ExprResolved.LoTypeEl.ClassType=TPasArrayType) then
- begin
- Result:=CheckAssignResCompatibility(ParamResolved,ExprResolved,Expr,false);
- if Result<>cIncompatible then exit;
- end;
- end;
- if IsGenericTemplType(ParamResolved) then
- exit(cGenericExact);
- //writeln('TPasResolver.CheckParamCompatibility NeedVar ParamResolved=',GetResolverResultDbg(ParamResolved),' ExprResolved=',GetResolverResultDbg(ExprResolved));
- if RaiseOnError then
- RaiseIncompatibleTypeRes(20170216152452,nIncompatibleTypeArgNoVarParamMustMatchExactly,
- [IntToStr(ParamNo+1)],ExprResolved,ParamResolved,
- Expr);
- exit(cIncompatible);
- end;
- Result:=CheckParamResCompatibility(Expr,ExprResolved,ParamResolved,ParamNo,
- RaiseOnError,SetReferenceFlags);
- end;
- function TPasResolver.CheckParamResCompatibility(Expr: TPasExpr;
- const ExprResolved, ParamResolved: TPasResolverResult; ParamNo: integer;
- RaiseOnError: boolean; SetReferenceFlags: boolean): integer;
- var
- UseAssignError: Boolean;
- begin
- UseAssignError:=false;
- if RaiseOnError and (ExprResolved.BaseType in [btArrayLit,btArrayOrSet]) then
- // e.g. Call([1,2]) -> on mismatch jump to the wrong param expression
- UseAssignError:=true;
- Result:=CheckAssignResCompatibility(ParamResolved,ExprResolved,Expr,UseAssignError);
- if (Result=cIncompatible) and RaiseOnError then
- RaiseIncompatibleTypeRes(20170216152454,nIncompatibleTypeArgNo,
- [IntToStr(ParamNo+1)],ExprResolved,ParamResolved,Expr);
- if SetReferenceFlags and (ParamResolved.BaseType=btContext)
- and (ParamResolved.LoTypeEl.ClassType=TPasArrayType) then
- MarkArrayExprRecursive(Expr,TPasArrayType(ParamResolved.LoTypeEl));
- end;
- function TPasResolver.CheckAssignCompatibilityUserType(const LHS,
- RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- var
- RTypeEl, LTypeEl: TPasType;
- SrcResolved, DstResolved: TPasResolverResult;
- LArray, RArray: TPasArrayType;
- GotDesc, ExpDesc: String;
- CurTVarRec: TPasRecordType;
- LeftClass, RightClass: TPasClassType;
- function RaiseIncompatType(Id: TMaxPrecInt): integer;
- begin
- Result:=cIncompatible;
- if not RaiseOnIncompatible then exit;
- RaiseIncompatibleTypeRes(Id,nIncompatibleTypesGotExpected,
- [],RHS,LHS,ErrorEl);
- end;
- begin
- if (RHS.LoTypeEl=nil) then
- RaiseInternalError(20160922163645);
- if (LHS.LoTypeEl=nil) then
- RaiseInternalError(20160922163648);
- LTypeEl:=LHS.LoTypeEl;
- RTypeEl:=RHS.LoTypeEl;
- // Note: do not check if LHS is writable, because this method is used for 'const' too.
- if (LTypeEl=RTypeEl) and (rrfReadable in RHS.Flags) then
- exit(cExact);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignCompatibilityUserType LTypeEl=',GetObjName(LTypeEl),' RTypeEl=',GetObjName(RTypeEl));
- {$ENDIF}
- Result:=-1;
- if LTypeEl.ClassType=TPasClassType then
- begin
- if RHS.BaseType=btNil then
- Result:=cExact
- else if RTypeEl.ClassType=TPasClassType then
- begin
- Result:=cIncompatible;
- if not (rrfReadable in RHS.Flags) then
- exit(RaiseIncompatType(20190215112914));
- LeftClass:=TPasClassType(LTypeEl);
- RightClass:=TPasClassType(RTypeEl);
- if LeftClass.ObjKind=RightClass.ObjKind then
- Result:=CheckSrcIsADstType(RHS,LHS)
- else if LeftClass.ObjKind=okInterface then
- begin
- if (RightClass.ObjKind=okClass)
- and (not RightClass.IsExternal) then
- begin
- // IntfVar:=ClassInstVar
- if GetClassImplementsIntf(RightClass,LeftClass)<>nil then
- exit(cTypeConversion);
- end;
- end;
- if Result=cIncompatible then
- Result:=CheckAssignCompatibilityClasses(LeftClass,RightClass);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseIncompatibleType(20170216152458,nIncompatibleTypesGotExpected,
- [],RTypeEl,LTypeEl,ErrorEl);
- end
- else
- exit(RaiseIncompatType(20190215112919));
- end
- else if LTypeEl.ClassType=TPasClassOfType then
- begin
- if RHS.BaseType=btNil then
- Result:=cExact
- else if (RTypeEl.ClassType=TPasClassOfType) then
- begin
- if RHS.IdentEl is TPasType then
- begin
- Result:=cIncompatible;
- if RaiseOnIncompatible then
- begin
- if ResolveAliasType(TPasType(RHS.IdentEl)) is TPasClassOfType then
- RaiseMsg(20180317103206,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['type class-of','class of '+TPasClassOfType(LTypeEl).DestType.Name],ErrorEl)
- else
- RaiseMsg(20180511123859,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [GetResolverResultDescription(RHS),'class of '+TPasClassOfType(LTypeEl).DestType.Name],ErrorEl)
- end;
- end
- else
- begin
- // e.g. ImageClass:=AnotherImageClass;
- Result:=CheckClassIsClass(TPasClassOfType(RTypeEl).DestType,
- TPasClassOfType(LTypeEl).DestType);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152500,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['class of '+TPasClassOfType(RTypeEl).DestType.PathName,'class of '+TPasClassOfType(LTypeEl).DestType.PathName],ErrorEl);
- end;
- end
- else if (RHS.IdentEl is TPasType)
- and (ResolveAliasType(TPasType(RHS.IdentEl)).ClassType=TPasClassType) then
- begin
- // e.g. ImageClass:=TFPMemoryImage;
- Result:=CheckClassIsClass(RTypeEl,TPasClassOfType(LTypeEl).DestType);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152501,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [RTypeEl.Name,'class of '+TPasClassOfType(LTypeEl).DestType.PathName],ErrorEl);
- // do not check rrfReadable -> exit
- exit;
- end;
- end
- else if LTypeEl is TPasProcedureType then
- begin
- if RHS.BaseType=btNil then
- exit(cExact);
- //writeln('TPasResolver.CheckAssignCompatibilityUserType LTypeEl=',GetObjName(LTypeEl),' RHS.BaseType=',BaseTypeNames[RHS.BaseType],' RTypeEl=',GetObjName(RTypeEl),' RHS.IdentEl=',GetObjName(RHS.IdentEl),' RHS.ExprEl=',GetObjName(RHS.ExprEl),' rrfReadable=',rrfReadable in RHS.Flags);
- if (LTypeEl.ClassType=RTypeEl.ClassType)
- and (rrfReadable in RHS.Flags) then
- begin
- // e.g. ProcVar1:=ProcVar2
- if CheckProcTypeCompatibility(TPasProcedureType(LTypeEl),TPasProcedureType(RTypeEl),
- true,ErrorEl,RaiseOnIncompatible) then
- exit(cExact);
- end;
- if RaiseOnIncompatible then
- begin
- if (RTypeEl is TPasProcedureType) and (rrfReadable in RHS.Flags) then
- RaiseMsg(20170404154738,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [GetElementTypeName(RTypeEl),GetElementTypeName(LTypeEl)],ErrorEl);
- end;
- end
- else if LTypeEl.ClassType=TPasArrayType then
- begin
- LArray:=TPasArrayType(LTypeEl);
- if (length(LArray.Ranges)=0) and (RTypeEl.ClassType=TPasArrayType) then
- begin
- // DynOrOpenArr:=array
- RArray:=TPasArrayType(RTypeEl);
- if length(RArray.Ranges)=1 then
- begin
- // DynOrOpenArr:=SingleDimStaticArr
- if (msDelphi in CurrentParser.CurrentModeswitches)
- and not IsOpenArray(LArray) then
- begin
- // DynArr:=SingleDimStaticArr forbidden in Delphi
- // Note: OpenArr:=StaticArr is allowed in Delphi
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeDesc(20180620115341,nIncompatibleTypesGotExpected,
- [],'static array','dynamic array',ErrorEl);
- exit(cIncompatible);
- end;
- end
- else if length(RArray.Ranges)>1 then
- begin
- // DynOrOpenArr:=MultiDimStaticArr -> no
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeDesc(20180620115235,nIncompatibleTypesGotExpected,
- [],'multi dimensional static array','dynamic array',ErrorEl);
- exit(cIncompatible);
- end
- else if not (proOpenAsDynArrays in Options) then
- begin
- if IsOpenArray(LArray) then
- // OpenArray:=OpenOrDynArr -> ok
- else if IsOpenArray(RArray) then
- begin
- // DynArray:=OpenArray
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeDesc(20180620115515,nIncompatibleTypesGotExpected,
- [],'open array','dynamic array',ErrorEl);
- exit(cIncompatible)
- end
- else
- begin
- // DynArray:=DynArr
- if (msDelphi in CurrentParser.CurrentModeswitches)
- and (LArray<>RArray) then
- begin
- // Delphi does not allow assigning arrays with same element types
- exit(RaiseIncompatType(20190215112626));
- end;
- end;
- end;
- // check element type
- if LArray.ElType=nil then
- begin
- // ArrayOfConst:=SingleDimArr
- if RArray.ElType=nil then
- // ArrayOfConst:=ArrayOfConst
- Result:=cExact
- else
- begin
- CurTVarRec:=GetTVarRec(LArray);
- if ResolveAliasType(RArray.ElType)=CurTVarRec then
- // ArrayOfConst:=ArrayOfTVarRec
- Result:=cExact
- else
- // ArrayOfConst:=SingleDimArr
- exit(RaiseIncompatType(20190215112715));
- end;
- end
- else if RArray.ElType=nil then
- // ArrayOfNonConst:=ArrayOfConst
- exit(RaiseIncompatType(20190215112907))
- else
- begin
- Result:=CheckElTypeCompatibility(LArray.ElType,RArray.ElType,prraAlias);
- if Result=cIncompatible then
- if RaiseOnIncompatible then
- begin
- GetIncompatibleTypeDesc(LArray.ElType,RArray.ElType,GotDesc,ExpDesc);
- RaiseMsg(20170328110050,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['array of '+GotDesc,
- 'array of '+ExpDesc],ErrorEl)
- end
- else
- exit(cIncompatible);
- end;
- end;
- end
- else if LTypeEl.ClassType=TPasRecordType then
- begin
- if (RTypeEl is TPasClassType) and (TPasClassType(RTypeEl).ObjKind=okInterface)
- and IsTGUID(TPasRecordType(LTypeEl)) then
- begin
- // GUIDVar := IntfTypeOrVar
- exit(cInterfaceToTGUID);
- end;
- // records of different type
- end
- else if LTypeEl.ClassType=TPasEnumType then
- begin
- // enums of different type
- end
- else if RTypeEl.ClassType=TPasSetType then
- begin
- // sets of different type are compatible if enum types are compatible
- if LTypeEl.ClassType=TPasSetType then
- begin
- ComputeElement(TPasSetType(LTypeEl).EnumType,DstResolved,[]);
- ComputeElement(TPasSetType(RTypeEl).EnumType,SrcResolved,[]);
- if (SrcResolved.LoTypeEl<>nil)
- and (SrcResolved.LoTypeEl=DstResolved.LoTypeEl) then
- Result:=cExact
- else if (SrcResolved.LoTypeEl.CustomData is TResElDataBaseType)
- and (DstResolved.LoTypeEl.CustomData is TResElDataBaseType)
- and (CompareText(SrcResolved.LoTypeEl.Name,DstResolved.LoTypeEl.Name)=0) then
- Result:=cExact
- else if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152510,nIncompatibleTypesGotExpected,
- [],SrcResolved,DstResolved,ErrorEl)
- else
- exit(cIncompatible);
- end
- else
- exit(RaiseIncompatType(20190215112924));
- end
- else if LTypeEl.ClassType=TPasPointerType then
- begin
- if RTypeEl.ClassType=TPasPointerType then
- begin
- // TypedPointer:=TypedPointer
- Result:=CheckAssignCompatibilityPointerType(TPasPointerType(LTypeEl).DestType,
- TPasPointerType(RTypeEl).DestType,ErrorEl,false);
- if Result=cIncompatible then
- exit(RaiseIncompatType(20190215112927));
- end;
- end
- else
- {$IFDEF VerbosePasResolver}
- RaiseNotYetImplemented(20160922163654,ErrorEl);
- {$ELSE}
- ;
- {$ENDIF}
- if Result=-1 then
- exit(RaiseIncompatType(20190215112931));
- if not (rrfReadable in RHS.Flags) then
- exit(RaiseIncompatType(20190215112934));
- end;
- function TPasResolver.CheckAssignCompatibilityArrayType(const LHS,
- RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- procedure Check_ArrayOfChar_String(ArrType: TPasArrayType;
- ArrLength: integer; const ElTypeResolved: TPasResolverResult;
- Expr: TPasExpr; ErrorEl: TPasElement);
- // check if assigning a string to an array of char fits
- var
- Value: TResEvalValue;
- ElBT: TResolverBaseType;
- l: Integer;
- S: String;
- {$ifdef FPC_HAS_CPSTRING}
- US: UnicodeString;
- {$endif}
- begin
- if Expr=nil then exit;
- ElBT:=GetActualBaseType(ElTypeResolved.BaseType);
- if length(ArrType.Ranges)=0 then
- begin
- // dynamic array of char can hold any string
- // ToDo: check if value can be converted without loss
- Result:=cExact;
- exit;
- end;
- // static array -> check length of string
- Value:=Eval(Expr,[refAutoConst]); // no external const allowed
- try
- case Value.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- if ElBT=btAnsiChar then
- l:=length(TResEvalString(Value).S)
- else
- begin
- US:=fExprEvaluator.GetUnicodeStr(TResEvalString(Value).S,ErrorEl);
- l:=length(US);
- end;
- {$endif}
- revkUnicodeString:
- begin
- if ElBT=btWideChar then
- l:=length(TResEvalUTF16(Value).S)
- else
- begin
- S:=String(TResEvalUTF16(Value).S);
- l:=length(S);
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('Check_ArrayOfChar_String Value=',Value.AsDebugString);
- {$ENDIF}
- exit; // incompatible
- end;
- if ArrLength<>l then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('Check_ArrayOfChar_String ElType=',ElBT,'=',GetResolverResultDbg(ElTypeResolved),' Value=',Value.AsDebugString);
- {$ENDIF}
- RaiseMsg(20170913113216,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(ArrLength),IntToStr(l)],ErrorEl);
- end;
- Result:=cExact;
- finally
- ReleaseEvalValue(Value);
- end;
- end;
- procedure CheckRange(ArrType: TPasArrayType; RangeIndex: integer;
- Values: TPasResolverResult; ErrorEl: TPasElement);
- var
- ElTypeResolved: TPasResolverResult;
- procedure CheckArrOfCharAssignString;
- begin
- ComputeElement(ArrType.ElType,ElTypeResolved,[rcType]);
- if ElTypeResolved.BaseType in btAllChars then
- Result:=cTypeConversion; // ArrOfChar:=aString
- end;
- var
- Range, Value, Expr: TPasExpr;
- RangeResolved, ValueResolved: TPasResolverResult;
- i, ExpectedCount, ValCnt: Integer;
- IsLastRange, IsConstExpr: Boolean;
- ArrayValues: TPasExprArray;
- LeftResult: integer;
- ExprCompFlags: TPasResolverComputeFlags;
- BuiltInProc: TResElDataBuiltInProc;
- Ref: TResolvedReference;
- RArrayType: TPasArrayType;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignCompatibilityArrayType.CheckRange ArrType=',GetObjName(ArrType),' RgIndex=',RangeIndex,' Values=',GetResolverResultDbg(Values));
- {$ENDIF}
- if not (rrfReadable in RHS.Flags) then
- exit;
- if (Values.BaseType=btContext) and (RangeIndex=0) and (Values.LoTypeEl=ArrType) then
- begin
- Result:=cExact;
- exit;
- end;
- Expr:=Values.ExprEl;
- if (Expr=nil) and (Values.IdentEl is TPasConst)
- and (TPasConst(Values.IdentEl).VarType=nil) then
- Expr:=TPasVariable(Values.IdentEl).Expr;
- IsConstExpr:=(Expr<>nil) and ExprEvaluator.IsConst(Expr);
- if IsConstExpr then
- ExprCompFlags:=[rcConstant]
- else
- ExprCompFlags:=[];
- if Expr<>nil then
- begin
- if IsEmptyArrayExpr(Values) then
- begin
- if length(ArrType.Ranges)=0 then
- begin
- if RaiseOnIncompatible then
- MarkArrayExprRecursive(Values.ExprEl,ArrType);
- Result:=cExact; // empty set fits open and dyn array
- exit;
- end;
- end
- else if IsArrayOperatorAdd(Expr) and not (Values.BaseType in btAllStrings) then
- begin
- // a:=left+right
- if length(ArrType.Ranges)>0 then
- exit; // ToDo: StaticArray:=A+B
- // check a:=left
- ComputeElement(TBinaryExpr(Expr).left,ValueResolved,ExprCompFlags);
- CheckRange(ArrType,RangeIndex,ValueResolved,ErrorEl);
- if Result=cIncompatible then exit;
- LeftResult:=Result;
- // check a:=right
- Result:=cIncompatible;
- ComputeElement(TBinaryExpr(Expr).right,ValueResolved,ExprCompFlags);
- CheckRange(ArrType,RangeIndex,ValueResolved,ErrorEl);
- if Result=cIncompatible then exit;
- if Result<LeftResult then
- Result:=LeftResult;
- exit;
- end
- else if (Expr<>nil) and (Expr.ClassType=TParamsExpr)
- and (TParamsExpr(Expr).Kind=pekFuncParams) then
- begin
- if TParamsExpr(Expr).Value.CustomData is TResolvedReference then
- begin
- Ref:=TResolvedReference(TParamsExpr(Expr).Value.CustomData);
- if (Ref.Declaration is TPasUnresolvedSymbolRef)
- and (Ref.Declaration.CustomData is TResElDataBuiltInProc) then
- begin
- BuiltInProc:=TResElDataBuiltInProc(Ref.Declaration.CustomData);
- ArrayValues:=TParamsExpr(Expr).Params;
- if BuiltInProc.BuiltIn=bfConcatArray then
- begin
- // check Concat(array1,array2,...)
- Result:=cExact;
- for i:=0 to length(ArrayValues)-1 do
- begin
- LeftResult:=Result;
- Result:=cIncompatible;
- ComputeElement(ArrayValues[i],ValueResolved,ExprCompFlags);
- CheckRange(ArrType,RangeIndex,ValueResolved,ErrorEl);
- if Result=cIncompatible then exit;
- if Result<LeftResult then
- Result:=LeftResult;
- end;
- exit;
- end
- else if BuiltInProc.BuiltIn=bfCopyArray then
- begin
- // check Copy(A...)
- ComputeElement(ArrayValues[0],ValueResolved,ExprCompFlags);
- CheckRange(ArrType,RangeIndex,ValueResolved,ErrorEl);
- exit;
- end;
- end;
- end;
- end;
- end;
- ExpectedCount:=-1;
- if length(ArrType.Ranges)=0 then
- begin
- // dynamic or open array
- if (Expr<>nil) then
- begin
- if Expr.ClassType=TArrayValues then
- ExpectedCount:=length(TArrayValues(Expr).Values)
- else if (Expr.ClassType=TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
- ExpectedCount:=length(TParamsExpr(Expr).Params)
- else if (Values.BaseType in btAllStringAndChars) then
- begin
- // e.g. const a: dynarray = string
- // or e.g. pass a string literal to an open array
- CheckArrOfCharAssignString;
- exit;
- end
- else
- begin
- // invalid
- exit;
- end;
- end
- else
- begin
- // type check
- if (Values.BaseType<>btContext) or (Values.LoTypeEl.ClassType<>TPasArrayType) then
- begin
- // RHS is not an array
- if (Values.BaseType in btAllStringAndChars) then
- begin
- // e.g. pass a string literal to an open array
- CheckArrOfCharAssignString;
- end;
- exit;
- end;
- RArrayType:=TPasArrayType(Values.LoTypeEl);
- if length(RArrayType.Ranges)>0 then
- begin
- if RaiseOnIncompatible then
- RaiseXExpectedButYFound(20180622104834,'dynamic array','static array',ErrorEl);
- exit;
- end;
- // dynarr:=dynarr -> check element type
- ComputeElement(GetArrayElType(ArrType),ElTypeResolved,[rcType]);
- Include(ElTypeResolved.Flags,rrfWritable);
- ComputeElement(GetArrayElType(RArrayType),ValueResolved,[rcType]);
- Include(ValueResolved.Flags,rrfReadable);
- Result:=CheckAssignResCompatibility(ElTypeResolved,ValueResolved,ErrorEl,RaiseOnIncompatible);
- exit;
- end;
- Range:=nil;
- IsLastRange:=true;
- end
- else
- begin
- // static array
- Range:=ArrType.Ranges[RangeIndex];
- ExpectedCount:=GetRangeLength(Range);
- if ExpectedCount=0 then
- begin
- ComputeElement(Range,RangeResolved,[rcConstant]);
- RaiseNotYetImplemented(20170222232409,Expr,'range '+GetResolverResultDbg(RangeResolved));
- end;
- IsLastRange:=RangeIndex+1=length(ArrType.Ranges);
- if Expr=nil then
- begin
- if (ValueResolved.BaseType=btContext) and (ValueResolved.LoTypeEl.ClassType=TPasArrayType) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('CheckRange TODO StaticArr:=Arr');
- {$ENDIF}
- end;
- exit;
- end;
- end;
- if IsLastRange then
- begin
- ComputeElement(ArrType.ElType,ElTypeResolved,[rcType]);
- ElTypeResolved.ExprEl:=Range;
- Include(ElTypeResolved.Flags,rrfWritable);
- end
- else
- ElTypeResolved.BaseType:=btNone;
- if (Expr<>nil)
- and ((Expr.ClassType=TArrayValues)
- or ((Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet))) then
- begin
- // array literal
- if (ErrorEl.Parent is TPasVariable) then
- begin
- // array initialization e.g. var a: tarray = []
- if msDelphi in CurrentParser.CurrentModeswitches then
- begin
- // Delphi expects square brackets for dynamic arrays
- // and round brackets for static arrays
- if length(ArrType.Ranges)>0 then
- begin
- // static array
- if Expr.ClassType<>TArrayValues then
- begin
- if RaiseOnIncompatible then
- RaiseXExpectedButYFound(20180615121203,'(','[',ErrorEl);
- exit;
- end;
- end
- else
- begin
- // dyn array
- if Expr.ClassType=TArrayValues then
- begin
- if RaiseOnIncompatible then
- RaiseXExpectedButYFound(20180615122953,'[','(',ErrorEl);
- exit;
- end;
- end;
- end
- else
- begin
- // ObjFPC always expects round brackets in initialization
- if Expr.ClassType<>TArrayValues then
- begin
- if RaiseOnIncompatible then
- RaiseXExpectedButYFound(20170913181208,'(','[',ErrorEl);
- exit;
- end;
- end;
- end;
- // check each value
- if Expr.ClassType=TArrayValues then
- ArrayValues:=TArrayValues(Expr).Values
- else
- ArrayValues:=TParamsExpr(Expr).Params;
- ValCnt:=length(ArrayValues);
- Include(ExprCompFlags,rcNoImplicitProcType);
- for i:=0 to ExpectedCount-1 do
- begin
- if i=ValCnt then
- begin
- // not enough values
- if ValCnt>0 then
- ErrorEl:=ArrayValues[ValCnt-1];
- RaiseMsg(20170222233001,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(ExpectedCount),IntToStr(ValCnt)],ErrorEl);
- end;
- Value:=ArrayValues[i];
- ComputeElement(Value,ValueResolved,ExprCompFlags);
- if IsLastRange then
- begin
- // last dimension -> check element type
- Result:=CheckAssignResCompatibility(ElTypeResolved,ValueResolved,Value,RaiseOnIncompatible);
- if Result=cIncompatible then
- exit;
- CheckAssignExprRange(ElTypeResolved,Value);
- end
- else
- begin
- // multi dimensional array -> check next range
- CheckRange(ArrType,RangeIndex+1,ValueResolved,Value);
- end;
- end;
- if ExpectedCount<ValCnt then
- begin
- // too many values
- ErrorEl:=ArrayValues[ExpectedCount];
- if RaiseOnIncompatible then
- RaiseMsg(20170222233605,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(ExpectedCount),IntToStr(ValCnt)],ErrorEl);
- exit;
- end;
- if RaiseOnIncompatible and (Expr.ClassType=TParamsExpr) then
- // mark [] expression as an array
- MarkArrayExpr(TParamsExpr(Expr),ArrType);
- end
- else
- begin
- // single value
- // Note: the parser does not store the difference between (1) and 1
- if not IsLastRange then
- begin
- if RaiseOnIncompatible then
- RaiseMsg(20170223095307,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(ExpectedCount),'1'],ErrorEl);
- exit;
- end;
- if (Values.BaseType in btAllStrings) and (ElTypeResolved.BaseType in btAllChars) then
- begin
- // e.g. array of char = ''
- Check_ArrayOfChar_String(ArrType,ExpectedCount,ElTypeResolved,Expr,ErrorEl);
- exit;
- end;
- if (ExpectedCount>1) then
- begin
- if RaiseOnIncompatible then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('CheckRange Values=',GetResolverResultDbg(Values),' ElTypeResolved=',GetResolverResultDbg(ElTypeResolved));
- {$ENDIF}
- RaiseMsg(20170913103143,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(ExpectedCount),'1'],ErrorEl);
- end;
- exit;
- end;
- // check element type
- Result:=CheckAssignResCompatibility(ElTypeResolved,Values,ErrorEl,RaiseOnIncompatible);
- if Result=cIncompatible then
- exit;
- if Expr<>nil then
- CheckAssignExprRange(ElTypeResolved,Expr);
- end;
- end;
- var
- LArrType: TPasArrayType;
- begin
- Result:=cIncompatible;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignCompatibilityArrayType LHS=',GetResolverResultDbg(LHS),' RHS=',GetResolverResultDbg(RHS));
- {$ENDIF}
- if (LHS.BaseType<>btContext) or (not (LHS.LoTypeEl is TPasArrayType)) then
- RaiseInternalError(20170222230012);
- LArrType:=TPasArrayType(LHS.LoTypeEl);
- if (LArrType.ElType=nil) and (rrfReadable in RHS.Flags)
- and (RHS.BaseType in [btArrayLit,btArrayOrSet]) then
- begin
- // ArrayOfConst:=[]
- exit(cExact);
- end;
- CheckRange(LArrType,0,RHS,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20180622104721,nIncompatibleTypesGotExpected,[],RHS,LHS,ErrorEl);
- end;
- function TPasResolver.CheckAssignCompatibilityPointerType(LTypeEl,
- RTypeEl: TPasType; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- var
- LeftResolved, RightResolved: TPasResolverResult;
- begin
- ComputeElement(LTypeEl,LeftResolved,[rcNoImplicitProc]);
- ComputeElement(RTypeEl,RightResolved,[rcNoImplicitProc]);
- Include(LeftResolved.Flags,rrfWritable);
- Include(RightResolved.Flags,rrfReadable);
- Result:=CheckAssignResCompatibility(LeftResolved,RightResolved,ErrorEl,RaiseOnIncompatible);
- end;
- function TPasResolver.CheckEqualCompatibilityUserType(const LHS,
- RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- // LHS.BaseType=btContext=RHS.BaseType and both rrfReadable
- var
- LTypeEl, RTypeEl: TPasType;
- AResolved, BResolved: TPasResolverResult;
- function IncompatibleElements: integer;
- begin
- Result:=cIncompatible;
- if not RaiseOnIncompatible then exit;
- RaiseIncompatibleType(20170216152513,nIncompatibleTypesGotExpected,
- [],LTypeEl,RTypeEl,ErrorEl);
- end;
- begin
- if (LHS.LoTypeEl=nil) then
- RaiseInternalError(20161007223118);
- if (RHS.LoTypeEl=nil) then
- RaiseInternalError(20161007223119);
- LTypeEl:=LHS.LoTypeEl;
- RTypeEl:=RHS.LoTypeEl;
- if LTypeEl=RTypeEl then
- exit(cExact);
- if LTypeEl.ClassType=TPasClassType then
- begin
- if RTypeEl.ClassType=TPasClassType then
- begin
- // e.g. if Sender=Button1 then
- Result:=CheckSrcIsADstType(LHS,RHS);
- if Result=cIncompatible then
- Result:=CheckSrcIsADstType(RHS,LHS);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20180324190757,nTypesAreNotRelatedXY,[],LHS,RHS,ErrorEl);
- exit;
- end
- else if RTypeEl.ClassType=TPasRecordType then
- begin
- if (TPasClassType(LTypeEl).ObjKind=okInterface)
- and IsTGUID(TPasRecordType(RTypeEl)) then
- // IntfVar=GuidVar
- exit(cInterfaceToTGUID);
- end;
- exit(IncompatibleElements);
- end
- else if LTypeEl.ClassType=TPasClassOfType then
- begin
- if RTypeEl.ClassType=TPasClassOfType then
- begin
- // for example: if ImageClass=ImageClass then
- Result:=CheckClassIsClass(TPasClassOfType(LTypeEl).DestType,
- TPasClassOfType(RTypeEl).DestType);
- if Result=cIncompatible then
- Result:=CheckClassIsClass(TPasClassOfType(RTypeEl).DestType,
- TPasClassOfType(LTypeEl).DestType);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20180324190804,nTypesAreNotRelatedXY,[],LHS,RHS,ErrorEl);
- exit;
- end;
- exit(IncompatibleElements);
- end
- else if LTypeEl.ClassType=TPasEnumType then
- begin
- // enums of different type
- if not RaiseOnIncompatible then
- exit(cIncompatible);
- if RTypeEl.ClassType=TPasEnumValue then
- RaiseIncompatibleType(20170216152523,nIncompatibleTypesGotExpected,
- [],TPasEnumType(LTypeEl),TPasEnumType(RTypeEl),ErrorEl)
- else
- exit(IncompatibleElements);
- end
- else if LTypeEl.ClassType=TPasRecordType then
- begin
- if RTypeEl.ClassType=TPasClassType then
- begin
- if (TPasClassType(RTypeEl).ObjKind=okInterface)
- and IsTGUID(TPasRecordType(LTypeEl)) then
- // GuidVar=IntfVar
- exit(cInterfaceToTGUID);
- end;
- end
- else if LTypeEl.ClassType=TPasSetType then
- begin
- if RTypeEl.ClassType=TPasSetType then
- begin
- ComputeElement(TPasSetType(LTypeEl).EnumType,AResolved,[]);
- ComputeElement(TPasSetType(RTypeEl).EnumType,BResolved,[]);
- if (AResolved.LoTypeEl<>nil)
- and (AResolved.LoTypeEl=BResolved.LoTypeEl) then
- exit(cExact);
- if (AResolved.LoTypeEl.CustomData is TResElDataBaseType)
- and (BResolved.LoTypeEl.CustomData is TResElDataBaseType)
- and (CompareText(AResolved.LoTypeEl.Name,BResolved.LoTypeEl.Name)=0) then
- exit(cExact);
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152524,nIncompatibleTypesGotExpected,
- [],AResolved,BResolved,ErrorEl)
- else
- exit(cIncompatible);
- end
- else
- exit(IncompatibleElements);
- end
- else if LTypeEl is TPasProcedureType then
- begin
- if RTypeEl is TPasProcedureType then
- begin
- // e.g. ProcVar1 = ProcVar2
- if CheckProcTypeCompatibility(TPasProcedureType(LTypeEl),TPasProcedureType(RTypeEl),
- false,nil,false) then
- exit(cExact);
- end
- else
- exit(IncompatibleElements);
- end
- else if LTypeEl.ClassType=TPasPointerType then
- begin
- if RTypeEl.ClassType=TPasPointerType then
- // TypedPointer=TypedPointer
- exit(cExact);
- end;
- exit(IncompatibleElements);
- end;
- function TPasResolver.CheckTypeCast(El: TPasType; Params: TParamsExpr;
- RaiseOnError: boolean): integer;
- // for example if TClassA(AnObject)=nil then ;
- var
- Param: TPasExpr;
- ParamResolved, ResolvedEl: TPasResolverResult;
- begin
- if length(Params.Params)<>1 then
- begin
- if RaiseOnError then
- RaiseMsg(20170216152526,nWrongNumberOfParametersForTypeCast,
- sWrongNumberOfParametersForTypeCast,[El.Name],Params);
- exit(cIncompatible);
- end;
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProcType]);
- ComputeElement(El,ResolvedEl,[rcType]);
- Result:=CheckTypeCastRes(ParamResolved,ResolvedEl,Param,RaiseOnError);
- end;
- function TPasResolver.CheckTypeCastRes(const FromResolved,
- ToResolved: TPasResolverResult; ErrorEl: TPasElement; RaiseOnError: boolean
- ): integer;
- procedure WarnClassTypesAreNotRelated(GotType, ExpType: TPasClassType);
- var
- GotDesc, ExpDesc: String;
- begin
- GetIncompatibleTypeDesc(GotType,ExpType,GotDesc,ExpDesc);
- LogMsg(20200209140450,mtWarning,nClassTypesAreNotRelatedXY,
- sClassTypesAreNotRelatedXY,[GotDesc,ExpDesc],ErrorEl);
- end;
- var
- ToTypeEl, FromTypeEl: TPasType;
- ToTypeBaseType: TResolverBaseType;
- C: TClass;
- ToProcType, FromProcType: TPasProcedureType;
- TemplType: TPasGenericTemplateType;
- i: Integer;
- ConToken: TToken;
- ConEl: TPasElement;
- ToClassType, FromClassType: TPasClassType;
- begin
- Result:=cIncompatible;
- ToTypeEl:=ToResolved.LoTypeEl;
- if (ToTypeEl<>nil)
- and (rrfReadable in FromResolved.Flags) then
- begin
- C:=ToTypeEl.ClassType;
- if FromResolved.BaseType=btUntyped then
- begin
- // typecast an untyped parameter
- Result:=cCompatible;
- end
- else if C=TPasUnresolvedSymbolRef then
- begin
- if ToTypeEl.CustomData is TResElDataBaseType then
- begin
- // type cast to base type, e.g. double(aninteger)
- if ToTypeEl=FromResolved.LoTypeEl then
- exit(cExact);
- if (FromResolved.BaseType=btContext)
- and (FromResolved.LoTypeEl.ClassType=TPasGenericTemplateType) then
- exit(cExact); // e.g. double(T) -> will be checked when specialized
- ToTypeBaseType:=(ToTypeEl.CustomData as TResElDataBaseType).BaseType;
- if ToTypeBaseType=FromResolved.BaseType then
- Result:=cExact
- else if ToTypeBaseType in btAllInteger then
- begin
- if FromResolved.BaseType in (btArrayRangeTypes+[btRange,btCurrency]) then
- Result:=cCompatible
- else if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- if FromTypeEl.ClassType=TPasEnumType then
- // e.g. longint(TEnum)
- Result:=cCompatible;
- end;
- end
- else if ToTypeBaseType in btAllFloats then
- begin
- if FromResolved.BaseType in btAllFloats then
- Result:=cCompatible
- else if FromResolved.BaseType in btAllInteger then
- Result:=cCompatible;
- end
- else if ToTypeBaseType in btAllBooleans then
- begin
- if FromResolved.BaseType in btAllBooleans then
- Result:=cCompatible
- else if FromResolved.BaseType in btAllInteger then
- Result:=cCompatible;
- end
- else if ToTypeBaseType in btAllChars then
- begin
- if FromResolved.BaseType in (btArrayRangeTypes+[btRange]) then
- Result:=cCompatible
- else if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- if FromTypeEl.ClassType=TPasEnumType then
- // e.g. char(TEnum)
- Result:=cCompatible;
- end;
- end
- else if ToTypeBaseType in btAllStrings then
- begin
- if FromResolved.BaseType in btAllStringAndChars then
- Result:=cCompatible
- else if (FromResolved.BaseType=btPointer)
- and (ToTypeBaseType in btAllStringPointer) then
- Result:=cExact;
- end
- else if ToTypeBaseType=btPointer then
- begin
- if FromResolved.BaseType in ([btPointer]+btAllStringPointer) then
- Result:=cExact
- else if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- C:=FromTypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasPointerType)
- or ((C=TPasArrayType) and IsDynArray(FromTypeEl)) then
- Result:=cExact
- else if (C=TPasProcedureType) or (C=TPasFunctionType) then
- begin
- // from procvar to pointer
- FromProcType:=TPasProcedureType(FromTypeEl);
- if FromProcType.IsOfObject then
- begin
- if proMethodAddrAsPointer in Options then
- Result:=cCompatible
- else if RaiseOnError then
- RaiseMsg(20170416183615,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [GetElementTypeName(FromProcType)+' '+ProcTypeModifiers[ptmOfObject],
- BaseTypeNames[btPointer]],ErrorEl);
- end
- else if FromProcType.IsNested then
- begin
- if RaiseOnError then
- RaiseMsg(20170416183800,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [GetElementTypeName(FromProcType)+' '+ProcTypeModifiers[ptmIsNested],
- BaseTypeNames[btPointer]],ErrorEl);
- end
- else if FromProcType.IsReferenceTo then
- begin
- if proProcTypeWithoutIsNested in Options then
- Result:=cCompatible
- else if RaiseOnError then
- RaiseMsg(20170419144311,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [GetElementTypeName(FromProcType)+' '+ProcTypeModifiers[ptmReferenceTo],
- BaseTypeNames[btPointer]],ErrorEl);
- end
- else
- Result:=cCompatible;
- end;
- end;
- end;
- end;
- end
- else if C=TPasClassType then
- begin
- ToClassType:=TPasClassType(ToTypeEl);
- // to class
- if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- if FromTypeEl.ClassType=TPasClassType then
- begin
- FromClassType:=TPasClassType(FromTypeEl);
- if FromResolved.IdentEl is TPasType then
- RaiseMsg(20170404162606,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl);
- if FromClassType.ObjKind=ToClassType.ObjKind then
- begin
- // type cast upwards or downwards
- Result:=CheckSrcIsADstType(FromResolved,ToResolved);
- if Result=cIncompatible then
- Result:=CheckSrcIsADstType(ToResolved,FromResolved);
- end
- else if ToClassType.ObjKind=okInterface then
- begin
- if (FromClassType.ObjKind=okClass)
- and (not FromClassType.IsExternal) then
- begin
- // e.g. intftype(classinstvar)
- Result:=cCompatible;
- end;
- end
- else if FromClassType.ObjKind=okInterface then
- begin
- if (ToClassType.ObjKind=okClass)
- and (not ToClassType.IsExternal) then
- begin
- // e.g. classtype(intfvar)
- Result:=cCompatible;
- end;
- end;
- if Result=cIncompatible then
- Result:=CheckTypeCastClassInstanceToClass(FromResolved,ToResolved,ErrorEl);
- if (Result=cIncompatible) and (FromClassType.ObjKind=ToClassType.ObjKind) then
- begin
- if RaiseOnError then
- WarnClassTypesAreNotRelated(FromClassType,ToClassType);
- Result:=cTypeConversion;
- end;
- end
- else if FromTypeEl.ClassType=TPasGenericTemplateType then
- begin
- // e.g. aClassType(T)
- TemplType:=TPasGenericTemplateType(FromTypeEl);
- if length(TemplType.Constraints)=0 then
- begin
- // typecast unconstrained template to a classtype
- // -> check when specialize
- Result:=cExact;
- end
- else
- for i:=0 to length(TemplType.Constraints)-1 do
- begin
- ConEl:=TemplType.Constraints[i];
- ConToken:=GetGenericConstraintKeyword(ConEl);
- case ConToken of
- tkrecord: ; // invalid type cast
- tkClass, tkconstructor:
- Result:=cExact;
- else
- // identifier constraint: class or interface -> allow
- Result:=cExact;
- break;
- end;
- end;
- end;
- end
- else if FromResolved.BaseType=btPointer then
- begin
- if IsBaseType(FromResolved.LoTypeEl,btPointer) then
- Result:=cExact; // untyped pointer to class instance
- end
- else if FromResolved.BaseType=btNil then
- Result:=cExact; // nil to class or interface
- end
- else if C=TPasGenericTemplateType then
- begin
- // e.g. T(var)
- TemplType:=TPasGenericTemplateType(ToTypeEl);
- FromTypeEl:=FromResolved.LoTypeEl;
- if (FromTypeEl<>nil)
- and (FromTypeEl.ClassType=TPasGenericTemplateType) then
- exit(cExact); // e.g. T(S) -> will be checked when specialized
- for i:=0 to length(TemplType.Constraints)-1 do
- begin
- ConEl:=TemplType.Constraints[i];
- ConToken:=GetGenericConstraintKeyword(ConEl);
- case ConToken of
- tkrecord:
- if FromResolved.BaseType=btContext then
- begin
- if FromTypeEl.ClassType=TPasRecordType then
- // typecast record to template record
- Result:=cExact
- else if FromTypeEl.ClassType=TPasGenericType then
- // typecast template to template record
- Result:=cExact;
- end;
- tkClass, tkconstructor:
- Result:=cExact;
- else
- // identifier constraint: class or interface -> allow
- Result:=cExact;
- break;
- end;
- end;
- end
- else if C=TPasClassOfType then
- begin
- //writeln('TPasResolver.CheckTypeCast class-of FromRes.TypeEl=',GetObjName(FromResolved.LoTypeEl),' FromRes.IdentEl=',GetObjName(FromResolved.IdentEl));
- if FromResolved.BaseType=btContext then
- begin
- if FromResolved.LoTypeEl.ClassType=TPasClassOfType then
- begin
- if (FromResolved.IdentEl is TPasType) then
- RaiseMsg(20170404162604,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl);
- // type cast classof(classof-var) upwards or downwards
- ToTypeEl:=TPasClassOfType(ToTypeEl).DestType;
- FromTypeEl:=TPasClassOfType(FromResolved.LoTypeEl).DestType;
- Result:=CheckClassesAreRelated(ToTypeEl,FromTypeEl);
- end;
- end
- else if FromResolved.BaseType=btPointer then
- begin
- if IsBaseType(FromResolved.LoTypeEl,btPointer) then
- Result:=cExact; // untyped pointer to class-of
- end
- else if FromResolved.BaseType=btNil then
- Result:=cExact; // nil to class-of
- end
- else if C=TPasRecordType then
- begin
- if FromResolved.BaseType=btContext then
- begin
- if FromResolved.LoTypeEl.ClassType=TPasRecordType then
- begin
- // typecast record to record
- Result:=cExact;
- end;
- end;
- end
- else if (C=TPasEnumType)
- or (C=TPasRangeType) then
- begin
- if CheckIsOrdinal(FromResolved,ErrorEl,true) then
- Result:=cExact;
- end
- else if C=TPasArrayType then
- begin
- if FromResolved.BaseType=btContext then
- begin
- if FromResolved.LoTypeEl.ClassType=TPasArrayType then
- Result:=CheckTypeCastArray(TPasArrayType(FromResolved.LoTypeEl),
- TPasArrayType(ToTypeEl),ErrorEl,RaiseOnError);
- end
- else if FromResolved.BaseType=btPointer then
- begin
- if IsDynArray(ToResolved.LoTypeEl)
- and IsBaseType(FromResolved.LoTypeEl,btPointer) then
- Result:=cExact; // untyped pointer to dynamic array
- end
- else if FromResolved.BaseType=btNil then
- begin
- if IsDynArray(ToResolved.LoTypeEl) then
- Result:=cExact; // nil to dynamic array
- end;
- end
- else if (C=TPasProcedureType) or (C=TPasFunctionType) then
- begin
- ToProcType:=TPasProcedureType(ToTypeEl);
- if IsBaseType(FromResolved.LoTypeEl,btPointer) then
- begin
- // type cast untyped pointer value to proctype
- if ToProcType.IsOfObject then
- begin
- if proMethodAddrAsPointer in Options then
- Result:=cCompatible
- else if RaiseOnError then
- RaiseMsg(20170416183940,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [BaseTypeNames[btPointer],
- ToProcType.ElementTypeName+' '+ProcTypeModifiers[ptmOfObject]],ErrorEl);
- end
- else if ToProcType.IsNested then
- begin
- if RaiseOnError then
- RaiseMsg(20170416184149,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [BaseTypeNames[btPointer],
- ToProcType.ElementTypeName+' '+ProcTypeModifiers[ptmIsNested]],ErrorEl);
- end
- else if ToProcType.IsReferenceTo then
- begin
- if proMethodAddrAsPointer in Options then
- Result:=cCompatible
- else if RaiseOnError then
- RaiseMsg(20170419144357,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [BaseTypeNames[btPointer],
- ToProcType.ElementTypeName+' '+ProcTypeModifiers[ptmReferenceTo]],ErrorEl);
- end
- else
- Result:=cCompatible;
- end
- else if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- if FromTypeEl is TPasProcedureType then
- begin
- // type cast procvar to proctype
- FromProcType:=TPasProcedureType(FromTypeEl);
- if ToProcType.IsReferenceTo then
- Result:=cCompatible
- else if FromProcType.IsReferenceTo then
- Result:=cCompatible
- else if (FromProcType.IsOfObject<>ToProcType.IsOfObject)
- and not (proMethodAddrAsPointer in Options) then
- begin
- if RaiseOnError then
- RaiseMsg(20170416183109,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [GetElementTypeName(FromProcType)+BoolToStr(FromProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],''),
- ToProcType.ElementTypeName+BoolToStr(ToProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],'')],ErrorEl);
- end
- else if FromProcType.IsNested<>ToProcType.IsNested then
- begin
- if RaiseOnError then
- RaiseMsg(20170416183305,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [GetElementTypeName(FromProcType)+BoolToStr(FromProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],''),
- ToProcType.ElementTypeName+BoolToStr(ToProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],'')],ErrorEl);
- end
- else
- Result:=cCompatible;
- end
- end
- else if FromResolved.BaseType=btProc then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- if FromTypeEl is TPasProcedureType then
- begin
- // typecast procedure (or anonymous procedure) to proctype
- FromProcType:=TPasProcedureType(FromTypeEl);
- if (msDelphi in CurrentParser.CurrentModeswitches)
- and (FromResolved.IdentEl=nil)
- and (FromResolved.LoTypeEl.Name<>'') then
- // Delphi forbids typecast (non anonymous) procedure to proctype
- else if ToProcType.IsReferenceTo then
- Result:=cCompatible
- else if FromResolved.IdentEl=nil then
- // anonymous proc to proctype
- Result:=cCompatible
- else if (FromProcType.IsOfObject<>ToProcType.IsOfObject)
- and not (proMethodAddrAsPointer in Options) then
- begin
- // e.g. TProcedure(Obj.DoIt)
- if RaiseOnError then
- RaiseMsg(20181210151058,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [GetElementTypeName(FromProcType)+BoolToStr(FromProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],''),
- ToProcType.ElementTypeName+BoolToStr(ToProcType.IsOfObject,' '+ProcTypeModifiers[ptmOfObject],'')],ErrorEl);
- end
- else if FromProcType.IsNested<>ToProcType.IsNested then
- begin
- if RaiseOnError then
- RaiseMsg(20181210151102,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [GetElementTypeName(FromProcType)+BoolToStr(FromProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],''),
- ToProcType.ElementTypeName+BoolToStr(ToProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],'')],ErrorEl);
- end
- else
- Result:=cCompatible;
- end;
- end
- else if FromResolved.BaseType=btNil then
- // typecast nil to procedure type
- Result:=cExact;
- end
- else if C=TPasPointerType then
- begin
- // typecast to typedpointer
- if FromResolved.BaseType in [btPointer,btNil] then
- Result:=cExact
- else if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- C:=FromTypeEl.ClassType;
- if (C=TPasPointerType)
- or (C=TPasClassOfType)
- or (C=TPasClassType)
- or (C.InheritsFrom(TPasProcedureType))
- or IsDynArray(FromTypeEl) then
- Result:=cCompatible;
- end;
- end
- end
- else if ToTypeEl<>nil then
- begin
- // FromResolved is not readable
- if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=FromResolved.LoTypeEl;
- if (FromTypeEl.ClassType=TPasClassType)
- and (FromTypeEl=FromResolved.IdentEl)
- and (ToResolved.BaseType=btContext) then
- begin
- ToTypeEl:=ToResolved.LoTypeEl;
- if (ToTypeEl.ClassType=TPasClassOfType)
- and (ToTypeEl=ToResolved.IdentEl) then
- begin
- // for example class-of(Self) in a class function
- ToTypeEl:=TPasClassOfType(ToTypeEl).DestType;
- Result:=CheckClassesAreRelated(ToTypeEl,FromTypeEl);
- end;
- end;
- end;
- if (Result=cIncompatible) and RaiseOnError then
- begin
- if FromResolved.IdentEl is TPasType then
- RaiseMsg(20170404162610,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl);
- end;
- end;
- if Result=cIncompatible then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckTypeCastRes From={',GetResolverResultDbg(FromResolved),'} To={',GetResolverResultDbg(ToResolved),'}');
- {$ENDIF}
- if RaiseOnError then
- RaiseIncompatibleTypeRes(20170216152528,nIllegalTypeConversionTo,
- [],FromResolved,ToResolved,ErrorEl);
- exit;
- end;
- end;
- function TPasResolver.CheckTypeCastArray(FromType, ToType: TPasArrayType;
- ErrorEl: TPasElement; RaiseOnError: boolean): integer;
- function NextDim(var ArrType: TPasArrayType; var NextIndex: integer;
- out ElTypeResolved: TPasResolverResult): boolean;
- begin
- inc(NextIndex);
- if NextIndex<length(ArrType.Ranges) then
- begin
- ElTypeResolved.BaseType:=btNone;
- exit(true);
- end;
- ComputeElement(GetArrayElType(ArrType),ElTypeResolved,[rcType]);
- if (ElTypeResolved.BaseType<>btContext)
- or (ElTypeResolved.LoTypeEl.ClassType<>TPasArrayType) then
- exit(false);
- ArrType:=TPasArrayType(ElTypeResolved.LoTypeEl);
- NextIndex:=0;
- Result:=true;
- end;
- var
- FromIndex, ToIndex: Integer;
- FromElTypeRes, ToElTypeRes: TPasResolverResult;
- StartFromType, StartToType: TPasArrayType;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDescription(FromType),' ToType=',GetTypeDescription(ToType));
- {$ENDIF}
- if not RaiseOnError then
- begin
- if (ToType.GenericTemplateTypes<>nil) and (ToType.GenericTemplateTypes.Count>0) then
- exit(cCompatible); // is later checked when specialized
- end;
- StartFromType:=FromType;
- StartToType:=ToType;
- Result:=cIncompatible;
- // check dimensions
- FromIndex:=0;
- ToIndex:=0;
- repeat
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDescription(FromType),' FromIndex=',FromIndex,' ToType=',GetTypeDescription(ToType),' ToIndex=',ToIndex);
- {$ENDIF}
- if length(ToType.Ranges)=0 then
- // ToType is dynamic/open array -> fits any size
- else
- begin
- // ToType is ranged
- // ToDo: check size of dimension
- end;
- // check next dimension
- if not NextDim(FromType,FromIndex,FromElTypeRes) then
- begin
- // at end of FromType
- if NextDim(ToType,ToIndex,ToElTypeRes) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckTypeCastArray To has more dims than From: From=',GetTypeDescription(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDescription(ToType),' ToIndex=',ToIndex);
- {$ENDIF}
- break; // ToType has more dimensions
- end;
- // have same dimension -> check ElType
- Include(FromElTypeRes.Flags,rrfReadable);
- FromElTypeRes.IdentEl:=nil;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckTypeCastArray check ElType From=',GetResolverResultDbg(FromElTypeRes),' To=',GetResolverResultDbg(ToElTypeRes));
- {$ENDIF}
- Result:=CheckTypeCastRes(FromElTypeRes,ToElTypeRes,ErrorEl,false);
- break;
- end
- else
- begin
- // FromType has more dimensions
- if not NextDim(ToType,ToIndex,ToElTypeRes) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckTypeCastArray From has more dims than To: From=',GetTypeDescription(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDescription(ToType),' ToIndex=',ToIndex);
- {$ENDIF}
- break; // ToType has less dimensions
- end;
- end;
- until false;
- if (Result=cIncompatible) and RaiseOnError then
- RaiseIncompatibleType(20170331124643,nIllegalTypeConversionTo,
- [],StartFromType,StartToType,ErrorEl);
- end;
- procedure TPasResolver.ComputeElement(El: TPasElement; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeIdentifier(Expr: TPasExpr);
- var
- Ref: TResolvedReference;
- Proc: TPasProcedure;
- ProcType: TPasProcedureType;
- begin
- Ref:=TResolvedReference(Expr.CustomData);
- ComputeElement(Ref.Declaration,ResolvedEl,Flags+[rcNoImplicitProc],StartEl);
- if rrfConstInherited in Ref.Flags then
- Exclude(ResolvedEl.Flags,rrfWritable);
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- if Expr is TPrimitiveExpr then
- writeln('TPasResolver.ComputeElement.ComputeIdentifier TPrimitiveExpr "',TPrimitiveExpr(Expr).Value,'" ',GetResolverResultDbg(ResolvedEl),' Flags=',dbgs(Flags))
- else
- writeln('TPasResolver.ComputeElement.ComputeIdentifier "',GetObjName(Expr),'" ',GetResolverResultDbg(ResolvedEl),' Flags=',dbgs(Flags));
- {AllowWriteln-}
- {$ENDIF}
- //if (Expr is TPrimitiveExpr) and (Expr.Parent is TParamsExpr) and (TPrimitiveExpr(Expr).Value='FA') then
- // RaiseNotYetImplemented(20180621235200,Expr);
- if not (rcSetReferenceFlags in Flags)
- and (rrfNoImplicitCallWithoutParams in Ref.Flags) then
- exit;
- if (ResolvedEl.BaseType=btProc) then
- begin
- // proc
- if rcNoImplicitProc in Flags then
- begin
- if rcSetReferenceFlags in Flags then
- Include(Ref.Flags,rrfNoImplicitCallWithoutParams);
- end
- else if [rcConstant,rcType]*Flags=[] then
- begin
- // implicit call without params is allowed -> check if possible
- Proc:=ResolvedEl.IdentEl as TPasProcedure;
- if not ProcNeedsParams(Proc.ProcType) then
- begin
- // parameter less proc -> implicit call possible
- if ResolvedEl.IdentEl is TPasFunction then
- begin
- // function => return result
- ComputeResultElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,
- ResolvedEl,Flags+[rcCall],StartEl);
- end
- else if (ResolvedEl.IdentEl.ClassType=TPasConstructor) then
- begin
- // constructor -> return value of type class
- ResolvedEl:=GetReference_ConstructorType(Ref,Expr);
- end
- else if ParentNeedsExprResult(Expr) then
- begin
- // a procedure address
- exit;
- end;
- if rcSetReferenceFlags in Flags then
- begin
- Exclude(Ref.Flags,rrfNoImplicitCallWithoutParams);
- Include(Ref.Flags,rrfImplicitCallWithoutParams);
- end;
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end;
- end;
- end
- else if IsProcedureType(ResolvedEl,true) then
- begin
- // proc type
- if [rcNoImplicitProc,rcNoImplicitProcType]*Flags<>[] then
- begin
- if rcSetReferenceFlags in Flags then
- Include(Ref.Flags,rrfNoImplicitCallWithoutParams);
- end
- else if [rcConstant,rcType]*Flags=[] then
- begin
- // implicit call without params is allowed -> check if possible
- ProcType:=TPasProcedureType(ResolvedEl.LoTypeEl);
- if not ProcNeedsParams(ProcType) then
- begin
- // parameter less proc type -> implicit call possible
- if ResolvedEl.LoTypeEl is TPasFunctionType then
- // function => return result
- ComputeResultElement(TPasFunctionType(ResolvedEl.LoTypeEl).ResultEl,
- ResolvedEl,Flags+[rcCall],StartEl)
- else if ParentNeedsExprResult(Expr) then
- begin
- // a procedure has no result
- exit;
- end;
- if rcSetReferenceFlags in Flags then
- begin
- Exclude(Ref.Flags,rrfNoImplicitCallWithoutParams);
- Include(Ref.Flags,rrfImplicitCallWithoutParams);
- end;
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end;
- end;
- end;
- end;
- procedure ComputeInherited(Expr: TInheritedExpr);
- var
- Ref: TResolvedReference;
- Proc: TPasProcedure;
- TypeEl: TPasProcedureType;
- HasName: Boolean;
- begin
- // "inherited;"
- Ref:=TResolvedReference(El.CustomData);
- Proc:=NoNil(Ref.Declaration) as TPasProcedure;
- TypeEl:=TPasProcedure(Proc).ProcType;
- SetResolverIdentifier(ResolvedEl,btProc,Proc,
- TypeEl,TypeEl,[rrfCanBeStatement]);
- HasName:=(El.Parent.ClassType=TBinaryExpr)
- and (TBinaryExpr(El.Parent).OpCode=eopNone); // true if 'inherited Proc;'
- if HasName or (rcNoImplicitProc in Flags) then
- exit;
- // inherited; -> implicit call possible
- if Proc is TPasFunction then
- begin
- // function => return result
- ComputeResultElement(TPasFunction(Proc).FuncType.ResultEl,
- ResolvedEl,Flags+[rcCall],StartEl);
- Exclude(ResolvedEl.Flags,rrfWritable);
- end
- else if (Proc.ClassType=TPasConstructor)
- and (rrfNewInstance in Ref.Flags) then
- begin
- // new instance constructor -> return value of type class
- ResolvedEl:=GetReference_ConstructorType(Ref,Expr);
- end
- else if ParentNeedsExprResult(Expr) then
- begin
- // a procedure
- exit;
- end;
- if rcSetReferenceFlags in Flags then
- begin
- Exclude(Ref.Flags,rrfNoImplicitCallWithoutParams);
- Include(Ref.Flags,rrfImplicitCallWithoutParams);
- end;
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end;
- procedure ComputeSpecializeType(SpecType: TPasSpecializeType);
- var
- TypeEl: TPasType;
- begin
- if SpecType.CustomData is TPasSpecializeTypeData then
- begin
- TypeEl:=TPasSpecializeTypeData(SpecType.CustomData).SpecializedType;
- if TypeEl=nil then
- RaiseNotYetImplemented(20190908153503,El);
- SetResolverIdentifier(ResolvedEl,btContext,TypeEl,TypeEl,TypeEl,[]);
- end
- else
- begin
- TypeEl:=SpecType.DestType;
- if TypeEl=nil then
- RaiseNotYetImplemented(20190908153434,El);
- SetResolverIdentifier(ResolvedEl,btContext,SpecType,TypeEl,SpecType,[]);
- end;
- end;
- procedure ComputeExportSymbol(ExpSymbol: TPasExportSymbol);
- var
- Ref: TResolvedReference;
- begin
- if ExpSymbol.CustomData is TResolvedReference then
- begin
- Ref:=TResolvedReference(El.CustomData);
- ComputeElement(Ref.Declaration,ResolvedEl,Flags+[rcNoImplicitProc],StartEl);
- end
- else if ExpSymbol.NameExpr<>nil then
- ComputeElement(ExpSymbol.NameExpr,ResolvedEl,Flags,StartEl)
- else
- RaiseNotYetImplemented(20210106225512,ExpSymbol);
- end;
- var
- DeclEl: TPasElement;
- ElClass: TClass;
- bt: TResolverBaseType;
- TypeEl: TPasType;
- Value: TResEvalValue;
- Int: TMaxPrecInt;
- begin
- if StartEl=nil then StartEl:=El;
- ResolvedEl:=Default(TPasResolverResult);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeElement El=',GetObjName(El));
- {$ENDIF}
- if El=nil then
- exit;
- ElClass:=El.ClassType;
- if ElClass=TPrimitiveExpr then
- begin
- case TPrimitiveExpr(El).Kind of
- pekIdent,pekSelf:
- begin
- if not (El.CustomData is TResolvedReference) then
- RaiseNotYetImplemented(20160922163658,El,'Value="'+TPrimitiveExpr(El).Value+'" CustomData='+GetObjName(El.CustomData)+' '+GetElementSourcePosStr(El));
- ComputeIdentifier(TPrimitiveExpr(El));
- end;
- pekNumber:
- begin
- if NumberIsFloat(TPrimitiveExpr(El).Value) then
- bt:=BaseTypeExtended
- else if length(TPrimitiveExpr(El).Value)<9 then
- bt:=btLongint
- else
- begin
- // with 9+ it could be longword: e.g. $87654321
- Value:=Eval(TPrimitiveExpr(El),[]);
- if Value=nil then
- RaiseNotYetImplemented(20190130162601,El);
- try
- case Value.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(Value).Int;
- bt:=GetSmallestIntegerBaseType(Int,Int);
- end;
- {$IFDEF HasInt64}
- revkUInt:
- bt:=btQWord;
- {$ENDIF}
- else
- bt:=BaseTypeExtended;
- end;
- finally
- ReleaseEvalValue(Value);
- end;
- end;
- SetResolverValueExpr(ResolvedEl,bt,FBaseTypes[bt],FBaseTypes[bt],
- TPrimitiveExpr(El),[rrfReadable])
- end;
- pekString:
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeElement pekString Value="',TPrimitiveExpr(El).Value,'"');
- {$ENDIF}
- bt:=IsCharLiteral(TPrimitiveExpr(El).Value,El);
- if bt in btAllChars then
- begin
- if bt=BaseTypeChar then
- bt:=btChar;
- SetResolverValueExpr(ResolvedEl,bt,FBaseTypes[bt],FBaseTypes[bt],
- TPrimitiveExpr(El),[rrfReadable]);
- end
- else
- SetResolverValueExpr(ResolvedEl,btString,
- FBaseTypes[btString],FBaseTypes[btString],
- TPrimitiveExpr(El),[rrfReadable]);
- end;
- pekNil:
- SetResolverValueExpr(ResolvedEl,btNil,FBaseTypes[btNil],FBaseTypes[btNil],
- TPrimitiveExpr(El),[rrfReadable]);
- pekBoolConst:
- SetResolverValueExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],FBaseTypes[btBoolean],
- TPrimitiveExpr(El),[rrfReadable]);
- else
- RaiseNotYetImplemented(20160922163701,El);
- end;
- end
- else if ElClass=TPasUnresolvedSymbolRef then
- begin
- // built-in type
- if El.CustomData is TResElDataBaseType then
- SetResolverIdentifier(ResolvedEl,TResElDataBaseType(El.CustomData).BaseType,
- El,TPasUnresolvedSymbolRef(El),TPasUnresolvedSymbolRef(El),[])
- else if El.CustomData is TResElDataBuiltInProc then
- begin
- SetResolverIdentifier(ResolvedEl,btBuiltInProc,El,
- TPasUnresolvedSymbolRef(El),TPasUnresolvedSymbolRef(El),[]);
- if bipfCanBeStatement in TResElDataBuiltInProc(El.CustomData).Flags then
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else
- RaiseNotYetImplemented(20160926194756,El);
- end
- else if ElClass=TBoolConstExpr then
- SetResolverValueExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],FBaseTypes[btBoolean],
- TBoolConstExpr(El),[rrfReadable])
- else if ElClass=TBinaryExpr then
- ComputeBinaryExpr(TBinaryExpr(El),ResolvedEl,Flags,StartEl)
- else if ElClass=TUnaryExpr then
- begin
- if TUnaryExpr(El).OpCode in [eopAddress,eopMemAddress] then
- ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags+[rcNoImplicitProc],StartEl)
- else
- ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags,StartEl);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeElement Unary Kind=',TUnaryExpr(El).Kind,' OpCode=',TUnaryExpr(El).OpCode,' OperandResolved=',GetResolverResultDbg(ResolvedEl),' ',GetElementSourcePosStr(El));
- {$ENDIF}
- case TUnaryExpr(El).OpCode of
- eopAdd, eopSubtract:
- if ResolvedEl.BaseType in (btAllInteger+btAllFloats) then
- exit
- else if IsGenericTemplType(ResolvedEl) then
- exit
- else
- RaiseMsg(20170216152532,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
- [OpcodeStrings[TUnaryExpr(El).OpCode],GetResolverResultDescription(ResolvedEl)],El);
- eopNot:
- begin
- if ResolvedEl.BaseType in (btAllInteger+btAllBooleans) then
- else
- ComputeUnaryNot(TUnaryExpr(El),ResolvedEl,Flags);
- exit;
- end;
- eopAddress:
- if (ResolvedEl.BaseType=btProc) and (ResolvedEl.IdentEl is TPasProcedure) then
- begin
- SetResolverValueExpr(ResolvedEl,btContext,
- ResolvedEl.LoTypeEl,ResolvedEl.HiTypeEl,TUnaryExpr(El).Operand,[rrfReadable]);
- exit;
- end
- else if (rrfReadable in ResolvedEl.Flags) and (ResolvedEl.BaseType<>btPointer) then
- begin
- SetResolverValueExpr(ResolvedEl,btPointer,
- ResolvedEl.LoTypeEl,ResolvedEl.HiTypeEl,TUnaryExpr(El).Operand,[rrfReadable]);
- exit;
- end
- else
- RaiseMsg(20180208121541,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
- [OpcodeStrings[TUnaryExpr(El).OpCode],GetResolverResultDescription(ResolvedEl)],El);
- eopDeref:
- begin
- ComputeDereference(TUnaryExpr(El),ResolvedEl);
- exit;
- end;
- eopMemAddress:
- if (ResolvedEl.BaseType=btContext)
- and ((ResolvedEl.LoTypeEl is TPasProcedureType)
- or IsGenericTemplType(ResolvedEl)) then
- // @@ProcVar
- exit
- else
- RaiseMsg(20180208121549,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
- [OpcodeStrings[TUnaryExpr(El).OpCode],GetResolverResultDescription(ResolvedEl)],El);
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeElement OpCode=',TUnaryExpr(El).OpCode);
- {$ENDIF}
- RaiseNotYetImplemented(20160926142426,El);
- end
- else if ElClass=TParamsExpr then
- case TParamsExpr(El).Kind of
- pekArrayParams: // a[]
- ComputeArrayParams(TParamsExpr(El),ResolvedEl,Flags,StartEl);
- pekFuncParams: // a()
- ComputeFuncParams(TParamsExpr(El),ResolvedEl,Flags,StartEl);
- pekSet: // []
- ComputeSetParams(TParamsExpr(El),ResolvedEl,Flags,StartEl);
- else
- RaiseNotYetImplemented(20161010184559,El);
- end
- else if ElClass=TInheritedExpr then
- begin
- // writeln('TPasResolver.ComputeElement TInheritedExpr El.CustomData=',GetObjName(El.CustomData));
- if El.CustomData is TResolvedReference then
- ComputeInherited(TInheritedExpr(El))
- else
- // no ancestor proc
- SetResolverIdentifier(ResolvedEl,btBuiltInProc,nil,nil,nil,[rrfCanBeStatement]);
- end
- else if (ElClass=TPasAliasType) or (ElClass=TPasTypeAliasType) then
- begin
- // e.g. 'type a = b' -> compute b
- ComputeElement(TPasAliasType(El).DestType,ResolvedEl,Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.HiTypeEl:=TPasAliasType(El);
- end
- else if (ElClass=TPasVariable) then
- begin
- // e.g. 'var a:b' -> compute b, use a as IdentEl
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152737,StartEl);
- ComputeElement(TPasVariable(El).VarType,ResolvedEl,Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.Flags:=[rrfReadable,rrfWritable];
- end
- else if (ElClass=TPasConst) then
- begin
- // e.g. 'var a:b' -> compute b, use a as IdentEl
- if TPasConst(El).VarType<>nil then
- begin
- // typed const
- if (not TPasConst(El).IsConst) and ([rcConstant,rcType]*Flags<>[]) then
- RaiseConstantExprExp(20170216152739,StartEl);
- ComputeElement(TPasConst(El).VarType,ResolvedEl,Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- if TPasConst(El).IsConst then
- ResolvedEl.Flags:=[rrfReadable]
- else
- ResolvedEl.Flags:=[rrfReadable,rrfWritable];
- end
- else
- begin
- // untyped const
- ComputeElement(TPasConst(El).Expr,ResolvedEl,Flags+[rcConstant],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.Flags:=[rrfReadable];
- end;
- end
- else if (ElClass=TPasEnumValue) then
- begin
- TypeEl:=NoNil(El.Parent) as TPasEnumType;
- SetResolverIdentifier(ResolvedEl,btContext,El,TypeEl,TypeEl,[rrfReadable])
- end
- else if (ElClass=TPasEnumType) then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasEnumType(El),TPasEnumType(El),[])
- else if (ElClass=TPasProperty) then
- begin
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152741,StartEl);
- if GetPasPropertyArgs(TPasProperty(El)).Count=0 then
- begin
- ComputeElement(GetPasPropertyType(TPasProperty(El)),ResolvedEl,
- Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.Flags:=[];
- if GetPasPropertyGetter(TPasProperty(El))<>nil then
- Include(ResolvedEl.Flags,rrfReadable);
- if GetPasPropertySetter(TPasProperty(El))<>nil then
- Include(ResolvedEl.Flags,rrfWritable);
- if IsProcedureType(ResolvedEl,true) then
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else
- begin
- // index property without name
- // Note: computing the pekArrayParams TParamsExpr will convert this to the type
- SetResolverIdentifier(ResolvedEl,btArrayProperty,El,nil,nil,[]);
- end;
- end
- else if ElClass=TPasArgument then
- begin
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152744,StartEl);
- if TPasArgument(El).ArgType=nil then
- // untyped parameter
- SetResolverIdentifier(ResolvedEl,btUntyped,El,nil,nil,[])
- else
- begin
- // typed parameter -> use param as IdentEl, compute type
- ComputeElement(TPasArgument(El).ArgType,ResolvedEl,Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- end;
- ResolvedEl.Flags:=[rrfReadable];
- if TPasArgument(El).Access in [argDefault, argVar, argOut] then
- Include(ResolvedEl.Flags,rrfWritable);
- if IsProcedureType(ResolvedEl,true) then
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else if ElClass=TPasClassType then
- begin
- if TPasClassType(El).IsForward and (El.CustomData<>nil) then
- begin
- DeclEl:=(TPasClassType(El).CustomData as TResolvedReference).Declaration;
- TypeEl:=NoNil(DeclEl) as TPasClassType;
- end
- else
- TypeEl:=TPasClassType(El);
- SetResolverIdentifier(ResolvedEl,btContext,
- TypeEl,TypeEl,TypeEl,[]);
- end
- else if ElClass=TPasClassOfType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasClassOfType(El),TPasClassOfType(El),[])
- else if ElClass=TPasPointerType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasPointerType(El),TPasPointerType(El),[])
- else if ElClass=TPasRecordType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasRecordType(El),TPasRecordType(El),[])
- else if ElClass=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(El).RangeExpr,ResolvedEl,[rcConstant],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.LoTypeEl:=TPasRangeType(El);
- ResolvedEl.HiTypeEl:=ResolvedEl.LoTypeEl;
- if ResolvedEl.ExprEl=nil then
- ResolvedEl.ExprEl:=TPasRangeType(El).RangeExpr;
- ResolvedEl.Flags:=[];
- end
- else if ElClass=TPasSetType then
- begin
- ComputeElement(TPasSetType(El).EnumType,ResolvedEl,[rcConstant],StartEl);
- if ResolvedEl.BaseType=btRange then
- begin
- ConvertRangeToElement(ResolvedEl);
- ResolvedEl.LoTypeEl:=TPasSetType(El).EnumType;
- ResolvedEl.HiTypeEl:=ResolvedEl.LoTypeEl;
- end;
- ResolvedEl.SubType:=ResolvedEl.BaseType;
- ResolvedEl.BaseType:=btSet;
- ResolvedEl.IdentEl:=El;
- ResolvedEl.Flags:=[];
- end
- else if ElClass=TPasResultElement then
- begin
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152746,StartEl);
- ComputeResultElement(TPasResultElement(El),ResolvedEl,Flags,StartEl);
- end
- else if ElClass=TPasUsesUnit then
- begin
- if TPasUsesUnit(El).Module is TPasModule then
- SetResolverIdentifier(ResolvedEl,btModule,TPasUsesUnit(El).Module,nil,nil,[])
- else
- RaiseNotYetImplemented(20170429112047,TPasUsesUnit(El).Module);
- end
- else if El.InheritsFrom(TPasModule) then
- SetResolverIdentifier(ResolvedEl,btModule,El,nil,nil,[])
- else if ElClass=TNilExpr then
- SetResolverValueExpr(ResolvedEl,btNil,FBaseTypes[btNil],FBaseTypes[btNil],
- TNilExpr(El),[rrfReadable])
- else if El.InheritsFrom(TPasProcedure) then
- begin
- TypeEl:=TPasProcedure(El).ProcType;
- SetResolverIdentifier(ResolvedEl,btProc,El,TypeEl,TypeEl,[rrfCanBeStatement]);
- if (TPasProcedure(El).ProcType is TPasFunctionType)
- or (ElClass=TPasConstructor) then
- Include(ResolvedEl.Flags,rrfReadable);
- // Note: implicit calls are handled in TPrimitiveExpr
- end
- else if El.InheritsFrom(TPasProcedureType) then
- begin
- SetResolverIdentifier(ResolvedEl,btContext,El,
- TPasProcedureType(El),TPasProcedureType(El),[rrfCanBeStatement]);
- // Note: implicit calls are handled in TPrimitiveExpr
- end
- else if ElClass=TProcedureExpr then
- begin
- TypeEl:=TProcedureExpr(El).Proc.ProcType;
- SetResolverValueExpr(ResolvedEl,btProc,TypeEl,TypeEl,TProcedureExpr(El),[rrfReadable]);
- end
- else if ElClass=TPasArrayType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasArrayType(El),TPasArrayType(El),[])
- else if ElClass=TArrayValues then
- SetResolverValueExpr(ResolvedEl,btArrayLit,nil,nil,TArrayValues(El),[rrfReadable])
- else if ElClass=TRecordValues then
- ComputeRecordValues(TRecordValues(El),ResolvedEl,Flags,StartEl)
- else if ElClass=TPasStringType then
- begin
- {$ifdef FPC_HAS_CPSTRING}
- SetResolverTypeExpr(ResolvedEl,btShortString,
- BaseTypes[btShortString],BaseTypes[btShortString],[rrfReadable]);
- if BaseTypes[btShortString]=nil then
- {$endif}
- RaiseMsg(20170419203146,nIllegalQualifier,sIllegalQualifier,['['],El);
- end
- else if ElClass=TPasResString then
- SetResolverIdentifier(ResolvedEl,btString,El,
- FBaseTypes[btString],FBaseTypes[btString],[rrfReadable])
- else if ElClass=TPasGenericTemplateType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasGenericTemplateType(El),
- TPasGenericTemplateType(El),[])
- else if ElClass=TPasSpecializeType then
- ComputeSpecializeType(TPasSpecializeType(El))
- else if ElClass=TInlineSpecializeExpr then
- ComputeElement(TInlineSpecializeExpr(El).NameExpr,ResolvedEl,Flags,StartEl)
- else if ElClass=TPasExportSymbol then
- ComputeExportSymbol(TPasExportSymbol(El))
- else
- RaiseNotYetImplemented(20160922163705,El);
- {$IF defined(nodejs) and defined(VerbosePasResolver)}
- if not isNumber(ResolvedEl.BaseType) then
- begin
- {AllowWriteln}
- writeln('TPasResolver.ComputeElement ',GetObjName(El),' typeof ResolvedEl.BaseType=',jsTypeOf(ResolvedEl.BaseType),' ResolvedEl=',GetResolverResultDbg(ResolvedEl));
- RaiseInternalError(20181101123527,jsTypeOf(ResolvedEl.LoTypeEl));
- {AllowWriteln-}
- end;
- {$ENDIF}
- end;
- procedure TPasResolver.ComputeResultElement(El: TPasResultElement; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- begin
- if El.ResultType=nil then
- RaiseNotYetImplemented(20200524214458,El);
- ComputeElement(El.ResultType,ResolvedEl,Flags+[rcType,rcNoImplicitProc],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.Flags:=[rrfReadable,rrfWritable];
- end;
- function TPasResolver.Eval(Expr: TPasExpr; Flags: TResEvalFlags;
- Store: boolean): TResEvalValue;
- // Important: Caller must free result with ReleaseEvalValue(Result)
- begin
- Result:=fExprEvaluator.Eval(Expr,Flags);
- if Result=nil then exit;
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.Eval Expr=',GetObjName(Expr),' Result=',Result.AsDebugString);
- {$ENDIF}
- if Store
- and (Expr.CustomData=nil)
- and (Result.Element=nil)
- and (not fExprEvaluator.IsSimpleExpr(Expr))
- and (Expr.GetModule=RootElement) then
- begin
- //writeln('TPasResolver.Eval STORE Expr=',GetObjName(Expr),' Result=',Result.AsDebugString);
- AddResolveData(Expr,Result,lkModule);
- end;
- end;
- function TPasResolver.Eval(const Value: TPasResolverResult;
- Flags: TResEvalFlags; Store: boolean): TResEvalValue;
- var
- Expr: TPasExpr;
- begin
- Result:=nil;
- if Value.ExprEl<>nil then
- Result:=Eval(Value.ExprEl,Flags,Store)
- else if Value.IdentEl is TPasConst then
- begin
- Expr:=TPasVariable(Value.IdentEl).Expr;
- if Expr=nil then exit;
- Result:=Eval(Expr,Flags,Store)
- end;
- end;
- function TPasResolver.IsSameType(TypeA, TypeB: TPasType;
- ResolveAlias: TPRResolveAlias): boolean;
- var
- btA, btB: TResolverBaseType;
- begin
- if (TypeA=nil) or (TypeB=nil) then exit(false);
- case ResolveAlias of
- prraSimple:
- begin
- TypeA:=ResolveSimpleAliasType(TypeA);
- TypeB:=ResolveSimpleAliasType(TypeB);
- end;
- prraAlias:
- begin
- TypeA:=ResolveAliasType(TypeA);
- TypeB:=ResolveAliasType(TypeB);
- end;
- end;
- if TypeA=TypeB then exit(true);
- if (TypeA.ClassType=TPasUnresolvedSymbolRef)
- and (TypeB.ClassType=TPasUnresolvedSymbolRef) then
- begin
- if CompareText(TypeA.Name,TypeB.Name)=0 then
- exit(true);
- btA:=TResElDataBaseType(TypeA.CustomData).BaseType;
- btB:=TResElDataBaseType(TypeB.CustomData).BaseType;
- Result:=GetActualBaseType(btA)=GetActualBaseType(btB);
- exit;
- end;
- Result:=false;
- end;
- function TPasResolver.HasExactType(const ResolvedEl: TPasResolverResult
- ): boolean;
- var
- IdentEl: TPasElement;
- Expr: TPasExpr;
- begin
- IdentEl:=ResolvedEl.IdentEl;
- if IdentEl<>nil then
- begin
- if IdentEl is TPasVariable then
- exit(TPasVariable(IdentEl).VarType<>nil)
- else if IdentEl.ClassType=TPasArgument then
- exit(TPasArgument(IdentEl).ArgType<>nil)
- else if IdentEl.ClassType=TPasResultElement then
- exit(TPasResultElement(IdentEl).ResultType<>nil)
- else if IdentEl is TPasType then
- exit(true)
- else
- exit(false);
- end;
- Expr:=ResolvedEl.ExprEl;
- if Expr<>nil then
- begin
- if Expr.Kind in [pekNumber,pekString,pekNil,pekBoolConst] then
- exit(true)
- else
- exit(false);
- end;
- Result:=false;
- end;
- function TPasResolver.IndexOfGenericParam(Params: TPasExprArray): integer;
- var
- i: Integer;
- ParamResolved: TPasResolverResult;
- begin
- for i:=0 to length(Params)-1 do
- begin
- ComputeElement(Params[i],ParamResolved,[]);
- if ParamResolved.LoTypeEl is TPasGenericTemplateType then
- exit(i);
- end;
- Result:=-1;
- end;
- procedure TPasResolver.CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
- ErrorEl: TPasElement);
- begin
- if aType=nil then exit;
- if aType is TPasGenericType then
- begin
- if aType.ClassType=TPasClassType then
- begin
- if TPasClassType(aType).HelperForType<>nil then
- RaiseHelpersCannotBeUsedAsType(id,ErrorEl);
- end;
- if (TPasGenericType(aType).GenericTemplateTypes<>nil)
- and (TPasGenericType(aType).GenericTemplateTypes.Count>0) then
- begin
- // ref to generic type without specialization
- if not (msDelphi in CurrentParser.CurrentModeswitches)
- and (ErrorEl.HasParent(aType)) then
- // ObjFPC allows referring to parent without type params
- else
- RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
- [ErrorEl.ElementTypeName],ErrorEl);
- end;
- end;
- end;
- function TPasResolver.GetPasClassAncestor(ClassEl: TPasClassType;
- SkipAlias: boolean): TPasType;
- var
- DeclEl: TPasElement;
- ClassScope: TPasClassScope;
- begin
- Result:=nil;
- if ClassEl=nil then
- exit;
- if ClassEl.CustomData=nil then
- exit;
- if ClassEl.IsForward then
- begin
- DeclEl:=(ClassEl.CustomData as TResolvedReference).Declaration;
- ClassEl:=NoNil(DeclEl) as TPasClassType;
- Result:=ClassEl;
- end
- else
- begin
- ClassScope:=ClassEl.CustomData as TPasClassScope;
- if not (pcsfAncestorResolved in ClassScope.Flags) then
- exit;
- if SkipAlias then
- begin
- if ClassScope.AncestorScope=nil then
- exit;
- Result:=TPasClassType(ClassScope.AncestorScope.Element);
- end
- else
- Result:=ClassScope.DirectAncestor;
- end;
- end;
- function TPasResolver.GetPasClassForward(ClassEl: TPasClassType): TPasClassType;
- var
- Parent: TPasElement;
- i: Integer;
- CurClass: TPasClassType;
- Ref: TResolvedReference;
- Decls: TFPList;
- begin
- Result:=nil;
- if ClassEl=nil then exit;
- Parent:=ClassEl.Parent;
- if not (Parent is TPasDeclarations) then
- RaiseNotYetImplemented(20200926214106,ClassEl);
- Decls:=TPasDeclarations(Parent).Classes;
- for i:=0 to Decls.Count-1 do
- begin
- CurClass:=TPasClassType(Decls[i]);
- if CurClass=ClassEl then exit;
- if not CurClass.IsForward then continue;
- Ref:=TResolvedReference(CurClass.CustomData);
- if Ref.Declaration=ClassEl then
- exit(TPasClassType(Ref.Declaration));
- end;
- end;
- function TPasResolver.GetParentProcBody(El: TPasElement): TProcedureBody;
- begin
- while El<>nil do
- begin
- if El is TProcedureBody then
- exit(TProcedureBody(El));
- El:=El.Parent;
- end;
- Result:=nil;
- end;
- function TPasResolver.ProcHasImplElements(Proc: TPasProcedure): boolean;
- begin
- Result:=GetProcFirstImplEl(Proc)<>nil;
- end;
- function TPasResolver.IndexOfImplementedInterface(ClassEl: TPasClassType;
- aType: TPasType): integer;
- var
- List: TFPList;
- i: Integer;
- begin
- if aType=nil then exit(-1);
- aType:=ResolveAliasType(aType);
- List:=ClassEl.Interfaces;
- for i:=0 to List.Count-1 do
- if ResolveAliasType(TPasType(List[i]))=aType then
- exit(i);
- Result:=-1;
- end;
- function TPasResolver.GetLoop(El: TPasElement): TPasImplElement;
- begin
- while El<>nil do
- begin
- if (El.ClassType=TPasImplRepeatUntil)
- or (El.ClassType=TPasImplWhileDo)
- or (El.ClassType=TPasImplForLoop) then
- exit(TPasImplElement(El));
- El:=El.Parent;
- end;
- Result:=nil;
- end;
- function TPasResolver.ResolveAliasType(aType: TPasType; SkipTypeAlias: boolean
- ): TPasType;
- var
- C: TClass;
- begin
- while aType<>nil do
- begin
- C:=aType.ClassType;
- if C=TPasAliasType then
- aType:=TPasAliasType(aType).DestType
- else if (C=TPasTypeAliasType) and SkipTypeAlias then
- aType:=TPasAliasType(aType).DestType
- else if (C=TPasClassType) and TPasClassType(aType).IsForward
- and (aType.CustomData is TResolvedReference) then
- aType:=NoNil(TResolvedReference(aType.CustomData).Declaration) as TPasType
- else if C=TPasSpecializeType then
- begin
- if aType.CustomData is TPasSpecializeTypeData then
- exit(TPasSpecializeTypeData(aType.CustomData).SpecializedType);
- aType:=TPasSpecializeType(aType).DestType;
- end
- else
- exit(aType);
- end;
- Result:=nil;
- end;
- function TPasResolver.ResolveAliasTypeEl(El: TPasElement): TPasType;
- begin
- if (El is TPasType) then
- Result:=ResolveAliasType(TPasType(El))
- else
- Result:=nil;
- end;
- function TPasResolver.ExprIsAddrTarget(El: TPasExpr): boolean;
- { returns true if El is
- a) the last element of an @ operator expression
- e.g. '@p().o[].El' or '@El[]'
- b) mode delphi: the last element of a right side of an assignment
- c) an accessor function, e.g. property P read El;
- d) an export
- }
- var
- Parent: TPasElement;
- Prop: TPasProperty;
- C: TClass;
- begin
- Result:=false;
- if El=nil then exit;
- if not IsNameExpr(El) then
- exit;
- repeat
- Parent:=El.Parent;
- //writeln('TPasResolver.ExprIsAddrTarget El=',GetObjName(El),' Parent=',GetObjName(Parent));
- C:=Parent.ClassType;
- if C=TUnaryExpr then
- begin
- if TUnaryExpr(Parent).OpCode=eopAddress then exit(true);
- end
- else if C=TBinaryExpr then
- begin
- if TBinaryExpr(Parent).right<>El then exit;
- if TBinaryExpr(Parent).OpCode<>eopSubIdent then exit;
- end
- else if C=TParamsExpr then
- begin
- if TParamsExpr(Parent).Value<>El then exit;
- end
- else if C=TPasProperty then
- begin
- Prop:=TPasProperty(Parent);
- Result:=(Prop.ReadAccessor=El) or (Prop.WriteAccessor=El) or (Prop.StoredAccessor=El);
- exit;
- end
- else if C=TPasImplAssign then
- begin
- if TPasImplAssign(Parent).right<>El then exit;
- if (msDelphi in CurrentParser.CurrentModeswitches) then exit(true);
- exit;
- end
- else if C=TPasExportSymbol then
- exit(true)
- else
- exit;
- El:=TPasExpr(Parent);
- until false;
- end;
- function TPasResolver.ParentNeedsExprResult(El: TPasExpr): boolean;
- var
- C: TClass;
- P: TPasElement;
- begin
- if (El=nil) or (El.Parent=nil) then exit(false);
- Result:=false;
- P:=El.Parent;
- C:=P.ClassType;
- if C=TBinaryExpr then
- begin
- if TBinaryExpr(P).right=El then
- begin
- if (TBinaryExpr(P).OpCode=eopSubIdent)
- or ((TBinaryExpr(P).OpCode=eopNone) and (TBinaryExpr(P).left is TInheritedExpr)) then
- Result:=ParentNeedsExprResult(TBinaryExpr(P))
- else
- Result:=true;
- end
- else
- Result:=true;
- end
- else if C=TInlineSpecializeExpr then
- Result:=ParentNeedsExprResult(TInlineSpecializeExpr(P))
- else if C.InheritsFrom(TPasExpr) then
- Result:=true
- else if (C=TPasEnumValue)
- or (C=TPasArgument)
- or (C=TPasVariable)
- or (C=TPasExportSymbol) then
- Result:=true
- else if C=TPasClassType then
- Result:=TPasClassType(P).GUIDExpr=El
- else if C=TPasProperty then
- Result:=(TPasProperty(P).IndexExpr=El)
- or (TPasProperty(P).DispIDExpr=El)
- or (TPasProperty(P).DefaultExpr=El)
- else if C=TPasProcedure then
- Result:=(TPasProcedure(P).LibraryExpr=El)
- or (TPasProcedure(P).DispIDExpr=El)
- else if C=TPasImplRepeatUntil then
- Result:=(TPasImplRepeatUntil(P).ConditionExpr=El)
- else if C=TPasImplIfElse then
- Result:=(TPasImplIfElse(P).ConditionExpr=El)
- else if C=TPasImplWhileDo then
- Result:=(TPasImplWhileDo(P).ConditionExpr=El)
- else if C=TPasImplWithDo then
- Result:=(TPasImplWithDo(P).Expressions.IndexOf(El)>=0)
- else if C=TPasImplCaseOf then
- Result:=(TPasImplCaseOf(P).CaseExpr=El)
- else if C=TPasImplCaseStatement then
- Result:=(TPasImplCaseStatement(P).Expressions.IndexOf(El)>=0)
- else if C=TPasImplForLoop then
- Result:=(TPasImplForLoop(P).StartExpr=El)
- or (TPasImplForLoop(P).EndExpr=El)
- else if C=TPasImplAssign then
- Result:=(TPasImplAssign(P).right=El)
- else if C=TPasImplRaise then
- Result:=(TPasImplRaise(P).ExceptAddr=El);
- end;
- function TPasResolver.GetReference_ConstructorType(Ref: TResolvedReference;
- Expr: TPasExpr): TPasResolverResult;
- var
- TypeEl: TPasType;
- begin
- TypeEl:=(Ref.Context as TResolvedRefCtxConstructor).Typ;
- if TypeEl=nil then
- RaiseNotYetImplemented(20190125205339,Expr)
- else if TypeEl is TPasMembersType then
- SetResolverValueExpr(Result,btContext,TypeEl,TypeEl,Expr,[rrfReadable])
- else
- begin
- ComputeElement(TypeEl,Result,[rcType]);
- Result.ExprEl:=Expr;
- Result.Flags:=[rrfReadable];
- end;
- end;
- function TPasResolver.GetParamsValueRef(Params: TParamsExpr): TResolvedReference;
- var
- El: TPasExpr;
- begin
- Result:=nil;
- if Params=nil then exit;
- El:=Params.Value;
- while El<>nil do
- begin
- if El.CustomData is TResolvedReference then
- exit(TResolvedReference(El.CustomData));
- if El.ClassType=TInlineSpecializeExpr then
- El:=TInlineSpecializeExpr(El).NameExpr
- else if (El.ClassType=TBinaryExpr)
- and (TBinaryExpr(El).OpCode=eopSubIdent) then
- El:=TBinaryExpr(El).right
- else
- exit;
- end;
- end;
- function TPasResolver.GetSetType(const ResolvedSet: TPasResolverResult
- ): TPasSetType;
- var
- IdentEl: TPasElement;
- aType: TPasType;
- C: TClass;
- begin
- Result:=nil;
- if ResolvedSet.BaseType=btSet then
- begin
- IdentEl:=ResolvedSet.IdentEl;
- if IdentEl=nil then exit;
- C:=IdentEl.ClassType;
- if (C=TPasVariable)
- or (C=TPasConst) then
- aType:=TPasVariable(IdentEl).VarType
- else if C=TPasProperty then
- aType:=GetPasPropertyType(TPasProperty(IdentEl))
- else if C=TPasArgument then
- aType:=TPasArgument(IdentEl).ArgType
- else if C.InheritsFrom(TPasProcedure)
- and (TPasProcedure(IdentEl).ProcType is TPasFunctionType) then
- aType:=TPasFunctionType(TPasProcedure(IdentEl).ProcType).ResultEl.ResultType
- else if C=TPasSetType then
- exit(TPasSetType(IdentEl))
- else
- exit;
- if aType.ClassType=TPasSetType then
- Result:=TPasSetType(aType);
- end
- else if ResolvedSet.BaseType=btContext then
- begin
- if ResolvedSet.LoTypeEl.ClassType=TPasSetType then
- if ResolvedSet.HiTypeEl.ClassType=TPasSetType then
- Result:=TPasSetType(ResolvedSet.HiTypeEl)
- else
- Result:=TPasSetType(ResolvedSet.LoTypeEl);
- end;
- end;
- function TPasResolver.IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean
- ): boolean;
- begin
- TypeEl:=ResolveAliasType(TypeEl);
- if (TypeEl=nil) or (TypeEl.ClassType<>TPasArrayType) then
- exit(false);
- if length(TPasArrayType(TypeEl).Ranges)<>0 then
- exit(false);
- // Note: Array of Const is an open array of TVarRec
- if OptionalOpenArray and (proOpenAsDynArrays in Options) then
- Result:=true
- else
- Result:=(TypeEl.Parent=nil) or (TypeEl.Parent.ClassType<>TPasArgument);
- end;
- function TPasResolver.IsOpenArray(TypeEl: TPasType): boolean;
- begin
- Result:=(TypeEl<>nil)
- and (TypeEl.ClassType=TPasArrayType)
- and (length(TPasArrayType(TypeEl).Ranges)=0)
- and (TypeEl.Parent<>nil)
- and (TypeEl.Parent.ClassType=TPasArgument);
- end;
- function TPasResolver.IsDynOrOpenArray(TypeEl: TPasType): boolean;
- begin
- TypeEl:=ResolveAliasType(TypeEl);
- Result:=(TypeEl<>nil) and (TypeEl.ClassType=TPasArrayType)
- and (length(TPasArrayType(TypeEl).Ranges)=0);
- end;
- function TPasResolver.IsArrayOfConst(TypeEl: TPasType): boolean;
- begin
- Result:=(TypeEl<>nil) and (TypeEl.ClassType=TPasArrayType)
- and (TPasArrayType(TypeEl).ElType=nil);
- end;
- function TPasResolver.GetArrayElType(ArrType: TPasArrayType): TPasType;
- begin
- Result:=ArrType.ElType;
- if Result=nil then
- Result:=GetTVarRec(ArrType);
- end;
- function TPasResolver.IsVarInit(Expr: TPasExpr): boolean;
- var
- C: TClass;
- begin
- Result:=false;
- if Expr=nil then exit;
- if Expr.Parent=nil then exit;
- C:=Expr.Parent.ClassType;
- if C.InheritsFrom(TPasVariable) then
- Result:=(TPasVariable(Expr.Parent).Expr=Expr)
- else if C=TPasArgument then
- Result:=(TPasArgument(Expr.Parent).ValueExpr=Expr);
- end;
- function TPasResolver.IsEmptyArrayExpr(const ResolvedEl: TPasResolverResult): boolean;
- begin
- Result:=(ResolvedEl.BaseType in [btSet,btArrayOrSet,btArrayLit])
- and (ResolvedEl.SubType=btNone);
- end;
- function TPasResolver.IsClassMethod(El: TPasElement): boolean;
- var
- C: TClass;
- begin
- if El=nil then exit(false);
- C:=El.ClassType;;
- Result:=(C=TPasClassConstructor)
- or (C=TPasClassDestructor)
- or (C=TPasClassProcedure)
- or (C=TPasClassFunction)
- or (C=TPasClassOperator);
- end;
- function TPasResolver.IsClassField(El: TPasElement): boolean;
- var
- C: TClass;
- begin
- if ((El.ClassType=TPasVariable) or (El.ClassType=TPasConst))
- and ([vmClass,vmStatic]*TPasVariable(El).VarModifiers<>[]) then
- begin
- C:=El.Parent.ClassType;
- Result:=(C=TPasClassType) or (C=TPasRecordType);
- end
- else
- Result:=false;
- end;
- function TPasResolver.GetFunctionType(El: TPasElement): TPasFunctionType;
- var
- ProcType: TPasProcedureType;
- begin
- if not (El is TPasProcedure) then exit(nil);
- ProcType:=TPasProcedure(El).ProcType;
- if ProcType is TPasFunctionType then
- Result:=TPasFunctionType(ProcType)
- else
- Result:=nil;
- end;
- function TPasResolver.MethodIsStatic(El: TPasProcedure): boolean;
- begin
- Result:=El.IsStatic
- or (El.ClassType=TPasClassConstructor)
- or (El.ClassType=TPasClassDestructor);
- end;
- function TPasResolver.IsMethod(El: TPasProcedure): boolean;
- var
- ProcScope: TPasProcedureScope;
- begin
- Result:=false;
- if El=nil then exit;
- if El.Parent is TPasMembersType then exit(true);
- if not (El.CustomData is TPasProcedureScope) then exit;
- ProcScope:=TPasProcedureScope(El.CustomData);
- Result:=IsMethod(ProcScope.DeclarationProc);
- end;
- function TPasResolver.IsMethod_SelfIsClass(El: TPasElement): boolean;
- var
- C: TClass;
- begin
- if (El=nil) then exit(false);
- C:=El.ClassType;
- Result:=((C=TPasClassProcedure) or (C=TPasClassFunction) or (C=TPasClassOperator))
- and not TPasProcedure(El).IsStatic;
- end;
- function TPasResolver.IsHelperMethod(El: TPasElement): boolean;
- begin
- Result:=(El is TPasProcedure) and (El.Parent is TPasClassType)
- and (TPasClassType(El.Parent).HelperForType<>nil);
- end;
- function TPasResolver.IsHelper(El: TPasElement): boolean;
- begin
- Result:=(El<>nil) and (El.ClassType=TPasClassType) and (TPasClassType(El).HelperForType<>nil);
- end;
- function TPasResolver.IsExternalClass_Name(aClass: TPasClassType;
- const ExtName: string): boolean;
- var
- AncestorScope: TPasClassScope;
- begin
- Result:=false;
- if aClass=nil then exit;
- while aClass<>nil do
- begin
- if aClass.ExternalName=ExtName then exit(true);
- AncestorScope:=(aClass.CustomData as TPasClassScope).AncestorScope;
- if AncestorScope=nil then exit;
- aClass:=NoNil(AncestorScope.Element) as TPasClassType;
- end;
- end;
- function TPasResolver.IsProcedureType(const ResolvedEl: TPasResolverResult;
- HasValue: boolean): boolean;
- var
- TypeEl: TPasType;
- begin
- if (ResolvedEl.BaseType<>btContext) then
- exit(false);
- TypeEl:=ResolvedEl.LoTypeEl;
- if not (TypeEl is TPasProcedureType) then
- exit(false);
- if HasValue and not (rrfReadable in ResolvedEl.Flags) then
- exit(false);
- Result:=true;
- end;
- function TPasResolver.IsArrayType(const ResolvedEl: TPasResolverResult
- ): boolean;
- begin
- Result:=(ResolvedEl.BaseType=btContext) and (ResolvedEl.LoTypeEl is TPasArrayType);
- end;
- function TPasResolver.IsArrayExpr(Expr: TParamsExpr): TPasArrayType;
- var
- Ref: TResolvedReference;
- begin
- Result:=nil;
- if Expr=nil then exit;
- if Expr.Kind<>pekSet then exit;
- if not (Expr.CustomData is TResolvedReference) then exit;
- Ref:=TResolvedReference(Expr.CustomData);
- if Ref.Declaration is TPasArrayType then
- Result:=TPasArrayType(Ref.Declaration);
- end;
- function TPasResolver.IsArrayOperatorAdd(Expr: TPasExpr): boolean;
- begin
- Result:=(Expr<>nil) and (Expr.ClassType=TBinaryExpr) and (Expr.OpCode=eopAdd)
- and ElHasModeSwitch(Expr,msArrayOperators);
- end;
- function TPasResolver.IsTypeCast(Params: TParamsExpr): boolean;
- var
- Value: TPasExpr;
- Ref: TResolvedReference;
- Decl: TPasElement;
- C: TClass;
- begin
- Result:=false;
- if (Params=nil) or (Params.Kind<>pekFuncParams) then exit;
- Value:=Params.Value;
- if not IsNameExpr(Value) then
- exit;
- if not (Value.CustomData is TResolvedReference) then exit;
- Ref:=TResolvedReference(Value.CustomData);
- Decl:=Ref.Declaration;
- C:=Decl.ClassType;
- if (C=TPasAliasType) or (C=TPasTypeAliasType) then
- begin
- Decl:=ResolveAliasType(TPasAliasType(Decl));
- C:=Decl.ClassType;
- end;
- if (C=TPasProcedureType)
- or (C=TPasFunctionType) then
- exit(true)
- else if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasEnumType)
- or (C=TPasRecordType)
- or (C=TPasArrayType)
- or (C=TPasSpecializeType)
- or (C=TPasGenericTemplateType) then
- exit(true)
- else if (C=TPasUnresolvedSymbolRef)
- and (Decl.CustomData is TResElDataBaseType) then
- exit(true);
- end;
- function TPasResolver.GetTypeParameterCount(aType: TPasGenericType): integer;
- begin
- if aType=nil then exit(0);
- if aType.GenericTemplateTypes=nil then exit(0);
- Result:=aType.GenericTemplateTypes.Count;
- end;
- function TPasResolver.GetGenericConstraintKeyword(El: TPasElement): TToken;
- var
- Prim: TPrimitiveExpr;
- begin
- if (El=nil) or (El.ClassType<>TPrimitiveExpr) then
- exit(tkEOF);
- Prim:=TPrimitiveExpr(El);
- if Prim.Kind<>pekIdent then
- exit(tkEOF);
- case lowercase(Prim.Value) of
- 'record': Result:=tkrecord;
- 'class': Result:=tkclass;
- 'constructor': Result:=tkconstructor;
- else Result:=tkEOF;
- end;
- end;
- function TPasResolver.GetGenericConstraintErrorEl(ConstraintEl,
- TemplType: TPasElement): TPasElement;
- begin
- if (ConstraintEl is TPasExpr) or (ConstraintEl.Parent=TemplType) then
- Result:=ConstraintEl
- else
- Result:=TemplType;
- end;
- function TPasResolver.GetSpecializedEl(El: TPasElement; GenericEl: TPasElement;
- Params: TFPList): TPasElement;
- var
- Data: TPasSpecializeTypeData;
- GenScope: TPasGenericScope;
- GenericTemplateList: TFPList;
- i, j: Integer;
- Param: TPasElement;
- ParamsResolved: TPasTypeArray;
- ResolvedEl: TPasResolverResult;
- SpecializedElList: TObjectList;
- Item: TPRSpecializedItem;
- SrcModule: TPasModule;
- SrcModuleScope: TPasModuleScope;
- SrcResolver: TPasResolver;
- IsSelf: Boolean;
- GenericType: TPasGenericType;
- GenericProc: TPasProcedure;
- ProcScope: TPasProcedureScope;
- begin
- Result:=nil;
- if (El.ClassType=TPasSpecializeType) and (El.CustomData<>nil) then
- RaiseNotYetImplemented(20190726142522,El);
- // check if there is already such a specialization
- GenScope:=nil;
- GenericType:=nil;
- GenericProc:=nil;
- if GenericEl is TPasGenericType then
- begin
- GenericType:=TPasGenericType(GenericEl);
- if not (GenericEl.CustomData is TPasGenericScope) then
- RaiseMsg(20190726194316,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
- [GetTypeDescription(GenericType)],El);
- GenScope:=TPasGenericScope(GenericEl.CustomData);
- if (not (GenericType is TPasClassType))
- and (GenScope.GenericStep<psgsInterfaceParsed) then
- RaiseMsg(20190807205038,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
- [GetTypeDescription(GenericType)],El);
- GenericTemplateList:=GenericType.GenericTemplateTypes;
- end
- else if GenericEl is TPasProcedure then
- begin
- GenericProc:=TPasProcedure(GenericEl);
- if not (GenericProc.CustomData is TPasProcedureScope) then
- RaiseMsg(20190919132733,nIdentifierNotFound,sIdentifierNotFound,
- [GenericProc.Name],El);
- ProcScope:=TPasProcedureScope(GenericProc.CustomData);
- if ProcScope.DeclarationProc<>nil then
- RaiseNotYetImplemented(20190920182602,El);
- GenScope:=ProcScope;
- if GenScope.GenericStep<psgsInterfaceParsed then
- RaiseMsg(20190920120649,nTypeXIsNotYetCompletelyDefined,sTypeXIsNotYetCompletelyDefined,
- [GetElementDbgPath(GenericProc)],El);
- GenericTemplateList:=GetProcTemplateTypes(GenericProc);
- end
- else
- RaiseNotYetImplemented(20190919132603,GenericEl);
- SpecializedElList:=GenScope.SpecializedItems;
- if GenericTemplateList=nil then
- RaiseMsg(20190905111703,nXExpectedButYFound,sXExpectedButYFound,
- ['generic templates',GenericEl.Name],El);
- if GenericTemplateList.Count<>Params.Count then
- RaiseMsg(20190905111704,nXExpectedButYFound,sXExpectedButYFound,
- ['type with '+IntToStr(Params.Count)+' generic template(s)',
- GenericEl.Name+GetGenericParamCommas(GenericTemplateList.Count)],El);
- SetLength(ParamsResolved{%H-},Params.Count);
- IsSelf:=true;
- for i:=0 to Params.Count-1 do
- begin
- Param:=TPasElement(Params[i]);
- ComputeElement(Param,ResolvedEl,[rcType]);
- ParamsResolved[i]:=ResolvedEl.LoTypeEl;
- if ResolvedEl.LoTypeEl<>TPasType(GenericTemplateList[i]) then
- IsSelf:=false;
- end;
- if IsSelf then
- exit(GenericEl);
- if SpecializedElList=nil then
- begin
- SpecializedElList:=TObjectList.Create(true);
- if GenScope<>nil then
- GenScope.SpecializedItems:=SpecializedElList
- else
- RaiseNotYetImplemented(20190919133159,El);
- end;
- i:=SpecializedElList.Count-1;
- Item:=nil;
- while i>=0 do
- begin
- Item:=TPRSpecializedItem(SpecializedElList[i]);
- j:=length(Item.Params)-1;
- while j>=0 do
- begin
- if not IsSameType(Item.Params[j],ParamsResolved[j],prraNone)
- and (CheckElTypeCompatibility(Item.Params[j],ParamsResolved[j],prraNone)>cExact) then
- break;
- dec(j);
- end;
- if j<0 then
- break;
- Item:=nil;
- dec(i);
- end;
- if Item=nil then
- begin
- // new specialization
- SrcModule:=GenericEl.GetModule;
- SrcModuleScope:=SrcModule.CustomData as TPasModuleScope;
- SrcResolver:=SrcModuleScope.Owner as TPasResolver;
- Item:=SrcResolver.CreateSpecializedItem(El,GenericEl,ParamsResolved)
- end;
- Result:=Item.SpecializedEl;
- if El.ClassType=TPasSpecializeType then
- begin
- Data:=TPasSpecializeTypeData.Create;
- // add to free list
- AddResolveData(El,Data,lkModule);
- Data.SpecializedType:=Result as TPasGenericType; // no AddRef
- end;
- end;
- procedure TPasResolver.FinishGenericClassOrRecIntf(Scope: TPasGenericScope);
- var
- El: TPasGenericType;
- SpecializedItems: TObjectList;
- i: Integer;
- SpecializedItem: TPRSpecializedTypeItem;
- OldScopeState: TScopeStashState;
- begin
- El:=Scope.Element as TPasGenericType;
- if Scope.GenericStep<>psgsNone then
- RaiseNotYetImplemented(20200219124544,El);
- Scope.GenericStep:=psgsInterfaceParsed;
- SpecializedItems:=Scope.SpecializedItems;
- if SpecializedItems<>nil then
- // finish interfaces of started specializations
- for i:=0 to SpecializedItems.Count-1 do
- begin
- SpecializedItem:=TPRSpecializedTypeItem(SpecializedItems[i]);
- SpecializedItem.GenericEl:=El;
- if SpecializedItem.Step<>prssNone then continue;
- InitSpecializeScopes(El,OldScopeState);
- {$IFDEF VerbosePasResolver}
- WriteScopesShort('TPasResolver.FinishSpecializedClassOrRecIntf Finishing specialize interface: '+GetObjName(SpecializedItem.SpecializedType));
- {$ENDIF}
- SpecializeGenericIntf(SpecializedItem);
- {$IFDEF VerbosePasResolver}
- WriteScopesShort('TPasResolver.FinishSpecializedClassOrRecIntf Finished specialize interface: '+GetObjName(SpecializedItem.SpecializedType));
- {$ENDIF}
- RestoreSpecializeScopes(OldScopeState);
- {$IFDEF VerbosePasResolver}
- WriteScopesShort('TPasResolver.FinishSpecializedClassOrRecIntf RestoreStashedScopes '+GetObjName(SpecializedItem.SpecializedType));
- {$ENDIF}
- end;
- end;
- procedure TPasResolver.FinishSpecializations(Scope: TPasGenericScope);
- var
- SpecializedItems: TObjectList;
- i: Integer;
- begin
- SpecializedItems:=Scope.SpecializedItems;
- if SpecializedItems=nil then exit;
- for i:=0 to SpecializedItems.Count-1 do
- SpecializeGenericImpl(TPRSpecializedItem(SpecializedItems[i]));
- end;
- procedure TPasResolver.CheckPendingForwardProcs(El: TPasElement);
- var
- i: Integer;
- DeclEl: TPasElement;
- Proc: TPasProcedure;
- aClassOrRec: TPasMembersType;
- ClassOrRecScope: TPasClassOrRecordScope;
- begin
- if IsElementSkipped(El) then exit;
- if El is TPasDeclarations then
- begin
- for i:=0 to TPasDeclarations(El).Declarations.Count-1 do
- begin
- DeclEl:=TPasElement(TPasDeclarations(El).Declarations[i]);
- if DeclEl is TPasProcedure then
- begin
- Proc:=TPasProcedure(DeclEl);
- if ProcNeedsImplProc(Proc)
- and (TPasProcedureScope(Proc.CustomData).ImplProc=nil) then
- RaiseMsg(20170216152219,nForwardProcNotResolved,sForwardProcNotResolved,
- [GetElementTypeName(Proc),Proc.Name],Proc);
- end;
- end;
- end
- else if El is TPasMembersType then
- begin
- aClassOrRec:=TPasMembersType(El);
- if (aClassOrRec is TPasClassType) then
- begin
- if (TPasClassType(aClassOrRec).ObjKind in [okInterface,okDispInterface]) then
- exit;
- if TPasClassType(aClassOrRec).IsForward then
- exit;
- if TPasClassType(aClassOrRec).IsExternal then
- exit;
- end;
- ClassOrRecScope:=aClassOrRec.CustomData as TPasClassOrRecordScope;
- if ClassOrRecScope.SpecializedFromItem<>nil then
- exit;
- // finish implementation of (generic) class/record
- if ClassOrRecScope.GenericStep<>psgsInterfaceParsed then
- RaiseNotYetImplemented(20190804115324,El);
- for i:=0 to aClassOrRec.Members.Count-1 do
- begin
- DeclEl:=TPasElement(aClassOrRec.Members[i]);
- if DeclEl is TPasProcedure then
- begin
- Proc:=TPasProcedure(DeclEl);
- if Proc.IsAbstract or Proc.IsExternal then continue;
- if TPasProcedureScope(Proc.CustomData).ImplProc=nil then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckPendingForwardProcs Proc.ParentPath=',Proc.PathName);
- {$ENDIF}
- RaiseMsg(20170216152221,nForwardProcNotResolved,sForwardProcNotResolved,
- [GetElementTypeName(Proc),Proc.Name],Proc);
- end;
- end;
- end;
- ClassOrRecScope.GenericStep:=psgsImplementationParsed;
- if ClassOrRecScope.SpecializedItems<>nil then
- FinishSpecializations(ClassOrRecScope);
- end;
- end;
- function TPasResolver.IsSpecialized(El: TPasGenericType): boolean;
- begin
- Result:=(El<>nil) and (El.CustomData is TPasGenericScope)
- and (TPasGenericScope(El.CustomData).SpecializedFromItem<>nil);
- end;
- function TPasResolver.IsFullySpecialized(El: TPasGenericType): boolean;
- var
- GenScope: TPasGenericScope;
- Params: TPasTypeArray;
- i: Integer;
- begin
- if (El.GenericTemplateTypes<>nil) and (El.GenericTemplateTypes.Count>0) then
- exit(false);
- if not (El.CustomData is TPasGenericScope) then exit(true);
- GenScope:=TPasGenericScope(El.CustomData);
- if GenScope.SpecializedFromItem=nil then exit(true);
- Params:=GenScope.SpecializedFromItem.Params;
- for i:=0 to length(Params)-1 do
- if Params[i] is TPasGenericTemplateType then exit(false);
- Result:=true;
- end;
- function TPasResolver.IsFullySpecialized(Proc: TPasProcedure): boolean;
- var
- Templates: TFPList;
- ProcScope: TPasProcedureScope;
- Params: TPasTypeArray;
- i: Integer;
- begin
- if Proc.CustomData=nil then exit(false);
- ProcScope:=TPasProcedureScope(Proc.CustomData);
- if ProcScope.DeclarationProc<>nil then
- begin
- Proc:=ProcScope.DeclarationProc;
- ProcScope:=TPasProcedureScope(Proc.CustomData);
- end;
- Templates:=GetProcTemplateTypes(Proc);
- if (Templates<>nil) and (Templates.Count>0) then
- exit(false);
- if ProcScope.SpecializedFromItem=nil then
- exit(true);
- Params:=ProcScope.SpecializedFromItem.Params;
- for i:=0 to length(Params)-1 do
- if Params[i] is TPasGenericTemplateType then exit(false);
- Result:=true;
- end;
- function TPasResolver.IsInterfaceType(const ResolvedEl: TPasResolverResult;
- IntfType: TPasClassInterfaceType): boolean;
- begin
- if ResolvedEl.BaseType<>btContext then exit(false);
- Result:=IsInterfaceType(ResolvedEl.LoTypeEl,IntfType);
- end;
- function TPasResolver.IsInterfaceType(TypeEl: TPasType;
- IntfType: TPasClassInterfaceType): boolean;
- begin
- if TypeEl=nil then exit(false);
- TypeEl:=ResolveAliasType(TypeEl);
- Result:=(TypeEl.ClassType=TPasClassType)
- and (TPasClassType(TypeEl).ObjKind=okInterface)
- and (TPasClassType(TypeEl).InterfaceType=IntfType);
- end;
- function TPasResolver.IsTGUID(RecTypeEl: TPasRecordType): boolean;
- var
- Members: TFPList;
- El: TPasElement;
- i, MemberIndex: Integer;
- begin
- Result:=false;
- if not SameText(RecTypeEl.Name,'TGUID') then exit;
- if SameText(RecTypeEl.GetModule.Name,'system') then exit(true);
- Members:=RecTypeEl.Members;
- i:=1;
- for MemberIndex:=0 to Members.Count-1 do
- begin
- El:=TPasElement(Members[MemberIndex]);
- if (El.ClassType<>TPasVariable) then continue;
- if SameText(El.Name,'D'+IntToStr(i)) then
- begin
- if i=4 then exit(true);
- inc(i);
- end;
- end;
- Result:=true;
- end;
- function TPasResolver.IsTGUIDString(const ResolvedEl: TPasResolverResult
- ): boolean;
- var
- TypeEl: TPasType;
- C: TClass;
- IdentEl: TPasElement;
- begin
- if not (ResolvedEl.BaseType in btAllStrings) then
- exit(false);
- if (ResolvedEl.ExprEl<>nil) and (ResolvedEl.LoTypeEl<>nil) then
- exit(true); // untyped string literal
- IdentEl:=ResolvedEl.IdentEl;
- if IdentEl<>nil then
- begin
- C:=IdentEl.ClassType;
- if C.InheritsFrom(TPasVariable) then
- TypeEl:=TPasVariable(IdentEl).VarType
- else if C=TPasArgument then
- TypeEl:=TPasArgument(IdentEl).ArgType
- else if C=TPasResultElement then
- TypeEl:=TPasResultElement(IdentEl).ResultType
- else
- TypeEl:=nil;
- while TypeEl<>nil do
- begin
- if (TypeEl.ClassType=TPasAliasType)
- or (TypeEl.ClassType=TPasTypeAliasType) then
- begin
- if SameText(TypeEl.Name,'TGUIDString') then
- exit(true);
- TypeEl:=TPasAliasType(TypeEl).DestType;
- end
- else
- break;
- end;
- end;
- Result:=false;
- end;
- function TPasResolver.IsCustomAttribute(El: TPasElement): boolean;
- var
- ClassEl: TPasClassType;
- ClassScope: TPasClassScope;
- aModule: TPasModule;
- begin
- Result:=false;
- if (El=nil)
- or (El.ClassType<>TPasClassType) then exit;
- ClassEl:=TPasClassType(El);
- if (ClassEl.IsExternal) or (ClassEl.ObjKind<>okClass) then exit;
- while not SameText(ClassEl.Name,'TCustomAttribute') do
- begin
- ClassScope:=ClassEl.CustomData as TPasClassScope;
- if ClassScope.AncestorScope=nil then exit;
- ClassEl:=TPasClassType(ClassScope.AncestorScope.Element);
- end;
- if not (ClassEl.Parent is TPasSection) then
- exit; // this TCustomAttribute is not top level
- aModule:=ClassEl.GetModule;
- Result:=IsSystemUnit(aModule);
- end;
- function TPasResolver.IsSystemUnit(El: TPasModule): boolean;
- var
- Section: TPasSection;
- begin
- Result:=false;
- if El=nil then exit;
- if SameText(El.Name,'system') then exit(true);
- // tests and scripts are their own system unit: check if this is the root module
- if El.ClassType=TPasProgram then
- Section:=TPasProgram(El).ProgramSection
- else if El.ClassType=TPasLibrary then
- Section:=TPasLibrary(El).LibrarySection
- else
- Section:=El.InterfaceSection;
- Result:=length(Section.UsesClause)=0;
- end;
- function TPasResolver.GetAttributeCallsEl(El: TPasElement): TPasExprArray;
- var
- Parent: TPasElement;
- C: TClass;
- Members: TFPList;
- i: Integer;
- begin
- Result:=nil;
- if El=nil then exit;
- // find El in El.Parent members
- Parent:=El.Parent;
- if Parent=nil then exit;
- C:=Parent.ClassType;
- if C.InheritsFrom(TPasDeclarations) then
- Members:=TPasDeclarations(Parent).Declarations
- else if C.InheritsFrom(TPasMembersType) then
- Members:=TPasMembersType(Parent).Members
- else
- exit;
- i:=Members.IndexOf(El);
- if i<0 then exit;
- Result:=GetAttributeCalls(Members,i);
- end;
- function TPasResolver.GetAttributeCalls(Members: TFPList; Index: integer
- ): TPasExprArray;
- procedure AddAttributesInFront(Members: TFPList; i: integer);
- var
- j, l, k: Integer;
- Calls: TPasExprArray;
- begin
- // find attributes in front
- j:=i;
- while (j>0) and (TPasElement(Members[j-1]).ClassType=TPasAttributes) do
- dec(j);
- // collect all attribute calls
- l:=0;
- while j<i do
- begin
- Calls:=TPasAttributes(Members[j]).Calls;
- SetLength(Result,l+length(Calls));
- for k:=0 to length(Calls)-1 do
- begin
- Result[l]:=Calls[k];
- inc(l);
- end;
- inc(j);
- end;
- end;
- var
- El, CurEl: TPasElement;
- begin
- Result:=nil;
- El:=TPasElement(Members[Index]);
- AddAttributesInFront(Members,Index);
- if (El.ClassType=TPasClassType) and (not TPasClassType(El).IsForward) then
- repeat
- dec(Index);
- if Index<1 then break;
- CurEl:=TPasElement(Members[Index]);
- if (CurEl.ClassType=TPasClassType)
- and TPasClassType(CurEl).IsForward
- and (TPasClassType(CurEl).CustomData is TResolvedReference)
- and (TResolvedReference(TPasClassType(CurEl).CustomData).Declaration=El)
- then
- begin
- // class has a forward declaration -> add attributes
- AddAttributesInFront(Members,Index);
- break;
- end;
- until false;
- end;
- function TPasResolver.ProcNeedsParams(El: TPasProcedureType): boolean;
- begin
- Result:=(El.Args.Count>0) and (TPasArgument(El.Args[0]).ValueExpr=nil);
- end;
- function TPasResolver.ProcHasSelf(El: TPasProcedure): boolean;
- var
- C: TClass;
- begin
- if El.IsStatic then
- exit(false);
- C:=El.Parent.ClassType;
- if C.InheritsFrom(TPasSection) or (C=TProcedureBody) then
- exit(false);
- C:=El.ClassType;
- if (C=TPasClassConstructor) or (C=TPasClassDestructor) then
- exit(false);
- Result:=true;
- end;
- procedure TPasResolver.CreateProcSelfArg(Proc: TPasProcedure);
- var
- SelfArg: TPasArgument;
- SelfType, LoSelfType: TPasType;
- ProcScope: TPasProcedureScope;
- ClassOrRecScope: TPasClassOrRecordScope;
- ClassRecType: TPasMembersType;
- begin
- if Proc.IsStatic or Proc.IsExternal then exit;
- // add 'Self'
- if (Proc.ClassType=TPasClassConstructor)
- or (Proc.ClassType=TPasClassDestructor) then
- // actually class constructor/destructor are static
- exit;
- ProcScope:=TPasProcedureScope(Proc.CustomData);
- ClassOrRecScope:=ProcScope.ClassRecScope;
- if ClassOrRecScope=nil then exit;
- ClassRecType:=TPasMembersType(ClassOrRecScope.Element);
- if (Proc.ClassType=TPasClassProcedure)
- or (Proc.ClassType=TPasClassFunction) then
- begin
- if (ClassOrRecScope is TPasClassScope)
- and (TPasClassScope(ClassOrRecScope).CanonicalClassOf<>nil) then
- begin
- // 'Self' in a class method is the hidden classtype argument
- // Note: this is true in classes, adv records and helpers
- SelfArg:=TPasArgument.Create('Self',Proc);
- ProcScope.SelfArg:=SelfArg;
- {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
- SelfArg.Access:=argConst;
- SelfArg.ArgType:=TPasClassScope(ClassOrRecScope).CanonicalClassOf;
- SelfArg.ArgType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
- end
- else
- RaiseInternalError(20190106121745);
- end
- else
- begin
- // 'Self' in a method is the hidden instance argument
- SelfArg:=TPasArgument.Create('Self',Proc);
- ProcScope.SelfArg:=SelfArg;
- {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
- SelfType:=ClassRecType;
- if (SelfType.ClassType=TPasClassType)
- and (TPasClassType(SelfType).HelperForType<>nil) then
- begin
- // in a helper Self is a var argument of the helped variable
- SelfType:=TPasClassType(SelfType).HelperForType;
- end;
- LoSelfType:=ResolveAliasType(SelfType);
- if (LoSelfType is TPasClassType)
- and (TPasClassType(LoSelfType).ObjKind=okClass) then
- SelfArg.Access:=argConst
- else
- SelfArg.Access:=argVar;
- SelfArg.ArgType:=SelfType;
- SelfType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
- end;
- end;
- function TPasResolver.IsProcOverride(AncestorProc, DescendantProc: TPasProcedure
- ): boolean;
- var
- Proc, OverriddenProc: TPasProcedure;
- begin
- Result:=false;
- Proc:=DescendantProc;
- if not Proc.IsOverride then exit;
- if not AncestorProc.IsOverride and not AncestorProc.IsVirtual then exit;
- repeat
- OverriddenProc:=TPasProcedureScope(Proc.CustomData).OverriddenProc;
- if AncestorProc=OverriddenProc then exit(true);
- Proc:=OverriddenProc;
- until Proc=nil;
- end;
- function TPasResolver.GetTopLvlProc(El: TPasElement): TPasProcedure;
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El is TPasProcedure then
- Result:=TPasProcedure(El);
- El:=El.Parent;
- end;
- end;
- function TPasResolver.GetParentProc(El: TPasElement; GetDeclProc: boolean
- ): TPasProcedure;
- var
- ProcScope: TPasProcedureScope;
- begin
- Result:=nil;
- while El<>nil do
- begin
- if El is TPasProcedure then
- begin
- Result:=TPasProcedure(El);
- if GetDeclProc and (El.CustomData is TPasProcedureScope) then
- begin
- ProcScope:=TPasProcedureScope(El.CustomData);
- if ProcScope.DeclarationProc<>nil then
- Result:=ProcScope.DeclarationProc;
- end;
- exit;
- end;
- El:=El.Parent;
- end;
- end;
- function TPasResolver.GetRangeLength(RangeExpr: TPasExpr): TMaxPrecInt;
- var
- Range: TResEvalValue;
- begin
- Result:=0;
- Range:=Eval(RangeExpr,[refConst]);
- if Range=nil then
- RaiseNotYetImplemented(20170910210416,RangeExpr);
- try
- case Range.Kind of
- revkRangeInt:
- Result:=TResEvalRangeInt(Range).RangeEnd-TResEvalRangeInt(Range).RangeStart+1;
- revkRangeUInt:
- Result:=TResEvalRangeUInt(Range).RangeEnd-TResEvalRangeUInt(Range).RangeStart+1;
- else
- RaiseNotYetImplemented(20170910210554,RangeExpr);
- end;
- finally
- ReleaseEvalValue(Range);
- end;
- {$IFDEF VerbosePasResolver}
- {AllowWriteln}
- //if Result=0 then
- writeln('TPasResolver.GetRangeLength Result=',Result);
- {AllowWriteln-}
- {$ENDIF}
- end;
- function TPasResolver.EvalRangeLimit(RangeExpr: TPasExpr; Flags: TResEvalFlags;
- EvalLow: boolean; ErrorEl: TPasElement): TResEvalValue;
- var
- Range: TResEvalValue;
- EnumType: TPasEnumType;
- begin
- Result:=nil;
- Range:=Eval(RangeExpr,Flags+[refConst]);
- if Range=nil then
- RaiseNotYetImplemented(20170601191258,RangeExpr);
- case Range.Kind of
- revkRangeInt:
- case TResEvalRangeInt(Range).ElKind of
- revskEnum:
- begin
- EnumType:=NoNil(TResEvalRangeInt(Range).ElType) as TPasEnumType;
- if EvalLow then
- Result:=TResEvalEnum.CreateValue(
- TResEvalRangeInt(Range).RangeStart,TPasEnumValue(EnumType.Values[0]))
- else
- Result:=TResEvalEnum.CreateValue(
- TResEvalRangeInt(Range).RangeEnd,
- TPasEnumValue(EnumType.Values[EnumType.Values.Count-1]));
- end;
- revskInt:
- if EvalLow then
- Result:=TResEvalInt.CreateValue(TResEvalRangeInt(Range).RangeStart)
- else
- Result:=TResEvalInt.CreateValue(TResEvalRangeInt(Range).RangeEnd);
- revskChar:
- {$ifdef FPC_HAS_CPSTRING}
- if TResEvalRangeInt(Range).RangeEnd<256 then
- begin
- if EvalLow then
- Result:=TResEvalString.CreateValue(chr(TResEvalRangeInt(Range).RangeStart))
- else
- Result:=TResEvalString.CreateValue(chr(TResEvalRangeInt(Range).RangeEnd));
- end
- else
- {$endif}
- begin
- if EvalLow then
- Result:=TResEvalUTF16.CreateValue(widechar(TResEvalRangeInt(Range).RangeStart))
- else
- Result:=TResEvalUTF16.CreateValue(widechar(TResEvalRangeInt(Range).RangeEnd));
- end;
- revskBool:
- if EvalLow then
- Result:=TResEvalBool.CreateValue(TResEvalRangeInt(Range).RangeStart<>0)
- else
- Result:=TResEvalBool.CreateValue(TResEvalRangeInt(Range).RangeEnd<>0);
- else
- ReleaseEvalValue(Range);
- RaiseNotYetImplemented(20170601195240,ErrorEl);
- end;
- revkRangeUInt:
- if EvalLow then
- Result:=TResEvalUInt.CreateValue(TResEvalRangeUInt(Range).RangeStart)
- else
- Result:=TResEvalUInt.CreateValue(TResEvalRangeUInt(Range).RangeEnd);
- else
- ReleaseEvalValue(Range);
- RaiseNotYetImplemented(20170601195336,ErrorEl);
- end;
- ReleaseEvalValue(Range);
- end;
- function TPasResolver.EvalTypeRange(Decl: TPasType; Flags: TResEvalFlags
- ): TResEvalValue;
- var
- C: TClass;
- BaseTypeData: TResElDataBaseType;
- begin
- Result:=nil;
- Decl:=ResolveAliasType(Decl);
- C:=Decl.ClassType;
- if C=TPasRangeType then
- begin
- Result:=fExprEvaluator.Eval(TPasRangeType(Decl).RangeExpr,Flags);
- if (Result<>nil) and (Result.IdentEl=nil) then
- begin
- Result.IdentEl:=Decl;
- exit;
- end;
- end
- else if C=TPasEnumType then
- begin
- Result:=TResEvalRangeInt.CreateValue(revskEnum,TPasEnumType(Decl),
- 0,TMaxPrecInt(TPasEnumType(Decl).Values.Count)-1);
- Result.IdentEl:=Decl;
- exit;
- end
- else if C=TPasUnresolvedSymbolRef then
- begin
- if (Decl.CustomData is TResElDataBaseType) then
- begin
- BaseTypeData:=TResElDataBaseType(Decl.CustomData);
- case BaseTypeData.BaseType of
- btChar:
- begin
- Result:=TResEvalRangeInt.Create;
- TResEvalRangeInt(Result).ElKind:=revskChar;
- TResEvalRangeInt(Result).RangeStart:=0;
- {$ifdef FPC_HAS_CPSTRING}
- if BaseTypeChar in [btChar,btAnsiChar] then
- TResEvalRangeInt(Result).RangeEnd:=$ff
- else
- {$endif}
- TResEvalRangeInt(Result).RangeEnd:=$ffff;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar:
- Result:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff);
- {$endif}
- btWideChar:
- Result:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ffff);
- btBoolean,btByteBool,btWordBool{$ifdef HasInt64},btQWordBool{$endif}:
- Result:=TResEvalRangeInt.CreateValue(revskBool,nil,0,1);
- btByte,
- btShortInt,
- btWord,
- btSmallInt,
- btLongWord,
- btLongint,
- {$ifdef HasInt64}
- btInt64,
- btComp,
- {$endif}
- btIntSingle,
- btUIntSingle,
- btIntDouble,
- btUIntDouble:
- begin
- Result:=TResEvalRangeInt.Create;
- TResEvalRangeInt(Result).ElKind:=revskInt;
- GetIntegerRange(BaseTypeData.BaseType,
- TResEvalRangeInt(Result).RangeStart,TResEvalRangeInt(Result).RangeEnd);
- end;
- end;
- end;
- end;
- end;
- function TPasResolver.HasTypeInfo(El: TPasType): boolean;
- begin
- Result:=false;
- if El=nil then exit;
- if El.CustomData is TResElDataBaseType then
- exit(true); // base type
- if El.Parent=nil then exit;
- if El.Parent is TPasType then
- begin
- if not HasTypeInfo(TPasType(El.Parent)) then
- exit;
- end
- else if ElHasModeSwitch(El,msOmitRTTI) then
- exit
- else if El.Parent is TPasAnonymousProcedure then
- exit;
- Result:=true;
- end;
- function TPasResolver.GetActualBaseType(bt: TResolverBaseType
- ): TResolverBaseType;
- begin
- case bt of
- btChar: Result:=BaseTypeChar;
- btString: Result:=BaseTypeString;
- btExtended: Result:=BaseTypeExtended;
- else Result:=bt;
- end;
- end;
- function TPasResolver.GetCombinedBoolean(Bool1, Bool2: TResolverBaseType;
- ErrorEl: TPasElement): TResolverBaseType;
- begin
- if Bool1=Bool2 then exit(Bool1);
- case Bool1 of
- btBoolean: Result:=Bool2;
- btByteBool: if Bool2<>btBoolean then Result:=Bool2;
- btWordBool: if not (Bool2 in [btBoolean,btByteBool]) then Result:=Bool2;
- btLongBool: if not (Bool2 in [btBoolean,btByteBool,btWordBool]) then Result:=Bool2;
- {$ifdef HasInt64}
- btQWordBool: if not (Bool2 in [btBoolean,btByteBool,btWordBool,btLongBool]) then Result:=Bool2;
- {$endif}
- else
- RaiseNotYetImplemented(20170420093805,ErrorEl);
- end;
- end;
- function TPasResolver.GetCombinedInt(const Int1, Int2: TPasResolverResult;
- ErrorEl: TPasElement): TResolverBaseType;
- var
- Precision1, Precision2: word;
- Signed1, Signed2: boolean;
- begin
- if Int1.BaseType=Int2.BaseType then exit;
- GetIntegerProps(Int1.BaseType,Precision1,Signed1);
- GetIntegerProps(Int2.BaseType,Precision2,Signed2);
- if Precision1=Precision2 then
- begin
- if Signed1<>Signed2 then
- Precision1:=Max(Precision1,Precision2)+1;
- end;
- Result:=GetIntegerBaseType(Max(Precision1,Precision2),Signed1 or Signed2,ErrorEl);
- end;
- procedure TPasResolver.GetIntegerProps(bt: TResolverBaseType; out
- Precision: word; out Signed: boolean);
- begin
- case bt of
- btByte: begin Precision:=8; Signed:=false; end;
- btShortInt: begin Precision:=8; Signed:=true; end;
- btWord: begin Precision:=16; Signed:=false; end;
- btSmallInt: begin Precision:=16; Signed:=true; end;
- btIntSingle: begin Precision:=23; Signed:=true; end;
- btUIntSingle: begin Precision:=22; Signed:=false; end;
- btLongWord: begin Precision:=32; Signed:=false; end;
- btLongint: begin Precision:=32; Signed:=true; end;
- btIntDouble: begin Precision:=53; Signed:=true; end;
- btUIntDouble: begin Precision:=52; Signed:=false; end;
- {$ifdef HasInt64}
- btQWord: begin Precision:=64; Signed:=false; end;
- btInt64,btComp: begin Precision:=64; Signed:=true; end;
- {$endif}
- else
- RaiseInternalError(20170420095727);
- end;
- end;
- function TPasResolver.GetIntegerRange(bt: TResolverBaseType; out MinVal,
- MaxVal: TMaxPrecInt): boolean;
- begin
- Result:=true;
- if bt=btExtended then bt:=BaseTypeExtended;
- case bt of
- btByte: begin MinVal:=Low(byte); MaxVal:=High(byte); end;
- btShortInt: begin MinVal:=low(ShortInt); MaxVal:=high(ShortInt); end;
- btWord: begin MinVal:=low(word); MaxVal:=high(word); end;
- btSmallInt: begin MinVal:=low(SmallInt); MaxVal:=high(SmallInt); end;
- btLongWord: begin MinVal:=low(LongWord); MaxVal:=high(LongWord); end;
- btLongint: begin MinVal:=low(LongInt); MaxVal:=high(LongInt); end;
- {$ifdef HasInt64}
- btInt64,
- btComp: begin MinVal:=low(int64); MaxVal:=high(int64); end;
- {$endif}
- btSingle,btIntSingle: begin MinVal:=MinSafeIntSingle; MaxVal:=MaxSafeIntSingle; end;
- btUIntSingle: begin MinVal:=0; MaxVal:=MaxSafeIntSingle; end;
- btDouble,btIntDouble: begin MinVal:=MinSafeIntDouble; MaxVal:=MaxSafeIntDouble; end;
- btUIntDouble: begin MinVal:=0; MaxVal:=MaxSafeIntDouble; end;
- btCurrency: begin MinVal:=MinSafeIntCurrency; MaxVal:=MaxSafeIntCurrency; end;
- else
- Result:=false;
- end;
- end;
- function TPasResolver.GetIntegerBaseType(Precision: word; Signed: boolean;
- ErrorEl: TPasElement): TResolverBaseType;
- begin
- if Precision<=8 then
- begin
- if Signed then
- Result:=btShortInt
- else
- Result:=btByte;
- if BaseTypes[Result]<>nil then exit;
- end;
- if Precision<=16 then
- begin
- if Signed then
- Result:=btSmallInt
- else
- Result:=btWord;
- if BaseTypes[Result]<>nil then exit;
- end;
- if (Precision<=22) and (not Signed) and (BaseTypes[btUIntSingle]<>nil) then
- exit(btUIntSingle);
- if (Precision<=23) and Signed and (BaseTypes[btIntSingle]<>nil) then
- exit(btIntSingle);
- if Precision<=32 then
- begin
- if Signed then
- Result:=btLongint
- else
- Result:=btLongWord;
- if BaseTypes[Result]<>nil then exit;
- end;
- if (Precision<=52) and (not Signed) and (BaseTypes[btUIntDouble]<>nil) then
- exit(btUIntDouble);
- if (Precision<=53) and Signed and (BaseTypes[btIntDouble]<>nil) then
- exit(btIntDouble);
- {$ifdef HasInt64}
- if Precision<=64 then
- begin
- if Signed then
- Result:=btInt64
- else
- Result:=btQWord;
- if BaseTypes[Result]<>nil then exit;
- end;
- {$endif}
- if ErrorEl<>nil then
- RaiseRangeCheck(20170420100336,ErrorEl)
- else
- Result:=btNone;
- end;
- function TPasResolver.GetSmallestIntegerBaseType(MinVal, MaxVal: TMaxPrecInt
- ): TResolverBaseType;
- // returns BaseTypeExtended if too big
- var
- V: TMaxPrecInt;
- begin
- if MinVal>MaxVal then
- MinVal:=MaxVal;
- if MinVal<0 then
- begin
- if MaxVal>-(MinVal+1) then
- V:=MaxVal
- else
- V:=-(MinVal+1);
- if V<=high(ShortInt) then
- Result:=btShortInt
- else if V<=high(SmallInt) then
- Result:=btSmallInt
- else if (BaseTypes[btIntSingle]<>nil) and (V<=MaxSafeIntSingle) then
- Result:=btIntSingle
- else if V<=High(Longint) then
- Result:=btLongint
- else if (BaseTypes[btIntDouble]<>nil) and (V<=MaxSafeIntDouble) then
- Result:=btIntDouble
- else
- begin
- Result:=btIntMax;
- if BaseTypes[Result]=nil then
- Result:=BaseTypeExtended;
- end;
- end
- else
- begin
- V:=MaxVal;
- if V<=high(Byte) then
- Result:=btByte
- else if V<=high(Word) then
- Result:=btWord
- else if (BaseTypes[btUIntSingle]<>nil) and (V<=MaxSafeIntSingle) then
- Result:=btUIntSingle
- else if V<=High(LongWord) then
- Result:=btLongWord
- else if (BaseTypes[btUIntDouble]<>nil) and (V<=MaxSafeIntDouble) then
- Result:=btUIntDouble
- else
- begin
- Result:=btIntMax;
- if BaseTypes[Result]=nil then
- Result:=BaseTypeExtended;
- end;
- end;
- end;
- function TPasResolver.GetCombinedChar(const Char1, Char2: TPasResolverResult;
- ErrorEl: TPasElement): TResolverBaseType;
- var
- bt1, bt2: TResolverBaseType;
- begin
- bt1:=GetActualBaseType(Char1.BaseType);
- bt2:=GetActualBaseType(Char2.BaseType);
- if bt1=bt2 then exit(bt1);
- if not (bt1 in btAllChars) then
- RaiseInternalError(20170420103128);
- Result:=btWideChar;
- if Result=BaseTypeChar then
- Result:=btChar;
- if ErrorEl=nil then ;
- end;
- function TPasResolver.GetCombinedString(const Str1, Str2: TPasResolverResult;
- ErrorEl: TPasElement): TResolverBaseType;
- var
- bt1, bt2: TResolverBaseType;
- begin
- bt1:=GetActualBaseType(Str1.BaseType);
- bt2:=GetActualBaseType(Str2.BaseType);
- if bt1=bt2 then exit(bt1);
- case bt1 of
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar:
- case bt2 of
- btChar: Result:=btChar;
- btWideChar: Result:=btWideChar;
- else Result:=bt2;
- end;
- {$endif}
- btWideChar:
- case bt2 of
- {$ifdef FPC_HAS_CPSTRING}
- btAnsiChar: Result:=btWideChar;
- {$endif}
- btWideString: Result:=btWideString;
- btString,btUnicodeString
- {$ifdef FPC_HAS_CPSTRING},btShortString,btAnsiString,btRawByteString{$endif}:
- Result:=btUnicodeString;
- else RaiseNotYetImplemented(20170420103808,ErrorEl);
- end;
- {$ifdef FPC_HAS_CPSTRING}
- btShortString:
- case bt2 of
- btChar,btAnsiChar: Result:=btShortString;
- btString,btAnsiString: Result:=btAnsiString;
- btRawByteString: Result:=btRawByteString;
- btWideChar,btUnicodeString: Result:=btUnicodeString;
- btWideString: Result:=btWideString;
- else RaiseNotYetImplemented(20170420120937,ErrorEl);
- end;
- {$endif}
- btString{$ifdef FPC_HAS_CPSTRING},btAnsiString{$endif}:
- case bt2 of
- {$ifdef FPC_HAS_CPSTRING}
- btChar,btAnsiChar,btString,btShortString,btRawByteString: Result:=btAnsiString;
- {$endif}
- btWideChar,btUnicodeString: Result:=btUnicodeString;
- btWideString: Result:=btWideString;
- else RaiseNotYetImplemented(20170420121201,ErrorEl);
- end;
- {$ifdef FPC_HAS_CPSTRING}
- btRawByteString:
- case bt2 of
- btChar,btAnsiChar,btRawByteString,btShortString: Result:=btRawByteString;
- btString,btAnsiString: Result:=btAnsiString;
- btWideChar,btUnicodeString: Result:=btUnicodeString;
- btWideString: Result:=btWideString;
- else RaiseNotYetImplemented(20170420121352,ErrorEl);
- end;
- {$endif}
- btWideString:
- case bt2 of
- btChar,btWideChar,{$ifdef FPC_HAS_CPSTRING}btAnsiChar,btShortString,{$endif}btWideString:
- Result:=btWideString;
- btString,{$ifdef FPC_HAS_CPSTRING}btAnsiString,{$endif}btUnicodeString:
- Result:=btUnicodeString;
- else RaiseNotYetImplemented(20170420121532,ErrorEl);
- end;
- btUnicodeString:
- Result:=btUnicodeString;
- else
- RaiseNotYetImplemented(20170420103153,ErrorEl);
- end;
- if Result=BaseTypeChar then
- Result:=btChar
- else if Result=BaseTypeString then
- Result:=btString;
- end;
- function TPasResolver.GetCombinedBaseType(const A, B: TPasResolverResult;
- ErrorEl: TPasElement): TResolverBaseType;
- begin
- Result:=btNone;
- if A.BaseType in btAllBooleans then
- begin
- if B.BaseType in btAllBooleans then
- Result:=GetCombinedBoolean(A.BaseType,B.BaseType,ErrorEl);
- end
- else if A.BaseType in btAllInteger then
- begin
- if B.BaseType in btAllInteger then
- Result:=GetCombinedInt(A,B,ErrorEl);
- end
- else if A.BaseType in btAllChars then
- begin
- if B.BaseType in btAllChars then
- Result:=GetCombinedChar(A,B,ErrorEl)
- else if B.BaseType in btAllStrings then
- Result:=GetCombinedString(A,B,ErrorEl);
- end
- else if A.BaseType in btAllStrings then
- begin
- if B.BaseType in btAllStringAndChars then
- Result:=GetCombinedString(A,B,ErrorEl);
- end;
- end;
- function TPasResolver.IsElementSkipped(El: TPasElement): boolean;
- begin
- Result:=El=nil;
- end;
- function TPasResolver.FindLocalBuiltInSymbol(El: TPasElement): TPasElement;
- var
- Data: TObject;
- begin
- Data:=El.CustomData;
- if Data=nil then
- RaiseInternalError(20180215185302,GetObjName(El));
- if Data.ClassType=TResElDataBaseType then
- Result:=BaseTypes[TResElDataBaseType(Data).BaseType]
- else if (Data.ClassType=TResElDataBuiltInProc)
- and (TResElDataBuiltInProc(Data).BuiltIn<>bfCustom) then
- Result:=BuiltInProcs[TResElDataBuiltInProc(Data).BuiltIn].Element
- else
- Result:=nil;
- end;
- function TPasResolver.GetFirstSection(WithUnitImpl: boolean): TPasSection;
- var
- Module: TPasModule;
- begin
- Result:=nil;
- Module:=RootElement;
- if Module=nil then exit;
- if Module is TPasProgram then
- Result:=TPasProgram(Module).ProgramSection
- else if Module is TPasLibrary then
- Result:=TPasLibrary(Module).LibrarySection
- else
- begin
- Result:=Module.InterfaceSection;
- if WithUnitImpl and (Result=nil) then
- Result:=Module.ImplementationSection;
- end;
- end;
- function TPasResolver.GetLastSection: TPasSection;
- var
- Module: TPasModule;
- begin
- Result:=nil;
- Module:=RootElement;
- if Module=nil then exit;
- if Module is TPasProgram then
- Result:=TPasProgram(Module).ProgramSection
- else if Module is TPasLibrary then
- Result:=TPasLibrary(Module).LibrarySection
- else if Module.ImplementationSection<>nil then
- Result:=Module.ImplementationSection
- else
- Result:=Module.InterfaceSection;
- end;
- function TPasResolver.GetParentSection(El: TPasElement): TPasSection;
- begin
- while El<>nil do
- begin
- if El is TPasSection then exit(TPasSection(El));
- El:=El.Parent;
- end;
- Result:=nil;
- end;
- function TPasResolver.FindUsedUnitInSection(aMod: TPasModule;
- Section: TPasSection): TPasUsesUnit;
- var
- Clause: TPasUsesClause;
- i: Integer;
- begin
- Result:=nil;
- if Section=nil then exit;
- Clause:=Section.UsesClause;
- for i:=0 to length(Clause)-1 do
- if Clause[i].Module=aMod then exit(Clause[i]);
- end;
- function TPasResolver.FirstSectionUsesUnit(aModule: TPasModule): boolean;
- var
- aSection: TPasSection;
- begin
- Result:=false;
- aSection:=GetFirstSection(false);
- if aSection=nil then
- exit;
- Result:=FindUsedUnitInSection(aModule,aSection)<>nil;
- end;
- function TPasResolver.ImplementationUsesUnit(aModule: TPasModule;
- NotInIntf: boolean): boolean;
- var
- MyModule: TPasModule;
- begin
- Result:=false;
- MyModule:=RootElement;
- if MyModule=nil then exit;
- if FindUsedUnitInSection(aModule,MyModule.ImplementationSection)=nil then
- exit;
- if NotInIntf then
- Result:=not FirstSectionUsesUnit(aModule);
- end;
- function TPasResolver.GetShiftAndMaskForLoHiFunc(BaseType: TResolverBaseType;
- isLoFunc: Boolean; out Mask: LongWord): Integer;
- const
- SHIFT_SIZE: array[btByte..{$IFDEF HasInt64}btComp{$ELSE}btIntDouble{$ENDIF}] of Integer = (
- 4, // btByte
- 8, // btShortInt FPC lo/hi(shortint) works like SmallInt
- 8, 8, // btWord, btSmallInt
- 16, 16, 16, 16, // btUIntSingle, btIntSingle, btLongWord, btLongint
- 32, 32 // btUIntDouble, btIntDouble
- {$IFDEF HasInt64}
- , 32, 32, 32 // btQWord, btInt64, btComp
- {$endif}
- );
- begin
- if (BaseType >= Low(SHIFT_SIZE)) and (BaseType <= High(SHIFT_SIZE)) then
- begin
- if msDelphi in CurrentParser.CurrentModeswitches then
- Result := 8
- else
- Result := SHIFT_SIZE[BaseType];
- case Result of
- 8: Mask := $FF;
- 16: Mask := $FFFF;
- 32: Mask := $FFFFFFFF;
- else
- {4} Mask := $F;
- end;
- if isLoFunc then
- Result := 0;
- end
- else
- begin
- RaiseInternalError(20190130122300);
- Result := -1;
- end;
- end;
- function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType,
- ResolvedDestType: TPasResolverResult): integer;
- // finds distance between classes SrcType and DestType
- begin
- Result:=CheckClassIsClass(ResolvedSrcType.LoTypeEl,ResolvedDestType.LoTypeEl);
- end;
- function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer;
- // check if Src is equal or descends from Dest
- // Generics: TBird<T> is both directions a TBird<word>
- // and TBird<TMap<T>> is both directions a TBird<TMap<word>>
- // but a TBird<word> is not a TBird<char>
- function CheckSpecialized(SrcScope, DestScope: TPasGenericScope): boolean;
- var
- SrcParams, DestParams: TPasTypeArray;
- i: Integer;
- SrcParam, DestParam: TPasType;
- SrcParamScope, DestParamScope: TPasGenericScope;
- SrcSpecializedFromItem, DestSpecializedFromItem: TPRSpecializedItem;
- begin
- SrcSpecializedFromItem:=SrcScope.SpecializedFromItem;
- DestSpecializedFromItem:=DestScope.SpecializedFromItem;
- if SrcSpecializedFromItem=nil then
- exit(false);
- if DestSpecializedFromItem=nil then
- exit(false);
- if SrcSpecializedFromItem.GenericEl<>DestSpecializedFromItem.GenericEl then
- exit(false);
- // specialized from same generic -> check params
- SrcParams:=SrcSpecializedFromItem.Params;
- DestParams:=DestSpecializedFromItem.Params;
- for i:=0 to length(SrcParams)-1 do
- begin
- SrcParam:=ResolveAliasType(SrcParams[i]);
- DestParam:=ResolveAliasType(DestParams[i]);
- if (SrcParam is TPasGenericTemplateType)
- or (DestParam is TPasGenericTemplateType)
- or (SrcParam=DestParam)
- then
- // ok
- else if (SrcParam is TPasGenericType) and (DestParam is TPasGenericType) then
- begin
- // e.g. TList<Src<...>> and TList<Dest<...>>
- SrcParamScope:=SrcParam.CustomData as TPasGenericScope;
- DestParamScope:=DestParam.CustomData as TPasGenericScope;
- if not CheckSpecialized(SrcParamScope,DestParamScope) then
- exit(false);
- end
- else
- exit(false); // specialized with different params -> incompatible
- end;
- Result:=true;
- end;
- var
- SrcClassEl: TPasClassType;
- SrcScope, DestScope: TPasClassScope;
- GenericType: TPasGenericType;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckClassIsClass SrcType=',GetObjName(SrcType),' DestType=',GetObjName(DestType));
- {$ENDIF}
- if DestType=nil then exit(cIncompatible);
- DestType:=ResolveAliasType(DestType);
- if DestType.ClassType<>TPasClassType then
- exit(cIncompatible);
- DestScope:=DestType.CustomData as TPasClassScope;
- Result:=cExact;
- while SrcType<>nil do
- begin
- {$IFDEF VerbosePasResolver}
- writeln(' Step=',Result,' SrcType=',GetObjName(SrcType),' DestType=',GetObjName(DestType));
- {$ENDIF}
- if SrcType=DestType then
- exit
- else if SrcType.ClassType=TPasAliasType then
- // alias -> skip
- SrcType:=TPasAliasType(SrcType).DestType
- else if SrcType.ClassType=TPasTypeAliasType then
- begin
- // type alias -> increase distance
- SrcType:=TPasAliasType(SrcType).DestType;
- inc(Result);
- end
- else if SrcType.ClassType=TPasSpecializeType then
- begin
- // specialize -> skip
- if SrcType.CustomData is TPasSpecializeTypeData then
- SrcType:=TPasSpecializeTypeData(SrcType.CustomData).SpecializedType
- else
- SrcType:=TPasSpecializeType(SrcType).DestType;
- end
- else if SrcType.ClassType=TPasClassType then
- begin
- SrcClassEl:=TPasClassType(SrcType);
- if SrcClassEl.IsForward then
- // class forward -> skip
- SrcType:=(SrcClassEl.CustomData as TResolvedReference).Declaration as TPasType
- else
- begin
- if (SrcClassEl.GenericTemplateTypes<>nil) and (SrcClassEl.GenericTemplateTypes.Count>0) then
- begin
- // SrcType is a generic
- if DestScope.SpecializedFromItem<>nil then
- begin
- // DestType is specialized
- GenericType:=TPasGenericType(DestScope.SpecializedFromItem.GenericEl);
- {$IFDEF VerbosePasResolver}
- writeln(' DestType is specialized from ',GetObjName(GenericType));
- {$ENDIF}
- if SrcType=GenericType then
- exit; // DestType is a specialized SrcType
- end;
- end;
- SrcScope:=SrcClassEl.CustomData as TPasClassScope;
- if (SrcScope.SpecializedFromItem<>nil)
- and (DestScope.SpecializedFromItem<>nil)
- and CheckSpecialized(SrcScope,DestScope) then
- exit;
- // class ancestor -> increase distance
- SrcType:=SrcScope.DirectAncestor;
- inc(Result);
- end;
- end
- else
- exit(cIncompatible);
- end;
- Result:=cIncompatible;
- end;
- function TPasResolver.CheckClassesAreRelated(TypeA, TypeB: TPasType): integer;
- begin
- Result:=CheckClassIsClass(TypeA,TypeB);
- if Result<>cIncompatible then exit;
- Result:=CheckClassIsClass(TypeB,TypeA);
- end;
- function TPasResolver.CheckAssignCompatibilityClasses(LType,
- RType: TPasClassType): integer;
- begin
- Result:=cIncompatible;
- if LType=nil then ;
- if RType=nil then ;
- end;
- function TPasResolver.GetClassImplementsIntf(ClassEl, Intf: TPasClassType
- ): TPasClassType;
- begin
- Result:=nil;
- while ClassEl<>nil do
- begin
- if (ClassEl=Intf) or (IndexOfImplementedInterface(ClassEl,Intf)>=0) then
- exit(ClassEl);
- ClassEl:=GetPasClassAncestor(ClassEl,true) as TPasClassType;
- end;
- end;
- end.
|