12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382153831538415385153861538715388153891539015391153921539315394153951539615397153981539915400154011540215403154041540515406154071540815409154101541115412154131541415415154161541715418154191542015421154221542315424154251542615427154281542915430154311543215433154341543515436154371543815439154401544115442154431544415445154461544715448154491545015451154521545315454154551545615457154581545915460154611546215463154641546515466154671546815469154701547115472154731547415475154761547715478154791548015481154821548315484154851548615487154881548915490154911549215493154941549515496154971549815499155001550115502155031550415505155061550715508155091551015511155121551315514155151551615517155181551915520155211552215523155241552515526155271552815529155301553115532155331553415535155361553715538155391554015541155421554315544155451554615547155481554915550155511555215553155541555515556155571555815559155601556115562155631556415565155661556715568155691557015571155721557315574155751557615577155781557915580155811558215583155841558515586155871558815589155901559115592155931559415595155961559715598155991560015601156021560315604156051560615607156081560915610156111561215613156141561515616156171561815619156201562115622156231562415625156261562715628156291563015631156321563315634156351563615637156381563915640156411564215643156441564515646156471564815649156501565115652156531565415655156561565715658156591566015661156621566315664156651566615667156681566915670156711567215673156741567515676156771567815679156801568115682156831568415685156861568715688156891569015691156921569315694156951569615697156981569915700157011570215703157041570515706157071570815709157101571115712157131571415715157161571715718157191572015721157221572315724157251572615727157281572915730157311573215733157341573515736157371573815739157401574115742157431574415745157461574715748157491575015751157521575315754157551575615757157581575915760157611576215763157641576515766157671576815769157701577115772157731577415775157761577715778157791578015781157821578315784157851578615787157881578915790157911579215793157941579515796157971579815799158001580115802158031580415805158061580715808158091581015811158121581315814158151581615817158181581915820158211582215823158241582515826158271582815829158301583115832158331583415835158361583715838158391584015841158421584315844158451584615847158481584915850158511585215853158541585515856158571585815859158601586115862158631586415865158661586715868158691587015871158721587315874158751587615877158781587915880158811588215883158841588515886158871588815889158901589115892158931589415895158961589715898158991590015901159021590315904159051590615907159081590915910159111591215913159141591515916159171591815919159201592115922159231592415925159261592715928159291593015931159321593315934159351593615937159381593915940159411594215943159441594515946159471594815949159501595115952159531595415955159561595715958159591596015961159621596315964159651596615967159681596915970159711597215973159741597515976159771597815979159801598115982159831598415985159861598715988159891599015991159921599315994159951599615997159981599916000160011600216003160041600516006160071600816009160101601116012160131601416015160161601716018160191602016021160221602316024160251602616027160281602916030160311603216033160341603516036160371603816039160401604116042160431604416045160461604716048160491605016051160521605316054160551605616057160581605916060160611606216063160641606516066160671606816069160701607116072160731607416075160761607716078160791608016081160821608316084160851608616087160881608916090160911609216093 |
- {
- This file is part of the Free Component Library
- Pascal source parser
- Copyright (c) 2000-2005 by
- Areca Systems GmbH / Sebastian Guenther, [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
- - try..finally..except, on, else, raise
- - for loop
- - spot duplicates
- - type cast base types
- - char
- - ord(), chr()
- - record
- - variants
- - const param makes children const too
- - 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
- - 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)
- - pointer TPasPointerType
- - nil, assigned(), typecast, class, classref, dynarray, procvar
- - 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])
- ToDo:
- - $pop, $push
- - $writableconst off $J-
- - $RTTI inherited|explicit
- - range checking:
- - indexedprop[param]
- - case-of unique
- - defaultvalue
- - fail to write a loop var inside the loop
- - nested classes
- - records - TPasRecordType,
- - const TRecordValues
- - function default(record type): record
- - pointer of record
- - proc: check if forward and impl default values match
- - call array of proc without ()
- - array+array
- - pointer type, ^type, @ operator, [] operator
- - type alias type
- - object
- - interfaces
- - implements, supports
- - generics, nested param lists
- - type helpers
- - record/class helpers
- - generics
- - futures
- - operator overload
- - operator enumerator
- - attributes
- - anonymous functions
- - TPasFileType
- - labels
- - $warn identifier ON|off|error|default
- - $zerobasedstrings on|off
- 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;
- {$mode objfpc}{$H+}
- {$inline on}
- {$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
- {$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
- interface
- uses
- Classes, SysUtils, Math, contnrs,
- PasTree, PScanner, PParser, PasResolveEval;
- const
- ParserMaxEmbeddedColumn = 2048;
- ParserMaxEmbeddedRow = $7fffffff div ParserMaxEmbeddedColumn;
- type
- TResolverBaseType = (
- btNone, // undefined
- btCustom, // provided by descendant resolver
- btContext, // a class or record
- btModule,
- btUntyped, // TPasArgument without ArgType
- btChar, // char
- btAnsiChar, // ansichar
- btWideChar, // widechar
- btString, // string
- btAnsiString, // ansistring
- btShortString, // shortstring
- btWideString, // widestring
- btUnicodeString,// unicodestring
- btRawByteString, // rawbytestring
- 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
- btQWordBool, // qwordbool true=not zero
- 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
- btQWord, // qword 0..18446744073709551615, bytes 8
- btInt64, // int64 -9223372036854775808..9223372036854775807, bytes 8
- btComp, // as Int64, not ordinal
- btPointer, // pointer
- btFile, // file
- btText, // text
- btVariant, // variant
- btNil, // nil = pointer, class, procedure, method, ...
- btProc, // TPasProcedure
- btBuiltInProc,
- btSet, // [] see SubType
- //btArrayLit, // [] array literal, can also be round bracket in var a:arraytype = (x,y)
- btRange // a..b see SubType
- );
- TResolveBaseTypes = set of TResolverBaseType;
- const
- btAllInteger = [btByte,btShortInt,btWord,btSmallInt,btIntSingle,btUIntSingle,
- btLongWord,btLongint,btIntDouble,btUIntDouble,btQWord,btInt64,btComp];
- btAllChars = [btChar,btAnsiChar,btWideChar];
- btAllStrings = [btString,btAnsiString,btShortString,
- btWideString,btUnicodeString,btRawByteString];
- btAllStringAndChars = btAllStrings+btAllChars;
- btAllFloats = [btSingle,btDouble,btExtended,btCExtended,btCurrency];
- btAllBooleans = [btBoolean,btByteBool,btWordBool,btLongBool,btQWordBool];
- btArrayRangeTypes = btAllChars+btAllBooleans+btAllInteger;
- btAllRanges = btArrayRangeTypes+[btRange];
- btAllStandardTypes = [
- btChar,
- btAnsiChar,
- btWideChar,
- btString,
- btAnsiString,
- btShortString,
- btWideString,
- btUnicodeString,
- btRawByteString,
- btSingle,
- btDouble,
- btExtended,
- btCExtended,
- btCurrency,
- btBoolean,
- btByteBool,
- btWordBool,
- btLongBool,
- btQWordBool,
- btByte,
- btShortInt,
- btWord,
- btSmallInt,
- btLongWord,
- btLongint,
- btQWord,
- btInt64,
- btComp,
- btPointer,
- btFile,
- btText,
- btVariant
- ];
- ResBaseTypeNames: array[TResolverBaseType] of string =(
- 'None',
- 'Custom',
- 'Context',
- 'Module',
- 'Untyped',
- 'Char',
- 'AnsiChar',
- 'WideChar',
- 'String',
- 'AnsiString',
- 'ShortString',
- 'WideString',
- 'UnicodeString',
- 'RawByteString',
- 'Single',
- 'Double',
- 'Extended',
- 'CExtended',
- 'Currency',
- 'Boolean',
- 'ByteBool',
- 'WordBool',
- 'LongBool',
- 'QWordBool',
- 'Byte',
- 'ShortInt',
- 'Word',
- 'SmallInt',
- 'UIntSingle',
- 'IntSingle',
- 'LongWord',
- 'Longint',
- 'UIntDouble',
- 'IntDouble',
- 'QWord',
- 'Int64',
- 'Comp',
- 'Pointer',
- 'File',
- 'Text',
- 'Variant',
- 'Nil',
- 'Procedure/Function',
- 'BuiltInProc',
- 'set',
- 'range..'
- );
- type
- TResolverBuiltInProc = (
- bfCustom,
- bfLength,
- bfSetLength,
- bfInclude,
- bfExclude,
- bfBreak,
- bfContinue,
- bfExit,
- bfInc,
- bfDec,
- bfAssigned,
- bfChr,
- bfOrd,
- bfLow,
- bfHigh,
- bfPred,
- bfSucc,
- bfStrProc,
- bfStrFunc,
- bfConcatArray,
- bfCopyArray,
- bfInsertArray,
- bfDeleteArray,
- bfTypeInfo,
- bfAssert
- );
- 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',
- 'Concat',
- 'Copy',
- 'Insert',
- 'Delete',
- 'TypeInfo',
- 'Assert'
- );
- bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)];
- const
- ResolverResultVar = 'Result';
- type
- { EPasResolve }
- EPasResolve = class(Exception)
- private
- FPasElement: TPasElement;
- procedure SetPasElement(AValue: TPasElement);
- public
- Id: int64;
- 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;
- TPasScope = class;
- 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; // methods sets this to a TPasClassType,
- // 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;
- 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;
- 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);
- public
- FirstName: string;
- PendingResolvers: TFPList; // list of TPasResolver waiting for the unit interface
- Flags: TPasModuleScopeFlags;
- ScannerBoolSwitches: 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;
- end;
- 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;
- { TPasIdentifierScope - elements with a list of sub identifiers }
- TPasIdentifierScope = Class(TPasScope)
- private
- FItems: TFPHashList;
- procedure InternalAdd(Item: TPasIdentifier);
- procedure OnClearItem(Item, Dummy: pointer);
- protected
- procedure OnWriteItem(Item, Dummy: pointer);
- public
- constructor Create; override;
- destructor Destroy; override;
- 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;
- end;
- { TPasDefaultScope - root scope }
- TPasDefaultScope = class(TPasIdentifierScope)
- public
- class function IsStoredInElement: boolean; override;
- end;
- { 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
- Finished: boolean;
- 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;
- { TPasEnumTypeScope }
- TPasEnumTypeScope = Class(TPasIdentifierScope)
- public
- CanonicalSet: TPasSetType;
- destructor Destroy; override;
- end;
- { TPasRecordScope }
- TPasRecordScope = Class(TPasIdentifierScope)
- end;
- TPasClassScopeFlag = (
- pcsfAncestorResolved,
- pcsfSealed,
- pcsfPublished // default visibility is published due to $M directive
- );
- TPasClassScopeFlags = set of TPasClassScopeFlag;
- { TPasClassScope }
- TPasClassScope = Class(TPasIdentifierScope)
- public
- AncestorScope: TPasClassScope;
- CanonicalClassOf: TPasClassOfType;
- DirectAncestor: TPasType; // TPasClassType or TPasAliasType or TPasTypeAliasType
- DefaultProperty: TPasProperty;
- Flags: TPasClassScopeFlags;
- AbstractProcs: TArrayOfPasProcedure;
- 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;
- TPasClassScopeClass = class of TPasClassScope;
- TPasProcedureScopeFlag = (
- ppsfIsGroupOverload // mode objfpc: one overload is enough for all procs in same scope
- );
- TPasProcedureScopeFlags = set of TPasProcedureScopeFlag;
- { TPasProcedureScope }
- TPasProcedureScope = Class(TPasIdentifierScope)
- public
- DeclarationProc: TPasProcedure; // the corresponding forward declaration
- ImplProc: TPasProcedure; // the corresponding proc with Body
- OverriddenProc: TPasProcedure; // if IsOverride then this is the ancestor proc (virtual or override)
- ClassScope: TPasClassScope;
- SelfArg: TPasArgument;
- Mode: TModeSwitch;
- Flags: TPasProcedureScopeFlags;
- ScannerBoolSwitches: TBoolSwitches;
- 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;
- 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,
- wesfConstParent // not writable
- );
- TPasWithExprScopeFlags = set of TPasWithExprScopeFlag;
- { TPasWithExprScope }
- TPasWithExprScope = Class(TPasScope)
- public
- WithScope: TPasWithScope; // owner
- Index: integer;
- Expr: TPasExpr;
- Scope: TPasScope;
- 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;
- 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;
- { TPasSubScope - base class for sub scopes aka dotted scopes }
- TPasSubScope = Class(TPasIdentifierScope)
- public
- class function IsStoredInElement: boolean; override;
- end;
- { TPasIterateFilterData }
- TPasIterateFilterData = record
- OnIterate: TIterateScopeElement;
- Data: Pointer;
- end;
- PPasIterateFilterData = ^TPasIterateFilterData;
- { TPasModuleDotScope - scope for searching unitname.<identifier> }
- TPasModuleDotScope = Class(TPasSubScope)
- 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;
- { TPasDotIdentifierScope }
- TPasDotIdentifierScope = Class(TPasSubScope)
- public
- IdentifierScope: TPasIdentifierScope;
- 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;
- end;
- { TPasDotRecordScope - used for aRecord.subidentifier }
- TPasDotRecordScope = Class(TPasDotIdentifierScope)
- end;
- { TPasDotEnumTypeScope - used for EnumType.EnumValue }
- TPasDotEnumTypeScope = Class(TPasDotIdentifierScope)
- end;
- { TPasDotClassScope - used for aClass.subidentifier }
- TPasDotClassScope = Class(TPasDotIdentifierScope)
- private
- FClassScope: TPasClassScope;
- procedure SetClassScope(AValue: TPasClassScope);
- public
- InheritedExpr: boolean; // this is 'inherited <name>' instead of '.<name'
- property ClassScope: TPasClassScope read FClassScope write SetClassScope;
- end;
- TResolvedReferenceFlag = (
- rrfDotScope, // found reference via a dot scope (TPasDotIdentifierScope)
- rrfImplicitCallWithoutParams, // a TPrimitiveExpr is an implicit call without params
- 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 children are 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;
- { 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 }
- TResolvedRefCtxConstructor = Class(TResolvedRefContext)
- public
- Typ: TPasType; // e.g. TPasClassType
- 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 and btRange
- IdentEl: TPasElement; // if set then this specific identifier is the value, can be a type
- TypeEl: TPasType; // can be nil for const expression
- ExprEl: TPasExpr;
- Flags: TPasResolverResultFlags;
- end;
- PPasResolvedElement = ^TPasResolverResult;
- type
- TPasResolverComputeFlag = (
- rcSkipTypeAlias,
- 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 expresson
- rcType // resolve a type expression
- );
- 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;
- end;
- { TPRFindData }
- TPRFindData = record
- ErrorPosEl: TPasElement;
- Found: TPasElement;
- ElScope: TPasScope; // Where Found was found
- StartScope: TPasScope; // where the searched started
- end;
- PPRFindData = ^TPRFindData;
- TPasResolverOption = (
- proFixCaseOfOverrides, // fix Name of overriding proc/property to the overriden proc/property
- proClassPropertyNonStatic, // class property accessors are 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
- );
- TPasResolverOptions = set of TPasResolverOption;
- TPasResolverStep = (
- prsInit,
- prsParsing,
- prsFinishingModule,
- prsFinishedModule
- );
- TPasResolverSteps = set of TPasResolverStep;
- { TPasResolver }
- TPasResolver = Class(TPasTreeContainer)
- private
- type
- TResolveDataListKind = (lkBuiltIn,lkModule);
- function GetBaseTypes(bt: TResolverBaseType): TPasUnresolvedSymbolRef; inline;
- function GetScopes(Index: integer): TPasScope; inline;
- private
- FAnonymousElTypePostfix: String;
- FBaseTypeChar: TResolverBaseType;
- FBaseTypeExtended: TResolverBaseType;
- FBaseTypeLength: TResolverBaseType;
- FBaseTypes: array[TResolverBaseType] of TPasUnresolvedSymbolRef;
- FBaseTypeString: TResolverBaseType;
- FDefaultNameSpace: String;
- FDefaultScope: TPasDefaultScope;
- FDynArrayMaxIndex: int64;
- FDynArrayMinIndex: int64;
- FLastCreatedData: array[TResolveDataListKind] of TResolveData;
- FLastElement: TPasElement;
- FLastMsg: string;
- FLastMsgArgs: TMessageArgs;
- FLastMsgElement: TPasElement;
- FLastMsgId: int64;
- FLastMsgNumber: integer;
- FLastMsgPattern: string;
- FLastMsgType: TMessageType;
- FLastSourcePos: TPasSourcePos;
- FOptions: TPasResolverOptions;
- FPendingForwardProcs: TFPList; // list of TPasElement needed to check for forward procs
- FRootElement: TPasModule;
- FScopeClass_Class: TPasClassScopeClass;
- FScopeClass_Proc: TPasProcedureScopeClass;
- FScopeClass_WithExpr: TPasWithExprScopeClass;
- FScopeCount: integer;
- FScopes: array of TPasScope; // stack of scopes
- FStep: TPasResolverStep;
- FStoreSrcColumns: boolean;
- FSubScopeCount: integer;
- FSubScopes: array of TPasScope; // stack of scopes
- FTopScope: TPasScope;
- procedure ClearResolveDataList(Kind: TResolveDataListKind);
- function GetBaseTypeNames(bt: TResolverBaseType): string;
- protected
- const
- cExact = 0;
- cCompatible = cExact+1;
- cIntToIntConversion = ord(High(TResolverBaseType));
- cToFloatConversion = 2*cIntToIntConversion;
- cTypeConversion = cExact+10000; // e.g. TObject to Pointer
- cLossyConversion = cExact+100000;
- cCompatibleWithDefaultParams = cLossyConversion+100000;
- cIncompatible = High(integer);
- type
- TFindCallElData = record
- Params: TParamsExpr;
- 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;
- TFindOverloadProcKind = (
- fopkSameSignature, // search method declaration for a body
- fopkProc, // check overloads for a proc
- fopkMethod // check overloads for a method
- );
- TFindOverloadProcData = record
- Proc: TPasProcedure;
- Args: TFPList; // List of TPasArgument objects
- Kind: TFindOverloadProcKind;
- OnlyScope: TPasScope;
- FoundOverloadModifier: boolean;
- FoundInSameScope: integer;
- Found: TPasProcedure;
- ElScope, StartScope: TPasScope;
- FoundNonProc: TPasElement;
- end;
- PFindOverloadProcData = ^TFindOverloadProcData;
- procedure OnFindFirstElement(El: TPasElement; ElScope, StartScope: TPasScope;
- FindFirstElementData: Pointer; var Abort: boolean); virtual;
- procedure OnFindCallElements(El: TPasElement; ElScope, StartScope: TPasScope;
- FindProcsData: Pointer; var Abort: boolean); virtual;
- procedure OnFindOverloadProc(El: TPasElement; ElScope, StartScope: TPasScope;
- FindOverloadData: Pointer; var Abort: boolean); virtual;
- function IsSameProcContext(ProcParentA, ProcParentB: TPasElement): boolean;
- function FindProcOverload(const ProcName: string; Proc: TPasProcedure;
- OnlyScope: TPasScope): TPasProcedure;
- protected
- procedure SetCurrentParser(AValue: TPasParser); override;
- 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 AddType(El: TPasType); virtual;
- procedure AddRecordType(El: TPasRecordType); virtual;
- procedure AddClassType(El: TPasClassType); virtual;
- procedure AddVariable(El: TPasVariable); virtual;
- procedure AddResourceString(El: TPasResString); virtual;
- procedure AddEnumType(El: TPasEnumType); virtual;
- procedure AddEnumValue(El: TPasEnumValue); virtual;
- procedure AddProperty(El: TPasProperty); virtual;
- procedure AddProcedure(El: TPasProcedure); virtual;
- procedure AddProcedureBody(El: TProcedureBody); virtual;
- procedure AddArgument(El: TPasArgument); virtual;
- procedure AddFunctionResult(El: TPasResultElement); virtual;
- procedure AddExceptOn(El: TPasImplExceptOn); virtual;
- procedure ResolveImplBlock(Block: TPasImplBlock); virtual;
- procedure ResolveImplElement(El: TPasImplElement); virtual;
- procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf); virtual;
- procedure ResolveImplLabelMark(Mark: TPasImplLabelMark); virtual;
- procedure ResolveImplForLoop(Loop: TPasImplForLoop); 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 ResolveInheritedCall(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 ResolveFuncParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveArrayParamsExpr(Params: TParamsExpr; Access: TResolvedRefAccess); virtual;
- procedure ResolveArrayParamsArgs(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess); virtual;
- function ResolveBracketOperatorClass(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult; ClassScope: TPasClassScope;
- Access: TResolvedRefAccess): boolean; virtual;
- procedure ResolveSetParamsExpr(Params: TParamsExpr); virtual;
- procedure ResolveArrayValues(El: TArrayValues); virtual;
- procedure SetResolvedRefAccess(Expr: TPasExpr; Ref: TResolvedReference;
- Access: TResolvedRefAccess); virtual;
- procedure AccessExpr(Expr: TPasExpr; Access: TResolvedRefAccess);
- procedure FinishModule(CurModule: TPasModule); virtual;
- procedure FinishUsesClause; virtual;
- procedure FinishSection(Section: TPasSection); virtual;
- procedure FinishInterfaceSection(Section: TPasSection); virtual;
- procedure FinishTypeSection(El: TPasDeclarations); 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 FinishArrayType(El: TPasArrayType); virtual;
- procedure FinishConstDef(El: TPasConst); virtual;
- procedure FinishResourcestring(El: TPasResString); virtual;
- procedure FinishProcedure(aProc: TPasProcedure); virtual;
- procedure FinishProcedureType(El: TPasProcedureType); virtual;
- procedure FinishMethodDeclHeader(Proc: TPasProcedure); virtual;
- procedure FinishMethodImplHeader(ImplProc: TPasProcedure); virtual;
- procedure FinishExceptOnExpr; virtual;
- procedure FinishExceptOnStatement; virtual;
- procedure FinishDeclaration(El: TPasElement); virtual;
- procedure FinishVariable(El: TPasVariable); virtual;
- procedure FinishPropertyOfClass(PropEl: TPasProperty); virtual;
- procedure FinishArgument(El: TPasArgument); virtual;
- procedure FinishAncestors(aClass: TPasClassType); virtual;
- procedure FinishPropertyParamAccess(Params: TParamsExpr;
- Prop: TPasProperty);
- procedure FinishCallArgAccess(Expr: TPasExpr; Access: TResolvedRefAccess);
- procedure EmitTypeHints(PosEl: TPasElement; aType: TPasType); virtual;
- function EmitElementHints(PosEl, El: TPasElement): boolean; virtual;
- procedure StoreScannerFlagsInProc(ProcScope: TPasProcedureScope);
- procedure ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope: TPasProcedureScope);
- procedure CheckConditionExpr(El: TPasExpr; const ResolvedEl: TPasResolverResult); virtual;
- procedure CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure; CheckNames: boolean);
- procedure CheckPendingForwardProcs(El: TPasElement);
- 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;
- procedure ComputeArrayParams(Params: TParamsExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeArrayParams_Class(Params: TParamsExpr;
- var ResolvedEl: TPasResolverResult; ClassScope: TPasClassScope;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement); virtual;
- procedure ComputeFuncParams(Params: TParamsExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure ComputeSetParams(Params: TParamsExpr;
- out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- procedure CheckIsClass(El: TPasElement; const ResolvedEl: TPasResolverResult);
- function CheckTypeCastClassInstanceToClass(
- const FromClassRes, ToClassRes: TPasResolverResult;
- ErrorEl: TPasElement): integer; virtual;
- 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 CheckForInClass(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): integer;
- function CheckRaiseTypeArgNo(id: int64; ArgNo: integer; Param: TPasExpr;
- const ParamResolved: TPasResolverResult; Expected: string; RaiseOnError: boolean): integer;
- function FindUsedUnitInSection(const aName: string; Section: TPasSection): TPasModule;
- function FindUsedUnit(const aName: string; aMod: TPasModule): TPasModule;
- procedure FinishAssertCall(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); virtual;
- function FindExceptionConstructor(const aUnitName, aClassName: string;
- out aClass: TPasClassType; out aConstructor: TPasConstructor;
- ErrorEl: TPasElement): boolean; virtual;
- procedure FindAssertExceptionConstructors(ErrorEl: TPasElement); virtual;
- procedure FindRangeErrorConstructors(ErrorEl: TPasElement); virtual;
- protected
- fExprEvaluator: TResExprEvaluator;
- procedure OnExprEvalLog(Sender: TResExprEvaluator; const id: int64;
- MsgType: TMessageType; MsgNumber: integer; const Fmt: String;
- Args: array of const; PosEl: TPasElement); virtual;
- function OnExprEvalIdentifier(Sender: TResExprEvaluator;
- Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
- function OnExprEvalParams(Sender: TResExprEvaluator;
- Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
- function EvalBaseTypeCast(Params: TParamsExpr; bt: TResolverBaseType): TResEvalvalue;
- 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;
- {%H-}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;
- {%H-}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;
- {%H-}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;
- {%H-}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({%H-}Proc: TResElDataBuiltInProc;
- {%H-}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({%H-}Proc: TResElDataBuiltInProc;
- {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- procedure BI_StrFunc_OnEval({%H-}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({%H-}Proc: TResElDataBuiltInProc;
- {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- function BI_CopyArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_CopyArray_OnGetCallResult({%H-}Proc: TResElDataBuiltInProc;
- {%H-}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({%H-}Proc: TResElDataBuiltInProc;
- {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
- function BI_Assert_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
- Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
- procedure BI_Assert_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr); 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): TPasElement;
- overload; override;
- function FindElement(const aName: String): TPasElement; override; // used by TPasParser
- function FindElementWithoutParams(const AName: String; ErrorPosEl: TPasElement;
- NoProcsWithArgs: boolean): TPasElement;
- function FindElementWithoutParams(const AName: String; out Data: TPRFindData;
- ErrorPosEl: TPasElement; NoProcsWithArgs: boolean): TPasElement;
- procedure FindLongestUnitName(var El: TPasElement; Expr: TPasExpr);
- procedure IterateElements(const aName: string;
- const OnIterateElement: TIterateScopeElement; Data: Pointer;
- var Abort: boolean); virtual;
- procedure CheckFoundElement(const FindData: TPRFindData;
- Ref: TResolvedReference); virtual;
- function GetVisibilityContext: TPasElement;
- procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override;
- function IsUnitIntfFinished(AModule: TPasModule): boolean;
- function GetPendingUsedInterface(Section: TPasSection): TPasUsesUnit;
- procedure CheckPendingUsedInterface(Section: TPasSection); override;
- procedure ContinueParsing; virtual;
- function NeedArrayValues(El: TPasElement): boolean; override;
- function GetDefaultClassVisibility(AClass: TPasClassType
- ): TPasMemberVisibility; override;
- // built in types and functions
- procedure ClearBuiltInIdentifiers; virtual;
- procedure AddObjFPCBuiltInIdentifiers(
- const TheBaseTypes: TResolveBaseTypes = btAllStandardTypes;
- 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 CreateScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; virtual;
- procedure PopScope;
- procedure PushScope(Scope: TPasScope); overload;
- function PushScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; overload;
- function PushModuleDotScope(aModule: TPasModule): TPasModuleDotScope;
- function PushClassDotScope(var CurClassType: TPasClassType): TPasDotClassScope;
- function PushRecordDotScope(CurRecordType: TPasRecordType): TPasDotRecordScope;
- function PushEnumDotScope(CurEnumType: TPasEnumType): TPasDotEnumTypeScope;
- procedure ResetSubScopes(out Depth: integer);
- procedure RestoreSubScopes(Depth: integer);
- function GetInheritedExprScope(ErrorEl: TPasElement): TPasProcedureScope;
- // log and messages
- class procedure UnmangleSourceLineNumber(LineNumber: integer;
- out Line, Column: integer);
- class function GetDbgSourcePosStr(El: TPasElement): string;
- function GetElementSourcePosStr(El: TPasElement): string;
- procedure SetLastMsg(const id: int64; MsgType: TMessageType; MsgNumber: integer;
- Const Fmt : String; Args : Array of const; PosEl: TPasElement);
- procedure LogMsg(const id: int64; MsgType: TMessageType; MsgNumber: integer;
- const Fmt: String; Args: Array of const; PosEl: TPasElement); overload;
- procedure RaiseMsg(const Id: int64; MsgNumber: integer; const Fmt: String;
- Args: Array of const; ErrorPosEl: TPasElement);
- procedure RaiseNotYetImplemented(id: int64; El: TPasElement; Msg: string = ''); virtual;
- procedure RaiseInternalError(id: int64; const Msg: string = '');
- procedure RaiseInvalidScopeForElement(id: int64; El: TPasElement; const Msg: string = '');
- procedure RaiseIdentifierNotFound(id: int64; Identifier: string; El: TPasElement);
- procedure RaiseXExpectedButYFound(id: int64; const X,Y: string; El: TPasElement);
- procedure RaiseContextXExpectedButYFound(id: int64; const C,X,Y: string; El: TPasElement);
- procedure RaiseContextXInvalidY(id: int64; const X,Y: string; El: TPasElement);
- procedure RaiseConstantExprExp(id: int64; ErrorEl: TPasElement);
- procedure RaiseRangeCheck(id: int64; ErrorEl: TPasElement);
- procedure RaiseIncompatibleTypeDesc(id: int64; MsgNumber: integer;
- const Args: array of const; const GotDesc, ExpDesc: String; ErrorEl: TPasElement);
- procedure RaiseIncompatibleType(id: int64; MsgNumber: integer;
- const Args: array of const; GotType, ExpType: TPasType; ErrorEl: TPasElement);
- procedure RaiseIncompatibleTypeRes(id: int64; MsgNumber: integer;
- const Args: array of const; const GotType, ExpType: TPasResolverResult;
- ErrorEl: TPasElement);
- procedure RaiseInvalidProcTypeModifier(id: int64; ProcType: TPasProcedureType;
- ptm: TProcTypeModifier; ErrorEl: TPasElement);
- procedure RaiseInvalidProcModifier(id: int64; Proc: TPasProcedure;
- pm: TProcedureModifier; ErrorEl: TPasElement);
- procedure WriteScopes;
- // find value and type of an element
- procedure ComputeElement(El: TPasElement; out ResolvedEl: TPasResolverResult;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil);
- function Eval(Expr: TPasExpr; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue;
- function Eval(const Value: TPasResolverResult; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue;
- // checking compatibilility
- function IsSameType(TypeA, TypeB: TPasType; ResolveAlias: boolean = false): boolean; // check if it is exactly the same
- 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 CheckAssignCompatibilityUserType(
- const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): integer;
- function CheckAssignCompatibilityArrayType(
- const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): integer;
- function CheckConstArrayCompatibility(Params: TParamsExpr;
- const ArrayResolved: TPasResolverResult; RaiseOnError: boolean;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil): integer;
- function CheckEqualCompatibilityUserType(
- const TypeA, TypeB: TPasResolverResult; ErrorEl: TPasElement;
- RaiseOnIncompatible: boolean): integer;
- 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;
- ErrorEl: TPasElement): integer;
- function CheckClassIsClass(SrcType, DestType: TPasType;
- ErrorEl: TPasElement): integer; virtual;
- function CheckClassesAreRelated(TypeA, TypeB: TPasType;
- ErrorEl: TPasElement): integer;
- function CheckOverloadProcCompatibility(Proc1, Proc2: TPasProcedure): boolean;
- function CheckProcTypeCompatibility(Proc1, Proc2: TPasProcedureType;
- IsAssign: boolean; ErrorEl: TPasElement; RaiseOnIncompatible: boolean): boolean;
- function CheckProcArgCompatibility(Arg1, Arg2: TPasArgument): boolean;
- function CheckProcArgTypeCompatibility(Arg1, Arg2: TPasType): boolean;
- function CheckCanBeLHS(const ResolvedEl: TPasResolverResult;
- ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean;
- function CheckAssignCompatibility(const LHS, RHS: TPasElement;
- RaiseOnIncompatible: boolean = true): 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 ResolvedElCanBeVarParam(const ResolvedEl: TPasResolverResult): boolean;
- function ResolvedElIsClassInstance(const ResolvedEl: TPasResolverResult): boolean;
- // uility functions
- property BaseTypeNames[bt: TResolverBaseType]: string read GetBaseTypeNames;
- function GetProcTypeDescription(ProcType: TPasProcedureType; UseName: boolean = true; AddPaths: boolean = false): 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 GetPasPropertyType(El: TPasProperty): TPasType;
- function GetPasPropertyAncestor(El: TPasProperty; WithRedeclarations: boolean = false): TPasProperty;
- function GetPasPropertyGetter(El: TPasProperty): TPasElement;
- function GetPasPropertySetter(El: TPasProperty): TPasElement;
- function GetPasPropertyIndex(El: TPasProperty): TPasExpr;
- function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
- function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
- function GetLoop(El: TPasElement): TPasImplElement;
- function ResolveAliasType(aType: TPasType): TPasType;
- function ResolveAliasTypeEl(El: TPasElement): TPasType; inline;
- function ExprIsAddrTarget(El: TPasExpr): boolean;
- function IsNameExpr(El: TPasExpr): boolean; inline; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
- function GetNameExprValue(El: TPasExpr): string; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
- function GetNextDottedExpr(El: TPasExpr): TPasExpr;
- function GetPathStart(El: TPasExpr): TPasExpr;
- function GetNewInstanceExpr(El: TPasExpr): TPasExpr;
- function ParentNeedsExprResult(El: TPasExpr): boolean;
- function GetReference_NewInstanceClass(Ref: TResolvedReference): TPasClassType;
- function IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean = true): boolean;
- function IsOpenArray(TypeEl: TPasType): boolean;
- function IsDynOrOpenArray(TypeEl: TPasType): boolean;
- function IsVarInit(Expr: TPasExpr): boolean;
- function IsEmptySet(const ResolvedEl: TPasResolverResult): boolean;
- function IsClassMethod(El: TPasElement): boolean;
- function IsExternalClassName(aClass: TPasClassType; const ExtName: string): boolean;
- function IsProcedureType(const ResolvedEl: TPasResolverResult; HasValue: boolean): boolean;
- function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
- function IsTypeCast(Params: TParamsExpr): boolean;
- function ProcNeedsParams(El: TPasProcedureType): boolean;
- function IsProcOverride(AncestorProc, DescendantProc: TPasProcedure): boolean;
- function GetRangeLength(RangeExpr: TPasExpr): MaxPrecInt;
- 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: MaxPrecInt): boolean;
- function GetIntegerBaseType(Precision: word; Signed: boolean; ErrorEl: TPasElement): TResolverBaseType;
- function GetSmallestIntegerBaseType(MinVal, MaxVal: MaxPrecInt): TResolverBaseType;
- function GetCombinedChar(const Char1, Char2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
- function GetCombinedString(const Str1, Str2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
- function IsElementSkipped(El: TPasElement): boolean; virtual;
- public
- // 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 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 ExprEvaluator: TResExprEvaluator read fExprEvaluator;
- property DynArrayMinIndex: int64 read FDynArrayMinIndex write FDynArrayMinIndex;
- property DynArrayMaxIndex: int64 read FDynArrayMaxIndex write FDynArrayMaxIndex;
- // parsed values
- property DefaultNameSpace: String read FDefaultNameSpace;
- property RootElement: TPasModule read FRootElement;
- property Step: TPasResolverStep read FStep;
- // scopes
- property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; {
- If true Line and Column is mangled together in TPasElement.SourceLineNumber.
- Use method UnmangleSourceLineNumber to extract. }
- 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_Class: TPasClassScopeClass read FScopeClass_Class write FScopeClass_Class;
- property ScopeClass_Procedure: TPasProcedureScopeClass read FScopeClass_Proc write FScopeClass_Proc;
- 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: int64 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;
- procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; IdentEl: TPasElement;
- TypeEl: TPasType; Flags: TPasResolverResultFlags); overload;
- procedure SetResolverTypeExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; TypeEl: TPasType;
- Flags: TPasResolverResultFlags); overload;
- procedure SetResolverValueExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; TypeEl: TPasType; ExprEl: TPasExpr;
- Flags: TPasResolverResultFlags); overload;
- function ProcNeedsImplProc(Proc: TPasProcedure): boolean;
- function ProcNeedsBody(Proc: TPasProcedure): boolean;
- function ProcHasGroupOverload(Proc: TPasProcedure): boolean;
- function ChompDottedIdentifier(const Identifier: string): string;
- function FirstDottedIdentifier(const Identifier: string): string;
- function IsDottedIdentifierPrefix(const Prefix, Identifier: string): boolean;
- {$IF FPC_FULLVERSION<30101}
- function IsValidIdent(const Ident: string; AllowDots: Boolean = False; StrictDots: Boolean = False): Boolean;
- {$ENDIF}
- function NoNil(o: TObject): TObject;
- function dbgs(const Flags: TPasResolverComputeFlags): string; overload;
- function dbgs(const a: TResolvedRefAccess): string;
- function dbgs(const Flags: TResolvedReferenceFlags): string; overload;
- implementation
- function GetTreeDbg(El: TPasElement; Indent: integer): string;
- procedure LineBreak(SubIndent: integer);
- begin
- Inc(Indent,SubIndent);
- Result:=Result+LineEnding+Space(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 TPasFunction then
- Result:=Result+':'+GetTreeDbg(TPasFunctionType(TPasFunction(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;
- begin
- Result:='[bt='+ResBaseTypeNames[T.BaseType];
- if T.SubType<>btNone then
- Result:=Result+' Sub='+ResBaseTypeNames[T.SubType];
- Result:=Result
- +' Ident='+GetObjName(T.IdentEl)
- +' Type='+GetObjName(T.TypeEl)
- +' 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+C.FullName;
- 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;
- procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; IdentEl: TPasElement; TypeEl: TPasType;
- Flags: TPasResolverResultFlags);
- begin
- if IdentEl is TPasExpr then
- raise Exception.Create('20170729101017');
- ResolvedType.BaseType:=BaseType;
- ResolvedType.SubType:=btNone;
- ResolvedType.IdentEl:=IdentEl;
- ResolvedType.TypeEl:=TypeEl;
- ResolvedType.ExprEl:=nil;
- ResolvedType.Flags:=Flags;
- end;
- procedure SetResolverTypeExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; TypeEl: TPasType; Flags: TPasResolverResultFlags
- );
- begin
- ResolvedType.BaseType:=BaseType;
- ResolvedType.SubType:=btNone;
- ResolvedType.IdentEl:=nil;
- ResolvedType.TypeEl:=TypeEl;
- ResolvedType.ExprEl:=nil;
- ResolvedType.Flags:=Flags;
- end;
- procedure SetResolverValueExpr(out ResolvedType: TPasResolverResult;
- BaseType: TResolverBaseType; TypeEl: TPasType; ExprEl: TPasExpr;
- Flags: TPasResolverResultFlags);
- begin
- ResolvedType.BaseType:=BaseType;
- ResolvedType.SubType:=btNone;
- ResolvedType.IdentEl:=nil;
- ResolvedType.TypeEl:=TypeEl;
- 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;
- function ChompDottedIdentifier(const Identifier: string): string;
- var
- p: Integer;
- begin
- Result:=Identifier;
- p:=length(Identifier);
- while (p>0) do
- begin
- if Identifier[p]='.' then
- break;
- dec(p);
- end;
- Result:=LeftStr(Identifier,p-1);
- end;
- function FirstDottedIdentifier(const Identifier: string): string;
- var
- p: SizeInt;
- begin
- p:=Pos('.',Identifier);
- if p<1 then
- Result:=Identifier
- else
- Result:=LeftStr(Identifier,p-1);
- 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 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;
- { TPasPropertyScope }
- destructor TPasPropertyScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasPropertyScope.Destroy START ',ClassName);
- {$ENDIF}
- ReleaseAndNil(TPasElement(AncestorProp));
- 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));
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasEnumTypeScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TPasDotIdentifierScope }
- function TPasDotIdentifierScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=IdentifierScope.FindIdentifier(Identifier);
- end;
- procedure TPasDotIdentifierScope.IterateElements(const aName: string;
- StartScope: TPasScope; const OnIterateElement: TIterateScopeElement;
- Data: Pointer; var Abort: boolean);
- begin
- IdentifierScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- end;
- procedure TPasDotIdentifierScope.WriteIdentifiers(Prefix: string);
- begin
- IdentifierScope.WriteIdentifiers(Prefix);
- 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
- writeln(Prefix+'WithExpr: '+GetTreeDbg(Expr,length(Prefix)));
- Scope.WriteIdentifiers(Prefix);
- 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 then exit;
- if ClassScope<>nil then
- Result:=ClassScope.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 ClassScope<>nil then
- ClassScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
- end;
- function TPasProcedureScope.GetSelfScope: TPasProcedureScope;
- var
- Proc: TPasProcedure;
- begin
- Result:=Self;
- repeat
- if Result.ClassScope<>nil then exit;
- Proc:=TPasProcedure(Element);
- if not (Proc.Parent is TProcedureBody) then exit(nil);
- Proc:=Proc.Parent.Parent as TPasProcedure;
- Result:=TPasProcedureScope(Proc.CustomData);
- until false;
- end;
- procedure TPasProcedureScope.WriteIdentifiers(Prefix: string);
- begin
- inherited WriteIdentifiers(Prefix);
- if ClassScope<>nil then
- ClassScope.WriteIdentifiers(Prefix+' ');
- end;
- destructor TPasProcedureScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasProcedureScope.Destroy START ',ClassName);
- {$ENDIF}
- inherited Destroy;
- ReleaseAndNil(TPasElement(SelfArg));
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasProcedureScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TPasClassScope }
- destructor TPasClassScope.Destroy;
- begin
- ReleaseAndNil(TPasElement(CanonicalClassOf));
- inherited Destroy;
- end;
- function TPasClassScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=inherited FindIdentifier(Identifier);
- if Result<>nil then exit;
- if AncestorScope<>nil then
- Result:=AncestorScope.FindIdentifier(Identifier);
- end;
- procedure TPasClassScope.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 AncestorScope<>nil then
- AncestorScope.IterateElements(aName,StartScope,OnIterateElement,Data,Abort);
- end;
- procedure TPasClassScope.WriteIdentifiers(Prefix: string);
- begin
- inherited WriteIdentifiers(Prefix);
- if AncestorScope<>nil then
- AncestorScope.WriteIdentifiers(Prefix+' ');
- end;
- { TPasDotClassScope }
- procedure TPasDotClassScope.SetClassScope(AValue: TPasClassScope);
- begin
- if FClassScope=AValue then Exit;
- FClassScope:=AValue;
- IdentifierScope:=AValue;
- end;
- { TPasIdentifier }
- procedure TPasIdentifier.SetElement(AValue: TPasElement);
- begin
- if FElement=AValue then Exit;
- if Element<>nil then
- Element.Release;
- FElement:=AValue;
- if Element<>nil then
- Element.AddRef;
- 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);
- begin
- if FPasElement=AValue then Exit;
- if PasElement<>nil then
- PasElement.Release;
- FPasElement:=AValue;
- if PasElement<>nil then
- PasElement.AddRef;
- 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;
- FDeclaration:=AValue;
- if Declaration<>nil then
- Declaration.AddRef;
- 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;
- { TPasSubScope }
- class function TPasSubScope.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;
- FModule:=AValue;
- if Module<>nil then
- Module.AddRef;
- 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}
- 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: TPasIdentifierScope;
- 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:=TPasIdentifierScope(UsesScopes[i]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasSectionScope.IterateElements "',aName,'" in used unit ',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
- 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;
- end;
- { TPasModuleScope }
- procedure TPasModuleScope.SetAssertDefConstructor(const AValue: TPasConstructor
- );
- begin
- if FAssertDefConstructor=AValue then Exit;
- if FAssertDefConstructor<>nil then
- FAssertDefConstructor.Release;
- FAssertDefConstructor:=AValue;
- if FAssertDefConstructor<>nil then
- FAssertDefConstructor.AddRef;
- end;
- procedure TPasModuleScope.SetAssertClass(const AValue: TPasClassType);
- begin
- if FAssertClass=AValue then Exit;
- if FAssertClass<>nil then
- FAssertClass.Release;
- FAssertClass:=AValue;
- if FAssertClass<>nil then
- FAssertClass.AddRef;
- end;
- procedure TPasModuleScope.SetAssertMsgConstructor(const AValue: TPasConstructor
- );
- begin
- if FAssertMsgConstructor=AValue then Exit;
- if FAssertMsgConstructor<>nil then
- FAssertMsgConstructor.Release;
- FAssertMsgConstructor:=AValue;
- if FAssertMsgConstructor<>nil then
- FAssertMsgConstructor.AddRef;
- end;
- procedure TPasModuleScope.SetRangeErrorClass(const AValue: TPasClassType);
- begin
- if FRangeErrorClass=AValue then Exit;
- if FRangeErrorClass<>nil then
- FRangeErrorClass.Release;
- FRangeErrorClass:=AValue;
- if FRangeErrorClass<>nil then
- FRangeErrorClass.AddRef;
- end;
- procedure TPasModuleScope.SetRangeErrorConstructor(const AValue: TPasConstructor
- );
- begin
- if FRangeErrorConstructor=AValue then Exit;
- if FRangeErrorConstructor<>nil then
- FRangeErrorConstructor.Release;
- FRangeErrorConstructor:=AValue;
- if FRangeErrorConstructor<>nil then
- FRangeErrorConstructor.AddRef;
- end;
- constructor TPasModuleScope.Create;
- begin
- inherited Create;
- PendingResolvers:=TFPList.Create;
- end;
- destructor TPasModuleScope.Destroy;
- begin
- AssertClass:=nil;
- AssertDefConstructor:=nil;
- AssertMsgConstructor:=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
- writeln(Prefix,'Element: ',GetObjName(Element));
- end;
- { TPasIdentifierScope }
- // inline
- function TPasIdentifierScope.FindLocalIdentifier(const Identifier: String
- ): TPasIdentifier;
- var
- LoName: String;
- begin
- LoName:=lowercase(Identifier);
- Result:=TPasIdentifier(FItems.Find(LoName));
- 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.OnWriteItem(Item, Dummy: pointer);
- var
- PasIdentifier: TPasIdentifier absolute Item;
- Prefix: String;
- begin
- Prefix:=AnsiString(Dummy);
- while PasIdentifier<>nil do
- begin
- writeln(Prefix,'Identifier="',PasIdentifier.Identifier,'" Element=',GetObjName(PasIdentifier.Element));
- PasIdentifier:=PasIdentifier.NextSameIdentifier;
- end;
- end;
- procedure TPasIdentifierScope.InternalAdd(Item: TPasIdentifier);
- var
- Index: Integer;
- OldItem: TPasIdentifier;
- LoName: string;
- begin
- LoName:=lowercase(Item.Identifier);
- 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;
- end;
- constructor TPasIdentifierScope.Create;
- begin
- FItems:=TFPHashList.Create;
- end;
- destructor TPasIdentifierScope.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasIdentifierScope.Destroy START ',ClassName);
- {$ENDIF}
- FItems.ForEachCall(@OnClearItem,nil);
- FItems.Clear;
- FreeAndNil(FItems);
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasIdentifierScope.Destroy END ',ClassName);
- {$ENDIF}
- end;
- function TPasIdentifierScope.FindIdentifier(const Identifier: String
- ): TPasIdentifier;
- begin
- Result:=FindLocalIdentifier(Identifier);
- {$IFDEF VerbosePasResolver}
- if (Result<>nil) and (Result.Owner<>Self) then
- begin
- writeln('TPasIdentifierScope.FindIdentifier Result.Owner<>Self Owner='+GetObjName(Result.Owner));
- raise Exception.Create('20160925184159');
- end;
- {$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(Identifier);
- 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);
- Prefix:=Prefix+' ';
- FItems.ForEachCall(@OnWriteItem,Pointer(Prefix));
- 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=TSelfExpr)
- or ((El.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent));
- 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 if El.ClassType=TSelfExpr then
- Result:='self'
- else
- Result:='';
- end;
- function TPasResolver.GetNextDottedExpr(El: TPasExpr): TPasExpr;
- // returns TSelfExpr or 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=TSelfExpr then
- exit(El)
- else 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.GetPathStart(El: TPasExpr): TPasExpr;
- // get leftmost name element (e.g. TPrimitiveExpr or TSelfExpr)
- // 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=TSelfExpr 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.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;
- procedure TPasResolver.OnFindFirstElement(El: TPasElement; ElScope,
- StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean);
- var
- Data: PPRFindData absolute FindFirstElementData;
- ok: Boolean;
- begin
- ok:=true;
- if (El is TPasProcedure)
- and ProcNeedsParams(TPasProcedure(El).ProcType) then
- // found a proc, but it needs parameters -> remember the first and continue
- ok:=false;
- 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.OnFindCallElements(El: TPasElement; ElScope,
- StartScope: TPasScope; FindProcsData: Pointer; var Abort: boolean);
- var
- Data: PFindCallElData absolute FindProcsData;
- Proc, PrevProc: TPasProcedure;
- Distance: integer;
- BuiltInProc: TResElDataBuiltInProc;
- CandidateFound: Boolean;
- VarType, TypeEl: TPasType;
- C: TClass;
- ProcScope: TPasProcedureScope;
- 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.
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- 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 TPasProcedureScope(Data^.LastProc.CustomData).Mode=msDelphi 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 (ProcScope.Mode=msDelphi) and not Proc.IsOverload then
- Abort:=true; // stop searching after this proc
- CandidateFound:=true;
- Distance:=CheckCallProcCompatibility(Proc.ProcType,Data^.Params,false);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindCallElements Proc Distance=',Distance,
- ' Data^.Found=',Data^.Found<>nil,' Data^.Distance=',ord(Data^.Distance),
- ' Signature={',GetProcTypeDescription(Proc.ProcType,true,true),'}',
- ' Abort=',Abort);
- {$ENDIF}
- Data^.LastProc:=Proc;
- end
- else if El is TPasType then
- begin
- TypeEl:=ResolveAliasType(TPasType(El));
- C:=TypeEl.ClassType;
- 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=TPasRecordType)
- or (C=TPasEnumType)
- or (C=TPasProcedureType)
- or (C=TPasFunctionType)
- or (C=TPasArrayType)
- or (C=TPasRangeType) 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;
- VarType:=ResolveAliasType(TPasVariable(El).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;
- 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,nIllegalQualifier,sIllegalQualifier,['('],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 (Distance>=cCompatibleWithDefaultParams)
- or (Data^.Distance=Distance)
- or ((Distance>=cLossyConversion) and (Data^.Distance>=cLossyConversion)) then
- begin
- // found another compatible one -> collect
- {$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}
- Data^.Found:=El;
- Data^.ElScope:=ElScope;
- Data^.StartScope:=StartScope;
- Data^.Distance:=Distance;
- if (Distance<cLossyConversion) then
- begin
- // found a good one
- Data^.Count:=1;
- if Data^.List<>nil then
- Data^.List.Clear;
- end
- else
- begin
- // found another lossy one
- // -> collect them
- inc(Data^.Count);
- end;
- if Data^.List<>nil then
- Data^.List.Add(El);
- end;
- end;
- procedure TPasResolver.OnFindOverloadProc(El: TPasElement; ElScope,
- StartScope: TPasScope; FindOverloadData: Pointer; var Abort: boolean);
- var
- Data: PFindOverloadProcData absolute FindOverloadData;
- Proc: TPasProcedure;
- Store, SameScope: Boolean;
- procedure CountProcInSameModule;
- begin
- inc(Data^.FoundInSameScope);
- if Proc.IsOverload then
- Data^.FoundOverloadModifier:=true;
- end;
- begin
- //writeln('TPasResolver.OnFindOverloadProc START ',El.Name,':',El.ElementTypeName,' 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
- fopkProc:
- // 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
- // give a hint
- LogMsg(20171118205344,mtHint,nFunctionHidesIdentifier,sFunctionHidesIdentifier,
- [GetElementSourcePosStr(El)],Data^.Proc.ProcType);
- fopkMethod:
- // method hides a non proc
- RaiseMsg(20171118232543,nDuplicateIdentifier,sDuplicateIdentifier,
- [El.Name,GetElementSourcePosStr(El)],Data^.Proc.ProcType);
- 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
- CountProcInSameModule;
- exit;
- end;
- //writeln('TPasResolver.OnFindOverloadProc Data^.OnlyScope=',GetObjName(Data^.OnlyScope),' ElScope=',GetObjName(ElScope),' ',Data^.OnlyScope=ElScope);
- if (Data^.OnlyScope<>nil) and (Data^.OnlyScope<>ElScope) then
- begin
- // do not search any further, only one scope should be searched
- // for example when searching the method declaration of a method body
- Abort:=false;
- exit;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnFindOverloadProc ',GetTreeDbg(El,2));
- {$ENDIF}
- Store:=CheckOverloadProcCompatibility(Data^.Proc,Proc);
- if Data^.Kind=fopkSameSignature then
- // finding a proc with same signature is enough, see above Data^.OnlyScope
- else
- begin
- if Data^.Kind=fopkProc then
- SameScope:=Data^.Proc.GetModule=Proc.GetModule
- else
- SameScope:=Data^.Proc.Parent=Proc.Parent;
- 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;
- CountProcInSameModule;
- 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
- // give a hint, that proc is hiding a proc in other scope
- if (Data^.Kind=fopkMethod) and (Proc.IsVirtual or Proc.IsOverride) then
- LogMsg(20170216151712,mtWarning,nMethodHidesMethodOfBaseType,
- sMethodHidesMethodOfBaseType,
- [Data^.Proc.Name,Proc.Parent.Name,GetElementSourcePosStr(Proc)],Data^.Proc.ProcType)
- else
- // Delphi/FPC do not give a message when hiding a non virtual method
- // -> emit only an Info
- LogMsg(20171118214523,mtInfo,nFunctionHidesIdentifier,sFunctionHidesIdentifier,
- [GetElementSourcePosStr(Proc)],Data^.Proc.ProcType);
- Abort:=true;
- end;
- end;
- end;
- end;
- 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.FindProcOverload(const ProcName: string;
- Proc: TPasProcedure; OnlyScope: TPasScope): TPasProcedure;
- var
- FindData: TFindOverloadProcData;
- Abort: boolean;
- begin
- FindData:=Default(TFindOverloadProcData);
- FindData.Proc:=Proc;
- FindData.Args:=Proc.ProcType.Args;
- FindData.Kind:=fopkSameSignature;
- FindData.OnlyScope:=OnlyScope;
- Abort:=false;
- OnlyScope.IterateElements(ProcName,OnlyScope,@OnFindOverloadProc,@FindData,Abort);
- Result:=FindData.Found;
- end;
- procedure TPasResolver.SetCurrentParser(AValue: TPasParser);
- begin
- //writeln('TPasResolver.SetCurrentParser ',AValue<>nil);
- if AValue=CurrentParser then exit;
- Clear;
- inherited SetCurrentParser(AValue);
- if CurrentParser<>nil then
- CurrentParser.Options:=CurrentParser.Options
- +[po_resolvestandardtypes,po_nooverloadedprocs,po_keepclassforward,
- po_arrayrangeexpr,po_CheckModeswitches,po_CheckCondFunction];
- 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;
- var
- Identifier, OlderIdentifier: TPasIdentifier;
- ClassScope: TPasClassScope;
- OlderEl: TPasElement;
- IsClassScope: Boolean;
- C: TClass;
- begin
- IsClassScope:=(Scope is TPasClassScope);
- 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 IsClassScope
- and (El.ClassType<>TPasProperty) then
- begin
- // check duplicate in ancestors
- ClassScope:=TPasClassScope(Scope).AncestorScope;
- while ClassScope<>nil do
- begin
- OlderIdentifier:=ClassScope.FindLocalIdentifier(aName);
- 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;
- ClassScope:=ClassScope.AncestorScope;
- end;
- end;
- Identifier:=Scope.AddIdentifier(aName,El,Kind);
- // check duplicate in current scope
- OlderIdentifier:=Identifier.NextSameIdentifier;
- if (OlderIdentifier<>nil) then
- if (Identifier.Kind=pikSimple)
- or (OlderIdentifier.Kind=pikSimple)
- or (El.Visibility=visPublished) then
- begin
- if (OlderIdentifier.Element.ClassType=TPasEnumValue)
- and (OlderIdentifier.Element.Parent.Parent<>Scope.Element) then
- // this enum was propagated from a sub type -> remove enum
- Scope.RemoveLocalIdentifier(OlderIdentifier.Element);
- RaiseMsg(20170216151530,nDuplicateIdentifier,sDuplicateIdentifier,
- [aName,GetElementSourcePosStr(OlderIdentifier.Element)],El);
- 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;
- ModScope.ScannerBoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
- if bsRangeChecks in ModScope.ScannerBoolSwitches then
- Include(ModScope.Flags,pmsfRangeErrorNeeded);
- FindRangeErrorConstructors(CurModule);
- if (CurModuleClass=TPasProgram) or (CurModuleClass=TPasLibrary) then
- begin
- // resolve begin..end block
- ResolveImplBlock(CurModule.InitializationSection);
- end
- else if (CurModuleClass=TPasModule) then
- begin
- // unit
- FinishSection(CurModule.InterfaceSection);
- 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=TPasSectionScope) do
- PopScope;
- CheckTopScope(TPasModuleScope);
- PopScope;
- FStep:=prsFinishedModule;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishModule END ',CurModule.Name);
- {$ENDIF}
- end;
- procedure TPasResolver.FinishUsesClause;
- var
- Section, CurSection: TPasSection;
- i, j: Integer;
- PublicEl, UseModule: TPasElement;
- Scope: TPasSectionScope;
- UsesScope: TPasIdentifierScope;
- UseUnit: TPasUsesUnit;
- FirstName: String;
- p: SizeInt;
- OldIdentifier: TPasIdentifier;
- begin
- CheckTopScope(TPasSectionScope);
- Scope:=TPasSectionScope(TopScope);
- Section:=TPasSection(Scope.Element);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishUsesClause Section=',Section.ClassName,' Section.UsesList.Count=',Section.UsesList.Count);
- {$ENDIF}
- 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=TLibrarySection) then
- PublicEl:=UseModule
- else if (UseModule.ClassType=TPasModule) then
- PublicEl:=TPasModule(UseModule).InterfaceSection
- else
- RaiseXExpectedButYFound(20170503004803,'unit',UseModule.ElementTypeName,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 TPasIdentifierScope) then
- RaiseInternalError(20160922163403,'uses element has invalid resolver data: '
- +UseUnit.Name+'->'+GetObjName(PublicEl)+'->'+PublicEl.CustomData.ClassName);
- // check if module was already used by a different name
- j:=i;
- CurSection:=Section;
- repeat
- dec(j);
- if j<0 then
- begin
- if CurSection.ClassType<>TImplementationSection then
- break;
- CurSection:=CurSection.GetModule.InterfaceSection;
- if CurSection=nil then break;
- j:=length(CurSection.UsesClause)-1;
- if j<0 then break;
- end;
- if CurSection.UsesClause[j].Module=UseModule then
- RaiseMsg(20170503004022,nDuplicateIdentifier,sDuplicateIdentifier,
- [UseModule.Name,GetElementSourcePosStr(CurSection.UsesClause[j])],UseUnit);
- until false;
- // add full uses name
- AddIdentifier(Scope,UseUnit.Name,UseUnit,pikSimple);
- // add scope
- UsesScope:=TPasIdentifierScope(PublicEl.CustomData);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishUsesClause Add UsesScope=',GetObjName(UsesScope));
- {$ENDIF}
- Scope.UsesScopes.Add(UsesScope);
- 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);
- var
- ModuleScope: TPasModuleScope;
- PendingResolver: TPasResolver;
- PendingParser: TPasParser;
- PendingModule: TPasModule;
- PendingImpl: TImplementationSection;
- begin
- {$IFDEF VerbosePasResolver}
- if not IsUnitIntfFinished(Section.GetModule) then
- RaiseInternalError(20171214004323,'TPasResolver.FinishInterfaceSection "'+CurrentParser.CurModule.Name+'" "'+Section.GetModule.Name+'" IsUnitIntfFinished=false');
- {$ENDIF}
- ModuleScope:=CurrentParser.CurModule.CustomData as TPasModuleScope;
- while ModuleScope.PendingResolvers.Count>0 do
- begin
- PendingResolver:=TObject(ModuleScope.PendingResolvers[0]) as TPasResolver;
- PendingParser:=PendingResolver.CurrentParser;
- PendingModule:=PendingParser.CurModule;
- PendingImpl:=PendingModule.ImplementationSection;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishInterfaceSection "',ModuleScope.Element.Name,'" Pending="',PendingModule.Name,'"');
- {$ENDIF}
- PendingResolver.CheckPendingUsedInterface(PendingImpl);
- end;
- if Section=nil then ;
- end;
- procedure TPasResolver.FinishTypeSection(El: TPasDeclarations);
- function ReplaceDestType(AliasType: TPasAliasType; const DestName: string;
- MustExist: boolean; ErrorEl: TPasElement): 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,@OnFindFirstElement,@Data,Abort);
- if (Data.Found=nil) then
- if MustExist then
- RaiseIdentifierNotFound(20170216151543,DestName,ErrorEl)
- else
- exit(false);
- if Data.Found.ClassType<>TPasClassType then
- RaiseXExpectedButYFound(20170216151548,'class',Data.Found.ElementTypeName,ErrorEl);
- // replace unresolved
- OldDestType:=AliasType.DestType;
- AliasType.DestType:=TPasType(Data.Found);
- AliasType.DestType.AddRef;
- OldDestType.Release;
- Result:=true;
- end;
- var
- i: Integer;
- Decl: TPasElement;
- ClassOfEl: TPasClassOfType;
- UnresolvedEl: TUnresolvedPendingRef;
- OldClassType: TPasClassType;
- TypeEl: TPasType;
- C: TClass;
- begin
- // resolve pending forwards
- for i:=0 to El.Declarations.Count-1 do
- begin
- Decl:=TPasElement(El.Declarations[i]);
- C:=Decl.ClassType;
- if C.InheritsFrom(TPasClassType) then
- begin
- if TPasClassType(Decl).IsForward and (TPasClassType(Decl).CustomData=nil) then
- RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[Decl.Name],Decl);
- end
- else if (C=TPasClassOfType) then
- begin
- ClassOfEl:=TPasClassOfType(Decl);
- TypeEl:=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,TypeEl.Name,true,UnresolvedEl);
- 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
- continue; // 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,TypeEl.Name,false,ClassOfEl);
- end;
- end;
- end;
- end;
- procedure TPasResolver.FinishTypeDef(El: TPasType);
- var
- C: TClass;
- aType: TPasType;
- 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=TPasArrayType then
- FinishArrayType(TPasArrayType(El))
- else if (C=TPasAliasType) or (C=TPasTypeAliasType) then
- begin
- aType:=ResolveAliasType(El);
- if (aType is TPasClassType) and (TPasClassType(aType).ObjKind=okInterface) then
- exit; // ToDo: msIgnoreInterfaces
- EmitTypeHints(El,TPasAliasType(El).DestType);
- end
- else if (C=TPasPointerType) then
- EmitTypeHints(El,TPasPointerType(El).DestType);
- end;
- procedure TPasResolver.FinishEnumType(El: TPasEnumType);
- begin
- if TopScope.Element=El then
- PopScope;
- end;
- procedure TPasResolver.FinishSetType(El: TPasSetType);
- var
- BaseTypeData: TResElDataBaseType;
- StartResolved, EndResolved: TPasResolverResult;
- RangeExpr: TBinaryExpr;
- C: TClass;
- EnumType: TPasType;
- begin
- EnumType:=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',EnumType.ElementTypeName,EnumType);
- end;
- end;
- RaiseXExpectedButYFound(20170216151557,'enum type',EnumType.ElementTypeName,EnumType);
- end;
- procedure TPasResolver.FinishSubElementType(Parent: TPasElement; El: TPasType);
- var
- Decl: TPasDeclarations;
- EnumScope: TPasEnumTypeScope;
- begin
- EmitTypeHints(Parent,El);
- if (El.Name<>'') or (AnonymousElTypePostfix='') then exit;
- if Parent.Name='' then
- RaiseMsg(20170415165455,nCannotNestAnonymousX,sCannotNestAnonymousX,[El.ElementTypeName],El);
- if not (Parent.Parent is TPasDeclarations) then
- RaiseMsg(20170416094735,nCannotNestAnonymousX,sCannotNestAnonymousX,[El.ElementTypeName],El);
- // 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}
- Decl:=TPasDeclarations(Parent.Parent);
- Decl.Declarations.Add(El);
- El.AddRef;
- El.Parent:=Decl;
- Decl.Types.Add(El);
- if (El.ClassType=TPasEnumType) and (Parent.ClassType=TPasSetType) then
- begin
- EnumScope:=TPasEnumTypeScope(El.CustomData);
- if EnumScope.CanonicalSet<>Parent then
- begin
- if EnumScope.CanonicalSet<>nil then
- EnumScope.CanonicalSet.Release;
- EnumScope.CanonicalSet:=TPasSetType(Parent);
- Parent.AddRef;
- 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,[rcSkipTypeAlias,rcConstant]);
- ComputeElement(Right,RightResolved,[rcSkipTypeAlias,rcConstant]);
- CheckSetLitElCompatible(Left,Right,LeftResolved,RightResolved);
- RgValue:=Eval(RangeExpr,[refConst]);
- ReleaseEvalValue(RgValue);
- end;
- procedure TPasResolver.FinishRecordType(El: TPasRecordType);
- begin
- if TopScope.Element=El then
- PopScope;
- end;
- procedure TPasResolver.FinishClassType(El: TPasClassType);
- begin
- if TopScope.Element=El then
- PopScope;
- end;
- procedure TPasResolver.FinishClassOfType(El: TPasClassOfType);
- var
- TypeEl: TPasType;
- begin
- TypeEl:=ResolveAliasType(El.DestType);
- if TypeEl is TUnresolvedPendingRef then exit;
- if TypeEl is TPasClassType then exit;
- RaiseMsg(20170216151602,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [El.DestType.Name,'class'],El);
- end;
- procedure TPasResolver.FinishArrayType(El: TPasArrayType);
- var
- i: Integer;
- Expr: TPasExpr;
- RangeResolved: TPasResolverResult;
- TypeEl: TPasType;
- begin
- 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
- RaiseXExpectedButYFound(20170216151607,'range',RangeResolved.IdentEl.ElementTypeName,Expr);
- 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:=ResolveAliasType(RangeResolved.TypeEl);
- if TypeEl is TPasRangeType then
- // custom range
- else
- RaiseXExpectedButYFound(20171009193629,'range',RangeResolved.IdentEl.ElementTypeName,Expr);
- end
- else
- RaiseXExpectedButYFound(20171009193514,'range',RangeResolved.IdentEl.ElementTypeName,Expr);
- end
- else if RangeResolved.BaseType in btArrayRangeTypes then
- // full range, e.g. array[char]
- else if (RangeResolved.BaseType=btContext) and (RangeResolved.TypeEl is TPasEnumType) then
- // e.g. array[enumtype]
- else
- RaiseXExpectedButYFound(20170216151609,'range',RangeResolved.IdentEl.ElementTypeName,Expr);
- end;
- if El.ElType=nil then
- RaiseNotYetImplemented(20171005235610,El,'array of const');
- FinishSubElementType(El,El.ElType);
- end;
- procedure TPasResolver.FinishConstDef(El: TPasConst);
- begin
- ResolveExpr(El.Expr,rraRead);
- if El.VarType<>nil then
- begin
- CheckAssignCompatibility(El,El.Expr,true);
- EmitTypeHints(El,El.VarType);
- end
- else
- Eval(El.Expr,[refConst])
- 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(aProc: TPasProcedure);
- var
- i: Integer;
- Body: TProcedureBody;
- SubEl: TPasElement;
- SubProcScope, ProcScope: TPasProcedureScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishProcedure START');
- {$ENDIF}
- CheckTopScope(FScopeClass_Proc);
- ProcScope:=TPasProcedureScope(TopScope);
- if ProcScope.Element<>aProc then
- RaiseInternalError(20170220163043);
- Body:=aProc.Body;
- if Body<>nil then
- begin
- StoreScannerFlagsInProc(ProcScope);
- if Body.Body is TPasImplAsmStatement then
- aProc.Modifiers:=aProc.Modifiers+[pmAssembler];
- ResolveImplBlock(Body.Body);
- // check if all 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,
- [SubEl.ElementTypeName,SubEl.Name],SubEl);
- end;
- end;
- end;
- PopScope;
- end;
- procedure TPasResolver.FinishProcedureType(El: TPasProcedureType);
- var
- ProcName: String;
- FindData: TFindOverloadProcData;
- DeclProc, Proc, ParentProc: TPasProcedure;
- Abort, HasDots: boolean;
- DeclProcScope, ProcScope: TPasProcedureScope;
- ParentScope: TPasScope;
- pm: TProcedureModifier;
- ptm: TProcTypeModifier;
- begin
- if (El.Parent is TPasProcedure) and (TPasProcedure(El.Parent).ProcType=El) then
- begin
- // finished header of a procedure declaration
- // -> search the best fitting proc
- CheckTopScope(FScopeClass_Proc);
- Proc:=TPasProcedure(El.Parent);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDbg(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent));
- {$ENDIF}
- ProcName:=Proc.Name;
- if (proProcTypeWithoutIsNested in Options) and El.IsNested then
- RaiseInvalidProcTypeModifier(20170402120811,El,ptmIsNested,El);
- if (Proc.Parent.ClassType=TProcedureBody) then
- begin
- // nested sub proc
- if not (proProcTypeWithoutIsNested in Options) then
- El.IsNested:=true;
- // inherit 'of Object'
- ParentProc:=Proc.Parent.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,[Proc.ElementTypeName,'external, '+ModifierNames[pm]],Proc);
- for ptm in Proc.ProcType.Modifiers do
- if not (ptm in [ptmOfObject,ptmIsNested,ptmStatic,ptmVarargs,ptmReferenceTo]) then
- RaiseMsg(20170411171224,nInvalidXModifierY,
- sInvalidXModifierY,[Proc.ElementTypeName,'external, '+ProcTypeModifiers[ptm]],Proc);
- end;
- HasDots:=Pos('.',ProcName)>1;
- if Proc.Parent is TPasClassType then
- begin
- // method declaration
- if Proc.IsAbstract then
- begin
- if not Proc.IsVirtual then
- RaiseMsg(20170216151623,nInvalidXModifierY,sInvalidXModifierY,[Proc.ElementTypeName,'abstract without virtual'],Proc);
- if Proc.IsOverride then
- RaiseMsg(20170216151625,nInvalidXModifierY,sInvalidXModifierY,[Proc.ElementTypeName,'abstract, override'],Proc);
- end;
- if Proc.IsVirtual and Proc.IsOverride then
- RaiseMsg(20170216151627,nInvalidXModifierY,sInvalidXModifierY,[Proc.ElementTypeName,'virtual, override'],Proc);
- if Proc.IsReintroduced and Proc.IsOverride then
- RaiseMsg(20171119111845,nInvalidXModifierY,sInvalidXModifierY,[Proc.ElementTypeName,'reintroduce, override'],Proc);
- if Proc.IsForward then
- RaiseMsg(20170216151629,nInvalidXModifierY,sInvalidXModifierY,[Proc.ElementTypeName,'forward'],Proc);
- if Proc.IsStatic then
- if (Proc.ClassType<>TPasClassProcedure) and (Proc.ClassType<>TPasClassFunction) then
- RaiseMsg(20170216151631,nInvalidXModifierY,sInvalidXModifierY,[Proc.ElementTypeName,'static'],Proc);
- end
- else
- begin
- // intf proc, forward proc, proc body, method body
- 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 then
- RaiseInvalidProcTypeModifier(20170216151640,El,ptmStatic,El);
- if (not HasDots)
- and (Proc.ClassType<>TPasProcedure)
- and (Proc.ClassType<>TPasFunction) then
- RaiseMsg(20170419232724,nXExpectedButYFound,sXExpectedButYFound,
- ['full method name','short name'],El);
- end;
- if HasDots then
- begin
- FinishMethodImplHeader(Proc);
- exit;
- end;
- // finish interface/implementation/nested procedure/method declaration
- if not IsValidIdent(ProcName) then
- RaiseNotYetImplemented(20160922163407,El);
- if El is TPasFunctionType then
- EmitTypeHints(TPasFunctionType(El).ResultEl,TPasFunctionType(El).ResultEl.ResultType);
- if Proc.LibraryExpr<>nil then
- ResolveExpr(Proc.LibraryExpr,rraRead);
- if Proc.LibrarySymbolName<>nil then
- ResolveExpr(Proc.LibrarySymbolName,rraRead);
- if Proc.Parent is TPasClassType then
- begin
- FinishMethodDeclHeader(Proc);
- exit;
- end;
- // finish interface/implementation/nested procedure
- if ProcNeedsBody(Proc) then
- begin
- // check if there is a forward declaration
- ParentScope:=Scopes[ScopeCount-2];
- //writeln('TPasResolver.FinishProcedureType FindForward2 ',GetObjName(ParentScope));
- DeclProc:=FindProcOverload(ProcName,Proc,ParentScope);
- //writeln('TPasResolver.FinishProcedureType FindForward3 ',GetObjName(DeclProc),' Proc.Parent=',GetObjName(Proc.Parent));
- if (DeclProc=nil) and (Proc.Parent.ClassType=TImplementationSection) then
- DeclProc:=FindProcOverload(ProcName,Proc,
- (Proc.GetModule.InterfaceSection.CustomData) as TPasScope);
- //writeln('TPasResolver.FinishProcedureType FindForward4 ',GetObjName(DeclProc));
- if (DeclProc<>nil) and ProcNeedsImplProc(DeclProc) then
- begin
- // found forward declaration -> connect
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishProcedureHeader forward found: Proc2=',GetTreeDbg(DeclProc),' ',GetElementSourcePosStr(DeclProc),' IsForward=',DeclProc.IsForward,' Parent=',GetObjName(DeclProc.Parent));
- {$ENDIF}
- CheckProcSignatureMatch(DeclProc,Proc,true);
- DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
- DeclProcScope.ImplProc:=Proc;
- ProcScope:=Proc.CustomData as TPasProcedureScope;
- ProcScope.DeclarationProc:=DeclProc;
- // remove ImplProc from scope
- ParentScope:=Scopes[ScopeCount-2];
- (ParentScope as TPasIdentifierScope).RemoveLocalIdentifier(Proc);
- // replace arguments with declaration arguments
- ReplaceProcScopeImplArgsWithDeclArgs(ProcScope);
- exit;
- end;
- end
- else
- begin
- // forward declaration
- ProcScope:=Proc.CustomData as TPasProcedureScope;
- // ToDo: store the scanner flags *before* it has parsed the token after the proc
- StoreScannerFlagsInProc(ProcScope);
- end;
- // check for invalid overloads
- FindData:=Default(TFindOverloadProcData);
- FindData.Proc:=Proc;
- FindData.Args:=Proc.ProcType.Args;
- FindData.Kind:=fopkProc;
- Abort:=false;
- IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort);
- end
- else if El.Name<>'' then
- begin
- // finished proc type, e.g. type TProcedure = procedure;
- end
- else
- RaiseNotYetImplemented(20160922163411,El.Parent);
- 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 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: boolean;
- ClassScope: TPasClassScope;
- FindData: TFindOverloadProcData;
- OverloadProc: TPasProcedure;
- ProcScope: TPasProcedureScope;
- i: Integer;
- begin
- Proc.ProcType.IsOfObject:=true;
- ProcScope:=TopScope as TPasProcedureScope;
- // ToDo: store the scanner flags *before* it has parsed the token after the proc
- StoreScannerFlagsInProc(ProcScope);
- ClassScope:=Scopes[ScopeCount-2] as TPasClassScope;
- ProcScope.ClassScope:=ClassScope;
- FindData:=Default(TFindOverloadProcData);
- FindData.Proc:=Proc;
- FindData.Args:=Proc.ProcType.Args;
- FindData.Kind:=fopkMethod;
- Abort:=false;
- ClassScope.IterateElements(Proc.Name,ClassScope,@OnFindOverloadProc,@FindData,Abort);
- 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,false);
- // 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 then
- for i:=length(ClassScope.AbstractProcs)-1 downto 0 do
- if ClassScope.AbstractProcs[i]=OverloadProc then
- Delete(ClassScope.AbstractProcs,i,1);
- end;
- end;
- // add abstract
- if Proc.IsAbstract then
- Insert(Proc,ClassScope.AbstractProcs,length(ClassScope.AbstractProcs));
- end;
- procedure TPasResolver.FinishMethodImplHeader(ImplProc: TPasProcedure);
- var
- ProcName: String;
- CurClassType: TPasClassType;
- ImplProcScope, DeclProcScope: TPasProcedureScope;
- DeclProc: TPasProcedure;
- CurClassScope: TPasClassScope;
- SelfArg: TPasArgument;
- p: Integer;
- begin
- if ImplProc.IsExternal then
- RaiseMsg(20170216151715,nInvalidXModifierY,sInvalidXModifierY,[ImplProc.ElementTypeName,'external'],ImplProc);
- if ImplProc.IsExported then
- RaiseMsg(20170216151717,nInvalidXModifierY,sInvalidXModifierY,[ImplProc.ElementTypeName,'export'],ImplProc);
- ProcName:=ImplProc.Name;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishMethodBodyHeader searching declaration "',ProcName,'" ...');
- {$ENDIF}
- ImplProc.ProcType.IsOfObject:=true;
- repeat
- p:=Pos('.',ProcName);
- if p<1 then break;
- Delete(ProcName,1,p);
- until false;
- // search ImplProc in class
- if not IsValidIdent(ProcName) then
- RaiseNotYetImplemented(20160922163421,ImplProc.ProcType);
- // search proc in class
- ImplProcScope:=ImplProc.CustomData as TPasProcedureScope;
- CurClassScope:=ImplProcScope.ClassScope;
- if CurClassScope=nil then
- RaiseInternalError(20161013172346);
- CurClassType:=NoNil(CurClassScope.Element) as TPasClassType;
- DeclProc:=FindProcOverload(ProcName,ImplProc,CurClassScope);
- if DeclProc=nil then
- RaiseIdentifierNotFound(20170216151720,ImplProc.Name,ImplProc.ProcType);
- // connect method declaration and body
- if DeclProc.IsAbstract then
- RaiseMsg(20170216151722,nAbstractMethodsMustNotHaveImplementation,sAbstractMethodsMustNotHaveImplementation,[],ImplProc);
- if DeclProc.IsExternal then
- RaiseXExpectedButYFound(20170216151725,'method','external method',ImplProc);
- CheckProcSignatureMatch(DeclProc,ImplProc,true);
- ImplProcScope.DeclarationProc:=DeclProc;
- DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
- DeclProcScope.ImplProc:=ImplProc;
- // replace arguments in scope with declaration arguments
- ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope);
- if not DeclProc.IsStatic then
- begin
- // add 'Self'
- if (DeclProc.ClassType=TPasClassConstructor)
- or (DeclProc.ClassType=TPasClassDestructor)
- or (DeclProc.ClassType=TPasClassProcedure)
- or (DeclProc.ClassType=TPasClassFunction) then
- begin
- if not DeclProc.IsStatic then
- begin
- // 'Self' in a class proc is the hidden classtype argument
- SelfArg:=TPasArgument.Create('Self',DeclProc);
- ImplProcScope.SelfArg:=SelfArg;
- SelfArg.Access:=argConst;
- SelfArg.ArgType:=CurClassScope.CanonicalClassOf;
- SelfArg.ArgType.AddRef;
- AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
- end;
- end
- else
- begin
- // 'Self' in a proc is the hidden instance argument
- SelfArg:=TPasArgument.Create('Self',DeclProc);
- ImplProcScope.SelfArg:=SelfArg;
- SelfArg.Access:=argConst;
- SelfArg.ArgType:=CurClassType;
- CurClassType.AddRef;
- AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
- end;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishMethodBodyHeader END of searching proc "',ImplProc.Name,'" ...');
- {$ENDIF}
- end;
- procedure TPasResolver.FinishExceptOnExpr;
- var
- El: TPasImplExceptOn;
- ResolvedType: TPasResolverResult;
- begin
- CheckTopScope(TPasExceptOnScope);
- El:=TPasImplExceptOn(FTopScope.Element);
- ComputeElement(El.TypeEl,ResolvedType,[rcSkipTypeAlias,rcType]);
- CheckIsClass(El.TypeEl,ResolvedType);
- end;
- procedure TPasResolver.FinishExceptOnStatement;
- begin
- //writeln('TPasResolver.FinishExceptOnStatement START');
- CheckTopScope(TPasExceptOnScope);
- ResolveImplElement(TPasImplExceptOn(FTopScope.Element).Body);
- PopScope;
- end;
- procedure TPasResolver.FinishDeclaration(El: TPasElement);
- var
- C: TClass;
- begin
- C:=El.ClassType;
- if C=TPasVariable then
- FinishVariable(TPasVariable(El))
- else if C=TPasProperty then
- FinishPropertyOfClass(TPasProperty(El))
- else if C=TPasArgument then
- FinishArgument(TPasArgument(El))
- else
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.FinishDeclaration ',GetObjName(El));
- {$ENDIF}
- end;
- end;
- procedure TPasResolver.FinishVariable(El: TPasVariable);
- var
- ResolvedAbs: TPasResolverResult;
- C: TClass;
- 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
- begin
- ResolveExpr(El.Expr,rraRead);
- CheckAssignCompatibility(El,El.Expr,true);
- end;
- if El.AbsoluteExpr<>nil then
- begin
- 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
- RaiseMsg(20171225234734,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
- 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
- RaiseMsg(20171225235249,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
- // check for cycles
- if ResolvedAbs.IdentEl=El then
- RaiseMsg(20171226000703,nVariableIdentifierExpected,sVariableIdentifierExpected,[],El.AbsoluteExpr);
- end;
- EmitTypeHints(El,El.VarType);
- end;
- procedure TPasResolver.FinishPropertyOfClass(PropEl: TPasProperty);
- var
- PropType: TPasType;
- ClassScope: TPasClassScope;
- AncestorProp: TPasProperty;
- IndexExpr: TPasExpr;
- procedure GetPropType;
- var
- AncEl: TPasElement;
- begin
- if PropType<>nil then exit;
- AncEl:=nil;
- if ClassScope.AncestorScope<>nil then
- AncEl:=ClassScope.AncestorScope.FindElement(PropEl.Name);
- if AncEl is TPasProperty then
- begin
- // override or redeclaration property
- AncestorProp:=TPasProperty(AncEl);
- TPasPropertyScope(PropEl.CustomData).AncestorProp:=AncestorProp;
- AncestorProp.AddRef;
- 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;
- 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,AncestorProp.ElementTypeName,PropEl.ElementTypeName,PropEl);
- // get inherited type
- PropType:=GetPasPropertyType(AncestorProp);
- // update DefaultProperty
- if (ClassScope.DefaultProperty=AncestorProp) then
- ClassScope.DefaultProperty:=PropEl;
- end;
- end;
- function GetAccessor(Expr: TPasExpr): TPasElement;
- var
- Prim: TPrimitiveExpr;
- DeclEl: TPasElement;
- Identifier: TPasIdentifier;
- Scope: TPasIdentifierScope;
- begin
- if Expr.ClassType=TBinaryExpr then
- begin
- if (TBinaryExpr(Expr).left is TPrimitiveExpr) then
- begin
- Prim:=TPrimitiveExpr(TBinaryExpr(Expr).left);
- if Prim.Kind<>pekIdent then
- RaiseXExpectedButYFound(20170216151746,'class',Prim.Value,Prim);
- Scope:=TopScope as TPasIdentifierScope;
- // search in class and ancestors, not in unit interface
- Identifier:=Scope.FindIdentifier(Prim.Value);
- if Identifier=nil then
- RaiseIdentifierNotFound(20170216151749,Prim.Value,Prim);
- DeclEl:=Identifier.Element;
- if DeclEl.ClassType<>TPasClassType then
- RaiseXExpectedButYFound(20170216151752,'class',DeclEl.ElementTypeName,Prim);
- CreateReference(DeclEl,Prim,rraRead);
- 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);
- PushClassDotScope(TPasClassType(DeclEl));
- Expr:=TBinaryExpr(Expr).right;
- Result:=GetAccessor(Expr);
- PopScope;
- end
- else if Expr.ClassType=TPrimitiveExpr then
- begin
- Prim:=TPrimitiveExpr(Expr);
- if Prim.Kind<>pekIdent then
- RaiseXExpectedButYFound(20170216151800,'identifier',Prim.Value,Prim);
- Scope:=TopScope as TPasIdentifierScope;
- // search in class and ancestors, not in unit interface
- Identifier:=Scope.FindIdentifier(Prim.Value);
- if Identifier=nil then
- RaiseIdentifierNotFound(20170216151803,Prim.Value,Prim);
- DeclEl:=Identifier.Element;
- CreateReference(DeclEl,Prim,rraRead);
- Result:=DeclEl;
- end
- else
- RaiseNotYetImplemented(20160922163436,Expr);
- 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;
- 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, ...
- if PropArg.Access<>ProcArg.Access then
- RaiseMsg(20170216151808,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),AccessDescriptions[ProcArg.Access],
- AccessDescriptions[PropArg.Access]],ErrorEl);
- // check argument type
- if PropArg.ArgType=nil then
- begin
- if ProcArg.ArgType<>nil then
- RaiseMsg(20170216151811,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),ProcArg.ArgType.ElementTypeName,'untyped'],ErrorEl);
- end
- else if ProcArg.ArgType=nil then
- RaiseMsg(20170216151813,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo,
- [IntToStr(ArgNo),'untyped',PropArg.ArgType.ElementTypeName],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.TypeEl=nil then
- RaiseInternalError(20161010125255);
- if ProcArgResolved.TypeEl=nil then
- RaiseInternalError(20161010125304);
- if not IsSameType(PropArgResolved.TypeEl,ProcArgResolved.TypeEl,true) then
- RaiseIncompatibleType(20170216151819,nIncompatibleTypeArgNo,
- [IntToStr(ArgNo)],ProcArgResolved.TypeEl,PropArgResolved.TypeEl,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 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 '+Proc.ElementTypeName,Expr);
- if Proc.ClassType<>TPasFunction then
- RaiseXExpectedButYFound(20170216151925,'function',Proc.ElementTypeName,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);
- // 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 '+aVar.ElementTypeName,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: TPasType;
- CurClassType: TPasClassType;
- AccEl: TPasElement;
- Proc: TPasProcedure;
- Arg: TPasArgument;
- PropArgCount, NeedArgCnt: Integer;
- PropTypeResolved, DefaultResolved, IndexResolved,
- AncIndexResolved: TPasResolverResult;
- m: TVariableModifier;
- IndexVal: TResEvalValue;
- AncIndexExpr: TPasExpr;
- 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;
- CurClassType:=PropEl.Parent as TPasClassType;
- ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope;
- 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,
- revkString, 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
- AccEl:=GetAccessor(PropEl.ReadAccessor);
- if (AccEl.ClassType=TPasVariable) or (AccEl.ClassType=TPasConst) then
- begin
- if (PropEl.Args.Count>0) then
- RaiseXExpectedButYFound(20170216151823,'function',AccEl.ElementTypeName,PropEl.ReadAccessor);
- if not IsSameType(TPasVariable(AccEl).VarType,PropType,true) then
- RaiseIncompatibleType(20170216151826,nIncompatibleTypesGotExpected,
- [],PropType,TPasVariable(AccEl).VarType,PropEl.ReadAccessor);
- if (vmClass in PropEl.VarModifiers)<>(vmClass in TPasVariable(AccEl).VarModifiers) then
- if vmClass in PropEl.VarModifiers then
- RaiseXExpectedButYFound(20170216151828,'class var','var',PropEl.ReadAccessor)
- else
- RaiseXExpectedButYFound(20170216151831,'var','class var',PropEl.ReadAccessor);
- 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',Proc.ElementTypeName,PropEl.ReadAccessor);
- if Proc.IsStatic=(proClassPropertyNonStatic in Options) then
- if Proc.IsStatic then
- RaiseMsg(20170216151837,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.ReadAccessor)
- else
- RaiseMsg(20170216151839,nClassPropertyAccessorMustBeStatic,sClassPropertyAccessorMustBeStatic,[],PropEl.ReadAccessor);
- end
- else
- begin
- if Proc.ClassType<>TPasFunction then
- RaiseXExpectedButYFound(20170216151842,'function',Proc.ElementTypeName,PropEl.ReadAccessor);
- end;
- // check function result type
- ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
- if not IsSameType(ResultType,PropType,true) then
- RaiseXExpectedButYFound(20170216151844,'function result '+GetTypeDescription(PropType,true),
- GetTypeDescription(ResultType,true),PropEl.ReadAccessor);
- // 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],PropEl.ReadAccessor);
- end
- else
- RaiseXExpectedButYFound(20170216151850,'variable',AccEl.ElementTypeName,PropEl.ReadAccessor);
- end;
- if PropEl.WriteAccessor<>nil then
- begin
- // check compatibility
- AccEl:=GetAccessor(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',AccEl.ElementTypeName,PropEl.WriteAccessor);
- if not IsSameType(TPasVariable(AccEl).VarType,PropType,true) then
- RaiseIncompatibleType(20170216151855,nIncompatibleTypesGotExpected,
- [],PropType,TPasVariable(AccEl).VarType,PropEl.WriteAccessor);
- if (vmClass in PropEl.VarModifiers)<>(vmClass in TPasVariable(AccEl).VarModifiers) then
- if vmClass in PropEl.VarModifiers then
- RaiseXExpectedButYFound(20170216151858,'class var','var',PropEl.WriteAccessor)
- else
- RaiseXExpectedButYFound(20170216151900,'var','class var',PropEl.WriteAccessor);
- 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',Proc.ElementTypeName,PropEl.WriteAccessor);
- if Proc.IsStatic=(proClassPropertyNonStatic in Options) then
- if Proc.IsStatic then
- RaiseMsg(20170216151905,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.WriteAccessor)
- else
- RaiseMsg(20170216151906,nClassPropertyAccessorMustBeStatic,sClassPropertyAccessorMustBeStatic,[],PropEl.WriteAccessor);
- end
- else
- begin
- if Proc.ClassType<>TPasProcedure then
- RaiseXExpectedButYFound(20170216151910,'procedure',Proc.ElementTypeName,PropEl.WriteAccessor);
- end;
- // check args
- CheckArgs(Proc,IndexVal,IndexResolved,PropEl.ReadAccessor);
- // 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],PropEl.WriteAccessor);
- 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]],PropEl.WriteAccessor);
- if not IsSameType(Arg.ArgType,PropType,true) then
- RaiseIncompatibleType(20170216151919,nIncompatibleTypeArgNo,
- [IntToStr(PropArgCount+1)],Arg.ArgType,PropType,PropEl.WriteAccessor);
- end
- else
- RaiseXExpectedButYFound(20170216151921,'variable',AccEl.ElementTypeName,PropEl.WriteAccessor);
- end;
- if PropEl.ImplementsFunc<>nil then
- begin
- ResolveExpr(PropEl.ImplementsFunc,rraRead);
- // ToDo: check compatibility
- RaiseNotYetImplemented(20170409213850,PropEl.ImplementsFunc);
- end;
- 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
- // set default array property
- if (ClassScope.DefaultProperty<>nil)
- and (ClassScope.DefaultProperty.Parent=PropEl.Parent) then
- RaiseMsg(20170216151938,nOnlyOneDefaultPropertyIsAllowed,sOnlyOneDefaultPropertyIsAllowed,[],PropEl);
- ClassScope.DefaultProperty:=PropEl;
- end;
- EmitTypeHints(PropEl,PropEl.VarType);
- finally
- ReleaseEvalValue(IndexVal);
- end;
- end;
- procedure TPasResolver.FinishArgument(El: TPasArgument);
- begin
- if El.ValueExpr<>nil then
- begin
- ResolveExpr(El.ValueExpr,rraRead);
- if El.ArgType<>nil then
- CheckAssignCompatibility(El,El.ValueExpr,true);
- 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
- AncestorEl: TPasClassType;
- ClassScope, AncestorClassScope: TPasClassScope;
- DirectAncestor, AncestorType, El: TPasType;
- i: Integer;
- aModifier: String;
- IsSealed: Boolean;
- CanonicalSelf: TPasClassOfType;
- begin
- if aClass.IsForward then
- exit;
- if aClass.ObjKind<>okClass then
- begin
- if (aClass.ObjKind=okInterface)
- and (msIgnoreInterfaces in CurrentParser.CurrentModeswitches) then
- exit;
- 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;
- else
- RaiseMsg(20170320190619,nIllegalQualifier,sIllegalQualifier,[aClass.Modifiers[i]],aClass);
- end;
- end;
- DirectAncestor:=aClass.AncestorType;
- AncestorType:=ResolveAliasType(DirectAncestor);
- if AncestorType=nil then
- begin
- if (CompareText(aClass.Name,'TObject')=0) or aClass.IsExternal then
- begin
- // ok, no ancestors
- AncestorEl:=nil;
- end else begin
- // search default ancestor TObject
- AncestorEl:=TPasClassType(FindElementWithoutParams('TObject',aClass,false));
- if not (AncestorEl is TPasClassType) then
- RaiseXExpectedButYFound(20170216151941,'class type',GetObjName(AncestorEl),aClass);
- if DirectAncestor=nil then
- DirectAncestor:=AncestorEl;
- 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
- AncestorEl:=TPasClassType(AncestorType);
- if AncestorEl.ObjKind<>okClass then
- AncestorEl:=nil
- else
- EmitTypeHints(aClass,AncestorEl);
- end;
- AncestorClassScope:=nil;
- if AncestorEl=nil then
- begin
- // root class e.g. TObject
- end
- else
- begin
- // inherited class
- if AncestorEl.IsForward then
- RaiseMsg(20170216151947,nCantUseForwardDeclarationAsAncestor,
- sCantUseForwardDeclarationAsAncestor,[AncestorEl.Name],aClass);
- if aClass.IsExternal and not AncestorEl.IsExternal then
- RaiseMsg(20170321144035,nAncestorIsNotExternal,sAncestorIsNotExternal,
- [AncestorEl.Name],aClass);
- AncestorClassScope:=AncestorEl.CustomData as TPasClassScope;
- if pcsfSealed in AncestorClassScope.Flags then
- RaiseMsg(20170320191735,nCannotCreateADescendantOfTheSealedClass,
- sCannotCreateADescendantOfTheSealedClass,[AncestorEl.Name],aClass);
- // check for cycle
- El:=AncestorEl;
- repeat
- if El=aClass then
- RaiseMsg(20170216151949,nAncestorCycleDetected,sAncestorCycleDetected,[],aClass);
- if (El.ClassType=TPasAliasType)
- or (El.ClassType=TPasTypeAliasType)
- then
- El:=TPasAliasType(El).DestType
- else if El.ClassType=TPasClassType then
- El:=TPasClassType(El).AncestorType;
- until El=nil;
- end;
- // start scope for elements
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.FinishAncestors ',GetObjName(aClass.CustomData));
- {$ENDIF}
- PushScope(aClass,ScopeClass_Class);
- ClassScope:=TPasClassScope(TopScope);
- ClassScope.VisibilityContext:=aClass;
- Include(ClassScope.Flags,pcsfAncestorResolved);
- if IsSealed then
- Include(ClassScope.Flags,pcsfSealed);
- ClassScope.DirectAncestor:=DirectAncestor;
- if AncestorEl<>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 CurrentParser.Scanner.IsDefined(LetterSwitchNames['M']) then
- Include(ClassScope.Flags,pcsfPublished);
- // create canonical class-of for the "Self" in class functions
- CanonicalSelf:=TPasClassOfType.Create('Self',aClass);
- ClassScope.CanonicalClassOf:=CanonicalSelf;
- CanonicalSelf.DestType:=aClass;
- aClass.AddRef;
- CanonicalSelf.Visibility:=visStrictPrivate;
- CanonicalSelf.SourceFilename:=aClass.SourceFilename;
- CanonicalSelf.SourceLinenumber:=aClass.SourceLinenumber;
- // ToDo: interfaces
- 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;
- AccessExpr(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.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<>nil) then
- aType:=TPasType((aType.CustomData as TResolvedReference).Declaration)
- else
- exit;
- end;
- end;
- function TPasResolver.EmitElementHints(PosEl, El: TPasElement): boolean;
- begin
- if IsElementSkipped(El) then
- RaiseMsg(20170927160030,nNotYetImplemented,sNotYetImplemented,[GetObjName(El)],PosEl);
- 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
- ProcScope.ScannerBoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
- if bsRangeChecks in ProcScope.ScannerBoolSwitches then
- begin
- ModScope:=RootElement.CustomData as TPasModuleScope;
- Include(ModScope.Flags,pmsfRangeErrorNeeded);
- end;
- end;
- procedure TPasResolver.ReplaceProcScopeImplArgsWithDeclArgs(
- ImplProcScope: TPasProcedureScope);
- var
- DeclProc, ImplProc: TPasProcedure;
- DeclArgs, ImplArgs: TFPList;
- i: Integer;
- DeclArg, ImplArg: TPasArgument;
- Identifier: TPasIdentifier;
- begin
- ImplProc:=ImplProcScope.Element as TPasProcedure;
- ImplArgs:=ImplProc.ProcType.Args;
- DeclProc:=ImplProcScope.DeclarationProc;
- 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
- RaiseNotYetImplemented(20170203161826,ImplProc);
- end;
- if DeclProc is TPasFunction then
- begin
- // redirect implementation 'Result' to declaration FuncType.ResultEl
- Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar);
- if Identifier.Element is TPasResultElement then
- Identifier.Element:=TPasFunction(DeclProc).FuncType.ResultEl;
- end;
- end;
- procedure TPasResolver.CheckConditionExpr(El: TPasExpr;
- const ResolvedEl: TPasResolverResult);
- begin
- if ResolvedEl.BaseType<>btBoolean then
- RaiseMsg(20170216152135,nXExpectedButYFound,sXExpectedButYFound,
- [BaseTypeNames[btBoolean],BaseTypeNames[ResolvedEl.BaseType]],El);
- end;
- procedure TPasResolver.CheckProcSignatureMatch(DeclProc,
- ImplProc: TPasProcedure; CheckNames: boolean);
- var
- i: Integer;
- DeclArgs, ImplArgs: TFPList;
- DeclName, ImplName: String;
- ImplResult, DeclResult: TPasType;
- begin
- if ImplProc.ClassType<>DeclProc.ClassType then
- RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc);
- if ImplProc.CallingConvention<>DeclProc.CallingConvention then
- RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
- if ImplProc is TPasFunction then
- begin
- // check result type
- ImplResult:=TPasFunction(ImplProc).FuncType.ResultEl.ResultType;
- DeclResult:=TPasFunction(DeclProc).FuncType.ResultEl.ResultType;
- if not CheckProcArgTypeCompatibility(ImplResult,DeclResult) then
- RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound,
- [],DeclResult,ImplResult,ImplProc);
- end;
- if CheckNames then
- begin
- // check argument names
- DeclArgs:=DeclProc.ProcType.Args;
- ImplArgs:=ImplProc.ProcType.Args;
- 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;
- 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
- ResolveImplForLoop(TPasImplForLoop(El))
- 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);
- var
- i, j: Integer;
- El: TPasElement;
- Stat: TPasImplCaseStatement;
- CaseExprResolved, OfExprResolved: TPasResolverResult;
- OfExpr: TPasExpr;
- ok: Boolean;
- begin
- ResolveExpr(CaseOf.CaseExpr,rraRead);
- ComputeElement(CaseOf.CaseExpr,CaseExprResolved,[rcSetReferenceFlags]);
- ok:=false;
- if (rrfReadable in CaseExprResolved.Flags) then
- begin
- if (CaseExprResolved.BaseType in (btAllInteger+btAllBooleans+btAllStringAndChars)) then
- ok:=true
- else if CaseExprResolved.BaseType=btContext then
- begin
- if CaseExprResolved.TypeEl.ClassType=TPasEnumType then
- ok:=true;
- end;
- end;
- if not ok then
- RaiseXExpectedButYFound(20170216151952,'ordinal expression',
- GetTypeDescription(CaseExprResolved.TypeEl),CaseOf.CaseExpr);
- 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);
- CheckEqualResCompatibility(CaseExprResolved,OfExprResolved,OfExpr,true);
- 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
- end;
- procedure TPasResolver.ResolveImplLabelMark(Mark: TPasImplLabelMark);
- begin
- RaiseNotYetImplemented(20161014141636,Mark);
- end;
- procedure TPasResolver.ResolveImplForLoop(Loop: TPasImplForLoop);
- var
- VarResolved, StartResolved, EndResolved,
- OrigStartResolved: TPasResolverResult;
- EnumeratorFound, HasInValues: Boolean;
- InRange, VarRange: TResEvalValue;
- InRangeInt, VarRangeInt: TResEvalRangeInt;
- bt: TResolverBaseType;
- TypeEl: TPasType;
- C: TClass;
- begin
- CreateScope(Loop,TPasForLoopScope);
- // loop var
- ResolveExpr(Loop.VariableName,rraReadAndAssign);
- ComputeElement(Loop.VariableName,VarResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
- if not ResolvedElCanBeVarParam(VarResolved) then
- RaiseMsg(20170216151955,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Loop.VariableName);
- // 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:=false;
- if (StartResolved.BaseType=btContext) then
- begin
- TypeEl:=ResolveAliasType(StartResolved.TypeEl);
- C:=TypeEl.ClassType;
- if C=TPasClassType then
- EnumeratorFound:=CheckForInClass(Loop,VarResolved,StartResolved);
- end;
- if not EnumeratorFound then
- begin
- VarRange:=EvalTypeRange(VarResolved.TypeEl,[]);
- if VarRange=nil then
- RaiseXExpectedButYFound(20171109191528,'range',
- GetResolverResultDescription(VarResolved),Loop.VariableName);
- //writeln('TPasResolver.ResolveImplForLoop ForIn VarRange=',VarRange.AsDebugString);
- InRange:=nil;
- try
- OrigStartResolved:=StartResolved;
- if StartResolved.IdentEl is TPasType then
- begin
- // e.g. for e in TEnum do
- TypeEl:=ResolveAliasType(StartResolved.TypeEl);
- 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}
- if InRange<>nil then
- writeln('TPasResolver.ResolveImplForLoop in type: InRange=',InRange.AsDebugString)
- else
- writeln('TPasResolver.ResolveImplForLoop in type: InRange=nil');
- {$ENDIF}
- end
- else if rrfReadable in StartResolved.Flags then
- begin
- // value (variable or expression)
- bt:=StartResolved.BaseType;
- if bt=btSet then
- begin
- if (StartResolved.IdentEl=nil) and (StartResolved.ExprEl<>nil) then
- InRange:=Eval(StartResolved.ExprEl,[refAutoConst])
- else
- InRange:=EvalTypeRange(StartResolved.TypeEl,[]);
- end
- else if bt=btContext then
- begin
- TypeEl:=ResolveAliasType(StartResolved.TypeEl);
- C:=TypeEl.ClassType;
- if C=TPasArrayType then
- begin
- ComputeElement(TPasArrayType(TypeEl).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);
- if bt=btAnsiString then
- InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff)
- else if bt=btUnicodeString then
- InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ffff);
- end;
- end;
- if (not EnumeratorFound) and (InRange<>nil) then
- begin
- // for v in <constant> do
- // -> check if same type
- //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) 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}
- writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRange.AsDebugString,' StartResolved=',GetResolverResultDbg(StartResolved));
- {$ENDIF}
- RaiseMsg(20171108223818,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
- [GetBaseDescription(OrigStartResolved)],Loop.StartExpr);
- end;
- finally
- ReleaseEvalValue(VarRange);
- ReleaseEvalValue(InRange);
- end;
- end;
- end;
- else
- RaiseNotYetImplemented(20171108221334,Loop);
- end;
- ResolveImplElement(Loop.Body);
- end;
- procedure TPasResolver.ResolveImplWithDo(El: TPasImplWithDo);
- var
- i, OldScopeCount: Integer;
- Expr, ErrorEl: TPasExpr;
- ExprResolved: TPasResolverResult;
- TypeEl: TPasType;
- WithScope: TPasWithScope;
- WithExprScope: TPasWithExprScope;
- ExprScope: TPasScope;
- OnlyTypeMembers: Boolean;
- ClassEl: TPasClassType;
- begin
- OldScopeCount:=ScopeCount;
- WithScope:=TPasWithScope(CreateScope(El,TPasWithScope));
- PushScope(WithScope);
- for i:=0 to El.Expressions.Count-1 do
- begin
- Expr:=TPasExpr(El.Expressions[i]);
- ResolveExpr(Expr,rraRead);
- ComputeElement(Expr,ExprResolved,[rcSkipTypeAlias,rcSetReferenceFlags]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveImplWithDo ExprResolved=',GetResolverResultDbg(ExprResolved));
- {$ENDIF}
- ErrorEl:=Expr;
- TypeEl:=ExprResolved.TypeEl;
- // ToDo: use last element in Expr for error position
- if TypeEl=nil then
- RaiseMsg(20170216152004,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
- [BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
- OnlyTypeMembers:=false;
- if TypeEl.ClassType=TPasRecordType then
- begin
- ExprScope:=NoNil(TPasRecordType(TypeEl).CustomData) as TPasRecordScope;
- if ExprResolved.IdentEl is TPasType then
- // e.g. with TPoint do PointInCircle
- OnlyTypeMembers:=true;
- end
- else if TypeEl.ClassType=TPasClassType then
- begin
- ExprScope:=NoNil(TPasClassType(TypeEl).CustomData) as TPasClassScope;
- if ExprResolved.IdentEl is TPasType then
- // e.g. with TFPMemoryImage do FindHandlerFromExtension()
- OnlyTypeMembers:=true;
- end
- else if TypeEl.ClassType=TPasClassOfType then
- begin
- // e.g. with ImageClass do FindHandlerFromExtension()
- ClassEl:=ResolveAliasType(TPasClassOfType(TypeEl).DestType) as TPasClassType;
- ExprScope:=ClassEl.CustomData as TPasClassScope;
- OnlyTypeMembers:=true;
- end
- else
- RaiseMsg(20170216152007,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
- [TypeEl.ElementTypeName],ErrorEl);
- WithExprScope:=ScopeClass_WithExpr.Create;
- WithExprScope.WithScope:=WithScope;
- WithExprScope.Index:=i;
- WithExprScope.Expr:=Expr;
- WithExprScope.Scope:=ExprScope;
- if not (ExprResolved.IdentEl is TPasType) then
- Include(WithExprScope.Flags,wesfNeedTmpVar);
- if OnlyTypeMembers then
- Include(WithExprScope.Flags,wesfOnlyTypeMembers);
- if (not (rrfWritable in ExprResolved.Flags))
- and (ExprResolved.BaseType=btContext)
- and (ExprResolved.TypeEl.ClassType=TPasRecordType) then
- Include(WithExprScope.Flags,wesfConstParent);
- WithScope.ExpressionScopes.Add(WithExprScope);
- PushScope(WithExprScope);
- end;
- ResolveImplElement(El.Body);
- CheckTopScope(ScopeClass_WithExpr);
- if TopScope<>WithScope.ExpressionScopes[WithScope.ExpressionScopes.Count-1] then
- RaiseInternalError(20160923102846);
- while ScopeCount>OldScopeCount do
- PopScope;
- 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;
- 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,[rcSkipTypeAlias,rcNoImplicitProc,rcSetReferenceFlags]);
- CheckCanBeLHS(LeftResolved,true,El.left);
- // compute RHS
- ResolveExpr(El.right,rraRead); // ToDo: btArrayLit: if LHS is array then pass ArrType and Dim
- Flags:=[rcSkipTypeAlias,rcSetReferenceFlags];
- if IsProcedureType(LeftResolved,true) then
- 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
- {$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);
- end;
- akAdd, akMinus,akMul,akDivision:
- begin
- if (El.Kind in [akAdd,akMinus,akMul]) and (LeftResolved.BaseType in btAllInteger) 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 (El.Kind=akAdd) and (LeftResolved.BaseType in btAllStrings) 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 (El.Kind in [akAdd,akMinus,akMul,akDivision])
- and (LeftResolved.BaseType in btAllFloats) 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=btSet) 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
- RaiseMsg(20170216152125,nIllegalQualifier,sIllegalQualifier,[AssignKindNames[El.Kind]],El);
- // store const expression result
- Eval(El.right,[]);
- 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,[rcSkipTypeAlias,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,[rcSkipTypeAlias,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}
- RaiseMsg(20170216152133,nXExpectedButYFound,sXExpectedButYFound,
- ['variable',ResolvedEl.IdentEl.ElementTypeName],El.ExceptObject);
- end;
- end
- else if ResolvedEl.ExprEl<>nil then
- else
- RaiseMsg(201702303145230,nXExpectedButYFound,sXExpectedButYFound,
- ['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=TSelfExpr then
- ResolveNameExpr(El,'Self',Access)
- 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
- 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,[rcSkipTypeAlias,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;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveNameExpr El=',GetObjName(El),' Name="',aName,'" ',Access);
- {$ENDIF}
- DeclEl:=FindElementWithoutParams(aName,FindData,El,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
- if El.Parent.ClassType=TPasProperty then
- // a property accessor does not need args -> ok
- // Note: the detailed tests are in FinishPropertyOfClass
- else
- begin
- // examples: funca or @proca or a.funca or @a.funca ...
- Proc:=TPasProcedure(DeclEl);
- if (Access=rraAssign) and (Proc is TPasFunction)
- 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:=(Proc as TPasFunction).FuncType.ResultEl;
- exit;
- end;
- end;
- if ProcNeedsParams(Proc.ProcType) and not ExprIsAddrTarget(El) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveNameExpr ',GetObjName(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 names 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
- ProcScope, DeclProcScope, SelfScope: TPasProcedureScope;
- AncestorScope, ClassScope: TPasClassScope;
- DeclProc, AncestorProc: TPasProcedure;
- 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;'
- ResolveInheritedCall(TBinaryExpr(El.Parent),Access);
- exit;
- end;
- // 'inherited;' without expression
- ProcScope:=GetInheritedExprScope(El);
- SelfScope:=ProcScope.GetSelfScope;
- if SelfScope=nil then
- RaiseMsg(20170216152141,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
- ClassScope:=SelfScope.ClassScope;
- AncestorScope:=ClassScope.AncestorScope;
- if AncestorScope=nil then
- begin
- // 'inherited;' without ancestor class is silently ignored
- exit;
- end;
- // search ancestor in element, i.e. 'inherited' expression
- DeclProc:=SelfScope.DeclarationProc;
- DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
- AncestorProc:=DeclProcScope.OverriddenProc;
- if AncestorProc=nil then
- begin
- // 'inherited;' without ancestor method is silently ignored
- exit;
- end;
- CreateReference(AncestorProc,El,Access);
- if AncestorProc.IsAbstract then
- RaiseMsg(20170216152144,nAbstractMethodsCannotBeCalledDirectly,
- sAbstractMethodsCannotBeCalledDirectly,[],El);
- end;
- procedure TPasResolver.ResolveInheritedCall(El: TBinaryExpr;
- Access: TResolvedRefAccess);
- // El.OpCode=eopNone
- // El.left is TInheritedExpr
- // El.right is the identifier and parameters
- var
- ProcScope, SelfScope: TPasProcedureScope;
- AncestorScope, ClassScope: TPasClassScope;
- AncestorClass: TPasClassType;
- InhScope: TPasDotClassScope;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El));
- {$ENDIF}
- ProcScope:=GetInheritedExprScope(El);
- SelfScope:=ProcScope.GetSelfScope;
- if SelfScope=nil then
- RaiseMsg(20170216152148,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
- ClassScope:=SelfScope.ClassScope;
- AncestorScope:=ClassScope.AncestorScope;
- if AncestorScope=nil then
- RaiseMsg(20170216152151,nInheritedNeedsAncestor,sInheritedNeedsAncestor,[],El.left);
- // search call in ancestor
- AncestorClass:=TPasClassType(AncestorScope.Element);
- InhScope:=PushClassDotScope(AncestorClass);
- InhScope.InheritedExpr:=true;
- 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}
- ResolveExpr(El.left,rraRead);
- if El.right=nil then exit;
- case El.OpCode of
- eopNone:
- case El.Kind of
- pekRange:
- ResolveExpr(El.right,rraRead);
- else
- if El.left.ClassType=TInheritedExpr then
- 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:
- ResolveExpr(El.right,rraRead);
- eopSubIdent:
- ResolveSubIdent(El,Access);
- else
- RaiseNotYetImplemented(20160922163459,El,OpcodeStrings[El.OpCode]);
- end;
- end;
- procedure TPasResolver.ResolveSubIdent(El: TBinaryExpr;
- Access: TResolvedRefAccess);
- var
- aModule: TPasModule;
- ClassEl: TPasClassType;
- ClassScope: TPasDotClassScope;
- LeftResolved: TPasResolverResult;
- Left: TPasExpr;
- RecordEl: TPasRecordType;
- RecordScope: TPasDotRecordScope;
- 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);
- ResolveExpr(El.right,Access);
- PopScope;
- exit;
- end
- else if LeftResolved.TypeEl=nil then
- begin
- // illegal qualifier, see below
- end
- else if LeftResolved.TypeEl.ClassType=TPasClassType then
- begin
- ClassEl:=TPasClassType(LeftResolved.TypeEl);
- ClassScope:=PushClassDotScope(ClassEl);
- if LeftResolved.IdentEl is TPasType then
- // e.g. TFPMemoryImage.FindHandlerFromExtension()
- ClassScope.OnlyTypeMembers:=true
- else
- // e.g. Image.Width
- ClassScope.OnlyTypeMembers:=false;
- ResolveExpr(El.right,Access);
- PopScope;
- exit;
- end
- else if LeftResolved.TypeEl.ClassType=TPasClassOfType then
- begin
- // e.g. ImageClass.FindHandlerFromExtension()
- ClassEl:=ResolveAliasType(TPasClassOfType(NoNil(LeftResolved.TypeEl)).DestType) as TPasClassType;
- ClassScope:=PushClassDotScope(ClassEl);
- ClassScope.OnlyTypeMembers:=true;
- ResolveExpr(El.right,Access);
- PopScope;
- exit;
- end
- else if LeftResolved.TypeEl.ClassType=TPasRecordType then
- begin
- RecordEl:=TPasRecordType(LeftResolved.TypeEl);
- 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;
- ResolveExpr(El.right,Access);
- PopScope;
- exit;
- end
- else if LeftResolved.TypeEl.ClassType=TPasEnumType then
- begin
- if LeftResolved.IdentEl is TPasType then
- begin
- // e.g. TShiftState.ssAlt
- PushEnumDotScope(TPasEnumType(LeftResolved.TypeEl));
- ResolveExpr(El.right,Access);
- PopScope;
- exit;
- end;
- end
- else
- RaiseMsg(20170216152541,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
- [LeftResolved.TypeEl.ElementTypeName],El);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveSubIdent left=',GetObjName(Left),' right=',GetObjName(El.right),' leftresolved=',GetResolverResultDbg(LeftResolved));
- {$ENDIF}
- RaiseMsg(20170216152157,nIllegalQualifier,sIllegalQualifier,['.'],El);
- end;
- procedure TPasResolver.ResolveParamsExpr(Params: TParamsExpr;
- Access: TResolvedRefAccess);
- var
- i, ScopeDepth: Integer;
- ParamAccess: 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
- ResetSubScopes(ScopeDepth);
- if Params.Kind in [pekFuncParams,pekArrayParams] then
- ParamAccess:=rraParamToUnknownProc
- else
- ParamAccess:=rraRead;
- for i:=0 to length(Params.Params)-1 do
- ResolveExpr(Params.Params[i],ParamAccess);
- RestoreSubScopes(ScopeDepth);
- // 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.ResolveFuncParamsExpr(Params: TParamsExpr;
- Access: TResolvedRefAccess);
- procedure FinishProcParams(ProcType: TPasProcedureType);
- var
- ParamAccess: TResolvedRefAccess;
- i: Integer;
- begin
- if not (Access in [rraRead,rraParamToUnknownProc]) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExpr.FinishProcParams Params=',GetObjName(Params),' Value=',GetObjName(Params.Value),' Access=',Access);
- {$ENDIF}
- RaiseMsg(20170306104440,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Params);
- end;
- for i:=0 to length(Params.Params)-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(Params.Params[i],ParamAccess);
- CheckCallProcCompatibility(ProcType,Params,false,true);
- end;
- end;
- procedure FinishUntypedParams(ParamAccess: TResolvedRefAccess);
- var
- i: Integer;
- begin
- for i:=0 to length(Params.Params)-1 do
- FinishCallArgAccess(Params.Params[i],ParamAccess);
- end;
- var
- i: Integer;
- ElName, Msg: String;
- FindCallData: TFindCallElData;
- Abort: boolean;
- El, FoundEl: TPasElement;
- Ref: TResolvedReference;
- FindData: TPRFindData;
- BuiltInProc: TResElDataBuiltInProc;
- SubParams: TParamsExpr;
- ResolvedEl: TPasResolverResult;
- Value: TPasExpr;
- TypeEl: TPasType;
- C: TClass;
- begin
- Value:=Params.Value;
- if IsNameExpr(Value) then
- begin
- // e.g. Name() -> find compatible
- if Value.ClassType=TPrimitiveExpr then
- ElName:=TPrimitiveExpr(Value).Value
- else
- ElName:='Self';
- FindCallData:=Default(TFindCallElData);
- FindCallData.Params:=Params;
- Abort:=false;
- IterateElements(ElName,@OnFindCallElements,@FindCallData,Abort);
- if FindCallData.Found=nil then
- RaiseIdentifierNotFound(20170216152544,ElName,Value);
- 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 FindCallData.Found is TPasProcedure then
- CheckCallProcCompatibility(TPasProcedure(FindCallData.Found).ProcType,Params,true)
- else if FindCallData.Found is TPasProcedureType then
- CheckTypeCast(TPasProcedureType(FindCallData.Found),Params,true)
- else if FindCallData.Found.ClassType=TPasUnresolvedSymbolRef then
- begin
- if FindCallData.Found.CustomData is TResElDataBuiltInProc then
- begin
- BuiltInProc:=TResElDataBuiltInProc(FindCallData.Found.CustomData);
- BuiltInProc.GetCallCompatibility(BuiltInProc,Params,true);
- end
- else if FindCallData.Found.CustomData is TResElDataBaseType then
- CheckTypeCast(TPasUnresolvedSymbolRef(FindCallData.Found),Params,true)
- else
- RaiseNotYetImplemented(20161006132825,FindCallData.Found);
- end
- else if FindCallData.Found is TPasType then
- // Note: check TPasType after TPasUnresolvedSymbolRef
- CheckTypeCast(TPasType(FindCallData.Found),Params,true)
- else if FindCallData.Found is TPasVariable then
- begin
- TypeEl:=ResolveAliasType(TPasVariable(FindCallData.Found).VarType);
- if TypeEl is TPasProcedureType then
- CheckCallProcCompatibility(TPasProcedureType(TypeEl),Params,true)
- else
- RaiseMsg(20170405003522,nIllegalQualifier,sIllegalQualifier,['('],Params);
- end
- else
- RaiseNotYetImplemented(20161003134755,FindCallData.Found);
- end;
- if FindCallData.Count>1 then
- begin
- // multiple overloads fit => search again and list the candidates
- FindCallData:=Default(TFindCallElData);
- FindCallData.Params:=Params;
- FindCallData.List:=TFPList.Create;
- try
- IterateElements(ElName,@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,true,true)],El);
- Msg:=Msg+', '+GetElementSourcePosStr(El);
- end;
- RaiseMsg(20170216152200,nCantDetermineWhichOverloadedFunctionToCall,
- sCantDetermineWhichOverloadedFunctionToCall+Msg,[ElName],Value);
- finally
- FindCallData.List.Free;
- end;
- end;
- // FoundEl compatible element -> create reference
- FoundEl:=FindCallData.Found;
- Ref:=CreateReference(FoundEl,Value,rraRead);
- if FindCallData.StartScope.ClassType=ScopeClass_WithExpr then
- Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope);
- FindData:=Default(TPRFindData);
- FindData.ErrorPosEl:=Value;
- FindData.StartScope:=FindCallData.StartScope;
- FindData.ElScope:=FindCallData.ElScope;
- FindData.Found:=FoundEl;
- CheckFoundElement(FindData,Ref);
- // set param expression Access flags
- if FoundEl is TPasProcedure then
- // now it is known which overloaded proc to call
- FinishProcParams(TPasProcedure(FoundEl).ProcType)
- 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) 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,nIllegalQualifier,sIllegalQualifier,['('],Params);
- end;
- end
- else
- begin
- // FoundEl is not a type, maybe a var
- ComputeElement(FoundEl,ResolvedEl,[rcNoImplicitProc,rcSetReferenceFlags]);
- if ResolvedEl.TypeEl is TPasProcedureType then
- begin
- FinishProcParams(TPasProcedureType(ResolvedEl.TypeEl));
- exit;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveFuncParamsExpr FoundEl=',GetObjName(FoundEl),' CustomData=',GetObjName(FoundEl.CustomData),' Resolvedel=',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- RaiseMsg(20170306104301,nIllegalQualifier,sIllegalQualifier,['('],Params);
- end;
- end
- else if Value.ClassType=TParamsExpr then
- begin
- SubParams:=TParamsExpr(Value);
- if (SubParams.Kind in [pekArrayParams,pekFuncParams]) then
- begin
- // e.g. Name()() or Name[]()
- ResolveExpr(SubParams,rraRead);
- ComputeElement(SubParams,ResolvedEl,[rcNoImplicitProc,rcSetReferenceFlags]);
- if IsProcedureType(ResolvedEl,true) then
- begin
- CheckCallProcCompatibility(TPasProcedureType(ResolvedEl.TypeEl),Params,true);
- CreateReference(TPasProcedureType(ResolvedEl.TypeEl),Value,Access);
- exit;
- end
- end;
- RaiseMsg(20170216152202,nIllegalQualifier,sIllegalQualifier,['('],Params);
- end
- else
- RaiseNotYetImplemented(20161014085118,Params.Value);
- end;
- procedure TPasResolver.ResolveArrayParamsExpr(Params: TParamsExpr;
- Access: TResolvedRefAccess);
- var
- ResolvedEl: TPasResolverResult;
- procedure ResolveValueName(Value: TPasElement; ArrayName: string);
- var
- FindData: TPRFindData;
- Ref: TResolvedReference;
- DeclEl: TPasElement;
- Proc, ImplProc: TPasProcedure;
- ProcScope: TPasProcedureScope;
- begin
- // e.g. Name[]
- DeclEl:=FindElementWithoutParams(ArrayName,FindData,Value,true);
- Ref:=CreateReference(DeclEl,Value,Access,@FindData);
- CheckFoundElement(FindData,Ref);
- if DeclEl is TPasProcedure then
- begin
- Proc:=TPasProcedure(DeclEl);
- if (Access=rraAssign) and (Proc is TPasFunction)
- and (Value.ClassType=TPrimitiveExpr)
- 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:=(Proc as TPasFunction).FuncType.ResultEl;
- end;
- end;
- end;
- ComputeElement(Value,ResolvedEl,[rcSkipTypeAlias,rcSetReferenceFlags]);
- end;
- var
- Value: TPasExpr;
- SubParams: TParamsExpr;
- begin
- Value:=Params.Value;
- if (Value.ClassType=TPrimitiveExpr)
- and (TPrimitiveExpr(Value).Kind=pekIdent) then
- // e.g. Name[]
- ResolveValueName(Value,TPrimitiveExpr(Value).Value)
- else if (Value.ClassType=TSelfExpr) then
- // e.g. Self[]
- ResolveValueName(Value,'Self')
- else if Value.ClassType=TParamsExpr then
- begin
- SubParams:=TParamsExpr(Value);
- if (SubParams.Kind in [pekArrayParams,pekFuncParams]) then
- begin
- // e.g. Name()[] or Name[][]
- ResolveExpr(SubParams,rraRead);
- ComputeElement(SubParams,ResolvedEl,[rcSkipTypeAlias,rcNoImplicitProc,rcSetReferenceFlags]);
- if Value.CustomData=nil then
- CreateReference(ResolvedEl.TypeEl,Value,Access);
- end
- else
- RaiseNotYetImplemented(20161010194925,Value);
- end
- else
- RaiseNotYetImplemented(20160927212610,Value);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveArrayParamsExpr Value=',GetObjName(Value),' ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- ResolveArrayParamsArgs(Params,ResolvedEl,Access);
- end;
- procedure TPasResolver.ResolveArrayParamsArgs(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess);
- var
- ArgExp: TPasExpr;
- ResolvedArg: TPasResolverResult;
- PropEl: TPasProperty;
- ClassScope: TPasClassScope;
- i: Integer;
- begin
- if ResolvedValue.BaseType in btAllStrings then
- begin
- // string -> check that ResolvedValue is not merely a type, but has a value
- if not (rrfReadable in ResolvedValue.Flags) then
- RaiseXExpectedButYFound(20170216152548,'variable',ResolvedValue.TypeEl.ElementTypeName,Params);
- // check single argument
- if length(Params.Params)<1 then
- RaiseMsg(20170216152204,nMissingParameterX,
- sMissingParameterX,['character 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,[rcSkipTypeAlias,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);
- exit;
- end
- else if (ResolvedValue.IdentEl is TPasProperty)
- and (TPasProperty(ResolvedValue.IdentEl).Args.Count>0) then
- begin
- PropEl:=TPasProperty(ResolvedValue.IdentEl);
- CheckCallPropertyCompatibility(PropEl,Params,true);
- FinishPropertyParamAccess(Params,PropEl);
- exit;
- end
- else if ResolvedValue.BaseType=btContext then
- begin
- if ResolvedValue.TypeEl.ClassType=TPasClassType then
- begin
- ClassScope:=NoNil(ResolvedValue.TypeEl.CustomData) as TPasClassScope;
- if ResolveBracketOperatorClass(Params,ResolvedValue,ClassScope,Access) then
- exit;
- end
- else if ResolvedValue.TypeEl.ClassType=TPasArrayType then
- begin
- if ResolvedValue.IdentEl is TPasType then
- RaiseMsg(20170216152215,nIllegalQualifier,sIllegalQualifier,['['],Params);
- CheckCallArrayCompatibility(TPasArrayType(ResolvedValue.TypeEl),Params,true,true);
- for i:=0 to length(Params.Params)-1 do
- AccessExpr(Params.Params[i],rraRead);
- exit;
- end;
- end;
- RaiseMsg(20170216152217,nIllegalQualifier,sIllegalQualifier,['['],Params);
- end;
- function TPasResolver.ResolveBracketOperatorClass(Params: TParamsExpr;
- const ResolvedValue: TPasResolverResult; ClassScope: TPasClassScope;
- Access: TResolvedRefAccess): boolean;
- var
- PropEl: TPasProperty;
- Value: TPasExpr;
- begin
- PropEl:=ClassScope.DefaultProperty;
- if PropEl<>nil then
- begin
- // class has default property
- if (ResolvedValue.IdentEl is TPasType) and (not PropEl.IsClass) then
- RaiseMsg(20170216152213,nIllegalQualifier,sIllegalQualifier,['['],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);
- exit(true);
- end;
- Result:=false;
- end;
- procedure TPasResolver.ResolveSetParamsExpr(Params: TParamsExpr);
- // e.g. resolving '[1,2..3]'
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResolveSetParamsExpr ',GetTreeDbg(Params));
- {$ENDIF}
- if Params.Value<>nil then
- RaiseNotYetImplemented(20160930135910,Params);
- 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.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
- AccessExpr(Params.Params[0],Access)
- else
- AccessExpr(Params.Value,Access);
- pekArrayParams:
- begin
- ComputeElement(Params.Value,ValueResolved,[]);
- if IsDynArray(ValueResolved.TypeEl,false) then
- // an element of a dynamic array is independ of the array variable
- 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=TSelfExpr) or ((C=TPrimitiveExpr) and (TPrimitiveExpr(Expr).Kind=pekIdent)) then
- // ok
- else if (Access in [rraRead,rraParamToUnknownProc])
- and ((C=TPrimitiveExpr)
- or (C=TNilExpr)
- or (C=TBoolConstExpr)) 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;
- procedure TPasResolver.CheckPendingForwardProcs(El: TPasElement);
- var
- i: Integer;
- DeclEl: TPasElement;
- Proc: TPasProcedure;
- aClassType: TPasClassType;
- 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,
- [Proc.ElementTypeName,Proc.Name],Proc);
- end;
- end;
- end
- else if El.ClassType=TPasClassType then
- begin
- aClassType:=TPasClassType(El);
- for i:=0 to aClassType.Members.Count-1 do
- begin
- DeclEl:=TPasElement(aClassType.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
- RaiseMsg(20170216152221,nForwardProcNotResolved,sForwardProcNotResolved,
- [Proc.ElementTypeName,Proc.Name],Proc);
- end;
- end;
- end;
- end;
- procedure TPasResolver.AddModule(El: TPasModule);
- var
- C: TClass;
- ModScope: TPasModuleScope;
- begin
- if TopScope<>DefaultScope then
- RaiseInvalidScopeForElement(20160922163504,El);
- ModScope:=TPasModuleScope(PushScope(El,TPasModuleScope));
- 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:='';
- end;
- procedure TPasResolver.AddSection(El: TPasSection);
- // TInterfaceSection, TImplementationSection, TProgramSection, TLibrarySection
- // Note: implementation scope is within the interface scope
- begin
- if TopScope is TPasSectionScope then
- FinishSection(TPasSectionScope(TopScope).Element as TPasSection);
- FPendingForwardProcs.Add(El); // check forward declarations at the end
- PushScope(El,TPasSectionScope);
- 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.AddRecordType(El: TPasRecordType);
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160922163508,El);
- if El.Name<>'' then begin
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- FPendingForwardProcs.Add(El); // check forward declarations at the end
- end;
- if El.Parent.ClassType<>TPasVariant then
- PushScope(El,TPasRecordScope);
- end;
- procedure TPasResolver.AddClassType(El: TPasClassType);
- var
- Duplicate: TPasIdentifier;
- ForwardDecl: TPasClassType;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddClassType ',GetObjName(El),' Parent=',GetObjName(El.Parent),' ',GetElementSourcePosStr(El));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160922163510,El);
- if not (TopScope is TPasSectionScope) then
- RaiseNotYetImplemented(20171225110934,El,'nested classes');
- Duplicate:=TPasIdentifierScope(TopScope).FindIdentifier(El.Name);
- //if Duplicate<>nil then
- //writeln(' Duplicate=',GetObjName(Duplicate.Element),' ',ord(Duplicate.Kind));
- if (Duplicate<>nil)
- and (Duplicate.Kind=pikSimple)
- and (Duplicate.Element<>nil)
- and (Duplicate.Element.Parent=El.Parent)
- and (Duplicate.Element is TPasClassType)
- and TPasClassType(Duplicate.Element).IsForward
- then
- begin
- // forward declaration found
- ForwardDecl:=TPasClassType(Duplicate.Element);
- {$IFDEF VerbosePasResolver}
- writeln(' Resolving Forward=',GetObjName(ForwardDecl),' ',GetElementSourcePosStr(ForwardDecl));
- {$ENDIF}
- if ForwardDecl.CustomData<>nil then
- RaiseInternalError(20160922163513,'forward class has already customdata');
- // create a ref from the forward to the real declaration
- CreateReference(El,ForwardDecl,rraRead);
- // change the cache item
- Duplicate.Element:=El;
- end
- else
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- 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.AddEnumType(El: TPasEnumType);
- var
- CanonicalSet: TPasSetType;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddEnumType ',GetObjName(El));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160929205732,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- PushScope(El,TPasEnumTypeScope);
- // add canonical set
- CanonicalSet:=TPasSetType.Create('',El);
- CanonicalSet.EnumType:=El;
- El.AddRef;
- TPasEnumTypeScope(TopScope).CanonicalSet:=CanonicalSet;
- end;
- procedure TPasResolver.AddEnumValue(El: TPasEnumValue);
- var
- i: Integer;
- Scope: TPasScope;
- Old: TPasIdentifier;
- 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);
- if not (bsScopedEnums in CurrentParser.Scanner.CurrentBoolSwitches) then
- begin
- // propagate enum to parent scopes
- for i:=ScopeCount-2 downto 0 do
- begin
- Scope:=Scopes[i];
- if (Scope is TPasClassScope) or (Scope is TPasRecordScope) 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);
- 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;
- end;
- procedure TPasResolver.AddProperty(El: TPasProperty);
- begin
- if (El.Name='') then
- RaiseNotYetImplemented(20160922163518,El);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProperty ',GetObjName(El));
- {$ENDIF}
- if not (TopScope is TPasClassScope) then
- RaiseInvalidScopeForElement(20160922163520,El);
- AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
- PushScope(El,TPasPropertyScope);
- end;
- procedure TPasResolver.AddProcedure(El: TPasProcedure);
- var
- ProcName, aClassName: String;
- p: SizeInt;
- CurClassType: TPasClassType;
- ProcScope: TPasProcedureScope;
- NeedPop, HasDot: Boolean;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProcedure ',GetObjName(El));
- {$ENDIF}
- if not (TopScope is TPasIdentifierScope) then
- RaiseInvalidScopeForElement(20160922163522,El);
- // Note: El.ProcType is nil !
- ProcName:=El.Name;
- HasDot:=Pos('.',ProcName)>1;
- if not HasDot then
- AddIdentifier(TPasIdentifierScope(TopScope),ProcName,El,pikProc);
- ProcScope:=TPasProcedureScope(PushScope(El,FScopeClass_Proc));
- if msDelphi in CurrentParser.CurrentModeswitches then
- ProcScope.Mode:=msDelphi
- else
- ProcScope.Mode:=msObjfpc;
- if HasDot then
- begin
- // method implementation -> search class
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProcedure searching class of "',ProcName,'" ...');
- {$ENDIF}
- CurClassType:=nil;
- repeat
- p:=Pos('.',ProcName);
- if p<1 then
- begin
- if CurClassType=nil then
- RaiseInternalError(20161013170829);
- break;
- end;
- aClassName:=LeftStr(ProcName,p-1);
- Delete(ProcName,1,p);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddProcedure searching class "',aClassName,'" ProcName="',ProcName,'" ...');
- {$ENDIF}
- if not IsValidIdent(aClassName) then
- RaiseNotYetImplemented(20161013170844,El);
- if CurClassType<>nil then
- begin
- NeedPop:=true;
- PushClassDotScope(CurClassType);
- end
- else
- NeedPop:=false;
- CurClassType:=TPasClassType(FindElementWithoutParams(aClassName,El,false));
- if not (CurClassType is TPasClassType) then
- begin
- aClassName:=LeftStr(El.Name,length(El.Name)-length(ProcName));
- RaiseXExpectedButYFound(20170216152557,'class',aClassname+':'+CurClassType.ElementTypeName,El);
- end;
- // restore scope
- if NeedPop then
- PopScope;
- until false;
- if not IsValidIdent(ProcName) then
- RaiseNotYetImplemented(20161013170956,El);
- ProcScope.VisibilityContext:=CurClassType;
- ProcScope.ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope;
- end;
- end;
- procedure TPasResolver.AddArgument(El: TPasArgument);
- var
- ProcType: TPasProcedureType;
- i: Integer;
- Arg: TPasArgument;
- begin
- if (El.Name='') then
- RaiseInternalError(20160922163526,GetObjName(El));
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.AddArgument ',GetObjName(El));
- {$ENDIF}
- if (TopScope=nil) then
- RaiseInvalidScopeForElement(20160922163529,El);
- if El.Parent.ClassType=TPasProperty then
- begin
- if TopScope.ClassType<>TPasPropertyScope then
- RaiseInvalidScopeForElement(20161014124530,El);
- AddIdentifier(TPasIdentifierScope(TopScope),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 TopScope.ClassType<>FScopeClass_Proc then
- RaiseInvalidScopeForElement(20160922163529,El);
- AddIdentifier(TPasIdentifierScope(TopScope),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);
- begin
- if TopScope.ClassType<>FScopeClass_Proc then exit;
- if not (El.Parent is TPasProcedure) then exit;
- AddIdentifier(TPasProcedureScope(TopScope),ResolverResultVar,El,pikSimple);
- end;
- procedure TPasResolver.AddExceptOn(El: TPasImplExceptOn);
- begin
- PushScope(El,TPasExceptOnScope);
- end;
- procedure TPasResolver.AddProcedureBody(El: TProcedureBody);
- begin
- if El=nil then ;
- CheckTopScope(FScopeClass_Proc);
- end;
- procedure TPasResolver.WriteScopes;
- 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;
- 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],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],Bin,[rrfReadable]);
- 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 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);
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]);
- if Bin.Parent is TPasRangeType then
- ResolvedEl.TypeEl:=TPasRangeType(Bin.Parent);
- exit;
- end;
- eopAdd, eopSubtract,
- eopMultiply, eopDiv, eopMod,
- eopPower,
- eopShl, eopShr,
- eopAnd, eopOr, eopXor:
- begin
- // use left type for result
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]);
- exit;
- end;
- eopLessThan,
- eopGreaterThan,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- eopDivide:
- begin
- SetBaseType(BaseTypeExtended);
- exit;
- end;
- end
- else if (RightResolved.BaseType=btSet) and (RightResolved.SubType in btAllInteger)
- and (Bin.OpCode=eopIn) then
- begin
- SetBaseType(btBoolean);
- exit;
- 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],Bin,[rrfReadable]);
- ResolvedEl.SubType:=LeftResolved.BaseType;
- exit;
- end;
- eopAnd, eopOr, eopXor:
- begin
- // use left type for result
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[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],Bin,[rrfReadable]);
- ResolvedEl.SubType:=LeftResolved.BaseType;
- exit;
- end;
- eopAdd:
- case LeftResolved.BaseType of
- btChar:
- begin
- case RightResolved.BaseType of
- btChar: SetBaseType(btString);
- btAnsiChar:
- if BaseTypeChar=btAnsiChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- btWideChar:
- if BaseTypeChar=btWideChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- else
- // use right type for result
- SetResolverValueExpr(ResolvedEl,RightResolved.BaseType,RightResolved.TypeEl,Bin,[rrfReadable]);
- end;
- exit;
- end;
- 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
- SetResolverValueExpr(ResolvedEl,RightResolved.BaseType,RightResolved.TypeEl,Bin,[rrfReadable]);
- end;
- exit;
- end;
- btWideChar:
- begin
- case RightResolved.BaseType of
- btChar,btAnsiChar,btWideChar:
- if BaseTypeChar=btWideChar then
- SetBaseType(btString)
- else
- SetBaseType(btUnicodeString);
- else
- // use right type for result
- SetResolverValueExpr(ResolvedEl,RightResolved.BaseType,RightResolved.TypeEl,Bin,[rrfReadable]);
- end;
- exit;
- end;
- btShortString:
- begin
- case RightResolved.BaseType of
- btChar,btAnsiChar,btShortString,btWideChar:
- // use left type for result
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]);
- else
- // shortstring + string => string
- SetResolverValueExpr(ResolvedEl,RightResolved.BaseType,RightResolved.TypeEl,Bin,[rrfReadable]);
- end;
- exit;
- end;
- btString,btAnsiString,btUnicodeString:
- begin
- // string + x => string
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]);
- exit;
- end;
- end;
- eopLessThan,
- eopGreaterThan,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end
- else if (RightResolved.BaseType=btSet)
- 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
- SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[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 (RightResolved.BaseType in btAllInteger)
- and (rrfReadable in RightResolved.Flags) then
- case Bin.OpCode of
- eopAdd,eopSubtract:
- begin
- SetResolverValueExpr(ResolvedEl,btPointer,LeftResolved.TypeEl,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
- else if LeftResolved.BaseType=btContext then
- 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.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 (btAllInteger+btAllChars) then
- begin
- if (RightResolved.BaseType<>btSet) then
- RaiseXExpectedButYFound(20170216152607,'set of '+BaseTypeNames[LeftResolved.BaseType],LeftResolved.TypeEl.ElementTypeName,Bin.right);
- 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 (LeftResolved.TypeEl is TPasEnumType) then
- begin
- if (RightResolved.BaseType<>btSet) then
- RaiseXExpectedButYFound(20170216152615,'set of '+LeftResolved.TypeEl.Name,LeftResolved.TypeEl.ElementTypeName,Bin.right);
- if LeftResolved.TypeEl=RightResolved.TypeEl then
- else if RightResolved.TypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(RightResolved.TypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]);
- if LeftResolved.TypeEl<>ElTypeResolved.TypeEl then
- RaiseXExpectedButYFound(20171109215833,'set of '+LeftResolved.TypeEl.Name,'set of '+RightResolved.TypeEl.Name,Bin.right);
- end
- else
- RaiseXExpectedButYFound(20170216152618,'set of '+LeftResolved.TypeEl.Name,'set of '+RightResolved.TypeEl.Name,Bin.right);
- SetBaseType(btBoolean);
- exit;
- end
- else
- RaiseMsg(20170216152228,nInOperatorExpectsSetElementButGot,
- sInOperatorExpectsSetElementButGot,[LeftResolved.TypeEl.ElementTypeName],Bin);
- end;
- eopIs:
- begin
- LeftTypeEl:=ResolveAliasType(LeftResolved.TypeEl);
- RightTypeEl:=ResolveAliasType(RightResolved.TypeEl);
- if (LeftTypeEl is TPasClassType) then
- begin
- if (LeftResolved.IdentEl=nil) or (LeftResolved.IdentEl is TPasType) then
- RaiseMsg(20170216152230,nIllegalQualifier,sIllegalQualifier,['is'],Bin);
- // left side is a class instance
- if (RightResolved.IdentEl is TPasType)
- and (ResolveAliasType(TPasType(RightResolved.IdentEl)) is TPasClassType) then
- begin
- // e.g. if Image is TFPMemoryImage then ;
- // Note: at compile time the check is reversed: right must inherit from left
- if CheckSrcIsADstType(RightResolved,LeftResolved,Bin)<>cIncompatible then
- begin
- SetBaseType(btBoolean);
- exit;
- end
- else if CheckSrcIsADstType(LeftResolved,RightResolved,Bin)<>cIncompatible then
- begin
- // e.g. if Image is TObject then ;
- // This is useful after some unchecked typecast -> allow
- SetBaseType(btBoolean);
- exit;
- end;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeBinaryExprRes LeftClass=',GetClassAncestorsDbg(TPasClassType(LeftResolved.TypeEl)));
- 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.TypeEl,
- TPasClassOfType(RightTypeEl).DestType,Bin)<>cIncompatible) then
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end
- else
- RaiseXExpectedButYFound(20170216152625,'class type',RightResolved.TypeEl.ElementTypeName,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
- RaiseMsg(20170322101128,nIllegalQualifier,sIllegalQualifier,['is'],Bin);
- // left side is class-of variable
- LeftTypeEl:=ResolveAliasType(TPasClassOfType(LeftResolved.TypeEl).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.TypeEl,LeftTypeEl,Bin)<>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,Bin)<>cIncompatible) then
- begin
- SetBaseType(btBoolean);
- exit;
- end
- end
- else
- RaiseXExpectedButYFound(20170322105252,'class type',RightResolved.TypeEl.ElementTypeName,Bin.right);
- end
- else if LeftResolved.TypeEl=nil then
- RaiseMsg(20170216152232,nLeftSideOfIsOperatorExpectsAClassButGot,sLeftSideOfIsOperatorExpectsAClassButGot,
- [BaseTypeNames[LeftResolved.BaseType]],Bin.left)
- else
- RaiseMsg(20170216152234,nLeftSideOfIsOperatorExpectsAClassButGot,sLeftSideOfIsOperatorExpectsAClassButGot,
- [LeftResolved.TypeEl.ElementTypeName],Bin.left);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeBinaryExprRes is-operator: left=',GetResolverResultDbg(LeftResolved),' right=',GetResolverResultDbg(RightResolved));
- {$ENDIF}
- RaiseMsg(20170216152236,nTypesAreNotRelated,sTypesAreNotRelated,[],Bin);
- end;
- eopAs:
- begin
- LeftTypeEl:=ResolveAliasType(LeftResolved.TypeEl);
- if (LeftTypeEl is TPasClassType) then
- begin
- if (LeftResolved.IdentEl=nil)
- or (LeftResolved.IdentEl is TPasType)
- or (not (rrfReadable in LeftResolved.Flags)) then
- RaiseMsg(20170216152237,nIllegalQualifier,sIllegalQualifier,['as'],Bin);
- if RightResolved.IdentEl=nil then
- RaiseXExpectedButYFound(20170216152630,'class',RightResolved.TypeEl.ElementTypeName,Bin.right);
- if not (RightResolved.IdentEl is TPasType) then
- RaiseXExpectedButYFound(20170216152632,'class',RightResolved.IdentEl.Name,Bin.right);
- if (CheckSrcIsADstType(RightResolved,LeftResolved,Bin)<>cIncompatible) then
- begin
- SetResolverValueExpr(ResolvedEl,btContext,RightResolved.TypeEl,Bin,[rrfReadable]);
- exit;
- end;
- RaiseMsg(20170216152239,nTypesAreNotRelated,sTypesAreNotRelated,[],Bin);
- end;
- end;
- eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual:
- begin
- LeftTypeEl:=ResolveAliasType(LeftResolved.TypeEl);
- RightTypeEl:=ResolveAliasType(RightResolved.TypeEl);
- if (LeftTypeEl.ClassType=TPasEnumType)
- and (rrfReadable in LeftResolved.Flags)
- and (LeftTypeEl=RightTypeEl)
- and (rrfReadable in RightResolved.Flags)
- then
- begin
- SetBaseType(btBoolean);
- exit;
- end;
- end;
- eopSubIdent:
- begin
- ResolvedEl:=RightResolved;
- exit;
- end;
- end
- else if LeftResolved.BaseType=btSet then
- begin
- if (rrfReadable in LeftResolved.Flags)
- and (RightResolved.BaseType=btSet)
- and (rrfReadable in RightResolved.Flags) then
- case Bin.OpCode of
- eopAdd,
- eopSubtract,
- eopMultiply,
- eopSymmetricaldifference,
- eopLessthanEqual,
- eopGreaterThanEqual:
- begin
- if RightResolved.TypeEl=nil then
- begin
- // right is empty set
- 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.TypeEl=nil then
- begin
- // left is empty set
- 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;
- 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}
- RaiseMsg(20170216152241,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[Bin.OpCode]],Bin);
- if Flags=[] then ;
- 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;
- var
- TypeEl: TPasType;
- ClassScope: TPasClassScope;
- ArrayEl: TPasArrayType;
- ArgNo: Integer;
- OrigResolved: TPasResolverResult;
- SubParams: TParamsExpr;
- begin
- if Params.Value.CustomData is TResolvedReference then
- begin
- // e.g. Name[]
- ComputeElement(Params.Value,ResolvedEl,
- Flags-[rcNoImplicitProc,rcNoImplicitProcType],StartEl);
- end
- else if Params.Value.ClassType=TParamsExpr then
- begin
- SubParams:=TParamsExpr(Params.Value);
- if SubParams.Kind in [pekArrayParams,pekFuncParams] then
- begin
- // e.g. Name()[] or Name[][]
- ComputeElement(SubParams,ResolvedEl,
- Flags-[rcNoImplicitProc,rcNoImplicitProcType],StartEl);
- end
- else
- RaiseNotYetImplemented(20161010195646,SubParams);
- end
- else
- RaiseNotYetImplemented(20160928174144,Params);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeArrayParams ResolvedEl=',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- if ResolvedEl.BaseType in btAllStrings then
- begin
- // stringvar[] => char
- case GetActualBaseType(ResolvedEl.BaseType) of
- btWideString,btUnicodeString:
- if BaseTypeChar=btWideChar then
- ResolvedEl.BaseType:=btChar
- else
- ResolvedEl.BaseType:=btWideChar;
- btAnsiString,btRawByteString,btShortString:
- if BaseTypeChar=btAnsiChar then
- ResolvedEl.BaseType:=btChar
- else
- ResolvedEl.BaseType:=btAnsiChar;
- else
- RaiseNotYetImplemented(20170417202354,Params);
- end;
- // keep ResolvedEl.IdentEl the string var
- ResolvedEl.TypeEl:=FBaseTypes[ResolvedEl.BaseType];
- ResolvedEl.ExprEl:=Params;
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable,rrfCanBeStatement]+[rrfAssignable];
- end
- else if (ResolvedEl.IdentEl is TPasProperty)
- and (TPasProperty(ResolvedEl.IdentEl).Args.Count>0) then
- // property with args
- ComputeIndexProperty(TPasProperty(ResolvedEl.IdentEl))
- else if ResolvedEl.BaseType=btContext then
- begin
- TypeEl:=ResolvedEl.TypeEl;
- if TypeEl.ClassType=TPasClassType then
- begin
- ClassScope:=NoNil(TypeEl.CustomData) as TPasClassScope;
- if ClassScope.DefaultProperty<>nil then
- ComputeIndexProperty(ClassScope.DefaultProperty)
- else
- ComputeArrayParams_Class(Params,ResolvedEl,ClassScope,Flags,StartEl);
- end
- else if TypeEl.ClassType=TPasClassOfType then
- begin
- ClassScope:=ResolveAliasType(TPasClassOfType(TypeEl).DestType).CustomData as TPasClassScope;
- if ClassScope.DefaultProperty<>nil then
- ComputeIndexProperty(ClassScope.DefaultProperty)
- else
- RaiseInternalError(20161010174916);
- end
- else if TypeEl.ClassType=TPasArrayType then
- begin
- if not (rrfReadable in ResolvedEl.Flags) then
- RaiseMsg(20170517001140,nIllegalQualifier,sIllegalQualifier,['['],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;
- ComputeElement(ArrayEl.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
- RaiseNotYetImplemented(20161010151727,Params,GetResolverResultDbg(ResolvedEl));
- end
- else
- RaiseNotYetImplemented(20160928174212,Params,GetResolverResultDbg(ResolvedEl));
- end;
- procedure TPasResolver.ComputeArrayParams_Class(Params: TParamsExpr;
- var ResolvedEl: TPasResolverResult; ClassScope: TPasClassScope;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement);
- begin
- RaiseInternalError(20161010174916);
- if Params=nil then ;
- if ClassScope=nil then ;
- if Flags=[] then ;
- if StartEl=nil then ;
- SetResolverIdentifier(ResolvedEl,btNone,nil,nil,[]);
- end;
- procedure TPasResolver.ComputeFuncParams(Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- var
- DeclEl: TPasElement;
- BuiltInProc: TResElDataBuiltInProc;
- Proc: TPasProcedure;
- aClass: TPasClassType;
- ResolvedTypeEl: TPasResolverResult;
- Ref: TResolvedReference;
- begin
- if Params.Value.CustomData is TResolvedReference then
- begin
- Ref:=TResolvedReference(Params.Value.CustomData);
- 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,[]);
- if bipfCanBeStatement in BuiltInProc.Flags then
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else if DeclEl.CustomData is TResElDataBaseType then
- begin
- // type cast to base type
- if TResElDataBaseType(DeclEl.CustomData).BaseType=btCustom then
- // custom base type
- SetResolverValueExpr(ResolvedEl,
- btCustom,
- TPasUnresolvedSymbolRef(DeclEl),Params.Params[0],[rrfReadable])
- else
- SetResolverValueExpr(ResolvedEl,
- TResElDataBaseType(DeclEl.CustomData).BaseType,
- TPasUnresolvedSymbolRef(DeclEl),Params.Params[0],[rrfReadable]);
- 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 is TPasFunction then
- // function call => return result
- ComputeElement(TPasFunction(Proc).FuncType.ResultEl,ResolvedEl,
- Flags+[rcNoImplicitProc],StartEl)
- else if (Proc.ClassType=TPasConstructor)
- and (rrfNewInstance in Ref.Flags) then
- begin
- // new instance call -> return value of type class
- aClass:=GetReference_NewInstanceClass(Ref);
- SetResolverValueExpr(ResolvedEl,btContext,aClass,Params.Value,[rrfReadable]);
- end
- else
- // procedure call, result is neither readable nor writable
- SetResolverIdentifier(ResolvedEl,btProc,Proc,Proc.ProcType,[]);
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else if ResolvedEl.TypeEl 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.TypeEl is TPasFunctionType then
- // function call => return result
- ComputeElement(TPasFunctionType(ResolvedEl.TypeEl).ResultEl,
- ResolvedEl,Flags+[rcNoImplicitProc],StartEl)
- else
- // procedure call, result is neither readable nor writable
- SetResolverTypeExpr(ResolvedEl,btProc,TPasProcedureType(ResolvedEl.TypeEl),[]);
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end
- else
- begin
- // typecast proctype
- if length(Params.Params)<>1 then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeFuncParams DeclEl=',GetObjName(DeclEl),' ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- RaiseMsg(20170416185211,nWrongNumberOfParametersForTypeCast,
- sWrongNumberOfParametersForTypeCast,[ResolvedEl.TypeEl.Name],Params);
- end;
- SetResolverValueExpr(ResolvedEl,btContext,TPasProcedureType(ResolvedEl.TypeEl),
- Params.Params[0],[rrfReadable]);
- end;
- end
- else if (DeclEl is TPasType) then
- begin
- // type cast
- ResolvedTypeEl:=ResolvedEl;
- ComputeElement(Params.Params[0],ResolvedEl,Flags,StartEl);
- ResolvedEl.BaseType:=ResolvedTypeEl.BaseType;
- ResolvedEl.TypeEl:=ResolvedTypeEl.TypeEl;
- end
- else
- RaiseNotYetImplemented(20160928180048,Params,GetResolverResultDbg(ResolvedEl));
- end;
- end
- else
- RaiseNotYetImplemented(20160928174124,Params);
- end;
- procedure TPasResolver.ComputeSetParams(Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
- StartEl: TPasElement);
- // [param,param,...]
- var
- ParamResolved, FirstResolved: TPasResolverResult;
- i: Integer;
- Param: TPasExpr;
- IsRange: Boolean;
- begin
- if length(Params.Params)=0 then
- SetResolverValueExpr(ResolvedEl,btSet,nil,Params,[rrfReadable])
- else
- begin
- 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);
- if ParamResolved.BaseType=btSet then
- RaiseNotYetImplemented(20170420134325,Param,'nested array literals');
- IsRange:=ParamResolved.BaseType=btRange;
- if IsRange then
- ConvertRangeToElement(ParamResolved);
- if FirstResolved.BaseType=btNone then
- begin
- // first value -> check type usable in a set
- FirstResolved:=ParamResolved;
- if IsRange then
- CheckIsOrdinal(FirstResolved,Param,true);
- if rrfReadable in FirstResolved.Flags then
- begin
- // has a value
- end
- else
- begin
- 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;
- FirstResolved.BaseType:=btSet;
- FirstResolved.Flags:=[rrfReadable];
- ResolvedEl:=FirstResolved;
- end;
- end;
- procedure TPasResolver.CheckIsClass(El: TPasElement;
- const ResolvedEl: TPasResolverResult);
- begin
- if (ResolvedEl.BaseType<>btContext) then
- RaiseMsg(20170216152245,nXExpectedButYFound,sXExpectedButYFound,
- ['class',BaseTypeNames[ResolvedEl.BaseType]],El);
- if (ResolvedEl.TypeEl.ClassType<>TPasClassType) then
- RaiseMsg(20170216152246,nXExpectedButYFound,sXExpectedButYFound,
- ['class',ResolvedEl.TypeEl.ElementTypeName],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.TypeEl<>nil then
- RaiseXExpectedButYFound(20170216152645,'ordinal',LHS.TypeEl.ElementTypeName,Left)
- else
- RaiseXExpectedButYFound(20170216152648,'ordinal',BaseTypeNames[LHS.BaseType],Left);
- end;
- if not (rrfReadable in RHS.Flags) then
- begin
- if RHS.TypeEl<>nil then
- RaiseXExpectedButYFound(20170216152651,'ordinal',RHS.TypeEl.ElementTypeName,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.TypeEl.ClassType=TPasEnumType then
- begin
- if LHS.TypeEl=RHS.TypeEl then
- exit;
- if RHS.TypeEl.ClassType<>TPasEnumType then
- RaiseXExpectedButYFound(20170216152707,LHS.TypeEl.Parent.Name,RHS.TypeEl.ElementTypeName,Right);
- if LHS.TypeEl.Parent<>RHS.TypeEl.Parent then
- RaiseXExpectedButYFound(20170216152710,LHS.TypeEl.Parent.Name,RHS.TypeEl.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.TypeEl.ClassType=TPasEnumType then
- else if RaiseOnError then
- RaiseXExpectedButYFound(20170216152718,'ordinal value',ResolvedEl.TypeEl.ElementTypeName,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.TypeEl=nil then
- RaiseXExpectedButYFound(20170420004537,'array element',BaseTypeNames[LHS.BaseType],Left);
- if RHS.TypeEl=nil then
- RaiseXExpectedButYFound(20170420004602,'array element',BaseTypeNames[RHS.BaseType],Right);
- if LHS.TypeEl=RHS.TypeEl 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:=ResolveAliasType(RHS.TypeEl).ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasPointerType)
- or ((C=TPasArrayType) and IsDynArray(RHS.TypeEl))
- or (C=TPasProcedureType)
- or (C=TPasFunctionType) then
- begin
- LHS:=RHS;
- exit;
- end;
- end;
- end
- else if LBT=btContext then
- begin
- C:=LHS.TypeEl.ClassType;
- if C=TPasEnumType then
- begin
- if LHS.TypeEl=RHS.TypeEl then
- exit;
- end
- else if C=TPasClassType then
- begin
- // array of class instances
- if RHS.TypeEl.ClassType<>TPasClassType then
- RaiseIncompatibleTypeRes(20170420135637,nIncompatibleTypesGotExpected,
- [],RHS,LHS,Right);
- if CheckClassIsClass(LHS.TypeEl,RHS.TypeEl,Right)<cIncompatible then
- begin
- // right class type is a left class type -> ok
- exit;
- end
- else if CheckClassIsClass(RHS.TypeEl,LHS.TypeEl,Right)<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.TypeEl.ClassType=TPasClassType then
- begin
- // array of class type
- if RHS.TypeEl.ClassType<>TPasClassType then
- RaiseIncompatibleTypeRes(20170420091839,nIncompatibleTypesGotExpected,
- [],RHS,LHS,Right);
- if CheckClassIsClass(LHS.TypeEl,RHS.TypeEl,Right)<cIncompatible then
- begin
- // right class type is a left class type -> ok
- exit;
- end
- else if CheckClassIsClass(RHS.TypeEl,LHS.TypeEl,Right)<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;
- 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.TypeEl=nil then
- if ResolvedEl.IdentEl<>nil then
- RaiseNotYetImplemented(20161001155747,ResolvedEl.IdentEl)
- else
- RaiseNotYetImplemented(20161001155834,ResolvedEl.ExprEl);
- TypeEl:=ResolveAliasType(ResolvedEl.TypeEl);
- 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
- p: PChar;
- i: SizeInt;
- base: Integer;
- begin
- Result:=btNone;
- //writeln('TPasResolver.IsCharLiteral ',BaseTypeChar,' "',Value,'" l=',length(Value));
- p:=PChar(Value);
- case p^ of
- '''':
- begin
- inc(p);
- case p^ of
- '''':
- if (p[1]='''') and (p[2]='''') and (p[3]=#0) then
- Result:=btAnsiChar;
- #32..#38,#40..#191:
- if (p[1]='''') and (p[2]=#0) then
- Result:=btAnsiChar;
- #192..#255:
- if BaseTypeChar=btWideChar then
- begin
- // default char is widechar: UTF-8 'ä' is a widechar
- i:=Utf8CodePointLen(p,4,false);
- //writeln('TPasResolver.IsCharLiteral "',Value,'" ',length(Value),' i=',i);
- if i<2 then
- exit;
- inc(p,i);
- if (p^='''') and (p[1]=#0) then
- // single UTF-8 codepoint
- Result:=btWideChar;
- end;
- end;
- end;
- '#':
- begin
- inc(p);
- case 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;
- repeat
- case p^ of
- '0'..'9': i:=i*base+ord(p^)-ord('0');
- 'A'..'Z': i:=i*base+ord(p^)-ord('A')+10;
- 'a'..'z': i:=i*base+ord(p^)-ord('a')+10;
- else
- break;
- end;
- inc(p);
- until false;
- if p^=#0 then
- if i<256 then
- Result:=btAnsiChar
- else
- Result:=btWideChar;
- end;
- '^':
- begin
- inc(p);
- if (p^ in ['a'..'z','A'..'Z']) and (p[1]=#0) then
- Result:=btAnsiChar;
- end;
- end;
- if Result in [btAnsiChar,btWideChar] then
- begin
- if FBaseTypes[Result]=nil then
- begin
- if Result=btAnsiChar then
- Result:=btWideChar
- else
- Result:=btChar;
- end;
- if Result=BaseTypeChar then
- Result:=btChar;
- end;
- end;
- function TPasResolver.CheckForInClass(Loop: TPasImplForLoop; const VarResolved,
- InResolved: TPasResolverResult): boolean;
- var
- TypeEl: TPasType;
- aClass: TPasClassType;
- ClassScope: TPasDotClassScope;
- Getter, MoveNext, Current: TPasIdentifier;
- GetterFunc, MoveNextFunc: TPasFunction;
- ptm: TProcTypeModifier;
- ResultResolved, MoveNextResolved, CurrentResolved: TPasResolverResult;
- CurrentProp: TPasProperty;
- ForScope: TPasForLoopScope;
- begin
- Result:=false;
- TypeEl:=ResolveAliasType(InResolved.TypeEl);
- if TypeEl is TPasClassType then
- begin
- if not (rrfReadable in InResolved.Flags) then
- RaiseMsg(20171221195421,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
- [GetBaseDescription(InResolved)],Loop.StartExpr);
- // check function GetEnumerator: class
- aClass:=TPasClassType(TypeEl);
- // find aClass.GetEnumerator
- ClassScope:=PushClassDotScope(aClass);
- Getter:=ClassScope.FindIdentifier('GetEnumerator');
- PopScope;
- if Getter=nil then
- RaiseIdentifierNotFound(20171221191511,'GetEnumerator',Loop.StartExpr);
- // check is function
- if Getter.Element.ClassType<>TPasFunction then
- RaiseContextXExpectedButYFound(20171221191638,'GetEnumerator','function',Getter.Element.ElementTypeName,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
- ComputeElement(GetterFunc.FuncType.ResultEl,ResultResolved,[rcType]);
- if (ResultResolved.BaseType<>btContext) then
- RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved),Loop.StartExpr);
- TypeEl:=ResolveAliasType(ResultResolved.TypeEl);
- if not (TypeEl is TPasClassType) then
- RaiseContextXExpectedButYFound(20171221193749,'function GetEnumerator','result class',GetTypeDescription(ResultResolved.TypeEl),Loop.StartExpr);
- if not (rrfReadable in ResultResolved.Flags) then
- RaiseContextXExpectedButYFound(20171221195506,'function GetEnumerator','result class instance',GetTypeDescription(ResultResolved.TypeEl),Loop.StartExpr);
- // check function MoveNext: boolean
- aClass:=TPasClassType(TypeEl);
- ClassScope:=PushClassDotScope(aClass);
- MoveNext:=ClassScope.FindIdentifier('MoveNext');
- if MoveNext=nil then
- RaiseIdentifierNotFound(20171221195632,'MoveNext',Loop.StartExpr);
- // check is function
- if MoveNext.Element.ClassType<>TPasFunction then
- RaiseContextXExpectedButYFound(20171221195651,'MoveNext','function',MoveNext.Element.ElementTypeName,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
- ComputeElement(MoveNextFunc.FuncType.ResultEl,MoveNextResolved,[rcType]);
- if not (MoveNextResolved.BaseType in btAllBooleans) then
- RaiseContextXExpectedButYFound(20171221200337,'function MoveNext','result boolean',GetTypeDescription(MoveNextResolved),Loop.StartExpr);
- // check property Current
- Current:=ClassScope.FindIdentifier('Current');
- if Current=nil then
- RaiseIdentifierNotFound(20171221200433,'Current',Loop.StartExpr);
- // check is property
- if Current.Element.ClassType<>TPasProperty then
- RaiseContextXExpectedButYFound(20171221200508,'Current','property',Current.Element.ElementTypeName,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;
- ForScope:=Loop.CustomData as TPasForLoopScope;
- ForScope.GetEnumerator:=GetterFunc;
- ForScope.MoveNext:=MoveNextFunc;
- ForScope.Current:=CurrentProp;
- exit(true);
- end;
- RaiseMsg(20171221192929,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
- [GetBaseDescription(InResolved)],Loop.StartExpr);
- 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): integer;
- begin
- if length(Params.Params)>MaxCount then
- begin
- if RaiseOnError then
- RaiseMsg(20170329154348,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[MaxCount]);
- exit(cIncompatible);
- end;
- Result:=cExact;
- end;
- function TPasResolver.CheckRaiseTypeArgNo(id: int64; 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.FindUsedUnitInSection(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.FindUsedUnit(const aName: string; aMod: TPasModule): TPasModule;
- var
- C: TClass;
- begin
- C:=aMod.ClassType;
- if C.InheritsFrom(TPasProgram) then
- Result:=FindUsedUnitInSection(aName,TPasProgram(aMod).ProgramSection)
- else if C.InheritsFrom(TPasLibrary) then
- Result:=FindUsedUnitInSection(aName,TPasLibrary(aMod).LibrarySection)
- else
- begin
- Result:=FindUsedUnitInSection(aName,aMod.InterfaceSection);
- if Result<>nil then exit;
- Result:=FindUsedUnitInSection(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(Params);
- 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.FindExceptionConstructor(const aUnitName,
- aClassName: string; out aClass: TPasClassType; out
- aConstructor: TPasConstructor; ErrorEl: TPasElement): boolean;
- var
- aMod, UtilsMod: TPasModule;
- SectionScope: TPasSectionScope;
- Identifier: TPasIdentifier;
- El: TPasElement;
- ClassScope: TPasClassScope;
- begin
- Result:=false;
- aClass:=nil;
- aConstructor:=nil;
- // find unit in uses clauses
- aMod:=RootElement;
- UtilsMod:=FindUsedUnit(aUnitName,aMod);
- if UtilsMod=nil then exit;
- // find class in interface
- if UtilsMod.InterfaceSection=nil then exit;
- SectionScope:=NoNil(UtilsMod.InterfaceSection.CustomData) as TPasSectionScope;
- Identifier:=SectionScope.FindLocalIdentifier(aClassName);
- if Identifier=nil then exit;
- El:=Identifier.Element;
- if not (El is TPasClassType) then
- RaiseXExpectedButYFound(20180119172517,'class '+aClassName,El.ElementTypeName,ErrorEl);
- aClass:=TPasClassType(El);
- 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;
- 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);
- FindExceptionConstructor('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);
- FindExceptionConstructor('sysutils','ERangeError',aClass,aConstructor,ErrorEl);
- ModScope.RangeErrorClass:=aClass;
- ModScope.RangeErrorConstructor:=aConstructor;
- end;
- procedure TPasResolver.OnExprEvalLog(Sender: TResExprEvaluator;
- const id: int64; MsgType: TMessageType; MsgNumber: integer;
- const Fmt: String; Args: array of const; 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;
- begin
- Result:=nil;
- if not (Expr.CustomData is TResolvedReference) then
- RaiseNotYetImplemented(20170518203134,Expr);
- 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;
- Result:=fExprEvaluator.Eval(TPasConst(Decl).Expr,Flags+[refConst]);
- 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;
- btIntDouble: TResEvalInt(Result).Typed:=reitIntDouble;
- btInt64: TResEvalInt(Result).Typed:=reitNone; // default
- else
- ReleaseEvalValue(Result);
- RaiseNotYetImplemented(20170624181050,TPasConst(Decl).VarType);
- end;
- end;
- exit;
- end;
- end;
- if refConst in Flags then
- RaiseConstantExprExp(20170518214928,Expr);
- 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);
- {$ENDIF}
- if (Result=nil) and (refConst in Flags) then
- RaiseConstantExprExp(20170518213616,Expr);
- 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}
- case BuiltInProc.BuiltIn of
- bfLength: BI_Length_OnEval(BuiltInProc,Params,Flags,Result);
- bfAssigned: Result:=nil;
- bfChr: BI_Chr_OnEval(BuiltInProc,Params,Flags,Result);
- bfOrd: BI_Ord_OnEval(BuiltInProc,Params,Flags,Result);
- bfLow,bfHigh: BI_LowHigh_OnEval(BuiltInProc,Params,Flags,Result);
- bfPred,bfSucc: BI_PredSucc_OnEval(BuiltInProc,Params,Flags,Result);
- bfStrFunc: BI_StrFunc_OnEval(BuiltInProc,Params,Flags,Result);
- 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}
- 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');
- {$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:=ResolveAliasType(ResolvedEl.TypeEl);
- 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 ;
- end;
- function TPasResolver.EvalBaseTypeCast(Params: TParamsExpr;
- bt: TResolverBaseType): TResEvalvalue;
- var
- Value: TResEvalValue;
- Int: MaxPrecInt;
- MinIntVal, MaxIntVal: int64;
- Flo: MaxPrecFloat;
- c: Char;
- w: WideChar;
- begin
- Result:=nil;
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.EvalBaseTypeCast bt=',bt);
- {$ENDIF}
- Value:=Eval(Params.Params[0],[refAutoConst]);
- if Value=nil then exit;
- try
- case Value.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(Value).Int;
- if bt=btQWord then
- begin
- // int to qword
- {$R-}
- Result:=TResEvalUInt.CreateValue(MaxPrecUInt(Int));
- {$IFDEF RangeCheckOn}{$R+}{$ENDIF}
- end
- else if bt in (btAllInteger-[btQWord]) 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);
- btInt64: Result:=TResEvalInt.CreateValue(Int);
- 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);
- btIntDouble: Result:=TResEvalInt.CreateValue(Int,reitIntDouble);
- btInt64: Result:=TResEvalInt.CreateValue(Int);
- 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
- else if (bt=btAnsiChar) or ((bt=btChar) and (BaseTypeChar=btAnsiChar)) then
- try
- c:=Char(Int);
- Result:=TResEvalString.CreateValue(c);
- except
- RaiseMsg(20180125112510,nRangeCheckError,sRangeCheckError,[],Params);
- end
- 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(Single(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
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams typecast int to ',bt);
- {$ENDIF}
- RaiseNotYetImplemented(20170624194308,Params);
- end;
- end;
- revkFloat:
- begin
- Flo:=TResEvalFloat(Value).FloatValue;
- if bt in (btAllInteger-[btQWord]) 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);
- btIntDouble: Result:=TResEvalInt.CreateValue(Int,reitIntDouble);
- btInt64: Result:=TResEvalInt.CreateValue(Int);
- else
- RaiseNotYetImplemented(20170711001513,Params);
- end;
- {$IFDEF RangeCheckOn}{$R+}{$ENDIF}
- exit;
- end
- else if bt=btSingle then
- begin
- // float to single
- try
- Result:=TResEvalFloat.CreateValue(single(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
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams typecast float to ',bt);
- {$ENDIF}
- RaiseNotYetImplemented(20170711002542,Params);
- end;
- end
- else
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.OnExprEvalParams typecast to ',bt);
- {$ENDIF}
- RaiseNotYetImplemented(20170624193436,Params);
- end;
- finally
- ReleaseEvalValue(Value);
- end;
- 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.TypeEl.ClassType=TPasArrayType) then
- begin
- Ranges:=TPasArrayType(ParamResolved.TypeEl).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],[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;
- 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
- revkString:
- Evaluated:=TResEvalInt.CreateValue(length(TResEvalString(Value).S));
- revkUnicodeString:
- Evaluated:=TResEvalInt.CreateValue(length(TResEvalUTF16(Value).S));
- end;
- ReleaseEvalValue(Value);
- end
- end
- else if ParamResolved.BaseType=btContext then
- begin
- if (ParamResolved.TypeEl.ClassType=TPasArrayType) then
- begin
- Ranges:=TPasArrayType(ParamResolved.TypeEl).Ranges;
- if length(Ranges)=0 then
- begin
- // open or dynamic array
- if (ParamResolved.IdentEl is TPasVariable)
- and (TPasVariable(ParamResolved.IdentEl).Expr is TPasExpr) then
- begin
- Expr:=TPasVariable(ParamResolved.IdentEl).Expr;
- if Expr is TArrayValues then
- Evaluated:=TResEvalInt.CreateValue(length(TArrayValues(Expr).Values));
- 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) then
- begin
- if ParamResolved.BaseType in btAllStrings then
- Result:=cExact
- else if ParamResolved.BaseType=btContext then
- begin
- if IsDynArray(ParamResolved.TypeEl,false) then
- begin
- Result:=cExact;
- DynArr:=NoNil(ParamResolved.TypeEl) 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;
- 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;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- EnumType: TPasEnumType;
- begin
- if not CheckBuiltInMinParamCount(Proc,Expr,2,RaiseOnError) then
- exit(cIncompatible);
- Params:=TParamsExpr(Expr);
- // first param: variable of set of enumtype
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
- EnumType:=nil;
- if ([rrfReadable,rrfWritable]*ParamResolved.Flags=[rrfReadable,rrfWritable])
- and ((ParamResolved.IdentEl is TPasVariable)
- or (ParamResolved.IdentEl is TPasArgument)) then
- begin
- if (ParamResolved.BaseType=btSet)
- and (ParamResolved.TypeEl is TPasEnumType) then
- EnumType:=TPasEnumType(ParamResolved.TypeEl);
- end;
- if EnumType=nil then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.OnGetCallCompatibility_InExclude ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- exit(CheckRaiseTypeArgNo(20170216152301,1,Param,ParamResolved,
- 'variable of set of enumtype',RaiseOnError));
- end;
- // second param: enum
- Param:=Params.Params[1];
- ComputeElement(Param,ParamResolved,[]);
- if (not (rrfReadable in ParamResolved.Flags))
- or (ParamResolved.TypeEl<>EnumType) then
- begin
- if RaiseOnError then
- RaiseIncompatibleType(20170216152302,nIncompatibleTypeArgNo,
- ['2'],ParamResolved.TypeEl,EnumType,Param);
- exit(cIncompatible);
- 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;
- 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;
- 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
- // first param is function result
- ProcScope:=TPasProcedureScope(Scopes[i]);
- if not (ProcScope.Element is TPasFunction) then
- begin
- if RaiseOnError then
- RaiseMsg(20170216152312,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,['procedure exit'],Params.Params[0]);
- exit(cIncompatible);
- end;
- ResultEl:=(ProcScope.Element as TPasFunction).FuncType.ResultEl;
- ComputeElement(ResultEl,ResultResolved,[rcType]);
- end
- else
- begin
- // default: main program, param is an integer
- SetResolverTypeExpr(ResultResolved,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;
- 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.OnGetCallCompatibility_IncDec ParamResolved=',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- Result:=cIncompatible;
- // Expr must be a variable
- if not ResolvedElCanBeVarParam(ParamResolved) then
- begin
- if RaiseOnError then
- RaiseMsg(20170216152319,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr);
- exit;
- end;
- if ParamResolved.BaseType in btAllInteger then
- Result:=cExact;
- 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.TypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or C.InheritsFrom(TPasProcedureType)
- or ((C=TPasArrayType) and (length(TPasArrayType(ParamResolved.TypeEl).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],[rrfReadable]);
- 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],[rrfReadable]);
- 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}
- if Value=nil then
- writeln('TPasResolver.BI_Chr_OnEval Value=NIL')
- else
- writeln('TPasResolver.BI_Chr_OnEval Value=',Value.AsDebugString);
- {$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, enum or char
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- Result:=cIncompatible;
- if rrfReadable in ParamResolved.Flags then
- begin
- if ParamResolved.BaseType in (btAllBooleans+btAllChars) then
- Result:=cExact
- else if (ParamResolved.BaseType=btContext) and (ParamResolved.TypeEl is TPasEnumType) then
- Result:=cExact
- else if ParamResolved.BaseType=btRange then
- begin
- if ParamResolved.SubType in btAllBooleans+btAllChars then
- Result:=cExact
- else if ParamResolved.SubType=btContext then
- begin
- TypeEl:=ResolveAliasType(ParamResolved.TypeEl);
- if TypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(TypeEl).RangeExpr.left,ResolvedEl,[rcConstant]);
- if ResolvedEl.TypeEl.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],[rrfReadable]);
- 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}
- if Value=nil then
- writeln('TPasResolver.BI_Ord_OnEval Value=NIL')
- else
- writeln('TPasResolver.BI_Ord_OnEval Value=',Value.AsDebugString);
- {$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 not (rrfReadable in ParamResolved.Flags)
- and (ParamResolved.BaseType in btAllRanges) then
- // built-in range e.g. high(char)
- Result:=cExact
- else if ParamResolved.BaseType=btSet then
- Result:=cExact
- else if (ParamResolved.BaseType=btContext) then
- begin
- C:=ParamResolved.TypeEl.ClassType;
- if (C=TPasArrayType)
- or (C=TPasSetType)
- or (C=TPasEnumType) then
- Result:=cExact;
- end;
- if Result=cIncompatible then
- exit(CheckRaiseTypeArgNo(20170216152338,1,Param,ParamResolved,'ordinal type, array or set',RaiseOnError));
- 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.TypeEl;
- 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],[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.TypeEl:=TPasSetType(TypeEl).EnumType;
- 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);
- var
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- var
- TypeEl: TPasType;
- ArrayEl: TPasArrayType;
- Value: TResEvalValue;
- EnumType: TPasEnumType;
- aSet: TResEvalSet;
- Int: MaxPrecInt;
- bt: TResolverBaseType;
- MinInt, MaxInt: int64;
- i: Integer;
- Expr: TPasExpr;
- begin
- Evaluated:=nil;
- Param:=Params.Params[0];
- ComputeElement(Param,ParamResolved,[]);
- TypeEl:=ParamResolved.TypeEl;
- 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 (ParamResolved.IdentEl is TPasVariable)
- and (TPasVariable(ParamResolved.IdentEl).Expr is TPasExpr) then
- begin
- Expr:=TPasVariable(ParamResolved.IdentEl).Expr;
- if Expr is TArrayValues then
- Evaluated:=TResEvalInt.CreateValue(length(TArrayValues(Expr).Values)-1);
- if Evaluated=nil then
- RaiseNotYetImplemented(20170601191003,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.Ranges[0].RangeStart
- else
- Int:=aSet.Ranges[length(aSet.Ranges)-1].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:
- if Int<256 then
- Evaluated:=TResEvalString.CreateValue(chr(Int))
- else
- 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)
- else if bt=btQWord then
- begin
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalInt.CreateValue(0)
- else
- Evaluated:=TResEvalUInt.CreateValue(High(QWord));
- end
- else if (bt in (btAllInteger-[btQWord])) and GetIntegerRange(bt,MinInt,MaxInt) then
- begin
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalInt.CreateValue(MinInt)
- else
- Evaluated:=TResEvalInt.CreateValue(MaxInt);
- end
- else if bt in [btChar,btAnsiChar] then
- begin
- if Proc.BuiltIn=bfLow then
- Evaluated:=TResEvalString.CreateValue(#0)
- else
- Evaluated:=TResEvalString.CreateValue(#255);
- end
- 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.TypeEl 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}
- 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);
- {$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];
- 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
- RaiseMsg(20170319221515,nXExpectedButYFound,sXExpectedButYFound,
- ['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
- TypeEl: TPasType;
- begin
- Result:=cIncompatible;
- if ParamResolved.BaseType in (btAllInteger+btAllBooleans+btAllFloats) then
- Result:=cExact
- else if IsFunc and (ParamResolved.BaseType in btAllStringAndChars) then
- Result:=cExact
- else if ParamResolved.BaseType=btContext then
- begin
- TypeEl:=ParamResolved.TypeEl;
- if TypeEl.ClassType=TPasEnumType 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) 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;
- 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
- if Params=nil then ;
- SetResolverIdentifier(ResolvedEl,btString,Proc.Proc,FBaseTypes[btString],[rrfReadable]);
- end;
- procedure TPasResolver.BI_StrFunc_OnEval(Proc: TResElDataBuiltInProc;
- Params: TParamsExpr; Flags: TResEvalFlags; out Evaluated: TResEvalValue);
- begin
- Evaluated:=fExprEvaluator.EvalStrFunc(Params,Flags);
- end;
- function TPasResolver.BI_ConcatArray_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- var
- Params: TParamsExpr;
- Param: TPasExpr;
- ParamResolved, ElTypeResolved, FirstElTypeResolved: TPasResolverResult;
- i: Integer;
- 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,[]);
- if not (rrfReadable in ParamResolved.Flags)
- or (ParamResolved.BaseType<>btContext)
- or not IsDynArray(ParamResolved.TypeEl) then
- exit(CheckRaiseTypeArgNo(20170329181206,i+1,Param,ParamResolved,'dynamic array',RaiseOnError));
- ComputeElement(TPasArrayType(ParamResolved.TypeEl).ElType,ElTypeResolved,[rcType]);
- Include(ElTypeResolved.Flags,rrfReadable);
- if i=0 then
- begin
- FirstElTypeResolved:=ElTypeResolved;
- Include(ElTypeResolved.Flags,rrfWritable);
- end
- else if CheckAssignResCompatibility(FirstElTypeResolved,ElTypeResolved,Param,RaiseOnError)=cIncompatible then
- exit(cIncompatible);
- end;
- end;
- procedure TPasResolver.BI_ConcatArray_OnGetCallResult(
- Proc: TResElDataBuiltInProc; Params: TParamsExpr; out
- ResolvedEl: TPasResolverResult);
- begin
- ComputeElement(Params.Params[0],ResolvedEl,[]);
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable];
- 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)
- and (ParamResolved.BaseType=btContext) then
- begin
- if IsDynArray(ParamResolved.TypeEl) 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
- ComputeElement(Params.Params[0],ResolvedEl,[]);
- ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable];
- 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;
- 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) then
- begin
- if RaiseOnError then
- RaiseMsg(20170329171514,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Param);
- exit;
- end;
- if (ParamResolved.BaseType<>btContext)
- or not IsDynArray(ParamResolved.TypeEl) then
- exit(CheckRaiseTypeArgNo(20170329172024,2,Param,ParamResolved,'dynamic array',RaiseOnError));
- ComputeElement(TPasArrayType(ParamResolved.TypeEl).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;
- begin
- if Proc=nil then ;
- P:=Params.Params;
- FinishCallArgAccess(P[0],rraRead);
- FinishCallArgAccess(P[1],rraVarParam);
- FinishCallArgAccess(P[2],rraRead);
- end;
- function TPasResolver.BI_DeleteArray_OnGetCallCompatibility(
- Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
- // Delete(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) then
- begin
- if RaiseOnError then
- RaiseMsg(20170329173421,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Param);
- exit;
- end;
- if (ParamResolved.BaseType<>btContext)
- or not IsDynArray(ParamResolved.TypeEl) 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;
- 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;
- Decl: TPasElement;
- ParamResolved: TPasResolverResult;
- 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) 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
- else if Decl.ClassType=TPasResultElement then
- aType:=TPasResultElement(Decl).ResultType
- else if Decl is TPasFunction then
- aType:=TPasFunction(Decl).FuncType.ResultEl.ResultType;
- {$IFDEF VerbosePasResolver}
- if aType=nil then
- writeln('TPasResolver.BI_TypeInfo_OnGetCallCompatibility Decl=',GetObjName(Decl));
- {$ENDIF}
- end;
- if aType=nil then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.BI_TypeInfo_OnGetCallCompatibility ',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- RaiseMsg(20170411100259,nTypeIdentifierExpected,sTypeIdentifierExpected,[],Param);
- end;
- 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],[rrfReadable]);
- 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;
- constructor TPasResolver.Create;
- begin
- inherited Create;
- FDefaultScope:=TPasDefaultScope.Create;
- FPendingForwardProcs:=TFPList.Create;
- FBaseTypeChar:=btAnsiChar;
- FBaseTypeString:=btAnsiString;
- FBaseTypeExtended:=btDouble;
- FBaseTypeLength:=btInt64;
- FDynArrayMinIndex:=0;
- FDynArrayMaxIndex:=High(int64);
- FScopeClass_Class:=TPasClassScope;
- FScopeClass_Proc:=TPasProcedureScope;
- FScopeClass_WithExpr:=TPasWithExprScope;
- fExprEvaluator:=TResExprEvaluator.Create;
- fExprEvaluator.OnLog:=@OnExprEvalLog;
- fExprEvaluator.OnEvalIdentifier:=@OnExprEvalIdentifier;
- fExprEvaluator.OnEvalParams:=@OnExprEvalParams;
- 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): TPasElement;
- var
- El: TPasElement;
- SrcY: integer;
- begin
- {$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
- begin
- if (ASrcPos.Column<ParserMaxEmbeddedColumn)
- and (SrcY<ParserMaxEmbeddedRow) then
- SrcY:=-(SrcY*ParserMaxEmbeddedColumn+integer(ASrcPos.Column));
- end;
- // create element
- El:=AClass.Create(AName,AParent);
- FLastElement:=El;
- Result:=FLastElement;
- El.Visibility:=AVisibility;
- El.SourceFilename:=ASrcPos.FileName;
- El.SourceLinenumber:=SrcY;
- if FRootElement=nil then
- begin
- FRootElement:=NoNil(Result) as TPasModule;
- if FStep=prsInit then
- FStep:=prsParsing;
- end;
- if IsElementSkipped(El) then exit;
- // create scope
- 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=TPasArrayType)
- or (AClass=TPasProcedureType)
- or (AClass=TPasFunctionType)
- or (AClass=TPasSetType)
- or (AClass=TPasRangeType) then
- AddType(TPasType(El))
- else if AClass=TPasStringType then
- begin
- AddType(TPasType(El));
- if BaseTypes[btShortString]=nil then
- RaiseMsg(20170419203043,nIllegalQualifier,sIllegalQualifier,['['],El);
- end
- else if AClass=TPasRecordType then
- AddRecordType(TPasRecordType(El))
- else if AClass=TPasClassType then
- AddClassType(TPasClassType(El))
- else if AClass=TPasVariant then
- else if AClass.InheritsFrom(TPasProcedure) then
- AddProcedure(TPasProcedure(El))
- else if AClass=TPasResultElement then
- AddFunctionResult(TPasResultElement(El))
- else if AClass=TProcedureBody then
- AddProcedureBody(TProcedureBody(El))
- else if AClass=TPasImplExceptOn then
- AddExceptOn(TPasImplExceptOn(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.InheritsFrom(TPasExpr) then
- // resolved when finished
- else if AClass.InheritsFrom(TPasImplBlock) then
- // resolved when finished
- else if AClass=TPasUnresolvedUnitRef then
- RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El)
- else
- RaiseNotYetImplemented(20160922163544,El);
- end;
- function TPasResolver.FindElement(const aName: String): TPasElement;
- // called by TPasParser for direct types, e.g. type t = ns1.unit1.tobj.tsub
- var
- p: SizeInt;
- RightPath, CurName: String;
- NeedPop: Boolean;
- CurScopeEl, NextEl, ErrorEl, BestEl: TPasElement;
- CurSection: TPasSection;
- i: Integer;
- UsesUnit: TPasUsesUnit;
- begin
- //writeln('TPasResolver.FindElement Name="',aName,'"');
- ErrorEl:=nil; // use nil to use scanner position as error position
- RightPath:=aName;
- 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;
- {$IFDEF VerbosePasResolver}
- if RightPath<>'' then
- writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ...');
- {$ENDIF}
- if not IsValidIdent(CurName) then
- RaiseNotYetImplemented(20170328000033,ErrorEl);
- if CurScopeEl<>nil then
- begin
- NeedPop:=true;
- if CurScopeEl.ClassType=TPasClassType then
- // check visibility
- PushClassDotScope(TPasClassType(CurScopeEl))
- else if CurScopeEl is TPasModule then
- PushModuleDotScope(TPasModule(CurScopeEl))
- else
- RaiseInternalError(20170504174021);
- end
- else
- NeedPop:=false;
- NextEl:=FindElementWithoutParams(CurName,ErrorEl,true);
- {$IFDEF VerbosePasResolver}
- //if RightPath<>'' then
- // writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ... NextEl=',GetObjName(NextEl));
- {$ENDIF}
- if NextEl is TPasModule then
- begin
- if CurScopeEl is TPasModule then
- RaiseXExpectedButYFound(20170328001619,'class',NextEl.ElementTypeName+' '+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',NextEl.ElementTypeName,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 if RightPath<>'' then
- begin
- if (CurScopeEl is TPasClassType) then
- CurScopeEl:=NextEl
- else
- RaiseIdentifierNotFound(20170328001941,CurName,ErrorEl);
- end;
- // restore scope
- if NeedPop then
- PopScope;
- if RightPath='' then
- exit(NextEl);
- until false;
- end;
- function TPasResolver.FindElementWithoutParams(const AName: String;
- ErrorPosEl: TPasElement; NoProcsWithArgs: boolean): TPasElement;
- var
- Data: TPRFindData;
- begin
- Result:=FindElementWithoutParams(AName,Data,ErrorPosEl,NoProcsWithArgs);
- 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: boolean
- ): TPasElement;
- var
- Abort: boolean;
- begin
- //writeln('TPasResolver.FindIdentifier Name="',AName,'"');
- Result:=Nil;
- Abort:=false;
- Data:=Default(TPRFindData);
- Data.ErrorPosEl:=ErrorPosEl;
- IterateElements(AName,@OnFindFirstElement,@Data,Abort);
- Result:=Data.Found;
- if Result=nil then
- begin
- if (ErrorPosEl=nil) and (LastElement<>nil)
- and (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;
- 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;
- 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;
- 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 TPasSubScope 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.
- var
- Proc: TPasProcedure;
- Context: TPasElement;
- FoundContext: TPasClassType;
- StartScope: TPasScope;
- OnlyTypeMembers: Boolean;
- TypeEl: TPasType;
- C: TClass;
- ClassScope: TPasClassScope;
- i: Integer;
- begin
- StartScope:=FindData.StartScope;
- OnlyTypeMembers:=false;
- if StartScope is TPasDotIdentifierScope then
- begin
- if Ref=nil then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckFoundElement FindData.Found=',GetObjName(FindData.Found),' StartScope=',GetObjName(StartScope));
- {$ENDIF}
- RaiseNotYetImplemented(20171225110626,FindData.ErrorPosEl);
- end;
- OnlyTypeMembers:=TPasDotIdentifierScope(StartScope).OnlyTypeMembers;
- Include(Ref.Flags,rrfDotScope);
- if TPasDotIdentifierScope(StartScope).ConstParent then
- Include(Ref.Flags,rrfConstInherited);
- end
- else if StartScope.ClassType=ScopeClass_WithExpr then
- begin
- OnlyTypeMembers:=wesfOnlyTypeMembers in TPasWithExprScope(StartScope).Flags;
- Include(Ref.Flags,rrfDotScope);
- if wesfConstParent in TPasWithExprScope(StartScope).Flags then
- Include(Ref.Flags,rrfConstInherited);
- 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;
- //writeln('TPasResolver.CheckFoundElOnStartScope StartScope=',StartScope.ClassName,
- // ' StartIsDot=',StartScope is TPasDotIdentifierScope,
- // ' OnlyTypeMembers=',(StartScope is TPasDotIdentifierScope)
- // and TPasDotIdentifierScope(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
- begin
- RaiseMsg(20170216152348,nCannotAccessThisMemberFromAX,
- sCannotAccessThisMemberFromAX,[FindData.Found.Parent.ElementTypeName],FindData.ErrorPosEl);
- end;
- end
- else if (proExtClassInstanceNoTypeMembers in Options)
- and (StartScope.ClassType=TPasDotClassScope)
- and TPasClassType(TPasDotClassScope(StartScope).ClassScope.Element).IsExternal then
- begin
- // found member in external class instance
- C:=FindData.Found.ClassType;
- if (C=TPasProcedure) or (C=TPasFunction) then
- // ok
- else if C.InheritsFrom(TPasVariable)
- and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then
- // ok
- else
- begin
- RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX,
- sExternalClassInstanceCannotAccessStaticX,
- [FindData.Found.ElementTypeName+' '+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=TPasDotClassScope)
- and TPasDotClassScope(StartScope).InheritedExpr then
- begin
- // 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, e.g. TObject.Create
- if (Proc.ClassType=TPasConstructor)
- and OnlyTypeMembers
- and (Ref<>nil) then
- begin
- Ref.Flags:=Ref.Flags+[rrfNewInstance]-[rrfConstInherited];
- // store the class in Ref.Context
- if Ref.Context<>nil then
- RaiseInternalError(20170131141936);
- Ref.Context:=TResolvedRefCtxConstructor.Create;
- if StartScope is TPasDotClassScope then
- ClassScope:=TPasDotClassScope(StartScope).ClassScope
- else if (StartScope is TPasWithExprScope)
- and (TPasWithExprScope(StartScope).Scope is TPasClassScope) then
- ClassScope:=TPasClassScope(TPasWithExprScope(StartScope).Scope)
- else if (StartScope is TPasProcedureScope) then
- ClassScope:=TPasProcedureScope(StartScope).ClassScope
- else
- RaiseInternalError(20170131150855,GetObjName(StartScope));
- TypeEl:=ClassScope.Element as TPasType;
- TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
- if length(ClassScope.AbstractProcs)>0 then
- begin
- for i:=0 to length(ClassScope.AbstractProcs)-1 do
- LogMsg(20171227110746,mtNote,nConstructingClassXWithAbstractMethodY,
- sConstructingClassXWithAbstractMethodY,
- [TypeEl.Name,ClassScope.AbstractProcs[i].Name],FindData.ErrorPosEl);
- end;
- end;
- {$IFDEF VerbosePasResolver}
- 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;
- {$ENDIF}
- // destructor: FreeInstance or normal call
- // it is a normal call if 'inherited'
- if (Proc.ClassType=TPasDestructor) and (Ref<>nil) then
- if ((StartScope.ClassType<>TPasDotClassScope)
- or (not TPasDotClassScope(StartScope).InheritedExpr)) then
- Ref.Flags:=Ref.Flags+[rrfFreeInstance];
- {$IFDEF VerbosePasResolver}
- 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.ClassType=TPasDotClassScope then
- write(' InheritedExpr=',TPasDotClassScope(StartScope).InheritedExpr);
- end;
- writeln;
- end;
- {$ENDIF}
- end;
- // check class visibility
- if FindData.Found.Visibility in [visPrivate,visProtected,visStrictPrivate,visStrictProtected] then
- begin
- Context:=GetVisibilityContext;
- FoundContext:=FindData.Found.Parent as TPasClassType;
- case FindData.Found.Visibility of
- visPrivate:
- // private members can only be accessed in same module
- if FoundContext.GetModule<>Context.GetModule then
- RaiseMsg(20170216152354,nCantAccessPrivateMember,sCantAccessPrivateMember,
- ['private',FindData.Found.Name],FindData.ErrorPosEl);
- visProtected:
- // protected members can only be accessed in same module
- // or modules of descendant classes
- if FoundContext.GetModule=Context.GetModule then
- // same module -> ok
- else if (Context is TPasType)
- and (CheckClassIsClass(TPasType(Context),FoundContext,FindData.ErrorPosEl)<>cIncompatible) then
- // context in class or descendant
- else if (TopScope is TPasDotClassScope)
- and (TPasDotClassScope(TopScope).ClassScope.Element.GetModule=Context.GetModule) then
- // e.g. aClassInThisModule.identifier
- else if (TopScope is TPasWithExprScope)
- and (TPasWithExprScope(TopScope).Scope is TPasClassScope)
- and (TPasClassScope(TPasWithExprScope(TopScope).Scope).Element.GetModule=Context.GetModule) then
- // e.g. with aClassInThisModule do identifier
- else
- RaiseMsg(20170216152356,nCantAccessPrivateMember,sCantAccessPrivateMember,
- ['protected',FindData.Found.Name],FindData.ErrorPosEl);
- visStrictPrivate:
- // strict private members can only be accessed in their class
- if Context<>FoundContext then
- RaiseMsg(20170216152357,nCantAccessPrivateMember,sCantAccessPrivateMember,
- ['strict private',FindData.Found.Name],FindData.ErrorPosEl);
- visStrictProtected:
- // strict protected members can only be accessed in their and descendant classes
- if (Context is TPasType)
- and (CheckClassIsClass(TPasType(Context),FoundContext,FindData.ErrorPosEl)<>cIncompatible) then
- // context in class or descendant
- else
- RaiseMsg(20170216152400,nCantAccessPrivateMember,sCantAccessPrivateMember,
- ['strict protected',FindData.Found.Name],FindData.ErrorPosEl);
- end;
- end;
- 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.FinishScope(ScopeType: TPasScopeType; El: TPasElement);
- begin
- if IsElementSkipped(El) then exit;
- case ScopeType of
- stModule: FinishModule(El as TPasModule);
- stUsesClause: FinishUsesClause;
- stTypeSection: FinishTypeSection(El as TPasDeclarations);
- stTypeDef: FinishTypeDef(El as TPasType);
- stConstDef: FinishConstDef(El as TPasConst);
- stResourceString: FinishResourcestring(El as TPasResString);
- stProcedure: FinishProcedure(El as TPasProcedure);
- stProcedureHeader: FinishProcedureType(El as TPasProcedureType);
- stExceptOnExpr: FinishExceptOnExpr;
- stExceptOnStatement: FinishExceptOnStatement;
- stDeclaration: FinishDeclaration(El);
- stAncestors: FinishAncestors(El as TPasClassType);
- else
- RaiseMsg(20170216152401,nNotYetImplemented,sNotYetImplemented+' FinishScope',[IntToStr(ord(ScopeType))],nil);
- 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;
- function TPasResolver.GetPendingUsedInterface(Section: TPasSection
- ): TPasUsesUnit;
- var
- i: Integer;
- UseUnit: TPasUsesUnit;
- begin
- Result:=nil;
- if not (Section is TImplementationSection) then exit;
- 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;
- procedure TPasResolver.CheckPendingUsedInterface(Section: TPasSection);
- var
- PendingModule: TPasModule;
- PendingModuleScope: TPasModuleScope;
- List: TFPList;
- WasPending: Boolean;
- begin
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.CheckPendingUsedInterface START "',CurrentParser.CurModule.Name,'"');
- {$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
- PendingModuleScope:=NoNil(PendingModule.CustomData) as TPasModuleScope;
- PendingModuleScope.PendingResolvers.Remove(Self);
- Section.PendingUsedIntf:=nil;
- end;
- Section.PendingUsedIntf:=GetPendingUsedInterface(Section);
- if Section.PendingUsedIntf<>nil then
- begin
- // unit not yet finished due to pending used interfaces
- PendingModule:=Section.PendingUsedIntf.Module as TPasModule;
- PendingModuleScope:=NoNil(PendingModule.CustomData) as TPasModuleScope;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckPendingUsedInterface "',CurrentParser.CurModule.Name,'" waiting for unit intf of "',PendingModule.Name,'"');
- {$ENDIF}
- List:=PendingModuleScope.PendingResolvers;
- if List.IndexOf(Self)<0 then
- List.Add(Self);
- end
- else
- begin
- if WasPending then
- // can now continue parsing
- ContinueParsing;
- end;
- end;
- procedure TPasResolver.ContinueParsing;
- // 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.ContinueParsing "',CurrentParser.CurModule.Name,'"...');
- {$ENDIF}
- CurrentParser.ParseContinueImplementation;
- 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;
- 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);
- 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);
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TPasResolver.Destroy END ',ClassName);
- {$ENDIF}
- end;
- procedure TPasResolver.Clear;
- begin
- RestoreSubScopes(0);
- // clear stack, keep DefaultScope
- while (FScopeCount>0) and (FTopScope<>DefaultScope) do
- PopScope;
- ClearResolveDataList(lkModule);
- end;
- procedure TPasResolver.ClearBuiltInIdentifiers;
- var
- bt: TResolverBaseType;
- begin
- ClearResolveDataList(lkBuiltIn);
- for bt in TResolverBaseType do
- FBaseTypes[bt]:=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,nil,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 bfConcatArray in TheBaseProcs then
- AddBuiltInProc('Concat','function Concat(const Array1, Array2, ...): Array',
- @BI_ConcatArray_OnGetCallCompatibility,@BI_ConcatArray_OnGetCallResult,
- nil,nil,bfConcatArray);
- 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 bfAssert in TheBaseProcs then
- AddBuiltInProc('Assert','procedure Assert(bool[,string])',
- @BI_Assert_OnGetCallCompatibility,nil,nil,
- @BI_Assert_OnFinishParamsExpr,bfAssert,[bipfCanBeStatement]);
- end;
- function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType
- ): TResElDataBaseType;
- var
- El: TPasUnresolvedSymbolRef;
- begin
- El:=TPasUnresolvedSymbolRef.Create(aName,nil);
- 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);
- 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;
- 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);
- 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
- 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;
- 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;
- 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;
- procedure TPasResolver.PopScope;
- var
- Scope: TPasScope;
- begin
- if FScopeCount=0 then
- RaiseInternalError(20160922163557);
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.PopScope ',FScopeCount,' ',FTopScope<>nil,' IsDefault=',FTopScope=FDefaultScope);
- writeln('TPasResolver.PopScope ',FTopScope.ClassName,' IsStoredInElement=',FTopScope.IsStoredInElement,' Element=',GetObjName(FTopScope.Element),' FreeOnPop=',FTopScope.FreeOnPop);
- {$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.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.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=CurrentParser.CurModule)
- 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
- ): 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.ClassScope:=ClassScope;
- PushScope(Result);
- end;
- function TPasResolver.PushRecordDotScope(CurRecordType: TPasRecordType
- ): TPasDotRecordScope;
- var
- RecScope: TPasRecordScope;
- begin
- RecScope:=NoNil(CurRecordType.CustomData) as TPasRecordScope;
- Result:=TPasDotRecordScope.Create;
- Result.Owner:=Self;
- Result.IdentifierScope:=RecScope;
- PushScope(Result);
- end;
- function TPasResolver.PushEnumDotScope(CurEnumType: TPasEnumType
- ): TPasDotEnumTypeScope;
- var
- EnumScope: TPasEnumTypeScope;
- begin
- EnumScope:=NoNil(CurEnumType.CustomData) as TPasEnumTypeScope;
- Result:=TPasDotEnumTypeScope.Create;
- Result.Owner:=Self;
- Result.IdentifierScope:=EnumScope;
- PushScope(Result);
- end;
- procedure TPasResolver.ResetSubScopes(out Depth: integer);
- // move all sub scopes from Scopes to SubScopes
- begin
- Depth:=FSubScopeCount;
- while TopScope is TPasSubScope do
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ResetSubScopes moving ',TopScope.ClassName,' ScopeCount=',ScopeCount,' SubScopeCount=',FSubScopeCount);
- {$ENDIF}
- if FSubScopeCount=length(FSubScopes) then
- SetLength(FSubScopes,FSubScopeCount+4);
- FSubScopes[FSubScopeCount]:=TopScope;
- inc(FSubScopeCount);
- dec(FScopeCount);
- FScopes[FScopeCount]:=nil;
- if FScopeCount>0 then
- FTopScope:=FScopes[FScopeCount-1]
- else
- FTopScope:=nil;
- end;
- end;
- procedure TPasResolver.RestoreSubScopes(Depth: integer);
- // restore sub scopes
- begin
- while FSubScopeCount>Depth do
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.RestoreSubScopes moving ',FSubScopes[FSubScopeCount-1].ClassName,' ScopeCount=',ScopeCount,' SubScopeCount=',FSubScopeCount);
- {$ENDIF}
- if FScopeCount=length(FScopes) then
- SetLength(FScopes,FScopeCount+4);
- dec(FSubScopeCount);
- FScopes[FScopeCount]:=FSubScopes[FSubScopeCount];
- FTopScope:=FScopes[FScopeCount];
- FSubScopes[FSubScopeCount]:=nil;
- inc(FScopeCount);
- end;
- end;
- function TPasResolver.GetInheritedExprScope(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;
- end;
- procedure TPasResolver.SetLastMsg(const id: int64; MsgType: TMessageType;
- MsgNumber: integer; const Fmt: String; Args: array of const;
- 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}
- write('TPasResolver.SetLastMsg ',id,' ',GetElementSourcePosStr(PosEl),' ');
- s:='';
- str(MsgType,s);
- write(s);
- writeln(': [',MsgNumber,'] ',FLastMsg);
- {$ENDIF}
- end;
- procedure TPasResolver.RaiseMsg(const Id: int64; MsgNumber: integer;
- const Fmt: String; Args: array of const; 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: int64; 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: int64; const Msg: string);
- begin
- raise Exception.Create('Internal error: ['+IntToStr(id)+'] '+Msg);
- end;
- procedure TPasResolver.RaiseInvalidScopeForElement(id: int64; 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: int64; 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: int64; const X, Y: string;
- El: TPasElement);
- begin
- RaiseMsg(id,nXExpectedButYFound,sXExpectedButYFound,[X,Y],El);
- end;
- procedure TPasResolver.RaiseContextXExpectedButYFound(id: int64; const C, X,
- Y: string; El: TPasElement);
- begin
- RaiseMsg(id,nContextExpectedXButFoundY,sContextExpectedXButFoundY,[C,X,Y],El);
- end;
- procedure TPasResolver.RaiseContextXInvalidY(id: int64; const X, Y: string;
- El: TPasElement);
- begin
- RaiseMsg(id,nContextXInvalidY,sContextXInvalidY,[X,Y],El);
- end;
- procedure TPasResolver.RaiseConstantExprExp(id: int64; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nConstantExpressionExpected,sConstantExpressionExpected,[],ErrorEl);
- end;
- procedure TPasResolver.RaiseRangeCheck(id: int64; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nRangeCheckError,sRangeCheckError,[],ErrorEl);
- end;
- procedure TPasResolver.RaiseIncompatibleTypeDesc(id: int64; MsgNumber: integer;
- const Args: array of const; const GotDesc, ExpDesc: String; ErrorEl: TPasElement);
- function GetString(ArgNo: integer): string;
- begin
- if ArgNo>High(Args) then
- exit('invalid param '+IntToStr(ArgNo));
- case Args[ArgNo].VType of
- vtAnsiString: Result:=AnsiString(Args[ArgNo].VAnsiString);
- else
- Result:='invalid param '+IntToStr(Ord(Args[ArgNo].VType));
- end;
- 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);
- else
- RaiseInternalError(20170329112911);
- end;
- end;
- procedure TPasResolver.RaiseIncompatibleType(id: int64; MsgNumber: integer;
- const Args: array of const; GotType, ExpType: TPasType; ErrorEl: TPasElement);
- var
- DescA, DescB: String;
- begin
- DescA:=GetTypeDescription(GotType);
- DescB:=GetTypeDescription(ExpType);
- if DescA=DescB then
- begin
- DescA:=GetTypeDescription(GotType,true);
- DescB:=GetTypeDescription(ExpType,true);
- end;
- RaiseIncompatibleTypeDesc(id,MsgNumber,Args,DescA,DescB,ErrorEl);
- end;
- procedure TPasResolver.RaiseIncompatibleTypeRes(id: int64; MsgNumber: integer;
- const Args: array of const; const GotType, ExpType: TPasResolverResult;
- ErrorEl: TPasElement);
- var
- GotDesc, ExpDesc: String;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.RaiseIncompatibleTypeRes Got={',GetResolverResultDbg(GotType),'} Expected={',GetResolverResultDbg(ExpType),'}');
- {$ENDIF}
- if GotType.BaseType<>ExpType.BaseType then
- begin
- GotDesc:=GetBaseDescription(GotType);
- if ExpType.BaseType=btNil then
- ExpDesc:=BaseTypeNames[btPointer]
- else
- ExpDesc:=GetBaseDescription(ExpType);
- if GotDesc=ExpDesc then
- begin
- GotDesc:=GetBaseDescription(GotType,true);
- ExpDesc:=GetBaseDescription(ExpType,true);
- end;
- end
- else if (GotType.TypeEl<>nil) and (ExpType.TypeEl<>nil) then
- begin
- GotDesc:=GetTypeDescription(GotType);
- ExpDesc:=GetTypeDescription(ExpType);
- if GotDesc=ExpDesc then
- begin
- GotDesc:=GetTypeDescription(GotType,true);
- ExpDesc:=GetTypeDescription(ExpType,true);
- end;
- end
- else
- begin
- GotDesc:=GetResolverResultDescription(GotType,true);
- ExpDesc:=GetResolverResultDescription(ExpType,true);
- if GotDesc=ExpDesc then
- begin
- GotDesc:=GetResolverResultDescription(GotType,false);
- ExpDesc:=GetResolverResultDescription(ExpType,false);
- end;
- end;
- RaiseIncompatibleTypeDesc(id,MsgNumber,Args,GotDesc,ExpDesc,ErrorEl);
- end;
- procedure TPasResolver.RaiseInvalidProcTypeModifier(id: int64;
- ProcType: TPasProcedureType; ptm: TProcTypeModifier; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nInvalidXModifierY,sInvalidXModifierY,[ProcType.ElementTypeName,
- ProcTypeModifiers[ptm]],ErrorEl);
- end;
- procedure TPasResolver.RaiseInvalidProcModifier(id: int64; Proc: TPasProcedure;
- pm: TProcedureModifier; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nInvalidXModifierY,sInvalidXModifierY,[Proc.ElementTypeName,
- ModifierNames[pm]],ErrorEl);
- end;
- procedure TPasResolver.LogMsg(const id: int64; MsgType: TMessageType;
- MsgNumber: integer; const Fmt: String; Args: array of const;
- PosEl: TPasElement);
- begin
- if (FStep<prsFinishingModule)
- and (CurrentParser.Scanner<>nil)
- and (CurrentParser.Scanner.IgnoreMsgType(MsgType)) then
- exit; // during parsing consider directives like $Hints on|off
- 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;
- function TPasResolver.CheckCallProcCompatibility(ProcType: TPasProcedureType;
- Params: TParamsExpr; RaiseOnError: boolean; SetReferenceFlags: boolean
- ): integer;
- var
- ProcArgs: TFPList;
- i, ParamCnt, ParamCompatibility: Integer;
- Param: TPasExpr;
- ParamResolved: TPasResolverResult;
- IsVarArgs: Boolean;
- Flags: TPasResolverComputeFlags;
- begin
- Result:=cExact;
- ProcArgs:=ProcType.Args;
- // check args
- ParamCnt:=length(Params.Params);
- IsVarArgs:=false;
- 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
- IsVarArgs:=IsVarArgs or (ptmVarargs in ProcType.Modifiers);
- if IsVarArgs then
- begin
- Flags:=[rcNoImplicitProcType];
- if SetReferenceFlags then
- Flags:=[rcNoImplicitProcType]
- else
- Flags:=[rcNoImplicitProcType,rcSetReferenceFlags];
- ComputeElement(Param,ParamResolved,Flags,Param);
- if not (rrfReadable in ParamResolved.Flags) then
- begin
- if RaiseOnError then
- RaiseMsg(20170318234957,nVariableIdentifierExpected,
- sVariableIdentifierExpected,[],Param);
- exit(cIncompatible);
- end;
- ParamCompatibility:=cExact;
- end
- else
- begin
- // too many arguments
- if RaiseOnError then
- RaiseMsg(20170216152408,nWrongNumberOfParametersForCallTo,
- sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(ProcType)],Param);
- exit(cIncompatible);
- end;
- end;
- inc(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
- Result:=cCompatibleWithDefaultParams;
- end;
- end;
- function TPasResolver.CheckCallPropertyCompatibility(PropEl: TPasProperty;
- Params: TParamsExpr; RaiseOnError: boolean): integer;
- var
- PropArg: TPasArgument;
- ArgNo, ParamComp: Integer;
- Param: TPasExpr;
- begin
- Result:=cExact;
- if PropEl.Args.Count<length(Params.Params) then
- begin
- if not RaiseOnError then exit(cIncompatible);
- RaiseMsg(20170216152412,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
- [PropEl.Name],Params)
- end
- else if PropEl.Args.Count>length(Params.Params) then
- begin
- if not RaiseOnError then exit(cIncompatible);
- RaiseMsg(20170216152413,nMissingParameterX,sMissingParameterX,
- [TPasArgument(PropEl.Args[length(Params.Params)]).Name],Params);
- end;
- for ArgNo:=0 to PropEl.Args.Count-1 do
- begin
- PropArg:=TPasArgument(PropEl.Args[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,[refAutoConst]);
- if ParamValue<>nil then
- try // has const value -> check range
- 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:=ResolveAliasType(RangeResolved.TypeEl);
- if ParamResolved.BaseType=btContext then
- begin
- if (TypeEl.ClassType=TPasEnumType)
- and IsSameType(TypeEl,ParamResolved.TypeEl,true) 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;
- end;
- function TPasResolver.CheckOverloadProcCompatibility(Proc1, Proc2: TPasProcedure
- ): boolean;
- // returns if number and type of arguments fit
- // does not check calling convention
- var
- ProcArgs1, ProcArgs2: TFPList;
- i: Integer;
- begin
- Result:=false;
- ProcArgs1:=Proc1.ProcType.Args;
- ProcArgs2:=Proc2.ProcType.Args;
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckOverloadProcCompatibility 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.CheckOverloadProcCompatibility ',i,'/',ProcArgs1.Count);
- {$ENDIF}
- if not CheckProcArgCompatibility(TPasArgument(ProcArgs1[i]),TPasArgument(ProcArgs2[i])) 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,
- [Proc1.ElementTypeName,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,Proc1.ElementTypeName,Proc2.ElementTypeName,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
- 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 RaiseOnIncompatible then
- RaiseMsg(20170402112253,nCallingConventionMismatch,sCallingConventionMismatch,
- [],ErrorEl);
- exit;
- 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.CheckProcAssignCompatibility ',i,'/',ProcArgs1.Count);
- {$ENDIF}
- ExpectedArg:=TPasArgument(ProcArgs1[i]);
- ActualArg:=TPasArgument(ProcArgs2[i]);
- if not CheckProcArgCompatibility(ExpectedArg,ActualArg) 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
- ComputeElement(TPasFunctionType(Proc1).ResultEl.ResultType,Result1Resolved,[rcType]);
- ComputeElement(TPasFunctionType(Proc2).ResultEl.ResultType,Result2Resolved,[rcType]);
- if (Result1Resolved.BaseType<>Result2Resolved.BaseType)
- or not IsSameType(Result1Resolved.TypeEl,Result2Resolved.TypeEl) then
- begin
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170402112648,nResultTypeMismatchExpectedButFound,
- [],Result1Resolved,Result2Resolved,ErrorEl);
- exit;
- end;
- end;
- Result:=true;
- end;
- function TPasResolver.CheckProcArgCompatibility(Arg1, Arg2: TPasArgument): boolean;
- begin
- Result:=false;
- // check access: var, const, ...
- if Arg1.Access<>Arg2.Access then exit;
- // check untyped
- if Arg1.ArgType=nil then
- exit(Arg2.ArgType=nil);
- if Arg2.ArgType=nil then exit;
- Result:=CheckProcArgTypeCompatibility(Arg1.ArgType,Arg2.ArgType);
- end;
- function TPasResolver.CheckProcArgTypeCompatibility(Arg1, Arg2: TPasType
- ): boolean;
- var
- Arg1Resolved, Arg2Resolved: TPasResolverResult;
- C: TClass;
- Arr1, Arr2: TPasArrayType;
- begin
- ComputeElement(Arg1,Arg1Resolved,[rcType]);
- ComputeElement(Arg2,Arg2Resolved,[rcType]);
- {$IFDEF VerbosePasResolver}
- //writeln('TPasResolver.CheckProcArgTypeCompatibility Arg1=',GetResolverResultDbg(Arg1Resolved),' Arg2=',GetResolverResultDbg(Arg2Resolved));
- {$ENDIF}
- if (Arg1Resolved.BaseType<>Arg2Resolved.BaseType)
- or (Arg1Resolved.TypeEl=nil)
- or (Arg2Resolved.TypeEl=nil) then
- exit(false);
- if (Arg1Resolved.BaseType=Arg2Resolved.BaseType)
- and IsSameType(Arg1Resolved.TypeEl,Arg2Resolved.TypeEl) then
- exit(true);
- C:=Arg1Resolved.TypeEl.ClassType;
- if (C=TPasArrayType) and (Arg2Resolved.TypeEl.ClassType=TPasArrayType) then
- begin
- Arr1:=TPasArrayType(Arg1Resolved.TypeEl);
- Arr2:=TPasArrayType(Arg2Resolved.TypeEl);
- if length(Arr1.Ranges)<>length(Arr2.Ranges) then
- exit(false);
- if length(Arr1.Ranges)>0 then
- RaiseNotYetImplemented(20170328093733,Arr1.Ranges[0],'anonymous static array');
- Result:=CheckProcArgTypeCompatibility(Arr1.ElType,Arr2.ElType);
- exit;
- end;
- Result:=false;
- 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 ErrorOnFalse then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckCanBeLHS ',GetResolverResultDbg(ResolvedEl));
- {$ENDIF}
- if (ResolvedEl.TypeEl<>nil) and (ResolvedEl.ExprEl<>nil) then
- RaiseXExpectedButYFound(20170216152727,'identifier',ResolvedEl.TypeEl.ElementTypeName,ResolvedEl.ExprEl)
- else
- RaiseMsg(20170216152426,nVariableIdentifierExpected,sVariableIdentifierExpected,[],ErrorEl);
- end;
- exit;
- end;
- if [rrfWritable,rrfAssignable]*ResolvedEl.Flags<>[] then
- exit(true);
- // not writable
- if not ErrorOnFalse then exit;
- if ResolvedEl.IdentEl is TPasProperty then
- RaiseMsg(20170216152427,nPropertyNotWritable,sPropertyNotWritable,[],ErrorEl)
- else
- RaiseMsg(20170216152429,nVariableIdentifierExpected,sVariableIdentifierExpected,[],ErrorEl);
- end;
- function TPasResolver.CheckAssignCompatibility(const LHS, RHS: TPasElement;
- RaiseOnIncompatible: boolean): integer;
- var
- LeftResolved, RightResolved: TPasResolverResult;
- Flags: TPasResolverComputeFlags;
- IsProcType: Boolean;
- begin
- 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,RHS,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;
- MinVal, MaxVal: int64;
- RangeExpr: TBinaryExpr;
- Int: MaxPrecInt;
- C: TClass;
- EnumType: TPasEnumType;
- bt: TResolverBaseType;
- w: WideChar;
- LTypeEl: TPasType;
- begin
- if (LeftResolved.TypeEl<>nil) and (LeftResolved.TypeEl.ClassType=TPasArrayType) then
- exit; // arrays are checked by element, not by the whole value
- LTypeEl:=ResolveAliasType(LeftResolved.TypeEl);
- if LTypeEl is TPasClassOfType then
- exit; // class-of are checked only by type, not by value
- RValue:=Eval(RHS,[refAutoConst]);
- 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 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,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 (btAllInteger-[btQWord]))
- 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)
- else if bt=btAnsiChar then
- LRangeValue:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff)
- 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 (btAllInteger-[btQWord]))
- 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(MaxPrecInt))
- or (MinVal>MaxPrecInt(TResEvalUInt(RValue).UInt))
- or (MaxVal<MaxPrecInt(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<MaxPrecFloat(low(MaxPrecInt)),' ',TResEvalFloat(RValue).FloatValue>MaxPrecFloat(high(MaxPrecInt)),' ',TResEvalFloat(RValue).FloatValue,' ',high(MaxPrecInt));
- {$ENDIF}
- RaiseRangeCheck(20170802133750,RHS);
- end;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.CheckAssignExprRange ',RValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530092731,RHS);
- end
- 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
- else if RValue.Kind in [revkNil,revkBool] then
- // simple type check is enough
- else if LeftResolved.BaseType in [btSingle,btDouble] then
- // simple type check is enough
- // ToDo: warn if precision loss
- else if LeftResolved.BaseType in btAllChars then
- begin
- case RValue.Kind of
- revkString:
- if length(TResEvalString(RValue).S)<>1 then
- begin
- if fExprEvaluator.GetWideChar(TResEvalString(RValue).S,w) then
- Int:=ord(w)
- else
- RaiseXExpectedButYFound(20170714171352,'char','string',RHS);
- end
- else
- Int:=ord(TResEvalString(RValue).S[1]);
- revkUnicodeString:
- if length(TResEvalUTF16(RValue).S)<>1 then
- RaiseXExpectedButYFound(20170714171534,'char','string',RHS)
- else
- Int:=ord(TResEvalUTF16(RValue).S[1]);
- else
- RaiseNotYetImplemented(20170714171218,RHS);
- end;
- case GetActualBaseType(LeftResolved.BaseType) of
- btAnsiChar: MaxVal:=$ff;
- 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
- TypeEl, RTypeEl: TPasType;
- Handled: Boolean;
- C: TClass;
- LBT, RBT: TResolverBaseType;
- LRange, RValue: 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 LHS.TypeEl=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
- Result:=cExact; // same base type, maybe not same type name (e.g. longint and integer)
- 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
- btAnsiChar:
- Result:=cLossyConversion;
- btWideChar:
- if RBT=btAnsiChar then
- Result:=cCompatible
- else
- 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);
- // LHS is ansichar
- if GetActualBaseType(RHS.SubType)=btAnsiChar then
- exit(cExact);
- RValue:=Eval(RHS,[refAutoConst]);
- 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;
- 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;
- RaiseNotYetImplemented(20171108195216,ErrorEl);
- end;
- end
- else if (LBT in btAllStrings)
- and (RBT in btAllStringAndChars) then
- case LBT of
- btAnsiString:
- if RBT in [btAnsiChar,btShortString,btRawByteString] then
- Result:=cCompatible
- else
- Result:=cLossyConversion;
- btShortString:
- if RBT=btAnsiChar then
- Result:=cCompatible
- else
- Result:=cLossyConversion;
- btWideString,btUnicodeString:
- Result:=cCompatible;
- btRawByteString:
- if RBT in [btAnsiChar,btAnsiString,btShortString] then
- Result:=cCompatible
- else
- Result:=cLossyConversion;
- else
- RaiseNotYetImplemented(20170417195208,ErrorEl,BaseTypeNames[LBT]);
- 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);
- btQWord,
- btInt64,btComp:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,btUIntSingle,btIntSingle,
- btLongWord,btLongint,btUIntDouble,btIntDouble]) then
- inc(Result,cLossyConversion);
- else
- RaiseNotYetImplemented(20170417205301,ErrorEl,BaseTypeNames[LBT]);
- end;
- end
- else if (LBT in btAllFloats)
- and (RBT in (btAllFloats+btAllInteger)) then
- begin
- Result:=cToFloatConversion+ord(LBT)-ord(RBT);
- case LBT of
- btSingle:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
- btIntSingle,btUIntSingle]) then
- inc(Result,cLossyConversion);
- btDouble:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
- btIntSingle,btUIntSingle,btSingle,
- btLongWord,btLongint,
- btIntDouble,btUIntDouble]) then
- inc(Result,cLossyConversion);
- btExtended,btCExtended:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
- btIntSingle,btUIntSingle,btSingle,
- btLongWord,btLongint,
- btInt64,btComp,
- btIntDouble,btUIntDouble,btDouble]) then
- inc(Result,cLossyConversion);
- btCurrency:
- if not (RBT in [btByte,btShortInt,btWord,btSmallInt,
- btIntSingle,btUIntSingle,
- btLongWord,btLongint]) then
- inc(Result,cLossyConversion);
- else
- RaiseNotYetImplemented(20170417205910,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.TypeEl,true) then
- begin
- // same enum type
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckAssignResCompatibility LeftRange=',LRange.AsDebugString,' Left.ElType=',GetObjName(TResEvalRangeInt(LRange).ElType),' RHS.TypeEl=',GetObjName(RHS.TypeEl));
- {$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,[refAutoConst]);
- if RValue<>nil then
- begin
- // ToDo: check range
- end;
- exit(cCompatible);
- end;
- revskChar:
- if RHS.BaseType in btAllStringAndChars then
- begin
- RValue:=Eval(RHS,[refAutoConst]);
- if RValue<>nil then
- begin
- case RValue.Kind of
- revkString:
- if not fExprEvaluator.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;
- 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,[refAutoConst]);
- 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 in [btSet,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
- TypeEl:=LHS.TypeEl;
- C:=TypeEl.ClassType;
- if (C=TPasClassType)
- or (C=TPasClassOfType)
- or (C=TPasPointerType)
- or C.InheritsFrom(TPasProcedureType)
- or IsDynArray(TypeEl) then
- Result:=cExact;
- end;
- end
- else if RBT=btProc then
- begin
- if (msDelphi in CurrentParser.CurrentModeswitches)
- and (LHS.TypeEl is TPasProcedureType)
- and (RHS.IdentEl is TPasProcedure) then
- begin
- // for example ProcVar:=Proc
- if CheckProcTypeCompatibility(TPasProcedureType(LHS.TypeEl),
- TPasProcedure(RHS.IdentEl).ProcType,true,ErrorEl,RaiseOnIncompatible) then
- exit(cExact);
- end;
- end
- else if LBT=btPointer then
- begin
- if RBT=btPointer then
- begin
- if IsBaseType(LHS.TypeEl,btPointer) then
- Result:=cExact // btPointer can take any pointer
- else if IsBaseType(RHS.TypeEl,btPointer) then
- Result:=cTypeConversion // any pointer can take a btPointer
- else if IsSameType(LHS.TypeEl,RHS.TypeEl) then
- Result:=cExact // pointer of same type
- else if (LHS.TypeEl.ClassType=TPasPointerType)
- and (RHS.TypeEl.ClassType=TPasPointerType) then
- Result:=CheckAssignCompatibility(TPasPointerType(LHS.TypeEl).DestType,
- TPasPointerType(RHS.TypeEl).DestType,RaiseOnIncompatible);
- end
- else if IsBaseType(LHS.TypeEl,btPointer) then
- begin
- if RBT=btContext then
- begin
- C:=RHS.TypeEl.ClassType;
- if C=TPasClassType then
- exit(cTypeConversion) // class type or class instance
- else if C=TPasClassOfType then
- Result:=cTypeConversion
- else if C=TPasArrayType then
- begin
- if IsDynArray(RHS.TypeEl) then
- Result:=cTypeConversion;
- end
- else if (C=TPasProcedureType) or (C=TPasFunctionType) then
- // pointer:=procvar
- Result:=cLossyConversion;
- end;
- end;
- end
- else if (LBT=btContext) then
- begin
- TypeEl:=ResolveAliasType(LHS.TypeEl);
- if (TypeEl.ClassType=TPasArrayType) then
- Result:=CheckAssignCompatibilityArrayType(LHS,RHS,ErrorEl,RaiseOnIncompatible)
- else if TypeEl.ClassType=TPasEnumType then
- begin
- if (RHS.BaseType=btRange) and (RHS.SubType=btContext) then
- begin
- RTypeEl:=ResolveAliasType(RHS.TypeEl);
- if RTypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(RTypeEl).RangeExpr.left,RightSubResolved,[rcConstant]);
- if (RightSubResolved.BaseType=btContext)
- and IsSameType(TypeEl,RightSubResolved.TypeEl,true) then
- begin
- // enumtype := enumrange
- Result:=cExact;
- end;
- 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}
- RaiseMsg(20170318235637,nVariableIdentifierExpected,
- sVariableIdentifierExpected,[],ErrorEl);
- 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
- TypeEl, 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) and (LHS.TypeEl.ClassType=TPasClassType)
- and (ResolveAliasTypeEl(LHS.IdentEl)=LHS.TypeEl) then
- begin
- if RHS.BaseType=btNil then
- exit(cExact)
- else if (RHS.BaseType=btContext) and (RHS.TypeEl.ClassType=TPasClassOfType)
- and (rrfReadable in RHS.Flags) then
- // for example if TImage=ImageClass then
- exit(cExact);
- end;
- RaiseMsg(20170216152438,nNotReadable,sNotReadable,[],LErrorEl);
- end;
- if not (rrfReadable in RHS.Flags) then
- begin
- if (RHS.BaseType=btContext) and (RHS.TypeEl.ClassType=TPasClassType)
- and (ResolveAliasTypeEl(RHS.IdentEl)=RHS.TypeEl) then
- begin
- if LHS.BaseType=btNil then
- exit(cExact)
- else if (LHS.BaseType=btContext) and (LHS.TypeEl.ClassType=TPasClassOfType)
- and (rrfReadable in LHS.Flags) then
- // for example if ImageClass=TImage then
- exit(cExact);
- end;
- RaiseMsg(20170216152440,nNotReadable,sNotReadable,[],RErrorEl);
- 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);
- end
- else if LHS.BaseType=btNil then
- begin
- if RHS.BaseType in [btPointer,btNil] then
- exit(cExact)
- else if RHS.BaseType=btContext then
- begin
- TypeEl:=RHS.TypeEl;
- if (TypeEl.ClassType=TPasClassType)
- or (TypeEl.ClassType=TPasClassOfType)
- or (TypeEl.ClassType=TPasPointerType)
- or (TypeEl is TPasProcedureType)
- or IsDynArray(TypeEl) 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
- TypeEl:=LHS.TypeEl;
- if (TypeEl.ClassType=TPasClassType)
- or (TypeEl.ClassType=TPasClassOfType)
- or (TypeEl.ClassType=TPasPointerType)
- or (TypeEl is TPasProcedureType)
- or IsDynArray(TypeEl) then
- exit(cExact);
- end;
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152444,nIncompatibleTypesGotExpected,
- [],LHS,RHS,LErrorEl)
- else
- exit(cIncompatible);
- end
- else if LHS.BaseType=btSet then
- begin
- if RHS.BaseType=btSet then
- begin
- if LHS.TypeEl=nil then
- exit(cExact); // empty set
- if RHS.TypeEl=nil then
- exit(cExact); // empty set
- if LHS.TypeEl=RHS.TypeEl 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
- TypeEl:=ResolveAliasType(LHS.TypeEl);
- if TypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(TypeEl).RangeExpr.left,ResolvedEl,[rcConstant]);
- if ResolvedEl.BaseType=btContext then
- begin
- TypeEl:=ResolveAliasType(ResolvedEl.TypeEl);
- if TypeEl.ClassType=TPasEnumType then
- begin
- if RHS.BaseType=btContext then
- begin
- RTypeEl:=ResolveAliasType(RHS.TypeEl);
- if (TypeEl=RTypeEl) then
- exit(cCompatible);
- end;
- end;
- end;
- end;
- end;
- end
- else if LHS.BaseType=btContext then
- begin
- TypeEl:=ResolveAliasType(LHS.TypeEl);
- if TypeEl.ClassType=TPasEnumType then
- begin
- if RHS.BaseType=btRange then
- begin
- RTypeEl:=ResolveAliasType(RHS.TypeEl);
- if RTypeEl.ClassType=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(RTypeEl).RangeExpr.left,ResolvedEl,[rcConstant]);
- if ResolvedEl.BaseType=btContext then
- begin
- RTypeEl:=ResolveAliasType(ResolvedEl.TypeEl);
- if TypeEl=RTypeEl then
- exit(cCompatible);
- end;
- end;
- end;
- end;
- end;
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152449,nIncompatibleTypesGotExpected,
- [],RHS,LHS,RErrorEl)
- else
- exit(cIncompatible);
- end;
- function TPasResolver.ResolvedElCanBeVarParam(
- const ResolvedEl: TPasResolverResult): boolean;
- begin
- Result:=false;
- if [rrfReadable,rrfWritable]*ResolvedEl.Flags<>[rrfReadable,rrfWritable] then
- exit;
- if ResolvedEl.IdentEl=nil then exit;
- if ResolvedEl.IdentEl.ClassType=TPasVariable then
- exit(true);
- if (ResolvedEl.IdentEl.ClassType=TPasArgument) then
- begin
- Result:=(TPasArgument(ResolvedEl.IdentEl).Access in [argDefault, argVar, argOut]);
- exit;
- end;
- if ResolvedEl.IdentEl.ClassType=TPasResultElement then
- exit(true);
- if (ResolvedEl.IdentEl.ClassType=TPasConst) then
- begin
- // typed const are writable
- Result:=(TPasConst(ResolvedEl.IdentEl).VarType<>nil);
- exit;
- end;
- if (proPropertyAsVarParam in Options)
- and (ResolvedEl.IdentEl.ClassType=TPasProperty) then
- exit(true);
- end;
- function TPasResolver.ResolvedElIsClassInstance(
- const ResolvedEl: TPasResolverResult): boolean;
- var
- TypeEl: TPasType;
- begin
- Result:=false;
- if ResolvedEl.BaseType<>btContext then exit;
- TypeEl:=ResolvedEl.TypeEl;
- if TypeEl=nil then exit;
- if TypeEl.ClassType<>TPasClassType then exit;
- if TPasClassType(TypeEl).ObjKind<>okClass then exit;
- if (ResolvedEl.IdentEl is TPasVariable)
- or (ResolvedEl.IdentEl.ClassType=TPasArgument)
- or (ResolvedEl.IdentEl.ClassType=TPasResultElement) then
- exit(true);
- end;
- function TPasResolver.GetProcTypeDescription(ProcType: TPasProcedureType;
- UseName: boolean; AddPaths: boolean): string;
- var
- Args: TFPList;
- i: Integer;
- Arg: TPasArgument;
- begin
- if ProcType=nil then exit('nil');
- Result:=ProcType.TypeName;
- if ProcType.IsReferenceTo then
- Result:=ProcTypeModifiers[ptmReferenceTo]+' '+Result;
- if UseName and (ProcType.Parent is TPasProcedure) then
- begin
- if AddPaths then
- Result:=Result+' '+ProcType.Parent.FullName
- else
- Result:=Result+' '+ProcType.Parent.Name;
- 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
- Result:=Result+GetTypeDescription(Arg.ArgType,AddPaths);
- 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.TypeEl<>nil) and (T.TypeEl.Name<>'') then
- Result:=T.TypeEl.Name
- else
- Result:=BaseTypeNames[T.SubType];
- end;
- var
- ArrayEl: TPasArrayType;
- begin
- case T.BaseType of
- btModule: exit(T.IdentEl.ElementTypeName+' '+T.IdentEl.Name);
- btNil: exit('nil');
- btRange:
- Result:='range of '+GetSubTypeName;
- btSet:
- Result:='set/array literal of '+GetSubTypeName;
- btContext:
- begin
- if T.TypeEl.ClassType=TPasClassOfType then
- Result:='class of '+TPasClassOfType(T.TypeEl).DestType.Name
- else if T.TypeEl.ClassType=TPasAliasType then
- Result:=TPasAliasType(T.TypeEl).DestType.Name
- else if T.TypeEl.ClassType=TPasTypeAliasType then
- Result:='type '+TPasAliasType(T.TypeEl).DestType.Name
- else if T.TypeEl.ClassType=TPasArrayType then
- begin
- ArrayEl:=TPasArrayType(T.TypeEl);
- if length(ArrayEl.Ranges)=0 then
- Result:='array of '+ArrayEl.ElType.Name
- else
- Result:='static array[] of '+ArrayEl.ElType.Name;
- end
- else if T.TypeEl is TPasProcedureType then
- Result:=GetProcTypeDescription(TPasProcedureType(T.TypeEl),false)
- else if T.TypeEl.Name<>'' then
- Result:=T.TypeEl.Name
- else
- Result:=T.TypeEl.ElementTypeName;
- end;
- btCustom:
- Result:=T.TypeEl.Name;
- else
- Result:=BaseTypeNames[T.BaseType];
- end;
- if (not OnlyType) and (T.TypeEl<>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;
- begin
- Result:=aType.Name;
- if Result='' then
- Result:=aType.ElementTypeName;
- if AddPath then
- begin
- s:=aType.FullPath;
- if (s<>'') and (s<>'.') then
- Result:=s+':'+Result;
- end;
- end;
- var
- C: TClass;
- begin
- if aType=nil then exit('untyped');
- C:=aType.ClassType;
- Result:=GetName;
- if (C=TPasUnresolvedSymbolRef) then
- begin
- if TPasUnresolvedSymbolRef(aType).CustomData is TResElDataBuiltInProc then
- Result:=Result+'()';
- exit;
- end;
- end;
- function TPasResolver.GetTypeDescription(const R: TPasResolverResult;
- AddPath: boolean): string;
- begin
- Result:=GetTypeDescription(R.TypeEl,AddPath);
- if R.IdentEl=R.TypeEl then
- begin
- if R.TypeEl.ElementTypeName<>'' then
- Result:=R.TypeEl.ElementTypeName+' '+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
- Result:=BaseTypeNames[R.BaseType];
- 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.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.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.CheckParamCompatibility(Expr: TPasExpr;
- Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean;
- SetReferenceFlags: boolean): integer;
- var
- ExprResolved, ParamResolved: TPasResolverResult;
- NeedVar: Boolean;
- RHSFlags: TPasResolverComputeFlags;
- begin
- Result:=cIncompatible;
- NeedVar:=Param.Access in [argVar, argOut];
- ComputeElement(Param,ParamResolved,[]);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckParamCompatibility Param=',GetTreeDbg(Param,2),' ParamResolved=',GetResolverResultDbg(ParamResolved));
- {$ENDIF}
- if (ParamResolved.TypeEl=nil) and (Param.ArgType<>nil) then
- RaiseInternalError(20160922163628,'GetResolvedType returned TypeEl=nil for '+GetTreeDbg(Param));
- if (Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
- begin
- // passing a const set
- if NeedVar then
- begin
- if RaiseOnError then
- RaiseMsg(20170216152450,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr);
- exit;
- end;
- if ParamResolved.TypeEl is TPasArrayType then
- begin
- Result:=CheckConstArrayCompatibility(TParamsExpr(Expr),ParamResolved,
- RaiseOnError,[],Expr);
- if (Result=cIncompatible) and RaiseOnError then
- RaiseInternalError(20170326211129);
- exit;
- end;
- end;
- RHSFlags:=[];
- if NeedVar then
- Include(RHSFlags,rcNoImplicitProc)
- else if IsProcedureType(ParamResolved,true)
- or (ParamResolved.BaseType=btPointer)
- or (Param.ArgType=nil) then
- Include(RHSFlags,rcNoImplicitProcType);
- if SetReferenceFlags then
- Include(RHSFlags,rcSetReferenceFlags);
- ComputeElement(Expr,ExprResolved,RHSFlags); // ToDo: btArrayLit: if ParamResolved is array then pass ArrType and Dim
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckParamCompatibility Expr=',GetTreeDbg(Expr,2),' ResolvedExpr=',GetResolverResultDbg(ExprResolved),' RHSFlags=',dbgs(RHSFlags));
- {$ENDIF}
- if NeedVar then
- begin
- // Expr must be a variable
- if not ResolvedElCanBeVarParam(ExprResolved) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckParamCompatibility NeedWritable: ',GetResolverResultDbg(ExprResolved));
- {$ENDIF}
- if RaiseOnError then
- RaiseMsg(20170216152450,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr);
- exit;
- end;
- if (ParamResolved.BaseType=ExprResolved.BaseType) then
- begin
- if IsSameType(ParamResolved.TypeEl,ExprResolved.TypeEl) then
- exit(cExact);
- end;
- if (Param.ArgType=nil) then
- exit(cExact); // untyped argument
- if RaiseOnError then
- RaiseIncompatibleType(20170216152452,nIncompatibleTypeArgNoVarParamMustMatchExactly,
- [IntToStr(ParamNo+1)],ExprResolved.TypeEl,ParamResolved.TypeEl,
- Expr);
- exit(cIncompatible);
- end;
- Result:=CheckAssignResCompatibility(ParamResolved,ExprResolved,Expr,false);
- if (Result=cIncompatible) and RaiseOnError then
- RaiseIncompatibleTypeRes(20170216152454,nIncompatibleTypeArgNo,
- [IntToStr(ParamNo+1)],ExprResolved,ParamResolved,Expr);
- end;
- function TPasResolver.CheckAssignCompatibilityUserType(const LHS,
- RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- var
- RTypeEl, LTypeEl: TPasType;
- SrcResolved, DstResolved: TPasResolverResult;
- LArray, RArray: TPasArrayType;
- function RaiseIncompatType: integer;
- begin
- if not RaiseOnIncompatible then exit(cIncompatible);
- RaiseIncompatibleTypeRes(20170216152505,nIncompatibleTypesGotExpected,
- [],RHS,LHS,ErrorEl);
- end;
- begin
- if (RHS.TypeEl=nil) then
- RaiseInternalError(20160922163645);
- if (LHS.TypeEl=nil) then
- RaiseInternalError(20160922163648);
- LTypeEl:=ResolveAliasType(LHS.TypeEl);
- RTypeEl:=ResolveAliasType(RHS.TypeEl);
- if LTypeEl=RTypeEl 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:=CheckSrcIsADstType(RHS,LHS,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseIncompatibleType(20170216152458,nIncompatibleTypesGotExpected,
- [],RTypeEl,LTypeEl,ErrorEl);
- end
- else
- exit(RaiseIncompatType);
- end
- else if LTypeEl.ClassType=TPasClassOfType then
- begin
- if RHS.BaseType=btNil then
- Result:=cExact
- else if (RTypeEl.ClassType=TPasClassOfType) then
- begin
- // e.g. ImageClass:=AnotherImageClass;
- Result:=CheckClassIsClass(TPasClassOfType(RTypeEl).DestType,
- TPasClassOfType(LTypeEl).DestType,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152500,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['class of '+TPasClassOfType(RTypeEl).DestType.FullName,'class of '+TPasClassOfType(LTypeEl).DestType.FullName],ErrorEl);
- end
- else if (RHS.IdentEl is TPasClassType)
- or ((RHS.IdentEl is TPasAliasType)
- and (ResolveAliasType(TPasAliasType(RHS.IdentEl)).ClassType=TPasClassType)) then
- begin
- // e.g. ImageClass:=TFPMemoryImage;
- Result:=CheckClassIsClass(RTypeEl,TPasClassOfType(LTypeEl).DestType,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152501,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- [RTypeEl.Name,'class of '+TPasClassOfType(LTypeEl).DestType.FullName],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,
- [RTypeEl.ElementTypeName,LTypeEl.ElementTypeName],ErrorEl);
- end;
- end
- else if LTypeEl.ClassType=TPasArrayType then
- begin
- // arrays of different types
- if IsOpenArray(LTypeEl) and (RTypeEl.ClassType=TPasArrayType) then
- begin
- LArray:=TPasArrayType(LTypeEl);
- RArray:=TPasArrayType(RTypeEl);
- if (length(RArray.Ranges)=1)
- or ((proOpenAsDynArrays in Options) and (length(RArray.Ranges)=0))
- or IsOpenArray(RTypeEl) then
- begin
- if CheckProcArgTypeCompatibility(LArray.ElType,RArray.ElType) then
- Result:=cExact
- else if RaiseOnIncompatible then
- RaiseMsg(20170328110050,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
- ['array of '+LArray.ElType.FullName,
- 'array of '+RArray.ElType.FullName],ErrorEl)
- else
- exit(cIncompatible);
- end;
- end;
- end
- else if LTypeEl.ClassType=TPasRecordType then
- begin
- // 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.TypeEl<>nil)
- and (SrcResolved.TypeEl=DstResolved.TypeEl) then
- Result:=cExact
- else if (SrcResolved.TypeEl.CustomData is TResElDataBaseType)
- and (DstResolved.TypeEl.CustomData is TResElDataBaseType)
- and (CompareText(SrcResolved.TypeEl.Name,DstResolved.TypeEl.Name)=0) then
- Result:=cExact
- else if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152510,nIncompatibleTypesGotExpected,
- [],SrcResolved,DstResolved,ErrorEl)
- else
- exit(cIncompatible);
- end
- else
- exit(RaiseIncompatType);
- end
- else
- RaiseNotYetImplemented(20160922163654,ErrorEl);
- if Result=-1 then
- exit(RaiseIncompatType);
- if not (rrfReadable in RHS.Flags) then
- exit(RaiseIncompatType);
- 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;
- US: UnicodeString;
- S: String;
- 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]);
- try
- case Value.Kind of
- revkString:
- if ElBT=btAnsiChar then
- l:=length(TResEvalString(Value).S)
- else
- begin
- US:=fExprEvaluator.GetUnicodeStr(TResEvalString(Value).S,ErrorEl);
- l:=length(US);
- end;
- 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
- Range, Value, Expr: TPasExpr;
- RangeResolved, ValueResolved, ElTypeResolved: TPasResolverResult;
- i, Count: Integer;
- IsLastRange: Boolean;
- ArrayValues: TPasExprArray;
- Impl: TPasElement;
- begin
- Expr:=Values.ExprEl;
- if (Expr=nil) and (Values.IdentEl is TPasVariable) then
- Expr:=TPasVariable(Values.IdentEl).Expr;
- if length(ArrType.Ranges)=0 then
- begin
- // dynamic array
- if (Expr<>nil) then
- begin
- if Expr.ClassType=TArrayValues then
- Count:=length(TArrayValues(Expr).Values)
- else if (Expr.ClassType=TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
- Count:=length(TParamsExpr(Expr).Params)
- else if (Values.BaseType in btAllStringAndChars) and IsVarInit(Expr) then
- begin
- // const a: dynarray = string
- ComputeElement(ArrType.ElType,ElTypeResolved,[rcType]);
- if ElTypeResolved.BaseType in btAllChars then
- Result:=cExact;
- exit;
- end
- else
- begin
- // single value
- exit;
- end;
- end;
- IsLastRange:=true;
- end
- else
- begin
- // static array
- Range:=ArrType.Ranges[RangeIndex];
- Count:=GetRangeLength(Range);
- if Count=0 then
- begin
- ComputeElement(Range,RangeResolved,[rcConstant]);
- RaiseNotYetImplemented(20170222232409,Expr,'range '+GetResolverResultDbg(RangeResolved));
- end;
- IsLastRange:=RangeIndex+1=length(ArrType.Ranges);
- 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) then
- begin
- ArrayValues:=TArrayValues(Expr).Values;
- // check each value
- for i:=0 to Count-1 do
- begin
- if i=length(ArrayValues) then
- begin
- // not enough values
- if length(ArrayValues)>0 then
- ErrorEl:=ArrayValues[length(ArrayValues)-1];
- RaiseMsg(20170222233001,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(Count),IntToStr(length(ArrayValues))],ErrorEl);
- end;
- Value:=ArrayValues[i];
- ComputeElement(Value,ValueResolved,[rcConstant]);
- 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 Count<length(ArrayValues) then
- begin
- // too many values
- ErrorEl:=ArrayValues[Count];
- if RaiseOnIncompatible then
- RaiseMsg(20170222233605,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(Count),IntToStr(length(ArrayValues))],ErrorEl);
- exit;
- end;
- end
- else if Values.BaseType=btSet then
- begin
- if ErrorEl.Parent is TPasVariable then
- begin
- // common mistake: const requires () instead of []
- if RaiseOnIncompatible then
- RaiseMsg(20170913181208,nXExpectedButYFound,sXExpectedButYFound,
- ['(','['],ErrorEl);
- exit;
- end;
- Impl:=ErrorEl;
- while (Impl<>nil) and not (Impl is TPasImplBlock) do
- begin
- if Impl is TPasProcedure then
- begin
- Impl:=nil;
- break;
- end;
- Impl:=Impl.Parent;
- end;
- if Impl=nil then
- exit;
- // ToDo: btArrayLit: const array in implblock, e.g. arr:=[1,2,3]
- exit;
- 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(Count),'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,Count,ElTypeResolved,Expr,ErrorEl);
- exit;
- end;
- if (Count>1) then
- begin
- if RaiseOnIncompatible then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('CheckRange Values=',GetResolverResultDbg(Values),' ElTypeResolved=',GetResolverResultDbg(ElTypeResolved));
- {$ENDIF}
- RaiseMsg(20170913103143,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
- [IntToStr(Count),'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.TypeEl is TPasArrayType)) then
- RaiseInternalError(20170222230012);
- if not (rrfReadable in RHS.Flags) then
- exit;
- LArrType:=TPasArrayType(LHS.TypeEl);
- if RHS.ExprEl=nil then
- exit;
- if IsEmptySet(RHS) then
- begin
- if (length(LArrType.Ranges)=0) then
- exit(cExact); // empty set fits open and dyn array
- end;
- CheckRange(LArrType,0,RHS,ErrorEl);
- end;
- function TPasResolver.CheckConstArrayCompatibility(Params: TParamsExpr;
- const ArrayResolved: TPasResolverResult; RaiseOnError: boolean;
- Flags: TPasResolverComputeFlags; StartEl: TPasElement): integer;
- // check that each Param fits the array element type
- var
- i, ParamComp: Integer;
- Param: TPasExpr;
- ArrayType: TPasArrayType;
- ElTypeResolved, ParamResolved: TPasResolverResult;
- ElTypeIsArray: boolean;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckConstArrayCompatibility Params.length=',length(Params.Params),
- ' ArrayResolved=',GetResolverResultDbg(ArrayResolved),' Flags=',dbgs(Flags));
- {$ENDIF}
- if not (ArrayResolved.TypeEl is TPasArrayType) then
- RaiseInternalError(20170326204957);
- ArrayType:=TPasArrayType(ArrayResolved.TypeEl);
- ComputeElement(ArrayType.ElType,ElTypeResolved,Flags+[rcType]);
- ElTypeIsArray:=ResolveAliasType(ElTypeResolved.TypeEl) is TPasArrayType;
- Result:=cExact;
- for i:=0 to length(Params.Params)-1 do
- begin
- Param:=Params.Params[i];
- if ElTypeIsArray and (Param is TParamsExpr) and (TParamsExpr(Param).Kind=pekSet) then
- ParamComp:=CheckConstArrayCompatibility(TParamsExpr(Param),ElTypeResolved,
- RaiseOnError,Flags,StartEl)
- else
- begin
- ComputeElement(Param,ParamResolved,Flags,StartEl);
- ParamComp:=CheckAssignResCompatibility(ElTypeResolved,ParamResolved,Param,RaiseOnError);
- end;
- if ParamComp=cIncompatible then
- exit(cIncompatible);
- inc(Result,ParamComp);
- end;
- end;
- function TPasResolver.CheckEqualCompatibilityUserType(const TypeA,
- TypeB: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
- ): integer;
- var
- ElA, ElB: TPasType;
- AResolved, BResolved: TPasResolverResult;
- function IncompatibleElements: integer;
- begin
- Result:=cIncompatible;
- if not RaiseOnIncompatible then exit;
- RaiseIncompatibleType(20170216152513,nIncompatibleTypesGotExpected,
- [],ElA,ElB,ErrorEl);
- end;
- begin
- if (TypeA.TypeEl=nil) then
- RaiseInternalError(20161007223118);
- if (TypeB.TypeEl=nil) then
- RaiseInternalError(20161007223119);
- ElA:=TypeA.TypeEl;
- ElB:=TypeB.TypeEl;
- if ElA=ElB then
- exit(cExact);
- if ElA.ClassType=TPasClassType then
- begin
- if TypeA.IdentEl is TPasType then
- begin
- if (TypeB.IdentEl is TPasType) and (ElA=ElB) then
- // e.g. if TFPMemoryImage=TFPMemoryImage then ;
- exit(cExact);
- if ElB.ClassType=TPasClassOfType then
- begin
- // e.g. if TFPMemoryImage=ImageClass then ;
- Result:=CheckClassIsClass(ElA,TPasClassOfType(ElB).DestType,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152515,nTypesAreNotRelated,sTypesAreNotRelated,[],ErrorEl);
- exit;
- end;
- end
- else if ElB.ClassType=TPasClassType then
- begin
- // e.g. if Sender=Button1 then
- Result:=CheckSrcIsADstType(TypeA,TypeB,ErrorEl);
- if Result=cIncompatible then
- Result:=CheckSrcIsADstType(TypeB,TypeA,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152517,nTypesAreNotRelated,sTypesAreNotRelated,[],ErrorEl);
- exit;
- end;
- exit(IncompatibleElements);
- end
- else if ElA.ClassType=TPasClassOfType then
- begin
- if ElB.ClassType=TPasClassOfType then
- begin
- // for example: if ImageClass=ImageClass then
- Result:=CheckClassIsClass(TPasClassOfType(ElA).DestType,
- TPasClassOfType(ElB).DestType,ErrorEl);
- if Result=cIncompatible then
- Result:=CheckClassIsClass(TPasClassOfType(ElB).DestType,
- TPasClassOfType(ElA).DestType,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152519,nTypesAreNotRelated,sTypesAreNotRelated,[],ErrorEl);
- exit;
- end
- else if TypeB.IdentEl is TPasClassType then
- begin
- // for example: if ImageClass=TFPMemoryImage then
- Result:=CheckClassIsClass(TPasClassType(TypeB.IdentEl),
- TPasClassOfType(ElA).DestType,ErrorEl);
- if (Result=cIncompatible) and RaiseOnIncompatible then
- RaiseMsg(20170216152520,nTypesAreNotRelated,sTypesAreNotRelated,[],ErrorEl);
- exit;
- end;
- exit(IncompatibleElements);
- end
- else if ElA.ClassType=TPasEnumType then
- begin
- // enums of different type
- if not RaiseOnIncompatible then
- exit(cIncompatible);
- if ElB.ClassType=TPasEnumValue then
- RaiseIncompatibleType(20170216152523,nIncompatibleTypesGotExpected,
- [],TPasEnumType(ElA),TPasEnumType(ElB),ErrorEl)
- else
- exit(IncompatibleElements);
- end
- else if ElA.ClassType=TPasSetType then
- begin
- if ElB.ClassType=TPasSetType then
- begin
- ComputeElement(TPasSetType(ElA).EnumType,AResolved,[]);
- ComputeElement(TPasSetType(ElB).EnumType,BResolved,[]);
- if (AResolved.TypeEl<>nil)
- and (AResolved.TypeEl=BResolved.TypeEl) then
- exit(cExact);
- if (AResolved.TypeEl.CustomData is TResElDataBaseType)
- and (BResolved.TypeEl.CustomData is TResElDataBaseType)
- and (CompareText(AResolved.TypeEl.Name,BResolved.TypeEl.Name)=0) then
- exit(cExact);
- if RaiseOnIncompatible then
- RaiseIncompatibleTypeRes(20170216152524,nIncompatibleTypesGotExpected,
- [],AResolved,BResolved,ErrorEl)
- else
- exit(cIncompatible);
- end
- else
- exit(IncompatibleElements);
- end
- else if (ElA is TPasProcedureType) and (rrfReadable in TypeA.Flags) then
- begin
- if (ElB is TPasProcedureType) and (rrfReadable in TypeB.Flags) then
- begin
- // e.g. ProcVar1 = ProcVar2
- if CheckProcTypeCompatibility(TPasProcedureType(ElA),TPasProcedureType(ElB),
- false,nil,false) then
- exit(cExact);
- end
- else
- exit(IncompatibleElements);
- 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;
- var
- ToTypeEl, ToClassType, FromClassType, FromTypeEl: TPasType;
- ToTypeBaseType: TResolverBaseType;
- C: TClass;
- ToProcType, FromProcType: TPasProcedureType;
- begin
- Result:=cIncompatible;
- ToTypeEl:=ResolveAliasType(ToResolved.TypeEl);
- 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
- // base type cast, e.g. double(aninteger)
- if ToTypeEl=FromResolved.TypeEl then
- exit(cExact);
- 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]) then
- Result:=cCompatible
- else if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=ResolveAliasType(FromResolved.TypeEl);
- 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:=ResolveAliasType(FromResolved.TypeEl);
- 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;
- end
- else if ToTypeBaseType=btPointer then
- begin
- if FromResolved.BaseType=btPointer then
- Result:=cExact
- else if FromResolved.BaseType=btContext then
- begin
- FromTypeEl:=ResolveAliasType(FromResolved.TypeEl);
- 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,
- [FromProcType.ElementTypeName+' '+ProcTypeModifiers[ptmOfObject],
- BaseTypeNames[btPointer]],ErrorEl);
- end
- else if FromProcType.IsNested then
- begin
- if RaiseOnError then
- RaiseMsg(20170416183800,nIllegalTypeConversionTo,sIllegalTypeConversionTo,
- [FromProcType.ElementTypeName+' '+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,
- [FromProcType.ElementTypeName+' '+ProcTypeModifiers[ptmReferenceTo],
- BaseTypeNames[btPointer]],ErrorEl);
- end
- else
- Result:=cCompatible;
- end;
- end;
- end;
- end;
- end
- else if C=TPasClassType then
- begin
- // to class
- if FromResolved.BaseType=btContext then
- begin
- if FromResolved.TypeEl.ClassType=TPasClassType then
- begin
- if FromResolved.IdentEl is TPasType then
- RaiseMsg(20170404162606,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl);
- // type cast upwards or downwards
- Result:=CheckSrcIsADstType(FromResolved,ToResolved,ErrorEl);
- if Result=cIncompatible then
- Result:=CheckSrcIsADstType(ToResolved,FromResolved,ErrorEl);
- if Result=cIncompatible then
- Result:=CheckTypeCastClassInstanceToClass(FromResolved,ToResolved,ErrorEl);
- end
- end
- else if FromResolved.BaseType=btPointer then
- begin
- if IsBaseType(FromResolved.TypeEl,btPointer) then
- Result:=cExact; // untyped pointer to class instance
- end;
- end
- else if C=TPasClassOfType then
- begin
- //writeln('TPasResolver.CheckTypeCast class-of FromRes.TypeEl=',GetObjName(FromResolved.TypeEl),' FromRes.IdentEl=',GetObjName(FromResolved.IdentEl));
- if FromResolved.BaseType=btContext then
- begin
- if FromResolved.TypeEl.ClassType=TPasClassOfType then
- begin
- if (FromResolved.IdentEl is TPasType) then
- RaiseMsg(20170404162604,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl);
- // type cast classof(classof-var) upwards or downwards
- ToClassType:=TPasClassOfType(ToTypeEl).DestType;
- FromClassType:=TPasClassOfType(FromResolved.TypeEl).DestType;
- Result:=CheckClassesAreRelated(ToClassType,FromClassType,ErrorEl);
- end;
- end
- else if FromResolved.BaseType=btPointer then
- begin
- if IsBaseType(FromResolved.TypeEl,btPointer) then
- Result:=cExact; // untyped pointer to class-of
- end;
- end
- else if C=TPasRecordType then
- begin
- if FromResolved.BaseType=btContext then
- begin
- if FromResolved.TypeEl.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.TypeEl.ClassType=TPasArrayType then
- Result:=CheckTypeCastArray(TPasArrayType(FromResolved.TypeEl),
- TPasArrayType(ToTypeEl),ErrorEl,RaiseOnError);
- end
- else if FromResolved.BaseType=btPointer then
- begin
- if IsDynArray(ToResolved.TypeEl)
- and IsBaseType(FromResolved.TypeEl,btPointer) then
- Result:=cExact; // untyped pointer to dynnamic array
- end;
- end
- else if (C=TPasProcedureType) or (C=TPasFunctionType) then
- begin
- ToProcType:=TPasProcedureType(ToTypeEl);
- if IsBaseType(FromResolved.TypeEl,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
- if FromResolved.TypeEl is TPasProcedureType then
- begin
- // type cast procvar to proctype
- FromProcType:=TPasProcedureType(FromResolved.TypeEl);
- 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,
- [FromProcType.ElementTypeName+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,
- [FromProcType.ElementTypeName+BoolToStr(FromProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],''),
- ToProcType.ElementTypeName+BoolToStr(ToProcType.IsNested,' '+ProcTypeModifiers[ptmIsNested],'')],ErrorEl);
- end
- else
- Result:=cCompatible;
- end;
- end;
- end;
- end
- else if ToTypeEl<>nil then
- begin
- // FromResolved is not readable
- if FromResolved.BaseType=btContext then
- begin
- if (FromResolved.TypeEl.ClassType=TPasClassType)
- and (FromResolved.TypeEl=FromResolved.IdentEl)
- and (ToResolved.BaseType=btContext)
- and (ToResolved.TypeEl.ClassType=TPasClassOfType)
- and (ToResolved.TypeEl=ToResolved.IdentEl) then
- begin
- // for example class-of(Self) in a class function
- ToClassType:=TPasClassOfType(ToTypeEl).DestType;
- FromClassType:=TPasClassType(FromResolved.TypeEl);
- Result:=CheckClassesAreRelated(ToClassType,FromClassType,ErrorEl);
- 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(ArrType.ElType,ElTypeResolved,[rcType]);
- if (ElTypeResolved.BaseType<>btContext)
- or (ElTypeResolved.TypeEl.ClassType<>TPasArrayType) then
- exit(false);
- ArrType:=TPasArrayType(ElTypeResolved.TypeEl);
- 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}
- 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
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckTypeCastArray check ElType From=',GetResolverResultDbg(FromElTypeRes),' To=',GetResolverResultDbg(ToElTypeRes));
- {$ENDIF}
- Include(FromElTypeRes.Flags,rrfReadable);
- 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;
- aClass: TPasClassType;
- begin
- Ref:=TResolvedReference(Expr.CustomData);
- ComputeElement(Ref.Declaration,ResolvedEl,Flags+[rcNoImplicitProc],StartEl);
- if rrfConstInherited in Ref.Flags then
- Exclude(ResolvedEl.Flags,rrfWritable);
- {$IFDEF VerbosePasResolver}
- 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));
- {$ENDIF}
- if (ResolvedEl.BaseType=btProc) then
- begin
- // proc
- if [rcNoImplicitProc,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
- ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,
- ResolvedEl,Flags+[rcType],StartEl);
- Exclude(ResolvedEl.Flags,rrfWritable);
- end
- else if (ResolvedEl.IdentEl.ClassType=TPasConstructor)
- and (rrfNewInstance in Ref.Flags) then
- begin
- // new instance constructor -> return value of type class
- aClass:=GetReference_NewInstanceClass(Ref);
- SetResolverValueExpr(ResolvedEl,btContext,aClass,TPrimitiveExpr(Expr),[rrfReadable]);
- end
- else if ParentNeedsExprResult(Expr) then
- begin
- // a procedure
- exit;
- end;
- if rcSetReferenceFlags in Flags then
- Include(Ref.Flags,rrfImplicitCallWithoutParams);
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end;
- end;
- end
- else if IsProcedureType(ResolvedEl,true) then
- begin
- // proc type
- if [rcNoImplicitProc,rcNoImplicitProcType,rcConstant,rcType]*Flags=[] then
- begin
- // implicit call without params is allowed -> check if possible
- ProcType:=TPasProcedureType(ResolvedEl.TypeEl);
- if not ProcNeedsParams(ProcType) then
- begin
- // parameter less proc type -> implicit call possible
- if ResolvedEl.TypeEl is TPasFunctionType then
- // function => return result
- ComputeElement(TPasFunctionType(ResolvedEl.TypeEl).ResultEl,
- ResolvedEl,Flags+[rcType],StartEl)
- else if ParentNeedsExprResult(Expr) then
- begin
- // a procedure has no result
- exit;
- end;
- if rcSetReferenceFlags in Flags then
- Include(Ref.Flags,rrfImplicitCallWithoutParams);
- Include(ResolvedEl.Flags,rrfCanBeStatement);
- end;
- end;
- end;
- end;
- var
- DeclEl: TPasElement;
- ElClass: TClass;
- bt: TResolverBaseType;
- begin
- if StartEl=nil then StartEl:=El;
- ResolvedEl:=Default(TPasResolverResult);
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.ComputeElement El=',GetObjName(El),' SkipTypeAlias=',rcSkipTypeAlias in Flags);
- {$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:
- if Pos('.',TPrimitiveExpr(El).Value)>0 then
- SetResolverValueExpr(ResolvedEl,BaseTypeExtended,FBaseTypes[BaseTypeExtended],
- TPrimitiveExpr(El),[rrfReadable])
- else
- SetResolverValueExpr(ResolvedEl,btLongint,FBaseTypes[btLongint],TPrimitiveExpr(El),[rrfReadable]);
- 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],TPrimitiveExpr(El),[rrfReadable]);
- end
- else
- SetResolverValueExpr(ResolvedEl,btString,FBaseTypes[btString],TPrimitiveExpr(El),[rrfReadable]);
- end;
- pekNil:
- SetResolverValueExpr(ResolvedEl,btNil,FBaseTypes[btNil],TPrimitiveExpr(El),[rrfReadable]);
- pekBoolConst:
- SetResolverValueExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],TPrimitiveExpr(El),[rrfReadable]);
- else
- RaiseNotYetImplemented(20160922163701,El);
- end;
- end
- else if ElClass=TSelfExpr then
- begin
- // self is just an identifier
- if not (El.CustomData is TResolvedReference) then
- RaiseNotYetImplemented(20170216150017,El,' El="'+GetObjName(El)+'" CustomData='+GetObjName(El.CustomData)+' '+GetElementSourcePosStr(El));
- ComputeIdentifier(TSelfExpr(El));
- 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),[])
- else if El.CustomData is TResElDataBuiltInProc then
- begin
- SetResolverIdentifier(ResolvedEl,btBuiltInProc,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],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
- RaiseMsg(20170216152532,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El);
- eopNot:
- if ResolvedEl.BaseType in (btAllInteger+btAllBooleans) then
- exit
- else
- RaiseMsg(20170216152534,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El);
- eopAddress:
- if (ResolvedEl.BaseType=btProc) and (ResolvedEl.IdentEl is TPasProcedure) then
- begin
- SetResolverValueExpr(ResolvedEl,btContext,ResolvedEl.TypeEl,TUnaryExpr(El).Operand,[rrfReadable]);
- exit;
- end
- else
- RaiseMsg(20170216152535,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El);
- eopMemAddress:
- begin
- if (ResolvedEl.BaseType=btContext) and (ResolvedEl.TypeEl is TPasProcedureType) then
- exit
- else
- RaiseMsg(20170902145547,nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El);
- end;
- end;
- RaiseNotYetImplemented(20160926142426,El);
- end
- else if ElClass=TParamsExpr then
- case TParamsExpr(El).Kind of
- pekArrayParams:
- ComputeArrayParams(TParamsExpr(El),ResolvedEl,Flags,StartEl);
- pekFuncParams:
- 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
- begin
- // "inherited;"
- DeclEl:=NoNil(TResolvedReference(El.CustomData).Declaration) as TPasProcedure;
- SetResolverIdentifier(ResolvedEl,btProc,DeclEl,
- TPasProcedure(DeclEl).ProcType,[rrfCanBeStatement]);
- end
- else
- // no ancestor proc
- SetResolverIdentifier(ResolvedEl,btBuiltInProc,nil,nil,[rrfCanBeStatement]);
- end
- else if ElClass=TPasAliasType then
- begin
- // e.g. 'type a = b' -> compute b
- ComputeElement(TPasAliasType(El).DestType,ResolvedEl,Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- end
- else if (ElClass=TPasTypeAliasType) then
- begin
- // e.g. 'type a = type b;' -> compute b
- ComputeElement(TPasTypeAliasType(El).DestType,ResolvedEl,Flags+[rcType],StartEl);
- if not (rcSkipTypeAlias in Flags) then
- ResolvedEl.IdentEl:=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 -> just like a var
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152739,StartEl);
- ComputeElement(TPasConst(El).VarType,ResolvedEl,Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- 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
- SetResolverIdentifier(ResolvedEl,btContext,El,NoNil(El.Parent) as TPasEnumType,[rrfReadable])
- else if (ElClass=TPasEnumType) then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasEnumType(El),[])
- else if (ElClass=TPasProperty) then
- begin
- if rcConstant in Flags then
- RaiseConstantExprExp(20170216152741,StartEl);
- if TPasProperty(El).Args.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
- // index property
- SetResolverIdentifier(ResolvedEl,btContext,El,nil,[]);
- 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,[])
- 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;
- ResolvedEl.TypeEl:=NoNil(DeclEl) as TPasClassType;
- end
- else
- ResolvedEl.TypeEl:=TPasClassType(El);
- SetResolverIdentifier(ResolvedEl,btContext,
- ResolvedEl.TypeEl,ResolvedEl.TypeEl,[]);
- end
- else if ElClass=TPasClassOfType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasClassOfType(El),[])
- else if ElClass=TPasRecordType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasRecordType(El),[])
- else if ElClass=TPasRangeType then
- begin
- ComputeElement(TPasRangeType(El).RangeExpr,ResolvedEl,[rcConstant],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.TypeEl:=TPasRangeType(El);
- 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.TypeEl:=TPasSetType(El).EnumType;
- 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);
- ComputeElement(TPasResultElement(El).ResultType,ResolvedEl,Flags+[rcType],StartEl);
- ResolvedEl.IdentEl:=El;
- ResolvedEl.Flags:=[rrfReadable,rrfWritable];
- end
- else if ElClass=TPasUsesUnit then
- begin
- if TPasUsesUnit(El).Module is TPasModule then
- SetResolverIdentifier(ResolvedEl,btModule,TPasUsesUnit(El).Module,nil,[])
- else
- RaiseNotYetImplemented(20170429112047,TPasUsesUnit(El).Module);
- end
- else if El.InheritsFrom(TPasModule) then
- SetResolverIdentifier(ResolvedEl,btModule,El,nil,[])
- else if ElClass=TNilExpr then
- SetResolverValueExpr(ResolvedEl,btNil,FBaseTypes[btNil],TNilExpr(El),[rrfReadable])
- else if El.InheritsFrom(TPasProcedure) then
- begin
- SetResolverIdentifier(ResolvedEl,btProc,El,TPasProcedure(El).ProcType,[rrfCanBeStatement]);
- if El is TPasFunction then
- Include(ResolvedEl.Flags,rrfReadable);
- // Note: the readability of TPasConstructor depends on the context
- // Note: implicit calls are handled in TPrimitiveExpr
- end
- else if El.InheritsFrom(TPasProcedureType) then
- begin
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasProcedureType(El),[rrfCanBeStatement]);
- // Note: implicit calls are handled in TPrimitiveExpr
- end
- else if ElClass=TPasArrayType then
- SetResolverIdentifier(ResolvedEl,btContext,El,TPasArrayType(El),[])
- else if ElClass=TArrayValues then
- SetResolverValueExpr(ResolvedEl,btSet,nil,TArrayValues(El),[rrfReadable])
- else if ElClass=TPasStringType then
- begin
- SetResolverTypeExpr(ResolvedEl,btShortString,BaseTypes[btShortString],[rrfReadable]);
- if BaseTypes[btShortString]=nil then
- RaiseMsg(20170419203146,nIllegalQualifier,sIllegalQualifier,['['],El);
- end
- else if ElClass=TPasResString then
- SetResolverIdentifier(ResolvedEl,btString,El,nil,[rrfReadable])
- else
- RaiseNotYetImplemented(20160922163705,El);
- 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)) 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: boolean
- ): boolean;
- begin
- if (TypeA=nil) or (TypeB=nil) then exit(false);
- if ResolveAlias then
- begin
- TypeA:=ResolveAliasType(TypeA);
- TypeB:=ResolveAliasType(TypeB);
- end;
- if TypeA=TypeB then exit(true);
- if (TypeA.ClassType=TPasUnresolvedSymbolRef)
- and (TypeB.ClassType=TPasUnresolvedSymbolRef) then
- begin
- Result:=CompareText(TypeA.Name,TypeB.Name)=0;
- exit;
- end;
- Result:=false;
- 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.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): TPasType;
- var
- C: TClass;
- begin
- Result:=aType;
- while Result<>nil do
- begin
- C:=Result.ClassType;
- if (C=TPasAliasType) or (C=TPasTypeAliasType) then
- Result:=TPasAliasType(Result).DestType
- else if (C=TPasClassType) and TPasClassType(Result).IsForward
- and (Result.CustomData is TResolvedReference) then
- Result:=NoNil(TResolvedReference(Result.CustomData).Declaration) as TPasType
- else
- exit;
- end;
- 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;
- }
- var
- Parent: TPasElement;
- Prop: TPasProperty;
- 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));
- if Parent.ClassType=TUnaryExpr then
- begin
- if TUnaryExpr(Parent).OpCode=eopAddress then exit(true);
- end
- else if Parent.ClassType=TBinaryExpr then
- begin
- if TBinaryExpr(Parent).right<>El then exit;
- if TBinaryExpr(Parent).OpCode<>eopSubIdent then exit;
- end
- else if Parent.ClassType=TParamsExpr then
- begin
- if TParamsExpr(Parent).Value<>El then exit;
- end
- else if Parent.ClassType=TPasProperty then
- begin
- Prop:=TPasProperty(Parent);
- Result:=(Prop.ReadAccessor=El) or (Prop.WriteAccessor=El) or (Prop.StoredAccessor=El);
- exit;
- end
- else if Parent.ClassType=TPasImplAssign then
- begin
- if TPasImplAssign(Parent).right<>El then exit;
- if (msDelphi in CurrentParser.CurrentModeswitches) then exit(true);
- exit;
- end
- 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.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_NewInstanceClass(Ref: TResolvedReference
- ): TPasClassType;
- begin
- Result:=(Ref.Context as TResolvedRefCtxConstructor).Typ as TPasClassType;
- end;
- function TPasResolver.IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean
- ): boolean;
- begin
- TypeEl:=ResolveAliasType(TypeEl);
- if (TypeEl=nil) or (TypeEl.ClassType<>TPasArrayType)
- or (length(TPasArrayType(TypeEl).Ranges)<>0) then
- exit(false);
- 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.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.IsEmptySet(const ResolvedEl: TPasResolverResult): boolean;
- begin
- Result:=(ResolvedEl.BaseType=btSet) 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.IsExternalClassName(aClass: TPasClassType;
- const ExtName: string): boolean;
- var
- AncestorScope: TPasClassScope;
- begin
- Result:=false;
- if aClass=nil then exit;
- while (aClass<>nil) and aClass.IsExternal 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;
- begin
- if (ResolvedEl.BaseType<>btContext) or not (ResolvedEl.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.TypeEl is TPasArrayType);
- 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) then
- exit(true)
- else if (C=TPasUnresolvedSymbolRef)
- and (Decl.CustomData is TResElDataBaseType) then
- exit(true);
- end;
- function TPasResolver.ProcNeedsParams(El: TPasProcedureType): boolean;
- begin
- Result:=(El.Args.Count>0) and (TPasArgument(El.Args[0]).ValueExpr=nil);
- 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.GetRangeLength(RangeExpr: TPasExpr): MaxPrecInt;
- var
- Range: TResEvalValue;
- begin
- Result:=0;
- Range:=Eval(RangeExpr,[refConst]);
- if Range=nil then
- RaiseNotYetImplemented(20170910210416,RangeExpr);
- 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;
- {$IFDEF VerbosePasResolver}
- //if Result=0 then
- writeln('TPasResolver.GetRangeLength Result=',Result);
- {$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:
- if EvalLow then
- Result:=TResEvalString.CreateValue(chr(TResEvalRangeInt(Range).RangeStart))
- else if TResEvalRangeInt(Range).RangeEnd<256 then
- Result:=TResEvalString.CreateValue(chr(TResEvalRangeInt(Range).RangeEnd))
- else
- Result:=TResEvalUTF16.CreateValue(widechar(TResEvalRangeInt(Range).RangeEnd));
- revskBool:
- if EvalLow then
- Result:=TResEvalBool.CreateValue(TResEvalRangeInt(Range).RangeStart<>0)
- else
- Result:=TResEvalBool.CreateValue(TResEvalRangeInt(Range).RangeEnd<>0);
- else
- RaiseNotYetImplemented(20170601195240,ErrorEl);
- end;
- revkRangeUInt:
- if EvalLow then
- Result:=TResEvalUInt.CreateValue(TResEvalRangeUInt(Range).RangeStart)
- else
- Result:=TResEvalUInt.CreateValue(TResEvalRangeUInt(Range).RangeEnd);
- else
- RaiseNotYetImplemented(20170601195336,ErrorEl);
- end;
- 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,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;
- if BaseTypeChar in [btChar,btAnsiChar] then
- TResEvalRangeInt(Result).RangeEnd:=$ff
- else
- TResEvalRangeInt(Result).RangeEnd:=$ffff;
- end;
- btAnsiChar:
- Result:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff);
- btWideChar:
- Result:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ffff);
- btBoolean,btByteBool,btWordBool,btQWordBool:
- Result:=TResEvalRangeInt.CreateValue(revskBool,nil,0,1);
- btByte,
- btShortInt,
- btWord,
- btSmallInt,
- btLongWord,
- btLongint,
- btInt64,
- btComp,
- btIntSingle,
- btUIntSingle,
- btIntDouble,
- btUIntDouble:
- begin
- Result:=TResEvalRangeInt.Create;
- TResEvalRangeInt(Result).ElKind:=revskInt;
- GetIntegerRange(BaseTypeData.BaseType,
- TResEvalRangeInt(Result).RangeStart,TResEvalRangeInt(Result).RangeEnd);
- exit;
- 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) and not HasTypeInfo(TPasType(El.Parent)) 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;
- btQWordBool: if not (Bool2 in [btBoolean,btByteBool,btWordBool,btLongBool]) then Result:=Bool2;
- 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;
- btQWord: begin Precision:=64; Signed:=false; end;
- btInt64,btComp: begin Precision:=64; Signed:=true; end;
- else
- RaiseInternalError(20170420095727);
- end;
- end;
- function TPasResolver.GetIntegerRange(bt: TResolverBaseType; out MinVal,
- MaxVal: MaxPrecInt): 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;
- btInt64,btComp: begin MinVal:=low(int64); MaxVal:=high(int64); end;
- 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);
- if Precision<=64 then
- begin
- if Signed then
- Result:=btInt64
- else
- Result:=btQWord;
- if BaseTypes[Result]<>nil then exit;
- end;
- RaiseRangeCheck(20170420100336,ErrorEl);
- end;
- function TPasResolver.GetSmallestIntegerBaseType(MinVal, MaxVal: MaxPrecInt
- ): TResolverBaseType;
- var
- V: MaxPrecInt;
- 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
- Result:=btInt64;
- 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
- Result:=btInt64;
- 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
- btChar,btAnsiChar:
- case bt2 of
- btChar: Result:=btChar;
- btWideChar: Result:=btWideChar;
- else Result:=bt2;
- end;
- btWideChar:
- case bt2 of
- btAnsiChar: Result:=btWideChar;
- btWideString: Result:=btWideString;
- btString,btShortString,btAnsiString,btRawByteString,btUnicodeString: Result:=btUnicodeString;
- else RaiseNotYetImplemented(20170420103808,ErrorEl);
- end;
- 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;
- btString,btAnsiString:
- case bt2 of
- btChar,btAnsiChar,btString,btShortString,btRawByteString: Result:=btAnsiString;
- btWideChar,btUnicodeString: Result:=btUnicodeString;
- btWideString: Result:=btWideString;
- else RaiseNotYetImplemented(20170420121201,ErrorEl);
- end;
- 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;
- btWideString:
- case bt2 of
- btChar,btAnsiChar,btWideChar,btShortString,btWideString: Result:=btWideString;
- btString,btAnsiString,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.IsElementSkipped(El: TPasElement): boolean;
- var
- C: TClass;
- aClass: TPasClassType;
- begin
- while El<>nil do
- begin
- C:=El.ClassType;
- if C.ClassType=TPasClassType then
- begin
- aClass:=TPasClassType(El);
- if aClass.ObjKind=okInterface then
- exit(true);
- end;
- El:=El.Parent;
- end;
- Result:=false;
- end;
- function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType,
- ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer;
- // finds distance between classes SrcType and DestType
- begin
- Result:=CheckClassIsClass(ResolvedSrcType.TypeEl,ResolvedDestType.TypeEl,ErrorEl);
- end;
- function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType;
- ErrorEl: TPasElement): integer;
- // check if Src is equal or descends from Dest
- var
- ClassEl: TPasClassType;
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TPasResolver.CheckClassIsClass SrcType=',GetObjName(SrcType),' DestType=',GetObjName(DestType));
- {$ENDIF}
- if DestType=nil then exit(cIncompatible);
- DestType:=ResolveAliasType(DestType);
- 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 -> increases distance
- SrcType:=TPasAliasType(SrcType).DestType;
- inc(Result);
- end
- else if SrcType.ClassType=TPasClassType then
- begin
- ClassEl:=TPasClassType(SrcType);
- if ClassEl.IsForward then
- // class forward -> skip
- SrcType:=(ClassEl.CustomData as TResolvedReference).Declaration as TPasType
- else
- begin
- // class ancestor -> increase distance
- SrcType:=(ClassEl.CustomData as TPasClassScope).DirectAncestor;
- inc(Result);
- end;
- end
- else
- exit(cIncompatible);
- end;
- if ErrorEl=nil then ;
- Result:=cIncompatible;
- end;
- function TPasResolver.CheckClassesAreRelated(TypeA, TypeB: TPasType;
- ErrorEl: TPasElement): integer;
- begin
- Result:=CheckClassIsClass(TypeA,TypeB,ErrorEl);
- if Result<>cIncompatible then exit;
- Result:=CheckClassIsClass(TypeB,TypeA,ErrorEl);
- end;
- end.
|