1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349 |
- {
- This file is part of the Free Component Library
- Pascal source parser
- Copyright (c) 2017 by Mattias Gaertner, [email protected]
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************
- Abstract:
- Evaluation of Pascal constants.
- Works:
- - Emitting range check warnings
- - Error on overflow
- - bool:
- - not, =, <>, and, or, xor, low(), high(), pred(), succ(), ord()
- - boolean(0), boolean(1)
- - int/uint
- - unary +, -
- - binary: +, -, *, div, mod, ^^, =, <>, <, >, <=, >=, and, or, xor, not, shl, shr
- - Low(), High(), Pred(), Succ(), Ord(), Lo(), Hi()
- - typecast longint(-1), word(-2), intsingle(-1), uintsingle(1)
- - float:
- - typecast single(double), double(single), float(integer)
- - +, -, /, *, =, <>, <, >, <=, >=
- - string:
- - #65, '', 'a', 'ab'
- - +, =, <>, <, >, <=, >=
- - pred(), succ(), chr(), ord(), low(char), high(char)
- - s[]
- - length(string)
- - #$DC00
- - unicodestring
- - enum
- - ord(), low(), high(), pred(), succ()
- - typecast enumtype(integer)
- - set of enum, set of char, set of bool, set of int
- - [a,b,c..d]
- - +, -, *, ><, =, <>, >=, <=, in
- - error on duplicate in const set
- - arrays
- - length()
- - array of int, charm enum, bool
- ToDo:
- - arrays
- - [], [a..b], multi dim [a,b], concat with +
- - array of record
- - array of string
- - error on: array[1..2] of longint = (1,2,3);
- - anonymous enum range: type f=(a,b,c,d); g=b..c;
- }
- unit PasResolveEval;
- {$mode objfpc}{$H+}
- {$ifdef fpc}
- {$define UsePChar}
- {$endif}
- {$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
- {$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
- interface
- uses
- Sysutils, Classes, Math, PasTree, PScanner;
- // message numbers
- const
- nIdentifierNotFound = 3001;
- nNotYetImplemented = 3002;
- nIllegalQualifier = 3003;
- nSyntaxErrorExpectedButFound = 3004;
- nWrongNumberOfParametersForCallTo = 3005;
- nIncompatibleTypeArgNo = 3006;
- nIncompatibleTypeArgNoVarParamMustMatchExactly = 3007;
- nVariableIdentifierExpected = 3008;
- nDuplicateIdentifier = 3009;
- nXExpectedButYFound = 3010;
- nAncestorCycleDetected = 3011;
- nCantUseForwardDeclarationAsAncestor = 3012;
- nCantDetermineWhichOverloadedFunctionToCall = 3013;
- nForwardTypeNotResolved = 3014;
- nForwardProcNotResolved = 3015;
- nInvalidXModifierY = 3016;
- nAbstractMethodsMustNotHaveImplementation = 3017;
- nCallingConventionMismatch = 3018;
- nResultTypeMismatchExpectedButFound = 3019;
- nFunctionHeaderMismatchForwardVarName = 3020;
- nFunctionHidesIdentifier_NonVirtualMethod = 3021;
- nNoMethodInAncestorToOverride = 3022;
- nInheritedOnlyWorksInMethods = 3023;
- nInheritedNeedsAncestor = 3024;
- nNoPropertyFoundToOverride = 3025;
- nExprTypeMustBeClassOrRecordTypeGot = 3026;
- nPropertyNotWritable = 3027;
- nIncompatibleTypesGotExpected = 3028;
- nTypesAreNotRelatedXY = 3029;
- nAbstractMethodsCannotBeCalledDirectly = 3030;
- nMissingParameterX = 3031;
- nInstanceMemberXInaccessible = 3032;
- nInOperatorExpectsSetElementButGot = 3033;
- nWrongNumberOfParametersForTypeCast = 3034;
- nIllegalTypeConversionTo = 3035;
- nConstantExpressionExpected = 3036;
- nLeftSideOfIsOperatorExpectsAClassButGot = 3037;
- nNotReadable = 3038;
- nClassPropertyAccessorMustBeStatic = 3039;
- nClassPropertyAccessorMustNotBeStatic = 3040;
- nOnlyOneDefaultPropertyIsAllowed = 3041;
- nWrongNumberOfParametersForArray = 3042;
- nCantAssignValuesToAnAddress = 3043;
- nIllegalExpression = 3044;
- nCantAccessXMember = 3045;
- nMustBeInsideALoop = 3046;
- nExpectXArrayElementsButFoundY = 3047;
- nCannotCreateADescendantOfTheSealedXY = 3048;
- nAncestorIsNotExternal = 3049;
- nPropertyMustHaveReadOrWrite = 3050;
- nExternalClassInstanceCannotAccessStaticX = 3051;
- nXModifierMismatchY = 3052;
- nSymbolCannotBePublished = 3053;
- nCannotTypecastAType = 3054;
- nTypeIdentifierExpected = 3055;
- nCannotNestAnonymousX = 3056;
- nFoundCallCandidateX = 3057;
- nTextAfterFinalIgnored = 3058;
- nNoMemberIsProvidedToAccessProperty = 3059;
- nTheUseOfXisNotAllowedInARecord = 3060;
- nParameterlessConstructorsNotAllowedInRecords = 3061;
- nMultipleXinTypeYNameZCAandB = 3062;
- nXCannotHaveParameters = 3063;
- nRangeCheckError = 3064;
- nHighRangeLimitLTLowRangeLimit = 3065;
- nRangeCheckEvaluatingConstantsVMinMax = 3066;
- nIllegalChar = 3067;
- nOverflowInArithmeticOperation = 3068;
- nDivByZero = 3069;
- nRangeCheckInSetConstructor = 3070;
- nIncompatibleTypesGotParametersExpected = 3071;
- nAddingIndexSpecifierRequiresNewX = 3072;
- nCantFindUnitX = 3073;
- nCannotFindEnumeratorForType = 3074;
- nPreviousDeclMissesOverload = 3075;
- nOverloadedProcMissesOverload = 3076;
- nMethodHidesMethodOfBaseType = 3077;
- nContextExpectedXButFoundY = 3078;
- nContextXInvalidY = 3079;
- nIdentifierXIsNotAnInstanceField = 3080;
- nXIsNotSupported = 3081;
- nOperatorIsNotOverloadedAOpB = 3082;
- nIllegalQualifierAfter = 3084;
- nIllegalQualifierInFrontOf = 3085;
- nIllegalQualifierWithin = 3086;
- nClassXNotFoundInThisModule = 3087;
- nClassMethodsMustBeStaticInX = 3088;
- nCannotMixMethodResolutionAndDelegationAtX = 3089;
- nImplementsDoesNotSupportArrayProperty = 3101;
- nImplementsDoesNotSupportIndex = 3102;
- nImplementsUsedOnUnimplIntf = 3103;
- nDuplicateImplementsForIntf = 3103;
- nImplPropMustHaveReadSpec = 3104;
- nDoesNotImplementInterface = 3105;
- nTypeCycleFound = 3106;
- nTypeXIsNotYetCompletelyDefined = 3107;
- nDuplicateCaseValueXatY = 3108;
- nMissingFieldsX = 3109;
- nCantAssignValuesToConstVariable = 3110;
- nIllegalAssignmentToForLoopVar = 3111;
- nFunctionHidesIdentifier_NonProc = 3112;
- nTypeXCannotBeExtendedByATypeHelper = 3113;
- nTypeXCannotBeExtendedByARecordHelper = 3114;
- nDerivedXMustExtendASubClassY = 3115;
- nDefaultPropertyNotAllowedInHelperForX = 3116;
- nHelpersCannotBeUsedAsTypes = 3117;
- nMessageHandlersInvalidParams = 3118;
- nImplictConversionUnicodeToAnsi = 3119;
- nWrongTypeXInArrayConstructor = 3120;
- nUnknownCustomAttributeX = 3121;
- nAttributeIgnoredBecauseAbstractX = 3122;
- nCreatingAnInstanceOfAbstractClassY = 3123;
- nIllegalExpressionAfterX = 3124;
- nMethodHidesNonVirtualMethodExactly = 3125;
- nDuplicatePublishedMethodXAtY = 3126;
- nConstraintXSpecifiedMoreThanOnce = 3127;
- nConstraintXAndConstraintYCannotBeTogether = 3128;
- nXIsNotAValidConstraint = 3129;
- nWrongNumberOfParametersForGenericX = 3130;
- nGenericsWithoutSpecializationAsType = 3131;
- nDeclOfXDiffersFromPrevAtY = 3132;
- nTypeParamXIsMissingConstraintY = 3133;
- nTypeParamXIsNotCompatibleWithY = 3134;
- nTypeParamXMustSupportIntfY = 3135;
- nTypeParamsNotAllowedOnX = 3136;
- nXMethodsCannotHaveTypeParams = 3137;
- nImplMustNotRepeatConstraints = 3138;
- nCouldNotInferTypeArgXForMethodY = 3139;
- nInferredTypeXFromDiffArgsMismatchFromMethodY = 3140;
- nParamOfThisTypeCannotHaveDefVal = 3141;
- nClassTypesAreNotRelatedXY = 3142;
- nDirectiveXNotAllowedHere = 3143;
- nAwaitWithoutPromise = 3144;
- nSymbolCannotExportedFromALibrary = 3145;
- // using same IDs as FPC
- nVirtualMethodXHasLowerVisibility = 3250; // was 3050
- nConstructingClassXWithAbstractMethodY = 4046; // was 3080
- nNoMatchingImplForIntfMethodXFound = 5042; // was 3088
- nSymbolXIsDeprecated = 5043; // was 3062
- nSymbolXBelongsToALibrary = 5065; // was 3061
- nSymbolXIsDeprecatedY = 5066; // 3063
- nSymbolXIsNotPortable = 5076; // was 3058
- nSymbolXIsNotImplemented = 5078; // was 3060
- nSymbolXIsExperimental = 5079; // was 3059
- // resourcestring patterns of messages
- resourcestring
- sIdentifierNotFound = 'identifier not found "%s"';
- sNotYetImplemented = 'not yet implemented: %s';
- sIllegalQualifier = 'illegal qualifier "%s"';
- sSyntaxErrorExpectedButFound = 'Syntax error, "%s" expected but "%s" found';
- sWrongNumberOfParametersForCallTo = 'Wrong number of parameters specified for call to "%s"';
- sIncompatibleTypeArgNo = 'Incompatible type arg no. %s: Got "%s", expected "%s"';
- sIncompatibleTypeArgNoVarParamMustMatchExactly = 'Incompatible type arg no. %s: Got "%s", expected "%s". Var param must match exactly.';
- sVariableIdentifierExpected = 'Variable identifier expected';
- sDuplicateIdentifier = 'Duplicate identifier "%s" at %s';
- sXExpectedButYFound = '%s expected, but %s found';
- sAncestorCycleDetected = 'Ancestor cycle detected';
- sCantUseForwardDeclarationAsAncestor = 'Can''t use forward declaration "%s" as ancestor';
- sCantDetermineWhichOverloadedFunctionToCall = 'Can''t determine which overloaded function to call';
- sForwardTypeNotResolved = 'Forward type not resolved "%s"';
- sForwardProcNotResolved = 'Forward %s not resolved "%s"';
- sInvalidXModifierY = 'Invalid %s modifier %s';
- sAbstractMethodsMustNotHaveImplementation = 'Abstract method must not have an implementation.';
- sCallingConventionMismatch = 'Calling convention mismatch';
- sResultTypeMismatchExpectedButFound = 'Result type mismatch, expected %s, but found %s';
- sFunctionHeaderMismatchForwardVarName = 'function header "%s" doesn''t match forward : var name changes %s => %s';
- sFunctionHidesIdentifier = 'function hides identifier at "%s". Use overload or reintroduce';
- sNoMethodInAncestorToOverride = 'There is no method in an ancestor class to be overridden "%s"';
- sInheritedOnlyWorksInMethods = 'Inherited works only in methods';
- sInheritedNeedsAncestor = 'inherited needs an ancestor';
- sNoPropertyFoundToOverride = 'No property found to override';
- sExprTypeMustBeClassOrRecordTypeGot = 'Expression type must be class or record type, got %s';
- sPropertyNotWritable = 'No member is provided to access property';
- sIncompatibleTypesGotExpected = 'Incompatible types: got "%s" expected "%s"';
- sTypesAreNotRelatedXY = 'Types are not related: "%s" and "%s"';
- sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly';
- sMissingParameterX = 'Missing parameter %s';
- sInstanceMemberXInaccessible = 'Instance member "%s" inaccessible here';
- sInOperatorExpectsSetElementButGot = 'the in-operator expects a set element, but got %s';
- sWrongNumberOfParametersForTypeCast = 'wrong number of parameters for type cast to %s';
- sIllegalTypeConversionTo = 'Illegal type conversion: "%s" to "%s"';
- sConstantExpressionExpected = 'Constant expression expected';
- sLeftSideOfIsOperatorExpectsAClassButGot = 'left side of is-operator expects a class, but got "%s"';
- sNotReadable = 'not readable';
- sClassPropertyAccessorMustBeStatic = 'class property accessor must be static';
- sClassPropertyAccessorMustNotBeStatic = 'class property accessor must not be static';
- sOnlyOneDefaultPropertyIsAllowed = 'Only one default property is allowed';
- sWrongNumberOfParametersForArray = 'Wrong number of parameters for array';
- sCantAssignValuesToAnAddress = 'Can''t assign values to an address';
- sIllegalExpression = 'Illegal expression';
- sCantAccessXMember = 'Can''t access %s member %s';
- sMustBeInsideALoop = '%s must be inside a loop';
- sExpectXArrayElementsButFoundY = 'Expect %s array elements, but found %s';
- sCannotCreateADescendantOfTheSealedXY = 'Cannot create a descendant of the sealed %s "%s"';
- sAncestorIsNotExternal = 'Ancestor "%s" is not external';
- sPropertyMustHaveReadOrWrite = 'Property must have read or write accessor';
- sVirtualMethodXHasLowerVisibility = 'Virtual method "%s" has a lower visibility (%s) than parent class %s (%s)';
- sExternalClassInstanceCannotAccessStaticX = 'External class instance cannot access static %s';
- sXModifierMismatchY = '%s modifier "%s" mismatch';
- sSymbolCannotBePublished = 'Symbol cannot be published';
- sCannotTypecastAType = 'Cannot type cast a type';
- sTypeIdentifierExpected = 'Type identifier expected';
- sCannotNestAnonymousX = 'Cannot nest anonymous %s';
- sFoundCallCandidateX = 'Found call candidate %s';
- sTextAfterFinalIgnored = 'Text after final ''end.''. ignored by compiler';
- sNoMemberIsProvidedToAccessProperty = 'No member is provided to access property';
- sTheUseOfXisNotAllowedInARecord = 'The use of "%s" is not allowed in a record';
- sParameterlessConstructorsNotAllowedInRecords = 'Parameterless constructors are not allowed in records or record/type helpers';
- sMultipleXinTypeYNameZCAandB = 'Multiple %s in %s %s: %s and %s';
- sXCannotHaveParameters = '%s cannot have parameters';
- sSymbolXIsNotPortable = 'Symbol "%s" is not portable';
- sSymbolXIsExperimental = 'Symbol "%s" is experimental';
- sSymbolXIsNotImplemented = 'Symbol "%s" is not implemented';
- sSymbolXBelongsToALibrary = 'Symbol "%s" belongs to a library';
- sSymbolXIsDeprecated = 'Symbol "%s" is deprecated';
- sSymbolXIsDeprecatedY = 'Symbol "%s" is deprecated: %s';
- sRangeCheckError = 'Range check error';
- sHighRangeLimitLTLowRangeLimit = 'High range limit < low range limit';
- sRangeCheckEvaluatingConstantsVMinMax = 'range check error while evaluating constants (%s is not between %s and %s)';
- sIllegalChar = 'Illegal character';
- sOverflowInArithmeticOperation = 'Overflow in arithmetic operation';
- sDivByZero = 'Division by zero';
- sRangeCheckInSetConstructor = 'range check error in set constructor or duplicate set element';
- sIncompatibleTypesGotParametersExpected = 'Incompatible types, got %s parameters, expected %s';
- sAddingIndexSpecifierRequiresNewX = 'adding index specifier requires new "%s" specifier';
- sCantFindUnitX = 'can''t find unit "%s"';
- sCannotFindEnumeratorForType = 'Cannot find an enumerator for the type "%s"';
- sPreviousDeclMissesOverload = 'Previous declaration of "%s" at %s was not marked with "overload" directive';
- sOverloadedProcMissesOverload = 'Overloaded procedure misses "overload" directive. Previous declaration is at %s';
- sMethodHidesMethodOfBaseType = 'Method "%s" hides method of base type "%s" at %s';
- sContextExpectedXButFoundY = '%s: expected "%s", but found "%s"';
- sContextXInvalidY = '%s: invalid %s';
- sIdentifierXIsNotAnInstanceField = 'Identifier "%s" is not an instance field';
- sConstructingClassXWithAbstractMethodY = 'Constructing a class "%s" with abstract method "%s"';
- sXIsNotSupported = '%s is not supported';
- sOperatorIsNotOverloadedAOpB = 'Operator is not overloaded: "%s" %s "%s"';
- sIllegalQualifierAfter = 'illegal qualifier "%s" after "%s"';
- sIllegalQualifierInFrontOf = 'illegal qualifier "%s" in front of "%s"';
- sIllegalQualifierWithin = 'illegal qualifier "%s" within "%s"';
- sClassXNotFoundInThisModule = 'class "%s" not found in this module';
- sNoMatchingImplForIntfMethodXFound = 'No matching implementation for interface method "%s" found';
- sClassMethodsMustBeStaticInX = 'Class methods must be static in %s';
- sCannotMixMethodResolutionAndDelegationAtX = 'Cannot mix method resolution and delegation at %s';
- sImplementsDoesNotSupportArrayProperty = '"implements" does dot support array property';
- sImplementsDoesNotSupportIndex = '"implements" does not support "index"';
- sImplementsUsedOnUnimplIntf = 'Implements-property used on unimplemented interface: "%"';
- sDuplicateImplementsForIntf = 'Duplicate implements for interface "%s" at %s';
- sImplPropMustHaveReadSpec = 'Implements-property must have read specifier';
- sDoesNotImplementInterface = '"%s" does not implement interface "%s"';
- sTypeCycleFound = 'Type cycle found';
- sTypeXIsNotYetCompletelyDefined = 'type "%s" is not yet completely defined';
- sDuplicateCaseValueXatY = 'Duplicate case value "%s", other at %s';
- sMissingFieldsX = 'Missing fields: "%s"';
- sCantAssignValuesToConstVariable = 'Can''t assign values to const variable';
- sIllegalAssignmentToForLoopVar = 'Illegal assignment to for-loop variable "%s"';
- sTypeXCannotBeExtendedByATypeHelper = 'Type "%s" cannot be extended by a type helper';
- sTypeXCannotBeExtendedByARecordHelper = 'Type "%s" cannot be extended by a record helper';
- sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself';
- sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s';
- sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types';
- sMessageHandlersInvalidParams = 'Message handlers can take only one call by ref. parameter';
- sImplictConversionUnicodeToAnsi = 'Implicit string type conversion with potential data loss from "UnicodeString" to "AnsiString"';
- sWrongTypeXInArrayConstructor = 'Wrong type "%s" in array constructor';
- sUnknownCustomAttributeX = 'Unknown custom attribute "%s"';
- sAttributeIgnoredBecauseAbstractX = 'attribute ignored because abstract %s';
- sCreatingAnInstanceOfAbstractClassY = 'Creating an instance of abstract class "%s"';
- sIllegalExpressionAfterX = 'illegal expression after %s';
- sMethodHidesNonVirtualMethodExactly = 'method hides identifier at "%s". Use reintroduce';
- sDuplicatePublishedMethodXAtY = 'Duplicate published method "%s" at %s';
- sConstraintXSpecifiedMoreThanOnce = 'Constraint "%s" specified more than once';
- sConstraintXAndConstraintYCannotBeTogether = '"%s" constraint and "%s" constraint cannot be specified together';
- sXIsNotAValidConstraint = '"%s" is not a valid constraint';
- sWrongNumberOfParametersForGenericX = 'wrong number of parameters for generic %s';
- sGenericsWithoutSpecializationAsType = 'Generics without specialization cannot be used as a type for a %s';
- sDeclOfXDiffersFromPrevAtY = 'Declaration of "%s" differs from previous declaration at %s';
- sTypeParamXIsMissingConstraintY = 'Type parameter "%s" is missing constraint "%s"';
- sTypeParamXIsNotCompatibleWithY = 'Type parameter "%s" is not compatible with type "%s"';
- sTypeParamXMustSupportIntfY = 'Type parameter "%s" must support interface "%s"';
- sTypeParamsNotAllowedOnX = 'Type parameters not allowed on %s';
- sXMethodsCannotHaveTypeParams = '%s methods cannot have type parameters';
- sImplMustNotRepeatConstraints = 'Implementations must not repeat constraints';
- sCouldNotInferTypeArgXForMethodY = 'Could not infer generic type argument "%s" for method "%s"';
- sInferredTypeXFromDiffArgsMismatchFromMethodY = 'Inferred type "%s" from different arguments mismatch for method "%s"';
- sParamOfThisTypeCannotHaveDefVal = 'Parameters of this type cannot have default values';
- sClassTypesAreNotRelatedXY = 'Class types "%s" and "%s" are not related';
- sDirectiveXNotAllowedHere = 'Directive "%s" not allowed here';
- sAwaitWithoutPromise = 'Await without promise';
- sSymbolCannotExportedFromALibrary = 'The symbol cannot be exported from a library';
- type
- { TResolveData - base class for data stored in TPasElement.CustomData }
- TResolveData = Class(TPasElementBase)
- private
- FElement: TPasElement;
- procedure SetElement(AValue: TPasElement);
- public
- Owner: TObject; // e.g. a TPasResolver
- Next: TResolveData; // TPasResolver uses this for its memory chain
- constructor Create; virtual;
- destructor Destroy; override;
- property Element: TPasElement read FElement write SetElement;// Element.CustomData=Self
- end;
- TResolveDataClass = class of TResolveData;
- type
- {$ifdef pas2js}
- TMaxPrecInt = nativeint;
- TMaxPrecUInt = NativeUInt;
- TMaxPrecFloat = double;
- {$else}
- TMaxPrecInt = int64;
- TMaxPrecUInt = qword;
- TMaxPrecFloat = extended;
- {$endif}
- TMaxPrecCurrency = currency;
- {$ifdef fpc}
- PMaxPrecInt = ^TMaxPrecInt;
- PMaxPrecUInt = ^TMaxPrecUInt;
- PMaxPrecFloat = ^TMaxPrecFloat;
- PMaxPrecCurrency = ^TMaxPrecCurrency;
- {$endif}
- const
- // Note: when FPC compares int64 with qword it converts the qword to an int64,
- // possibly resulting in a range check error -> using a qword const instead
- HighIntAsUInt = TMaxPrecUInt(High(TMaxPrecInt));
- const
- MinSafeIntCurrency = -922337203685477; // .5808
- MaxSafeIntCurrency = 922337203685477; // .5807
- MinSafeIntSingle = -16777216;
- MaxSafeIntSingle = 16777216;
- MaskUIntSingle = $3fffff;
- MinSafeIntDouble = -$1fffffffffffff; // -9007199254740991 54 bits (52 plus signed bit plus implicit highest bit)
- MaxSafeIntDouble = $1fffffffffffff; // 9007199254740991
- MaskUIntDouble = $1fffffffffffff;
- type
- { TResEvalValue }
- TREVKind = (
- revkNone,
- revkCustom,
- revkNil, // TResEvalValue
- revkBool, // TResEvalBool
- revkInt, // TResEvalInt
- revkUInt, // TResEvalUInt
- revkFloat, // TResEvalFloat
- revkCurrency, // TResEvalCurrency
- {$ifdef FPC_HAS_CPSTRING}
- revkString, // TResEvalString rawbytestring
- {$endif}
- revkUnicodeString, // TResEvalUTF16
- revkEnum, // TResEvalEnum
- revkRangeInt, // TResEvalRangeInt: range of enum, int, char, widechar, e.g. 1..2
- revkRangeUInt, // TResEvalRangeUInt: range of uint, e.g. 1..2
- revkSetOfInt, // set of enum, int, char, widechar, e.g. [1,2..3]
- revkExternal // TResEvalExternal: an external const
- );
- TREVKinds = set of TREVKind;
- const
- revkAllStrings = [{$ifdef FPC_HAS_CPSTRING}revkString,{$endif}revkUnicodeString];
- type
- TResEvalValue = class(TResolveData)
- public
- Kind: TREVKind;
- IdentEl: TPasElement;
- // Note: "Element" is used when the TResEvalValue is stored as CustomData of an Element
- constructor CreateKind(const aKind: TREVKind);
- function Clone: TResEvalValue; virtual;
- function AsDebugString: string; virtual;
- function AsString: string; virtual;
- function TypeAsString: string; virtual;
- end;
- TResEvalValueClass = class of TResEvalValue;
- { TResEvalBool }
- TResEvalBool = class(TResEvalValue)
- public
- B: boolean;
- constructor Create; override;
- constructor CreateValue(const aValue: boolean);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- end;
- TResEvalTypedInt = (
- reitNone,
- reitByte,
- reitShortInt,
- reitWord,
- reitSmallInt,
- reitUIntSingle,
- reitIntSingle,
- reitLongWord,
- reitLongInt,
- reitUIntDouble,
- reitIntDouble);
- TResEvalTypedInts = set of TResEvalTypedInt;
- const
- reitDefaults = [reitNone,reitByte,reitShortInt,reitWord,reitSmallInt,reitLongWord,reitLongInt];
- reitAllSigned = [reitNone,reitShortInt,reitSmallInt,reitIntSingle,reitLongInt,reitIntDouble];
- reitAllUnsigned = [reitByte,reitWord,reitUIntSingle,reitLongWord,reitUIntDouble];
- reitLow: array[TResEvalTypedInt] of TMaxPrecInt = (
- low(TMaxPrecInt), // reitNone,
- low(Byte), // reitByte,
- low(ShortInt), // reitShortInt,
- low(Word), // reitWord,
- low(SmallInt), // reitSmallInt,
- 0, // reitUIntSingle,
- MinSafeIntSingle, // reitIntSingle,
- low(LongWord), // reitLongWord,
- low(LongInt), // reitLongInt,
- 0, // reitUIntDouble,
- MinSafeIntDouble // reitIntDouble)
- );
- reitHigh: array[TResEvalTypedInt] of TMaxPrecInt = (
- high(TMaxPrecInt), // reitNone,
- high(Byte), // reitByte,
- high(ShortInt), // reitShortInt,
- high(Word), // reitWord,
- high(SmallInt), // reitSmallInt,
- MaxSafeIntSingle, // reitUIntSingle,
- MaxSafeIntSingle, // reitIntSingle,
- high(LongWord), // reitLongWord,
- high(LongInt), // reitLongInt,
- MaxSafeIntDouble, // reitUIntDouble,
- MaxSafeIntDouble // reitIntDouble)
- );
- type
- { TResEvalInt }
- TResEvalInt = class(TResEvalValue)
- public
- Int: TMaxPrecInt;
- Typed: TResEvalTypedInt;
- constructor Create; override;
- constructor CreateValue(const aValue: TMaxPrecInt);
- constructor CreateValue(const aValue: TMaxPrecInt; aTyped: TResEvalTypedInt);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function AsDebugString: string; override;
- function TypeAsString: string; override;
- end;
- { TResEvalUInt }
- TResEvalUInt = class(TResEvalValue)
- public
- UInt: TMaxPrecUInt;
- constructor Create; override;
- constructor CreateValue(const aValue: TMaxPrecUInt);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- end;
- { TResEvalFloat }
- TResEvalFloat = class(TResEvalValue)
- public
- FloatValue: TMaxPrecFloat;
- constructor Create; override;
- constructor CreateValue(const aValue: TMaxPrecFloat);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function IsInt(out Int: TMaxPrecInt): boolean;
- function TypeAsString: string; override;
- end;
- { TResEvalCurrency }
- TResEvalCurrency = class(TResEvalValue)
- public
- Value: TMaxPrecCurrency;
- constructor Create; override;
- constructor CreateValue(const aValue: TMaxPrecCurrency);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function IsInt(out Int: TMaxPrecInt): boolean;
- function AsInt: TMaxPrecInt; // value * 10.000
- function TypeAsString: string; override;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- { TResEvalString - Kind=revkString }
- TResEvalString = class(TResEvalValue)
- public
- S: RawByteString;
- OnlyASCII: boolean;
- constructor Create; override;
- constructor CreateValue(const aValue: RawByteString);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- end;
- {$endif}
- { TResEvalUTF16 - Kind=revkUnicodeString }
- TResEvalUTF16 = class(TResEvalValue)
- public
- S: UnicodeString;
- constructor Create; override;
- constructor CreateValue(const aValue: UnicodeString);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- end;
- { TResEvalEnum - Kind=revkEnum, Value.Int }
- TResEvalEnum = class(TResEvalValue)
- public
- Index: integer; // Beware: might be outside TPasEnumType
- ElType: TPasEnumType; // TPasEnumType
- constructor Create; override;
- constructor CreateValue(const aValue: integer; aIdentEl: TPasEnumValue);
- function GetEnumValue: TPasEnumValue;
- function GetEnumName: String;
- function Clone: TResEvalValue; override;
- function AsDebugString: string; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- end;
- TRESetElKind = (
- revskNone,
- revskEnum, // ElType is TPasEnumType
- revskInt,
- revskChar,
- revskBool
- );
- { TResEvalRangeInt - Kind=revkRangeInt }
- TResEvalRangeInt = class(TResEvalValue)
- public
- ElKind: TRESetElKind;
- RangeStart, RangeEnd: TMaxPrecInt;
- ElType: TPasType; // revskEnum: TPasEnumType
- constructor Create; override;
- constructor CreateValue(const aElKind: TRESetElKind; aElType: TPasType;
- const aRangeStart, aRangeEnd: TMaxPrecInt); virtual;
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function AsDebugString: string; override;
- function ElementAsString(El: TMaxPrecInt): string; virtual;
- function TypeAsString: string; override;
- end;
- { TResEvalRangeUInt }
- TResEvalRangeUInt = class(TResEvalValue)
- public
- RangeStart, RangeEnd: TMaxPrecUInt;
- constructor Create; override;
- constructor CreateValue(const aRangeStart, aRangeEnd: TMaxPrecUInt);
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- end;
- { TResEvalSet - Kind=revkSetOfInt }
- TResEvalSet = class(TResEvalRangeInt)
- public
- const MaxCount = $ffff;
- type
- TItem = record
- RangeStart, RangeEnd: TMaxPrecInt;
- end;
- TItems = array of TItem;
- public
- Ranges: TItems; // disjunct, sorted ascending
- constructor Create; override;
- constructor CreateEmpty(const aElKind: TRESetElKind; aElType: TPasType = nil);
- constructor CreateEmptySameKind(aSet: TResEvalSet);
- constructor CreateValue(const aElKind: TRESetElKind; aElType: TPasType;
- const aRangeStart, aRangeEnd: TMaxPrecInt); override;
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- function Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; // false if duplicate ignored
- function IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean = false): integer;
- function Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer; // returns index of first intersecting range
- procedure ConsistencyCheck;
- end;
- { TResEvalExternal }
- TResEvalExternal = class(TResEvalValue)
- public
- constructor Create; override;
- function Clone: TResEvalValue; override;
- function AsString: string; override;
- function TypeAsString: string; override;
- end;
- TResEvalFlag = (
- refConst, // computing a const, error if a value is not const
- refConstExt, // as refConst, except allow external const
- refAutoConst, // set refConst if in a const
- refAutoConstExt // set refConstExt if in a const
- );
- TResEvalFlags = set of TResEvalFlag;
- TResExprEvaluator = class;
- TPasResEvalLogHandler = procedure(Sender: TResExprEvaluator; const id: TMaxPrecInt;
- MsgType: TMessageType; MsgNumber: integer;
- const Fmt: String; Args: Array of const; PosEl: TPasElement) of object;
- TPasResEvalIdentHandler = function(Sender: TResExprEvaluator;
- Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue of object;
- TPasResEvalParamsHandler = function(Sender: TResExprEvaluator;
- Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue of object;
- TPasResEvalRangeCheckElHandler = procedure(Sender: TResExprEvaluator;
- El: TPasElement; var MsgType: TMessageType) of object;
- { TResExprEvaluator }
- TResExprEvaluator = class
- private
- FAllowedInts: TResEvalTypedInts;
- {$ifdef FPC_HAS_CPSTRING}
- FDefaultSourceEncoding: TSystemCodePage;
- FDefaultStringEncoding: TSystemCodePage;
- {$endif}
- FOnEvalIdentifier: TPasResEvalIdentHandler;
- FOnEvalParams: TPasResEvalParamsHandler;
- FOnLog: TPasResEvalLogHandler;
- FOnRangeCheckEl: TPasResEvalRangeCheckElHandler;
- protected
- procedure LogMsg(const id: TMaxPrecInt; MsgType: TMessageType; MsgNumber: integer;
- const Fmt: String; Args: Array of const; PosEl: TPasElement); overload;
- procedure RaiseMsg(const Id: TMaxPrecInt; MsgNumber: integer; const Fmt: String;
- Args: Array of const; ErrorPosEl: TPasElement);
- procedure RaiseNotYetImplemented(id: TMaxPrecInt; El: TPasElement; Msg: string = ''); virtual;
- procedure RaiseInternalError(id: TMaxPrecInt; const Msg: string = '');
- procedure RaiseConstantExprExp(id: TMaxPrecInt; ErrorEl: TPasElement);
- procedure RaiseRangeCheck(id: TMaxPrecInt; ErrorEl: TPasElement);
- procedure RaiseOverflowArithmetic(id: TMaxPrecInt; ErrorEl: TPasElement);
- procedure RaiseDivByZero(id: TMaxPrecInt; ErrorEl: TPasElement);
- function EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags): TResEvalValue;
- function EvalBinaryExpr(Expr: TBinaryExpr; Flags: TResEvalFlags): TResEvalValue;
- function EvalBinaryRangeExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryAddExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinarySubExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryMulExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryDivideExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryDivExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryModExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryPowerExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryShiftExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryBoolOpExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryNEqualExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryLessGreaterExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinaryInExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalBinarySymmetricaldifferenceExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- function EvalParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
- function EvalArrayParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
- function EvalSetParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalSet;
- function EvalSetExpr(Expr: TPasExpr; ExprArray: TPasExprArray; Flags: TResEvalFlags): TResEvalSet;
- function EvalArrayValuesExpr(Expr: TArrayValues; Flags: TResEvalFlags): TResEvalSet;
- function EvalPrimitiveExprString(Expr: TPrimitiveExpr): TResEvalValue; virtual;
- procedure PredBool(Value: TResEvalBool; ErrorEl: TPasElement);
- procedure SuccBool(Value: TResEvalBool; ErrorEl: TPasElement);
- procedure PredInt(Value: TResEvalInt; ErrorEl: TPasElement);
- procedure SuccInt(Value: TResEvalInt; ErrorEl: TPasElement);
- procedure PredUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
- procedure SuccUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
- {$ifdef FPC_HAS_CPSTRING}
- procedure PredString(Value: TResEvalString; ErrorEl: TPasElement);
- procedure SuccString(Value: TResEvalString; ErrorEl: TPasElement);
- {$endif}
- procedure PredUnicodeString(Value: TResEvalUTF16; ErrorEl: TPasElement);
- procedure SuccUnicodeString(Value: TResEvalUTF16; ErrorEl: TPasElement);
- procedure PredEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
- procedure SuccEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
- function CreateResEvalInt(UInt: TMaxPrecUInt): TResEvalValue; virtual;
- public
- constructor Create;
- function Eval(Expr: TPasExpr; Flags: TResEvalFlags): TResEvalValue;
- function IsInRange(Expr, RangeExpr: TPasExpr; EmitHints: boolean): boolean;
- function IsInRange(Value: TResEvalValue; ValueExpr: TPasExpr;
- RangeValue: TResEvalValue; RangeExpr: TPasExpr; EmitHints: boolean): boolean;
- function IsSetCompatible(Value: TResEvalValue; ValueExpr: TPasExpr;
- RangeValue: TResEvalValue; EmitHints: boolean): boolean;
- function IsConst(Expr: TPasExpr): boolean;
- function IsSimpleExpr(Expr: TPasExpr): boolean; // true = no need to store result
- procedure EmitRangeCheckConst(id: TMaxPrecInt; const aValue, MinVal, MaxVal: String;
- PosEl: TPasElement; MsgType: TMessageType = mtWarning); virtual;
- procedure EmitRangeCheckConst(id: TMaxPrecInt; const aValue: String;
- MinVal, MaxVal: TMaxPrecInt; PosEl: TPasElement; MsgType: TMessageType = mtWarning);
- function ChrValue(Value: TResEvalValue; ErrorEl: TPasElement): TResEvalValue; virtual;
- function OrdValue(Value: TResEvalValue; ErrorEl: TPasElement): TResEvalValue; virtual;
- function StringToOrd(Value: TResEvalValue; PosEl: TPasElement): longword; virtual;
- procedure PredValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
- procedure SuccValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
- function EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
- function EvalStringAddExpr(Expr, LeftExpr, RightExpr: TPasExpr;
- LeftValue, RightValue: TResEvalValue): TResEvalValue; virtual;
- function LoHiValue(Value: TResEvalValue; ShiftSize: Integer; Mask: LongWord;
- ErrorEl: TPasElement): TResEvalValue; virtual;
- function EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
- Flags: TResEvalFlags): TResEvalEnum; virtual;
- {$ifdef FPC_HAS_CPSTRING}
- function CheckValidUTF8(const s: RawByteString; ErrorEl: TPasElement): boolean;
- function GetCodePage(const s: RawByteString): TSystemCodePage;
- function GetRawByteString(const s: UnicodeString; CodePage: TSystemCodePage; ErrorEl: TPasElement): RawByteString;
- function GetUTF8Str(const s: RawByteString; ErrorEl: TPasElement): String;
- function GetUnicodeStr(const s: RawByteString; ErrorEl: TPasElement): UnicodeString;
- function GetWideChar(const s: RawByteString; out w: WideChar): boolean;
- function GetExprStringTargetCP(Expr: TPasExpr): TSystemCodePage; virtual; // e.g. var s: String(1234) = 'ä' return 1234
- function GetExprStringSourceCP(Expr: TPasExpr): TSystemCodePage; virtual; // e.g. {$codepage 123}var s: String = 'ä' return 123
- {$endif}
- property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog;
- property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier;
- property OnEvalParams: TPasResEvalParamsHandler read FOnEvalParams write FOnEvalParams;
- property OnRangeCheckEl: TPasResEvalRangeCheckElHandler read FOnRangeCheckEl write FOnRangeCheckEl;
- property AllowedInts: TResEvalTypedInts read FAllowedInts write FAllowedInts;
- {$ifdef FPC_HAS_CPSTRING}
- property DefaultSourceCodePage: TSystemCodePage read FDefaultSourceEncoding write FDefaultSourceEncoding;
- property DefaultStringCodePage: TSystemCodePage read FDefaultStringEncoding write FDefaultStringEncoding;
- {$endif}
- end;
- TResExprEvaluatorClass = class of TResExprEvaluator;
- procedure ReleaseEvalValue(var Value: TResEvalValue);
- function NumberIsFloat(const Value: string): boolean;
- {$ifdef FPC_HAS_CPSTRING}
- function RawStrToCaption(const r: RawByteString; MaxLength: integer): string;
- {$endif}
- function UnicodeStrToCaption(const u: UnicodeString; MaxLength: integer): Unicodestring;
- function CodePointToString(CodePoint: longword): String;
- function CodePointToUnicodeString(u: longword): UnicodeString;
- function GetObjName(o: TObject): string;
- function GetObjPath(o: TObject): string;
- function GetGenericParamCommas(Cnt: integer): string;
- function GetElementNameAndParams(El: TPasElement; MaxLvl: integer = 3): string;
- function GetTypeParamNames(Templates: TFPList; MaxLvl: integer = 3): string;
- function dbgs(const Flags: TResEvalFlags): string; overload;
- function dbgs(v: TResEvalValue): string; overload;
- function LastPos(c: char; const s: string): sizeint;
- implementation
- procedure ReleaseEvalValue(var Value: TResEvalValue);
- begin
- if Value=nil then exit;
- if Value.Element<>nil then exit;
- Value.{$ifdef pas2js}Destroy{$else}Free{$endif};
- Value:=nil;
- end;
- function NumberIsFloat(const Value: string): boolean;
- var
- i: Integer;
- begin
- if Value='' then exit(false);
- if Value[1] in ['$','%','&'] then exit(false);
- for i:=2 to length(Value) do
- if Value[i] in ['.','E','e'] then exit(true);
- Result:=false;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- function RawStrToCaption(const r: RawByteString; MaxLength: integer): string;
- var
- s: RawByteString;
- p: PAnsiChar;
- InLit: boolean;
- Len: integer;
- procedure AddHash(o: integer);
- var
- h: String;
- begin
- if (Result<>'') and InLit then
- begin
- Result:=Result+'''';
- inc(Len);
- InLit:=false;
- end;
- h:='#'+IntToStr(o);
- inc(Len,length(h));
- if Len<=MaxLength then
- Result:=Result+h;
- end;
- procedure AddLit(const Lit: string; CaptionLen: integer);
- begin
- if not InLit then
- begin
- Result:=Result+'''';
- inc(Len);
- InLit:=true;
- end;
- Result:=Result+Lit;
- inc(Len,CaptionLen);
- end;
- var
- l: SizeInt;
- CP: TSystemCodePage;
- EndP: PAnsiChar;
- begin
- Result:='';
- s:=r;
- CP:=StringCodePage(s);
- if (CP<>CP_ACP) and (CP<>CP_UTF8) then
- SetCodePage(s, CP_ACP, true);
- p:=PAnsiChar(s);
- EndP:=p+length(s);
- Len:=0;
- InLit:=false;
- while Len<MaxLength do
- case p^ of
- #0:
- begin
- if p-PAnsiChar(s)=length(s) then
- break;
- AddHash(0);
- inc(p);
- end;
- '''':
- begin
- AddLit('''''',2);
- inc(p);
- end;
- #1..#31,#127..#192:
- begin
- AddHash(ord(p^));
- inc(p);
- end
- else
- begin
- l:=Utf8CodePointLen(p,EndP-p,true);
- if l<=0 then
- begin
- // invalid
- AddHash(ord(p^));
- inc(p);
- end
- else
- begin
- AddLit(copy(s,p-PAnsiChar(s)+1,l),1);
- inc(p,l);
- end;
- end;
- end;
- if InLit then
- Result:=Result+'''';
- end;
- {$endif}
- function UnicodeStrToCaption(const u: UnicodeString; MaxLength: integer
- ): Unicodestring;
- // encode a string as a Pascal string literal using '' and #
- var
- InLit: boolean;
- Len: integer;
- procedure AddHash(o: integer);
- var
- h: UnicodeString;
- begin
- if (Result<>'') and InLit then
- begin
- Result:=Result+'''';
- inc(Len);
- InLit:=false;
- end;
- h:='#'+UnicodeString(IntToStr(o));
- inc(Len,length(h));
- if Len<=MaxLength then
- Result:=Result+h;
- end;
- procedure AddLit(const Lit: Unicodestring; CaptionLen: integer);
- begin
- if not InLit then
- begin
- Result:=Result+'''';
- inc(Len);
- InLit:=true;
- end;
- Result:=Result+Lit;
- inc(Len,CaptionLen);
- end;
- var
- p: integer;
- begin
- Result:='';
- p:=1;
- Len:=0;
- InLit:=false;
- while (Len<MaxLength) and (p<=length(u)) do
- case u[p] of
- '''':
- begin
- AddLit('''''',2);
- inc(p);
- end;
- #0..#31,#127..#255,#$D800..#$ffff:
- begin
- AddHash(ord(u[p]));
- inc(p);
- end
- else
- begin
- AddLit(u[p],1);
- inc(p);
- end;
- end;
- if InLit then
- Result:=Result+'''';
- end;
- function CodePointToString(CodePoint: longword): String;
- begin
- case CodePoint of
- 0..$7f:
- begin
- Result:=char(byte(CodePoint));
- end;
- $80..$7ff:
- begin
- Result:=char(byte($c0 or (CodePoint shr 6)))
- +char(byte($80 or (CodePoint and $3f)));
- end;
- $800..$ffff:
- begin
- Result:=char(byte($e0 or (CodePoint shr 12)))
- +char(byte((CodePoint shr 6) and $3f) or $80)
- +char(byte(CodePoint and $3f) or $80);
- end;
- $10000..$10ffff:
- begin
- Result:=char(byte($f0 or (CodePoint shr 18)))
- +char(byte((CodePoint shr 12) and $3f) or $80)
- +char(byte((CodePoint shr 6) and $3f) or $80)
- +char(byte(CodePoint and $3f) or $80);
- end;
- else
- Result:='';
- end;
- end;
- function CodePointToUnicodeString(u: longword): UnicodeString;
- begin
- if u < $10000 then
- // Note: codepoints $D800 - $DFFF are reserved
- Result:=WideChar(u)
- else
- Result:=WideChar($D800+((u - $10000) shr 10))+WideChar($DC00+((u - $10000) and $3ff));
- end;
- function GetObjName(o: TObject): string;
- var
- GenType: TPasGenericType;
- begin
- if o=nil then
- Result:='nil'
- else if (o is TPasArrayType) and (TPasArrayType(o).Name='') then
- begin
- if TPasArrayType(o).ElType = nil then
- Result:='array of const'
- else
- Result:=Format('TArray<%s>', [TPasArrayType(o).ElType.Name]);
- end
- else if o is TPasElement then
- begin
- Result:=TPasElement(o).Name;
- if o is TPasGenericType then
- begin
- GenType:=TPasGenericType(o);
- if (GenType.GenericTemplateTypes<>nil)
- and (GenType.GenericTemplateTypes.Count>0) then
- Result:=Result+GetGenericParamCommas(GenType.GenericTemplateTypes.Count);
- end;
- Result:=Result+':'+o.ClassName;
- end
- else
- Result:=o.ClassName;
- end;
- function GetObjPath(o: TObject): string;
- var
- El: TPasElement;
- GenType: TPasGenericType;
- begin
- if o is TPasElement then
- begin
- El:=TPasElement(o);
- Result:=':'+El.ClassName;
- while El<>nil do
- begin
- if El<>o then
- Result:='.'+Result;
- if El is TPasGenericType then
- begin
- GenType:=TPasGenericType(El);
- if (GenType.GenericTemplateTypes<>nil)
- and (GenType.GenericTemplateTypes.Count>0)
- and (Pos('<',El.Name)<1) then
- Result:=GetGenericParamCommas(GenType.GenericTemplateTypes.Count)+Result;
- end;
- if El.Name<>'' then
- begin
- if IsValidIdent(El.Name) then
- Result:=El.Name+Result
- else
- Result:='"'+El.Name+'"'+Result;
- end
- else
- Result:='['+El.ClassName+']'+Result;
- El:=El.Parent;
- end;
- end
- else
- Result:=GetObjName(o);
- end;
- function GetGenericParamCommas(Cnt: integer): string;
- begin
- if Cnt<=0 then
- Result:=''
- else
- Result:='<'+StringOfChar(',',Cnt-1)+'>';
- end;
- function GetElementNameAndParams(El: TPasElement; MaxLvl: integer): string;
- begin
- if El=nil then
- exit('(nil)');
- Result:=El.Name;
- if El is TPasGenericType then
- Result:=Result+GetTypeParamNames(TPasGenericType(El).GenericTemplateTypes,MaxLvl-1);
- end;
- function GetTypeParamNames(Templates: TFPList; MaxLvl: integer): string;
- var
- i: Integer;
- El: TPasElement;
- begin
- if (Templates=nil) or (Templates.Count=0) then
- exit('');
- if MaxLvl<=0 then
- exit('...');
- Result:='<';
- for i:=0 to Templates.Count-1 do
- begin
- if i>0 then
- Result:=Result+',';
- El:=TPasElement(Templates[i]);
- if El.Name<>'' then
- Result:=Result+GetElementNameAndParams(El,MaxLvl-1)
- else if El is TPasArrayType then
- Result:=Result+'array...'
- else
- Result:=Result+'...';
- end;
- Result:=Result+'>';
- end;
- function dbgs(const Flags: TResEvalFlags): string;
- var
- s: string;
- f: TResEvalFlag;
- 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(v: TResEvalValue): string;
- begin
- if v=nil then
- Result:='nil'
- else
- Result:=v.AsDebugString;
- end;
- function LastPos(c: char; const s: string): sizeint;
- var
- i: SizeInt;
- begin
- for i:=length(s) downto 1 do
- if s[i]=c then exit(i);
- Result:=-1;
- end;
- { TResEvalExternal }
- constructor TResEvalExternal.Create;
- begin
- inherited Create;
- Kind:=revkExternal;
- end;
- function TResEvalExternal.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- end;
- function TResEvalExternal.AsString: string;
- begin
- Result:=inherited AsString;
- end;
- function TResEvalExternal.TypeAsString: string;
- begin
- Result:='external value';
- end;
- { TResEvalCurrency }
- constructor TResEvalCurrency.Create;
- begin
- inherited Create;
- Kind:=revkCurrency;
- end;
- constructor TResEvalCurrency.CreateValue(const aValue: TMaxPrecCurrency);
- begin
- Create;
- Value:=aValue;
- end;
- function TResEvalCurrency.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalCurrency(Result).Value:=Value;
- end;
- function TResEvalCurrency.AsString: string;
- begin
- str(Value,Result);
- end;
- function TResEvalCurrency.IsInt(out Int: TMaxPrecInt): boolean;
- var
- i: TMaxPrecInt;
- begin
- i:=AsInt;
- Result:=(i mod 10000)=0;
- Int:=i div 10000;
- end;
- function TResEvalCurrency.AsInt: TMaxPrecInt;
- begin
- {$ifdef pas2js}
- Result:=NativeInt(Value); // pas2js stores currency as a double with factor 10.000
- {$else}
- Result:=PInt64(@Value)^; // fpc stores currency as an int64 with factor 10.000
- {$endif};
- end;
- function TResEvalCurrency.TypeAsString: string;
- begin
- Result:='currency';
- end;
- { TResEvalBool }
- constructor TResEvalBool.Create;
- begin
- inherited Create;
- Kind:=revkBool;
- end;
- constructor TResEvalBool.CreateValue(const aValue: boolean);
- begin
- Create;
- B:=aValue;
- end;
- function TResEvalBool.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalBool(Result).B:=B;
- end;
- function TResEvalBool.AsString: string;
- begin
- if B then
- Result:='true'
- else
- Result:='false';
- end;
- function TResEvalBool.TypeAsString: string;
- begin
- Result:='boolean';
- end;
- { TResEvalRangeUInt }
- constructor TResEvalRangeUInt.Create;
- begin
- inherited Create;
- Kind:=revkRangeInt;
- end;
- constructor TResEvalRangeUInt.CreateValue(const aRangeStart,
- aRangeEnd: TMaxPrecUInt);
- begin
- Create;
- RangeStart:=aRangeStart;
- RangeEnd:=aRangeEnd;
- end;
- function TResEvalRangeUInt.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalRangeUInt(Result).RangeStart:=RangeStart;
- TResEvalRangeUInt(Result).RangeEnd:=RangeEnd;
- end;
- function TResEvalRangeUInt.AsString: string;
- begin
- Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd);
- end;
- function TResEvalRangeUInt.TypeAsString: string;
- begin
- Result:='unsigned integer range';
- end;
- { TResExprEvaluator }
- procedure TResExprEvaluator.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType;
- MsgNumber: integer; const Fmt: String;
- Args: array of const;
- PosEl: TPasElement);
- begin
- OnLog(Self,id,MsgType,MsgNumber,Fmt,Args,PosEl);
- end;
- procedure TResExprEvaluator.RaiseMsg(const Id: TMaxPrecInt; MsgNumber: integer;
- const Fmt: String; Args: array of const;
- ErrorPosEl: TPasElement);
- begin
- LogMsg(id,mtError,MsgNumber,Fmt,Args,ErrorPosEl);
- raise Exception.Create('['+IntToStr(id)+'] ('+IntToStr(MsgNumber)+') '+SafeFormat(Fmt,Args));
- end;
- procedure TResExprEvaluator.RaiseNotYetImplemented(id: TMaxPrecInt; El: TPasElement;
- Msg: string);
- var
- s: String;
- begin
- s:=sNotYetImplemented+' ['+IntToStr(id)+']';
- if Msg<>'' then
- s:=s+' '+Msg;
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.RaiseNotYetImplemented s="',s,'" El=',GetObjName(El));
- {$ENDIF}
- RaiseMsg(id,nNotYetImplemented,s,[GetObjName(El)],El);
- end;
- procedure TResExprEvaluator.RaiseInternalError(id: TMaxPrecInt; const Msg: string);
- begin
- raise Exception.Create('Internal error: ['+IntToStr(id)+'] '+Msg);
- end;
- procedure TResExprEvaluator.RaiseConstantExprExp(id: TMaxPrecInt; ErrorEl: TPasElement
- );
- begin
- RaiseMsg(id,nConstantExpressionExpected,sConstantExpressionExpected,[],ErrorEl);
- end;
- procedure TResExprEvaluator.RaiseRangeCheck(id: TMaxPrecInt; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nRangeCheckError,sRangeCheckError,[],ErrorEl);
- end;
- procedure TResExprEvaluator.RaiseOverflowArithmetic(id: TMaxPrecInt;
- ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nOverflowInArithmeticOperation,sOverflowInArithmeticOperation,[],ErrorEl);
- end;
- procedure TResExprEvaluator.RaiseDivByZero(id: TMaxPrecInt; ErrorEl: TPasElement);
- begin
- RaiseMsg(id,nDivByZero,sDivByZero,[],ErrorEl);
- end;
- function TResExprEvaluator.EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags
- ): TResEvalValue;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- begin
- Result:=Eval(Expr.Operand,Flags);
- if Result=nil then exit;
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.EvalUnaryExpr ',OpcodeStrings[Expr.OpCode],' Value=',Result.AsDebugString);
- {$ENDIF}
- case Expr.OpCode of
- eopAdd: ;
- eopSubtract:
- case Result.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(Result).Int;
- if Int=0 then exit;
- if Result.Element<>nil then
- Result:=Result.Clone;
- if (TResEvalInt(Result).Typed in reitAllSigned) then
- begin
- if Int=reitLow[TResEvalInt(Result).Typed] then
- begin
- // need higher precision
- if TResEvalInt(Result).Typed<>reitNone then
- // unsigned -> switch to untyped
- TResEvalInt(Result).Typed:=reitNone
- else
- begin
- // switch to float
- ReleaseEvalValue(Result);
- Result:=TResEvalFloat.CreateValue(-TMaxPrecFloat(low(TMaxPrecInt)));
- exit;
- end;
- end;
- end
- else
- begin
- // unsigned -> switch to untyped
- TResEvalInt(Result).Typed:=reitNone;
- end ;
- // negate
- TResEvalInt(Result).Int:=-Int;
- end;
- revkUInt:
- begin
- UInt:=TResEvalUInt(Result).UInt;
- if UInt=0 then exit;
- if UInt<=High(TMaxPrecInt) then
- begin
- ReleaseEvalValue(Result);
- Result:=TResEvalInt.CreateValue(-TMaxPrecInt(UInt));
- end
- else
- begin
- // switch to float
- ReleaseEvalValue(Result);
- Result:=TResEvalFloat.CreateValue(-TMaxPrecFloat(UInt));
- end;
- end;
- revkFloat:
- begin
- if TResEvalFloat(Result).FloatValue=0 then exit;
- if Result.Element<>nil then
- Result:=Result.Clone;
- TResEvalFloat(Result).FloatValue:=-TResEvalFloat(Result).FloatValue;
- end;
- revkCurrency:
- begin
- if TResEvalCurrency(Result).Value=0 then exit;
- if Result.Element<>nil then
- Result:=Result.Clone;
- TResEvalCurrency(Result).Value:=-TResEvalCurrency(Result).Value;
- end;
- revkExternal:
- exit;
- else
- begin
- if Result.Element=nil then
- Result.Free;
- RaiseNotYetImplemented(20170518230738,Expr);
- end;
- end;
- eopNot:
- case Result.Kind of
- revkBool:
- begin
- if Result.Element<>nil then
- Result:=Result.Clone;
- TResEvalBool(Result).B:=not TResEvalBool(Result).B;
- end;
- revkInt:
- begin
- if Result.Element<>nil then
- Result:=Result.Clone;
- case TResEvalInt(Result).Typed of
- reitByte: TResEvalInt(Result).Int:=not byte(TResEvalInt(Result).Int);
- reitShortInt: TResEvalInt(Result).Int:=not shortint(TResEvalInt(Result).Int);
- reitWord: TResEvalInt(Result).Int:=not word(TResEvalInt(Result).Int);
- reitSmallInt: TResEvalInt(Result).Int:=not smallint(TResEvalInt(Result).Int);
- reitUIntSingle: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $3fffff;
- reitIntSingle: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $7fffff;
- reitLongWord: TResEvalInt(Result).Int:=not longword(TResEvalInt(Result).Int);
- reitLongInt: TResEvalInt(Result).Int:=not longint(TResEvalInt(Result).Int);
- reitUIntDouble: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $fffffffffffff;
- reitIntDouble: {$ifdef fpc}TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $1fffffffffffff{$endif};
- else TResEvalInt(Result).Int:=not TResEvalInt(Result).Int;
- end;
- end;
- revkUInt:
- begin
- if Result.Element<>nil then
- Result:=Result.Clone;
- TResEvalUInt(Result).UInt:=not TResEvalUInt(Result).UInt;
- end;
- revkExternal:
- exit;
- else
- begin
- if Result.Element=nil then
- Result.Free;
- RaiseNotYetImplemented(20170518232804,Expr);
- end;
- end;
- eopAddress:
- begin
- if Result.Element=nil then
- Result.Free;
- // @ operator requires a compiler (not just a resolver) -> return nil
- Result:=TResEvalValue.CreateKind(revkNil);
- end
- else
- RaiseNotYetImplemented(20170518232823,Expr,'operator='+OpcodeStrings[Expr.OpCode]);
- end;
- end;
- function TResExprEvaluator.EvalBinaryExpr(Expr: TBinaryExpr;
- Flags: TResEvalFlags): TResEvalValue;
- var
- LeftValue, RightValue: TResEvalValue;
- Left: TPasExpr;
- SubBin: TBinaryExpr;
- begin
- Result:=nil;
- if (Expr.Kind=pekBinary) and (Expr.OpCode=eopSubIdent) then
- begin
- Result:=Eval(Expr.right,Flags);
- exit;
- end;
- LeftValue:=nil;
- RightValue:=nil;
- try
- if Expr.OpCode=eopAdd then
- begin
- // handle multi adds without stack
- Left:=Expr.left;
- while Left.ClassType=TBinaryExpr do
- begin
- SubBin:=TBinaryExpr(Left);
- if SubBin.OpCode<>eopAdd then break;
- Left:=SubBin.left;
- end;
- LeftValue:=Eval(Left,Flags);
- while LeftValue<>nil do
- begin
- SubBin:=TBinaryExpr(Left.Parent);
- RightValue:=Eval(SubBin.right,Flags);
- if RightValue=nil then exit;
- if LeftValue.Kind=revkExternal then
- begin
- if [refConst,refConstExt]*Flags=[refConst] then
- RaiseConstantExprExp(20210321205928,Expr.left);
- Result:=LeftValue;
- LeftValue:=nil;
- exit;
- end;
- if RightValue.Kind=revkExternal then
- begin
- if [refConst,refConstExt]*Flags=[refConst] then
- RaiseConstantExprExp(20210321205948,Expr.right);
- Result:=RightValue;
- RightValue:=nil;
- exit;
- end;
- Result:=EvalBinaryAddExpr(SubBin,LeftValue,RightValue);
- ReleaseEvalValue(LeftValue);
- if SubBin=Expr then exit;
- LeftValue:=Result;
- Result:=nil;
- Left:=SubBin;
- end;
- exit;
- end;
- LeftValue:=Eval(Expr.left,Flags);
- if LeftValue=nil then exit;
- RightValue:=Eval(Expr.right,Flags);
- if RightValue=nil then exit;
- if LeftValue.Kind=revkExternal then
- begin
- if [refConst,refConstExt]*Flags=[refConst] then
- RaiseConstantExprExp(20181024134508,Expr.left);
- Result:=LeftValue;
- LeftValue:=nil;
- exit;
- end;
- if RightValue.Kind=revkExternal then
- begin
- if [refConst,refConstExt]*Flags=[refConst] then
- RaiseConstantExprExp(20181024134545,Expr.right);
- Result:=RightValue;
- RightValue:=nil;
- exit;
- end;
- case Expr.Kind of
- pekRange:
- // leftvalue..rightvalue
- Result:=EvalBinaryRangeExpr(Expr,LeftValue,RightValue);
- pekBinary:
- case Expr.OpCode of
- eopAdd:
- Result:=EvalBinaryAddExpr(Expr,LeftValue,RightValue);
- eopSubtract:
- Result:=EvalBinarySubExpr(Expr,LeftValue,RightValue);
- eopMultiply:
- Result:=EvalBinaryMulExpr(Expr,LeftValue,RightValue);
- eopDivide:
- Result:=EvalBinaryDivideExpr(Expr,LeftValue,RightValue);
- eopDiv:
- Result:=EvalBinaryDivExpr(Expr,LeftValue,RightValue);
- eopMod:
- Result:=EvalBinaryModExpr(Expr,LeftValue,RightValue);
- eopPower:
- Result:=EvalBinaryPowerExpr(Expr,LeftValue,RightValue);
- eopShl,eopShr:
- Result:=EvalBinaryShiftExpr(Expr,LeftValue,RightValue);
- eopAnd,eopOr,eopXor:
- Result:=EvalBinaryBoolOpExpr(Expr,LeftValue,RightValue);
- eopEqual,eopNotEqual:
- Result:=EvalBinaryNEqualExpr(Expr,LeftValue,RightValue);
- eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual:
- Result:=EvalBinaryLessGreaterExpr(Expr,LeftValue,RightValue);
- eopIn:
- Result:=EvalBinaryInExpr(Expr,LeftValue,RightValue);
- eopSymmetricaldifference:
- Result:=EvalBinarySymmetricaldifferenceExpr(Expr,LeftValue,RightValue);
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryExpr Kind=',Expr.Kind,' Opcode=',OpcodeStrings[Expr.OpCode],' Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530100823,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryExpr Kind=',Expr.Kind,' Opcode=',OpcodeStrings[Expr.OpCode]);
- {$ENDIF}
- RaiseNotYetImplemented(20170530100827,Expr);
- end;
- {$IFDEF VerbosePasResEval}
- {AllowWriteln}
- if Result<>nil then
- writeln('TResExprEvaluator.EvalBinaryExpr Left=',LeftValue.AsDebugString,' Opcode=',OpcodeStrings[Expr.OpCode],' Right=',RightValue.AsDebugString,' Result=',Result.AsDebugString)
- else
- writeln('TResExprEvaluator.EvalBinaryExpr Left=',LeftValue.AsDebugString,' Opcode=',OpcodeStrings[Expr.OpCode],' Right=',RightValue.AsDebugString,' Result not set');
- {AllowWriteln-}
- {$ENDIF}
- finally
- ReleaseEvalValue(LeftValue);
- ReleaseEvalValue(RightValue);
- end;
- end;
- function TResExprEvaluator.EvalBinaryRangeExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- // LeftValue..RightValue
- var
- LeftInt, RightInt: TMaxPrecInt;
- begin
- case LeftValue.Kind of
- revkBool:
- if RightValue.Kind<>revkBool then
- RaiseRangeCheck(20170714133017,Expr.Right)
- else
- begin
- LeftInt:=ord(TResEvalBool(LeftValue).B);
- RightInt:=ord(TResEvalBool(RightValue).B);
- if LeftInt>RightInt then
- RaiseMsg(20170714133540,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeInt.CreateValue(revskBool,nil,LeftInt,RightInt);
- exit;
- end;
- revkInt:
- if RightValue.Kind=revkInt then
- begin
- LeftInt:=TResEvalInt(LeftValue).Int;
- RightInt:=TResEvalInt(RightValue).Int;
- if LeftInt>RightInt then
- RaiseMsg(20170518222939,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeInt.CreateValue(revskInt,nil,LeftInt,RightInt);
- exit;
- end
- else if RightValue.Kind=revkUInt then
- begin
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- if TResEvalUInt(RightValue).UInt<=HighIntAsUInt then
- begin
- if TResEvalInt(LeftValue).Int>TResEvalUInt(RightValue).UInt then
- RaiseMsg(20170519000235,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeInt.CreateValue(revskInt,nil,
- TResEvalInt(LeftValue).Int,TMaxPrecInt(TResEvalUInt(RightValue).UInt));
- exit;
- end
- else if TResEvalInt(LeftValue).Int<0 then
- RaiseRangeCheck(20170522151629,Expr.Right)
- else if TMaxPrecUInt(TResEvalInt(LeftValue).Int)>TResEvalUInt(RightValue).UInt then
- RaiseMsg(20170522151708,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeUInt.CreateValue(TMaxPrecUInt(TResEvalInt(LeftValue).Int),
- TResEvalUInt(RightValue).UInt);
- exit;
- end
- else
- RaiseRangeCheck(20170518222812,Expr.Right);
- revkUInt:
- if RightValue.Kind=revkInt then
- begin
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- if TResEvalUInt(LeftValue).UInt>HighIntAsUInt then
- begin
- if TResEvalInt(RightValue).Int<0 then
- RaiseRangeCheck(20170522152608,Expr.Right)
- else if TResEvalUInt(LeftValue).UInt>TMaxPrecUInt(TResEvalInt(RightValue).Int) then
- RaiseMsg(20170522152648,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeUInt.CreateValue(TResEvalUInt(LeftValue).UInt,
- TMaxPrecUInt(TResEvalInt(RightValue).Int));
- exit;
- end
- else if TResEvalUInt(LeftValue).UInt>TResEvalInt(RightValue).Int then
- RaiseMsg(20170522152804,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeInt.CreateValue(revskInt,nil,
- TMaxPrecInt(TResEvalUInt(LeftValue).UInt),TResEvalInt(RightValue).Int);
- exit;
- end
- else if RightValue.Kind=revkUInt then
- begin
- if TResEvalUInt(LeftValue).UInt>TResEvalUInt(RightValue).UInt then
- RaiseMsg(20170519000240,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeUInt.CreateValue(TResEvalUInt(LeftValue).UInt,
- TResEvalUInt(RightValue).UInt);
- exit;
- end
- else
- RaiseRangeCheck(20170522123106,Expr.Right);
- revkEnum:
- if (RightValue.Kind<>revkEnum) then
- RaiseRangeCheck(20170522153003,Expr.Right)
- else if (TResEvalEnum(LeftValue).ElType<>TResEvalEnum(RightValue).ElType) then
- begin
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryRangeExpr LeftValue=',dbgs(LeftValue),',',GetObjName(TResEvalEnum(LeftValue).ElType),' RightValue=',dbgs(RightValue),',',GetObjName(TResEvalEnum(RightValue).ElType));
- {$ENDIF}
- RaiseRangeCheck(20170522123241,Expr.Right) // mismatch enumtype
- end
- else if TResEvalEnum(LeftValue).Index>TResEvalEnum(RightValue).Index then
- RaiseMsg(20170522123320,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right)
- else
- begin
- Result:=TResEvalRangeInt.CreateValue(revskEnum,
- TResEvalEnum(LeftValue).ElType as TPasEnumType,
- TResEvalEnum(LeftValue).Index,TResEvalEnum(RightValue).Index);
- exit;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- revkString,
- {$endif}
- revkUnicodeString:
- begin
- LeftInt:=StringToOrd(LeftValue,Expr.left);
- if RightValue.Kind in revkAllStrings then
- begin
- RightInt:=StringToOrd(RightValue,Expr.right);
- if LeftInt>RightInt then
- RaiseMsg(20170523151508,nHighRangeLimitLTLowRangeLimit,
- sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
- Result:=TResEvalRangeInt.CreateValue(revskChar,nil,LeftInt,RightInt);
- exit;
- end
- else
- RaiseRangeCheck(20170522123106,Expr.Right);
- end
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryRangeExpr Left=',GetObjName(Expr.Left),' LeftValue.Kind=',LeftValue.Kind);
- RaiseNotYetImplemented(20170518221103,Expr.Left);
- {$ENDIF}
- end;
- end;
- function TResExprEvaluator.EvalBinaryAddExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- procedure IntAddUInt(const i: TMaxPrecInt; const u: TMaxPrecUInt);
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- begin
- if (i>=0) then
- begin
- UInt:=TMaxPrecUInt(i)+u;
- Result:=CreateResEvalInt(UInt);
- end
- else if u<=HighIntAsUInt then
- begin
- Int:=i + TMaxPrecInt(u);
- Result:=TResEvalInt.CreateValue(Int);
- end
- else
- RaiseRangeCheck(20170601140523,Expr);
- end;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- Flo: TMaxPrecFloat;
- aCurrency: TMaxPrecCurrency;
- LeftSet, RightSet: TResEvalSet;
- i: Integer;
- begin
- Result:=nil;
- try
- {$Q+} // enable overflow and range checks
- {$R+}
- case LeftValue.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(LeftValue).Int;
- case RightValue.Kind of
- revkInt: // int + int
- if (Int>0) and (TResEvalInt(RightValue).Int>0) then
- begin
- UInt:=TMaxPrecUInt(Int)+TMaxPrecUInt(TResEvalInt(RightValue).Int);
- Result:=CreateResEvalInt(UInt);
- end
- else
- begin
- Int:=Int + TResEvalInt(RightValue).Int;
- Result:=TResEvalInt.CreateValue(Int);
- end;
- revkUInt: // int + uint
- IntAddUInt(Int,TResEvalUInt(RightValue).UInt);
- revkFloat: // int + float
- Result:=TResEvalFloat.CreateValue(Int + TResEvalFloat(RightValue).FloatValue);
- revkCurrency: // int + currency
- Result:=TResEvalCurrency.CreateValue(Int + TResEvalCurrency(RightValue).Value);
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryAddExpr int+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170525115537,Expr);
- end;
- end;
- revkUInt:
- begin
- UInt:=TResEvalUInt(LeftValue).UInt;
- case RightValue.Kind of
- revkInt: // uint + int
- IntAddUInt(UInt,TResEvalInt(RightValue).Int);
- revkUInt: // uint + uint
- begin
- UInt:=UInt+TResEvalUInt(RightValue).UInt;
- Result:=TResEvalUInt.CreateValue(UInt);
- end;
- revkFloat: // uint + float
- Result:=TResEvalFloat.CreateValue(UInt + TResEvalFloat(RightValue).FloatValue);
- revkCurrency: // uint + currency
- Result:=TResEvalCurrency.CreateValue(UInt + TResEvalCurrency(RightValue).Value);
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryAddExpr uint+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170601141031,Expr);
- end;
- end;
- revkFloat:
- begin
- Flo:=TResEvalFloat(LeftValue).FloatValue;
- case RightValue.Kind of
- revkInt: // float + int
- Result:=TResEvalFloat.CreateValue(Flo + TResEvalInt(RightValue).Int);
- revkUInt: // float + uint
- Result:=TResEvalFloat.CreateValue(Flo + TResEvalUInt(RightValue).UInt);
- revkFloat: // float + float
- Result:=TResEvalFloat.CreateValue(Flo + TResEvalFloat(RightValue).FloatValue);
- revkCurrency: // float + Currency
- Result:=TResEvalCurrency.CreateValue(Flo + TResEvalCurrency(RightValue).Value);
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryAddExpr float+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711145637,Expr);
- end;
- end;
- revkCurrency:
- begin
- aCurrency:=TResEvalCurrency(LeftValue).Value;
- case RightValue.Kind of
- revkInt: // currency + int
- Result:=TResEvalFloat.CreateValue(aCurrency + TResEvalInt(RightValue).Int);
- revkUInt: // currency + uint
- Result:=TResEvalFloat.CreateValue(aCurrency + TResEvalUInt(RightValue).UInt);
- revkFloat: // currency + float
- Result:=TResEvalFloat.CreateValue(aCurrency + TResEvalFloat(RightValue).FloatValue);
- revkCurrency: // currency + currency
- Result:=TResEvalCurrency.CreateValue(aCurrency + TResEvalCurrency(RightValue).Value);
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryAddExpr currency+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20180421163819,Expr);
- end;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- revkString,
- {$endif}
- revkUnicodeString:
- Result:=EvalStringAddExpr(Expr,Expr.left,Expr.right,LeftValue,RightValue);
- revkSetOfInt:
- case RightValue.Kind of
- revkSetOfInt:
- begin
- // union
- LeftSet:=TResEvalSet(LeftValue);
- RightSet:=TResEvalSet(RightValue);
- if LeftSet.ElKind=revskNone then
- Result:=RightSet.Clone
- else if RightSet.ElKind=revskNone then
- Result:=LeftSet.Clone
- else
- begin
- Result:=RightSet.Clone;
- // add elements of left
- for i:=0 to length(LeftSet.Ranges)-1 do
- begin
- Int:=LeftSet.Ranges[i].RangeStart;
- while Int<=LeftSet.Ranges[i].RangeEnd do
- begin
- TResEvalSet(Result).Add(Int,Int);
- inc(Int);
- end;
- end;
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryMulExpr add set+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714114055,Expr);
- end
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryAddExpr ?+ Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170525115548,Expr);
- end;
- except
- on EOverflow do
- RaiseOverflowArithmetic(20170601140130,Expr);
- on ERangeError do
- RaiseRangeCheck(20170601140132,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinarySubExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- Flo: TMaxPrecFloat;
- aCurrency: TMaxPrecCurrency;
- LeftSet, RightSet: TResEvalSet;
- i: Integer;
- begin
- Result:=nil;
- case LeftValue.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(LeftValue).Int;
- case RightValue.Kind of
- revkInt:
- // int - int
- try
- {$Q+}
- Int:=Int - TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- on E: EOverflow do
- if (Int>0) and (TResEvalInt(RightValue).Int<0) then
- begin
- UInt:=TMaxPrecUInt(Int)+TMaxPrecUInt(-TResEvalInt(RightValue).Int);
- Result:=CreateResEvalInt(UInt);
- end
- else
- RaiseOverflowArithmetic(20170525230247,Expr);
- end;
- revkUInt:
- // int - uint
- try
- {$Q+}
- Int:=Int - TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151201,Expr);
- end;
- revkFloat:
- // int - float
- try
- {$Q+}
- Flo:=TMaxPrecFloat(Int) - TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151313,Expr);
- end;
- revkCurrency:
- // int - currency
- try
- {$Q+}
- aCurrency:=TMaxPrecCurrency(Int) - TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164011,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySubExpr sub int-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170525230028,Expr);
- end;
- end;
- revkUInt:
- begin
- UInt:=TResEvalUInt(LeftValue).UInt;
- case RightValue.Kind of
- revkInt:
- // uint - int
- try
- {$Q+}
- UInt:=UInt - TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalUInt.CreateValue(UInt);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151405,Expr);
- end;
- revkUInt:
- // uint - uint
- try
- {$Q+}
- UInt:=UInt - TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalUInt.CreateValue(UInt);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151419,Expr);
- end;
- revkFloat:
- // uint - float
- try
- {$Q+}
- Flo:=TMaxPrecFloat(UInt) - TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151428,Expr);
- end;
- revkCurrency:
- // uint - currency
- try
- {$Q+}
- aCurrency:=TMaxPrecCurrency(UInt) - TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164005,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySubExpr sub uint-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711151435,Expr);
- end;
- end;
- revkFloat:
- begin
- Flo:=TResEvalFloat(LeftValue).FloatValue;
- case RightValue.Kind of
- revkInt:
- // float - int
- try
- {$Q+}
- Flo:=Flo - TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151519,Expr);
- end;
- revkUInt:
- // float - uint
- try
- {$Q+}
- Flo:=Flo - TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151538,Expr);
- end;
- revkFloat:
- // float - float
- try
- {$Q+}
- Flo:=Flo - TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711151552,Expr);
- end;
- revkCurrency:
- // float - currency
- try
- {$Q+}
- aCurrency:=Flo - TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164054,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySubExpr sub float-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711151600,Expr);
- end;
- end;
- revkCurrency:
- begin
- aCurrency:=TResEvalCurrency(LeftValue).Value;
- case RightValue.Kind of
- revkInt:
- // currency - int
- try
- {$Q+}
- aCurrency:=aCurrency - TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164200,Expr);
- end;
- revkUInt:
- // currency - uint
- try
- {$Q+}
- aCurrency:=aCurrency - TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164218,Expr);
- end;
- revkFloat:
- // currency - float
- try
- {$Q+}
- aCurrency:=aCurrency - TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164250,Expr);
- end;
- revkCurrency:
- // currency - currency
- try
- {$Q+}
- aCurrency:=aCurrency - TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164258,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySubExpr sub currency-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20180421164312,Expr);
- end;
- end;
- revkSetOfInt:
- case RightValue.Kind of
- revkSetOfInt:
- begin
- // difference
- LeftSet:=TResEvalSet(LeftValue);
- RightSet:=TResEvalSet(RightValue);
- if LeftSet.ElKind=revskNone then
- Result:=TResEvalSet.CreateEmptySameKind(RightSet)
- else
- begin
- Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
- // add elements, which exists only in LeftSet
- for i:=0 to length(LeftSet.Ranges)-1 do
- begin
- Int:=LeftSet.Ranges[i].RangeStart;
- while Int<=LeftSet.Ranges[i].RangeEnd do
- begin
- if RightSet.IndexOfRange(Int)<0 then
- TResEvalSet(Result).Add(Int,Int);
- inc(Int);
- end;
- end;
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySubExpr sub set-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714114101,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySubExpr sub ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170525225946,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryMulExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- Flo: TMaxPrecFloat;
- aCurrency: TMaxPrecCurrency;
- LeftSet, RightSet: TResEvalSet;
- i: Integer;
- begin
- Result:=nil;
- case LeftValue.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(LeftValue).Int;
- case RightValue.Kind of
- revkInt:
- // int * int
- try
- {$Q+}
- Int:=Int * TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- on E: EOverflow do
- if (Int>0) and (TResEvalInt(RightValue).Int>0) then
- try
- // try uint*uint
- {$Q+}
- UInt:=TMaxPrecUInt(Int) * TMaxPrecUInt(TResEvalInt(RightValue).Int);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=CreateResEvalInt(UInt);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170530101616,Expr);
- end
- else
- RaiseOverflowArithmetic(20170525230247,Expr);
- end;
- revkUInt:
- // int * uint
- try
- {$Q+}
- Int:=Int * TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- RaiseOverflowArithmetic(20170711164445,Expr);
- end;
- revkFloat:
- // int * float
- try
- {$Q+}
- Flo:=Int * TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170711164541,Expr);
- end;
- revkCurrency:
- // int * currency
- try
- {$Q+}
- aCurrency:=Int * TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421164426,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryMulExpr mul int*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170525230028,Expr);
- end;
- end;
- revkUInt:
- begin
- UInt:=TResEvalUInt(LeftValue).UInt;
- case RightValue.Kind of
- revkInt:
- // uint * int
- if TResEvalInt(RightValue).Int>=0 then
- try
- {$Q+}
- UInt:=UInt * TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalUInt.CreateValue(UInt);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711164714,Expr);
- end
- else
- try
- {$Q+}
- Int:=UInt * TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711164736,Expr);
- end;
- revkUInt:
- // uint * uint
- try
- {$Q+}
- UInt:=UInt * TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalUInt.CreateValue(UInt);
- except
- RaiseOverflowArithmetic(20170711164751,Expr);
- end;
- revkFloat:
- // uint * float
- try
- {$Q+}
- Flo:=UInt * TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170711164800,Expr);
- end;
- revkCurrency:
- // uint * currency
- try
- {$Q+}
- aCurrency:=UInt * TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421164500,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryMulExpr mul uint*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711164810,Expr);
- end;
- end;
- revkFloat:
- begin
- Flo:=TResEvalFloat(LeftValue).FloatValue;
- case RightValue.Kind of
- revkInt:
- // float * int
- try
- {$Q+}
- Flo:=Flo * TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20170711164920,Expr);
- end;
- revkUInt:
- // float * uint
- try
- {$Q+}
- Flo:=Flo * TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170711164940,Expr);
- end;
- revkFloat:
- // float * float
- try
- {$Q+}
- Flo:=Flo * TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170711164955,Expr);
- end;
- revkCurrency:
- // float * currency
- try
- {$Q+}
- Flo:=Flo * TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20180421164542,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryMulExpr mul float*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711165004,Expr);
- end;
- end;
- revkCurrency:
- begin
- aCurrency:=TResEvalCurrency(LeftValue).Value;
- case RightValue.Kind of
- revkInt:
- // currency * int
- try
- {$Q+}
- aCurrency:=aCurrency * TResEvalInt(RightValue).Int;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- on E: EOverflow do
- RaiseOverflowArithmetic(20180421164636,Expr);
- end;
- revkUInt:
- // currency * uint
- try
- {$Q+}
- aCurrency:=aCurrency * TResEvalUInt(RightValue).UInt;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421164654,Expr);
- end;
- revkFloat:
- // currency * float
- try
- {$Q+}
- Flo:=aCurrency * TResEvalFloat(RightValue).FloatValue;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20180421164718,Expr);
- end;
- revkCurrency:
- // currency * currency
- try
- {$Q+}
- aCurrency:=aCurrency * TResEvalCurrency(RightValue).Value;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421164806,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryMulExpr mul currency*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20180421164817,Expr);
- end;
- end;
- revkSetOfInt:
- case RightValue.Kind of
- revkSetOfInt:
- begin
- // intersect
- LeftSet:=TResEvalSet(LeftValue);
- RightSet:=TResEvalSet(RightValue);
- if LeftSet.ElKind=revskNone then
- Result:=TResEvalSet.CreateEmptySameKind(RightSet)
- else
- begin
- Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
- // add elements, which exists in both
- for i:=0 to length(LeftSet.Ranges)-1 do
- begin
- Int:=LeftSet.Ranges[i].RangeStart;
- while Int<=LeftSet.Ranges[i].RangeEnd do
- begin
- if RightSet.IndexOfRange(Int)>=0 then
- TResEvalSet(Result).Add(Int,Int);
- inc(Int);
- end;
- end;
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryMulExpr mul set*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714110420,Expr);
- end
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryMulExpr mul ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170525225946,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryDivideExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- Flo: TMaxPrecFloat;
- aCurrency: TMaxPrecCurrency;
- begin
- Result:=nil;
- case LeftValue.Kind of
- revkInt:
- begin
- Int:=TResEvalInt(LeftValue).Int;
- case RightValue.Kind of
- revkInt:
- // int / int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170711143925,Expr)
- else
- Result:=TResEvalFloat.CreateValue(Int / TResEvalInt(RightValue).Int);
- revkUInt:
- // int / uint
- if TResEvalUInt(RightValue).UInt=0 then
- RaiseDivByZero(20170711144013,Expr)
- else
- Result:=TResEvalFloat.CreateValue(Int / TResEvalUInt(RightValue).UInt);
- revkFloat:
- begin
- // int / float
- try
- Flo:=Int / TResEvalFloat(RightValue).FloatValue;
- except
- RaiseMsg(20170711144525,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalFloat.CreateValue(Flo);
- end;
- revkCurrency:
- begin
- // int / currency
- try
- aCurrency:=Int / TResEvalCurrency(RightValue).Value;
- except
- RaiseMsg(20180421164915,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivideExpr int / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711144057,Expr);
- end;
- end;
- revkUInt:
- begin
- UInt:=TResEvalUInt(LeftValue).UInt;
- case RightValue.Kind of
- revkInt:
- // uint / int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170711144103,Expr)
- else
- Result:=TResEvalFloat.CreateValue(UInt / TResEvalInt(RightValue).Int);
- revkUInt:
- // uint / uint
- if TResEvalUInt(RightValue).UInt=0 then
- RaiseDivByZero(20170711144203,Expr)
- else
- Result:=TResEvalFloat.CreateValue(UInt / TResEvalUInt(RightValue).UInt);
- revkFloat:
- begin
- // uint / float
- try
- Flo:=UInt / TResEvalFloat(RightValue).FloatValue;
- except
- RaiseMsg(20170711144912,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalFloat.CreateValue(Flo);
- end;
- revkCurrency:
- begin
- // uint / currency
- try
- aCurrency:=UInt / TResEvalCurrency(RightValue).Value;
- except
- RaiseMsg(20180421164959,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivideExpr uint / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711144239,Expr);
- end;
- end;
- revkFloat:
- begin
- Flo:=TResEvalFloat(LeftValue).FloatValue;
- case RightValue.Kind of
- revkInt:
- // float / int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170711144954,Expr)
- else
- Result:=TResEvalFloat.CreateValue(Flo / TResEvalInt(RightValue).Int);
- revkUInt:
- // float / uint
- if TResEvalUInt(RightValue).UInt=0 then
- RaiseDivByZero(20170711145023,Expr)
- else
- Result:=TResEvalFloat.CreateValue(Flo / TResEvalUInt(RightValue).UInt);
- revkFloat:
- begin
- // float / float
- try
- Flo:=Flo / TResEvalFloat(RightValue).FloatValue;
- except
- RaiseMsg(20170711145040,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalFloat.CreateValue(Flo);
- end;
- revkCurrency:
- begin
- // float / currency
- try
- aCurrency:=Flo / TResEvalCurrency(RightValue).Value;
- except
- RaiseMsg(20180421165058,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivideExpr float / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711145050,Expr);
- end;
- end;
- revkCurrency:
- begin
- aCurrency:=TResEvalCurrency(LeftValue).Value;
- case RightValue.Kind of
- revkInt:
- // currency / int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20180421165154,Expr)
- else
- Result:=TResEvalCurrency.CreateValue(aCurrency / TResEvalInt(RightValue).Int);
- revkUInt:
- // currency / uint
- if TResEvalUInt(RightValue).UInt=0 then
- RaiseDivByZero(20180421165205,Expr)
- else
- Result:=TResEvalCurrency.CreateValue(aCurrency / TResEvalUInt(RightValue).UInt);
- revkFloat:
- begin
- // currency / float
- try
- aCurrency:=aCurrency / TResEvalFloat(RightValue).FloatValue;
- except
- RaiseMsg(20180421165237,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- end;
- revkCurrency:
- begin
- // currency / currency
- try
- aCurrency:=aCurrency / TResEvalCurrency(RightValue).Value;
- except
- RaiseMsg(20180421165252,nDivByZero,sDivByZero,[],Expr);
- end;
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivideExpr currency / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20180421165301,Expr);
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivExpr div ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530102352,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryDivExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- begin
- Result:=nil;
- case LeftValue.Kind of
- revkInt:
- case RightValue.Kind of
- revkInt:
- // int div int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170530102619,Expr)
- else
- begin
- Int:=TResEvalInt(LeftValue).Int div TResEvalInt(RightValue).Int;
- Result:=TResEvalInt.CreateValue(Int);
- end;
- revkUInt:
- // int div uint
- if TResEvalUInt(RightValue).UInt=0 then
- RaiseDivByZero(20170530102745,Expr)
- else
- begin
- if TResEvalUInt(RightValue).UInt>HighIntAsUInt then
- Int:=0
- else
- Int:=TResEvalInt(LeftValue).Int div TResEvalUInt(RightValue).UInt;
- Result:=TResEvalInt.CreateValue(Int);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivExpr int div ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530102403,Expr);
- end;
- revkUInt:
- case RightValue.Kind of
- revkInt:
- // uint div int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170530103026,Expr)
- else if TResEvalUInt(LeftValue).UInt<=HighIntAsUInt then
- begin
- Int:=TMaxPrecInt(TResEvalUInt(LeftValue).UInt) div TResEvalInt(RightValue).Int;
- Result:=TResEvalInt.CreateValue(Int);
- end
- else if TResEvalInt(RightValue).Int>0 then
- begin
- UInt:=TResEvalUInt(LeftValue).UInt div TMaxPrecUInt(TResEvalInt(RightValue).Int);
- Result:=CreateResEvalInt(UInt);
- end
- else
- RaiseOverflowArithmetic(20170530104315,Expr);
- revkUInt:
- // uint div uint
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170530103026,Expr)
- else
- begin
- UInt:=TResEvalUInt(LeftValue).UInt div TResEvalUInt(RightValue).UInt;
- Result:=CreateResEvalInt(UInt);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivExpr uint div ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530102403,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryDivExpr div ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530102352,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryModExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- begin
- Result:=nil;
- case LeftValue.Kind of
- revkInt:
- case RightValue.Kind of
- revkInt:
- // int mod int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170530104638,Expr)
- else
- begin
- Int:=TResEvalInt(LeftValue).Int mod TResEvalInt(RightValue).Int;
- Result:=TResEvalInt.CreateValue(Int);
- end;
- revkUInt:
- // int mod uint
- if TResEvalUInt(RightValue).UInt=0 then
- RaiseDivByZero(20170530104758,Expr)
- else
- begin
- if TResEvalInt(LeftValue).Int<0 then
- UInt:=TMaxPrecUInt(-TResEvalInt(LeftValue).Int) mod TResEvalUInt(RightValue).UInt
- else
- UInt:=TMaxPrecUInt(TResEvalInt(LeftValue).Int) mod TResEvalUInt(RightValue).UInt;
- Result:=CreateResEvalInt(UInt);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryModExpr int mod ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530110057,Expr);
- end;
- revkUInt:
- case RightValue.Kind of
- revkInt:
- // uint mod int
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170530110110,Expr)
- else if TResEvalUInt(LeftValue).UInt<=HighIntAsUInt then
- begin
- Int:=TMaxPrecInt(TResEvalUInt(LeftValue).UInt) mod TResEvalInt(RightValue).Int;
- Result:=TResEvalInt.CreateValue(Int);
- end
- else if TResEvalInt(RightValue).Int>0 then
- begin
- UInt:=TResEvalUInt(LeftValue).UInt mod TMaxPrecUInt(TResEvalInt(RightValue).Int);
- Result:=CreateResEvalInt(UInt);
- end
- else
- RaiseOverflowArithmetic(20170530110602,Expr);
- revkUInt:
- // uint div uint
- if TResEvalInt(RightValue).Int=0 then
- RaiseDivByZero(20170530110609,Expr)
- else
- begin
- UInt:=TResEvalUInt(LeftValue).UInt mod TResEvalUInt(RightValue).UInt;
- Result:=CreateResEvalInt(UInt);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryModExpr uint mod ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530110633,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryModExpr mod ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530110644,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryShiftExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- ShiftLeft: Boolean;
- begin
- Result:=nil;
- ShiftLeft:=Expr.OpCode=eopShl;
- case LeftValue.Kind of
- revkInt:
- case RightValue.Kind of
- revkInt:
- // int shl int
- begin
- if (TResEvalInt(RightValue).Int<0) or (TResEvalInt(RightValue).Int>63) then
- EmitRangeCheckConst(20170530203840,IntToStr(TResEvalInt(RightValue).Int),0,63,Expr);
- if ShiftLeft then
- Int:=TResEvalInt(LeftValue).Int shl byte(TResEvalInt(RightValue).Int)
- else
- Int:=TResEvalInt(LeftValue).Int shr byte(TResEvalInt(RightValue).Int);
- Result:=TResEvalInt.CreateValue(Int);
- end;
- revkUInt:
- // int shl uint
- begin
- if (TResEvalUInt(RightValue).UInt>63) then
- EmitRangeCheckConst(20170530203840,IntToStr(TResEvalUInt(RightValue).UInt),0,63,Expr);
- if ShiftLeft then
- Int:=TResEvalInt(LeftValue).Int shl byte(TResEvalUInt(RightValue).UInt)
- else
- Int:=TResEvalInt(LeftValue).Int shr byte(TResEvalUInt(RightValue).UInt);
- Result:=TResEvalInt.CreateValue(Int);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryModExpr int shl/shr ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530205332,Expr);
- end;
- revkUInt:
- case RightValue.Kind of
- revkInt:
- // uint shl int
- begin
- if (TResEvalInt(RightValue).Int<0) or (TResEvalInt(RightValue).Int>63) then
- EmitRangeCheckConst(20170530205414,IntToStr(TResEvalInt(RightValue).Int),0,63,Expr);
- if ShiftLeft then
- UInt:=TResEvalUInt(LeftValue).UInt shl byte(TResEvalInt(RightValue).Int)
- else
- UInt:=TResEvalUInt(LeftValue).UInt shr byte(TResEvalInt(RightValue).Int);
- Result:=CreateResEvalInt(UInt);
- end;
- revkUInt:
- // uint shl uint
- begin
- if (TResEvalUInt(RightValue).UInt>63) then
- EmitRangeCheckConst(20170530205601,IntToStr(TResEvalUInt(RightValue).UInt),0,63,Expr);
- if ShiftLeft then
- UInt:=TResEvalUInt(LeftValue).UInt shl byte(TResEvalUInt(RightValue).UInt)
- else
- UInt:=TResEvalUInt(LeftValue).UInt shr byte(TResEvalUInt(RightValue).UInt);
- Result:=CreateResEvalInt(UInt);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryShiftExpr uint shl/shr ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530205640,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryShiftExpr shl/shr ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530205646,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryBoolOpExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- // AND, OR, XOR
- begin
- Result:=nil;
- case LeftValue.Kind of
- revkBool:
- case RightValue.Kind of
- revkBool:
- begin
- // logical and/or/xor
- Result:=TResEvalBool.Create;
- case Expr.OpCode of
- eopAnd: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B and TResEvalBool(RightValue).B;
- eopOr: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B or TResEvalBool(RightValue).B;
- eopXor: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B xor TResEvalBool(RightValue).B;
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryBoolOpExpr bool ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170531011502,Expr);
- end;
- revkInt:
- case RightValue.Kind of
- revkInt:
- begin
- // bitwise and/or/xor
- Result:=TResEvalInt.Create;
- case Expr.OpCode of
- eopAnd: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int and TResEvalInt(RightValue).Int;
- eopOr: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int or TResEvalInt(RightValue).Int;
- eopXor: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int xor TResEvalInt(RightValue).Int;
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryBoolOpExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530211140,Expr);
- end;
- revkUInt:
- case RightValue.Kind of
- revkUInt:
- begin
- // bitwise and/or/xor
- Result:=TResEvalUInt.Create;
- case Expr.OpCode of
- eopAnd: TResEvalUInt(Result).UInt:=TResEvalUInt(LeftValue).UInt and TResEvalUInt(RightValue).UInt;
- eopOr: TResEvalUInt(Result).UInt:=TResEvalUInt(LeftValue).UInt or TResEvalUInt(RightValue).UInt;
- eopXor: TResEvalUInt(Result).UInt:=TResEvalUInt(LeftValue).UInt xor TResEvalUInt(RightValue).UInt;
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryBoolOpExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530211140,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryBoolOpExpr ',Expr.OpCode,' ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530205938,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryNEqualExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- UInt: TMaxPrecUInt;
- LeftSet, RightSet: TResEvalSet;
- i: Integer;
- begin
- Result:=TResEvalBool.Create;
- try
- {$Q+}
- {$R+}
- case LeftValue.Kind of
- revkBool:
- case RightValue.Kind of
- revkBool:
- TResEvalBool(Result).B:=TResEvalBool(LeftValue).B=TResEvalBool(RightValue).B;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr bool ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170531011937,Expr);
- end;
- revkInt:
- case RightValue.Kind of
- revkInt:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalInt(RightValue).Int;
- revkUInt:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalUInt(RightValue).UInt;
- revkFloat:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalFloat(RightValue).FloatValue;
- revkCurrency:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalCurrency(RightValue).Value;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170531012412,Expr);
- end;
- revkUInt:
- begin
- UInt:=TResEvalUInt(LeftValue).UInt;
- case RightValue.Kind of
- revkInt:
- TResEvalBool(Result).B:=(UInt<=HighIntAsUInt)
- and (TMaxPrecInt(UInt)=TResEvalInt(RightValue).Int);
- revkUInt:
- TResEvalBool(Result).B:=UInt=TResEvalUInt(RightValue).UInt;
- revkFloat:
- TResEvalBool(Result).B:=UInt=TResEvalFloat(RightValue).FloatValue;
- revkCurrency:
- TResEvalBool(Result).B:=UInt=TResEvalCurrency(RightValue).Value;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr uint ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170601122803,Expr);
- end;
- end;
- revkFloat:
- case RightValue.Kind of
- revkInt:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalInt(RightValue).Int;
- revkUInt:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalUInt(RightValue).UInt;
- revkFloat:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalFloat(RightValue).FloatValue;
- revkCurrency:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalCurrency(RightValue).Value;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr float ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170601122806,Expr);
- end;
- revkCurrency:
- case RightValue.Kind of
- revkInt:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalInt(RightValue).Int;
- revkUInt:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalUInt(RightValue).UInt;
- revkFloat:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalFloat(RightValue).FloatValue;
- revkCurrency:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalCurrency(RightValue).Value;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr currency ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20180421165438,Expr);
- end;
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- case RightValue.Kind of
- revkString:
- if GetCodePage(TResEvalString(LeftValue).S)=GetCodePage(TResEvalString(RightValue).S) then
- TResEvalBool(Result).B:=TResEvalString(LeftValue).S=TResEvalString(RightValue).S
- else
- TResEvalBool(Result).B:=GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left)
- =GetUnicodeStr(TResEvalString(RightValue).S,Expr.right);
- revkUnicodeString:
- TResEvalBool(Result).B:=GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left)
- =TResEvalUTF16(RightValue).S;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr string ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170711175409,Expr);
- end;
- {$endif}
- revkUnicodeString:
- case RightValue.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- TResEvalBool(Result).B:=TResEvalUTF16(LeftValue).S
- =GetUnicodeStr(TResEvalString(RightValue).S,Expr.right);
- {$endif}
- revkUnicodeString:
- TResEvalBool(Result).B:=TResEvalUTF16(LeftValue).S
- =TResEvalUTF16(RightValue).S;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr string ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170711175409,Expr);
- end;
- revkSetOfInt:
- case RightValue.Kind of
- revkSetOfInt:
- begin
- LeftSet:=TResEvalSet(LeftValue);
- RightSet:=TResEvalSet(RightValue);
- if LeftSet.ElKind=revskNone then
- TResEvalBool(Result).B:=length(RightSet.Ranges)=0
- else if RightSet.ElKind=revskNone then
- TResEvalBool(Result).B:=length(LeftSet.Ranges)=0
- else if length(LeftSet.Ranges)<>length(RightSet.Ranges) then
- TResEvalBool(Result).B:=false
- else
- begin
- TResEvalBool(Result).B:=true;
- for i:=0 to length(LeftSet.Ranges)-1 do
- if (LeftSet.Ranges[i].RangeStart<>RightSet.Ranges[i].RangeStart)
- or (LeftSet.Ranges[i].RangeEnd<>RightSet.Ranges[i].RangeEnd) then
- begin
- TResEvalBool(Result).B:=false;
- break;
- end;
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr ',Expr.OpCode,' set=? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714120756,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryNEqualExpr ',Expr.OpCode,' ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170531011931,Expr);
- end;
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- except
- on EOverflow do
- RaiseOverflowArithmetic(20170601132729,Expr);
- on ERangeError do
- RaiseRangeCheck(20170601132740,Expr);
- end;
- if Expr.OpCode=eopNotEqual then
- TResEvalBool(Result).B:=not TResEvalBool(Result).B;
- end;
- function TResExprEvaluator.EvalBinaryLessGreaterExpr(Expr: TBinaryExpr;
- LeftValue, RightValue: TResEvalValue): TResEvalValue;
- procedure CmpUnicode(const LeftUnicode, RightUnicode: UnicodeString);
- begin
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=LeftUnicode < RightUnicode;
- eopGreaterThan:
- TResEvalBool(Result).B:=LeftUnicode > RightUnicode;
- eopLessthanEqual:
- TResEvalBool(Result).B:=LeftUnicode <= RightUnicode;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=LeftUnicode >= RightUnicode;
- end;
- end;
- var
- LeftSet, RightSet: TResEvalSet;
- i: Integer;
- Int: TMaxPrecInt;
- begin
- Result:=TResEvalBool.Create;
- try
- {$Q+}
- {$R+}
- case LeftValue.Kind of
- revkInt:
- case RightValue.Kind of
- revkInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalInt(RightValue).Int;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalInt(RightValue).Int;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalInt(RightValue).Int;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalInt(RightValue).Int;
- end;
- revkUInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalUInt(RightValue).UInt;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalUInt(RightValue).UInt;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalUInt(RightValue).UInt;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalUInt(RightValue).UInt;
- end;
- revkFloat:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalFloat(RightValue).FloatValue;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalFloat(RightValue).FloatValue;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalFloat(RightValue).FloatValue;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalFloat(RightValue).FloatValue;
- end;
- revkCurrency:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalCurrency(RightValue).Value;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalCurrency(RightValue).Value;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalCurrency(RightValue).Value;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalCurrency(RightValue).Value;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170601122512,Expr);
- end;
- revkUInt:
- case RightValue.Kind of
- revkInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalInt(RightValue).Int;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalInt(RightValue).Int;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalInt(RightValue).Int;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalInt(RightValue).Int;
- end;
- revkUInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalUInt(RightValue).UInt;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalUInt(RightValue).UInt;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalUInt(RightValue).UInt;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalUInt(RightValue).UInt;
- end;
- revkFloat:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalFloat(RightValue).FloatValue;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalFloat(RightValue).FloatValue;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalFloat(RightValue).FloatValue;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalFloat(RightValue).FloatValue;
- end;
- revkCurrency:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalCurrency(RightValue).Value;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalCurrency(RightValue).Value;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalCurrency(RightValue).Value;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalCurrency(RightValue).Value;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr uint ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170601133222,Expr);
- end;
- revkFloat:
- case RightValue.Kind of
- revkInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalInt(RightValue).Int;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalInt(RightValue).Int;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalInt(RightValue).Int;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalInt(RightValue).Int;
- end;
- revkUInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalUInt(RightValue).UInt;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalUInt(RightValue).UInt;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalUInt(RightValue).UInt;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalUInt(RightValue).UInt;
- end;
- revkFloat:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalFloat(RightValue).FloatValue;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalFloat(RightValue).FloatValue;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalFloat(RightValue).FloatValue;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalFloat(RightValue).FloatValue;
- end;
- revkCurrency:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalCurrency(RightValue).Value;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalCurrency(RightValue).Value;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalCurrency(RightValue).Value;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalCurrency(RightValue).Value;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr float ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170601133421,Expr);
- end;
- revkCurrency:
- case RightValue.Kind of
- revkInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalInt(RightValue).Int;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalInt(RightValue).Int;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalInt(RightValue).Int;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalInt(RightValue).Int;
- end;
- revkUInt:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalUInt(RightValue).UInt;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalUInt(RightValue).UInt;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalUInt(RightValue).UInt;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalUInt(RightValue).UInt;
- end;
- revkFloat:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalFloat(RightValue).FloatValue;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalFloat(RightValue).FloatValue;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalFloat(RightValue).FloatValue;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalFloat(RightValue).FloatValue;
- end;
- revkCurrency:
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalCurrency(RightValue).Value;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalCurrency(RightValue).Value;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalCurrency(RightValue).Value;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalCurrency(RightValue).Value;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr currency ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20180421165752,Expr);
- end;
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- case RightValue.Kind of
- revkString:
- if GetCodePage(TResEvalString(LeftValue).S)=GetCodePage(TResEvalString(RightValue).S) then
- case Expr.OpCode of
- eopLessThan:
- TResEvalBool(Result).B:=TResEvalString(LeftValue).S < TResEvalString(RightValue).S;
- eopGreaterThan:
- TResEvalBool(Result).B:=TResEvalString(LeftValue).S > TResEvalString(RightValue).S;
- eopLessthanEqual:
- TResEvalBool(Result).B:=TResEvalString(LeftValue).S <= TResEvalString(RightValue).S;
- eopGreaterThanEqual:
- TResEvalBool(Result).B:=TResEvalString(LeftValue).S >= TResEvalString(RightValue).S;
- end
- else
- CmpUnicode(GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left),
- GetUnicodeStr(TResEvalString(RightValue).S,Expr.right));
- revkUnicodeString:
- CmpUnicode(GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left),
- TResEvalUTF16(RightValue).S);
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr string ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170711175629,Expr);
- end;
- {$endif}
- revkUnicodeString:
- case RightValue.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- CmpUnicode(TResEvalUTF16(LeftValue).S,
- GetUnicodeStr(TResEvalString(RightValue).S,Expr.right));
- {$endif}
- revkUnicodeString:
- CmpUnicode(TResEvalUTF16(LeftValue).S,TResEvalUTF16(RightValue).S);
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr unicodestring ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170711210730,Expr);
- end;
- revkSetOfInt:
- case RightValue.Kind of
- revkSetOfInt:
- begin
- LeftSet:=TResEvalSet(LeftValue);
- RightSet:=TResEvalSet(RightValue);
- case Expr.OpCode of
- eopGreaterThanEqual:
- begin
- // >= -> true if all elements of RightSet are in LeftSet
- TResEvalBool(Result).B:=true;
- for i:=0 to length(RightSet.Ranges)-1 do
- begin
- Int:=RightSet.Ranges[i].RangeStart;
- while Int<=RightSet.Ranges[i].RangeEnd do
- begin
- if LeftSet.IndexOfRange(Int)<0 then
- begin
- TResEvalBool(Result).B:=false;
- break;
- end;
- inc(Int);
- end;
- end;
- end;
- eopLessthanEqual:
- begin
- // <= -> true if all elements of LeftSet are in RightSet
- TResEvalBool(Result).B:=true;
- for i:=0 to length(LeftSet.Ranges)-1 do
- begin
- Int:=LeftSet.Ranges[i].RangeStart;
- while Int<=LeftSet.Ranges[i].RangeEnd do
- begin
- if RightSet.IndexOfRange(Int)<0 then
- begin
- TResEvalBool(Result).B:=false;
- break;
- end;
- inc(Int);
- end;
- end;
- end
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr set ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170714122121,Expr);
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr set ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170714121925,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr ? ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- Result.Free;
- RaiseNotYetImplemented(20170601122529,Expr);
- end;
- except
- on EOverflow do
- RaiseOverflowArithmetic(20170601132956,Expr);
- on ERangeError do
- RaiseRangeCheck(20170601132958,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinaryInExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- RightSet: TResEvalSet;
- Int: TMaxPrecInt;
- begin
- Result:=nil;
- case RightValue.Kind of
- revkSetOfInt:
- begin
- RightSet:=TResEvalSet(RightValue);
- case LeftValue.Kind of
- revkBool:
- Int:=ord(TResEvalBool(LeftValue).B);
- revkInt:
- Int:=TResEvalInt(LeftValue).Int;
- revkUInt:
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- if TResEvalUInt(LeftValue).UInt>HighIntAsUInt then
- RaiseMsg(20170714123700,nRangeCheckError,sRangeCheckError,[],Expr)
- else
- Int:=TResEvalUInt(LeftValue).UInt;
- {$ifdef FPC_HAS_CPSTRING}
- revkString,
- {$endif}
- revkUnicodeString:
- Int:=StringToOrd(LeftValue,Expr);
- revkEnum:
- Int:=TResEvalEnum(LeftValue).Index;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryInExpr ? in Set Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714123412,Expr);
- end;
- Result:=TResEvalBool.CreateValue(RightSet.IndexOfRange(Int)>=0);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryInExpr ? ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714123409,Expr);
- end;
- end;
- function TResExprEvaluator.EvalBinarySymmetricaldifferenceExpr(
- Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- var
- LeftSet, RightSet: TResEvalSet;
- i: Integer;
- Int: TMaxPrecInt;
- begin
- case LeftValue.Kind of
- revkSetOfInt:
- case RightValue.Kind of
- revkSetOfInt:
- begin
- // sym diff
- LeftSet:=TResEvalSet(LeftValue);
- RightSet:=TResEvalSet(RightValue);
- // elements, which exists in either, but not both
- if LeftSet.ElKind=revskNone then
- Result:=RightSet.Clone
- else
- begin
- Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
- for i:=0 to length(LeftSet.Ranges)-1 do
- begin
- Int:=LeftSet.Ranges[i].RangeStart;
- while Int<=LeftSet.Ranges[i].RangeEnd do
- begin
- if RightSet.IndexOfRange(Int)<0 then
- TResEvalSet(Result).Add(Int,Int);
- inc(Int);
- end;
- end;
- for i:=0 to length(RightSet.Ranges)-1 do
- begin
- Int:=RightSet.Ranges[i].RangeStart;
- while Int<=RightSet.Ranges[i].RangeEnd do
- begin
- if LeftSet.IndexOfRange(Int)<0 then
- TResEvalSet(Result).Add(Int,Int);
- inc(Int);
- end;
- end;
- end;
- end
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySymmetricaldifferenceExpr Set><? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714114144,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinarySymmetricaldifferenceExpr ? ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170714114119,Expr);
- end;
- end;
- function TResExprEvaluator.EvalParamsExpr(Expr: TParamsExpr;
- Flags: TResEvalFlags): TResEvalValue;
- begin
- Result:=OnEvalParams(Self,Expr,Flags);
- if Result<>nil then exit;
- case Expr.Kind of
- pekArrayParams: Result:=EvalArrayParamsExpr(Expr,Flags);
- pekSet: Result:=EvalSetParamsExpr(Expr,Flags);
- end;
- if Result=nil then
- begin
- if [refConst,refConstExt]*Flags<>[] then
- RaiseConstantExprExp(20170713124038,Expr);
- exit;
- end;
- end;
- function TResExprEvaluator.EvalArrayParamsExpr(Expr: TParamsExpr;
- Flags: TResEvalFlags): TResEvalValue;
- var
- ArrayValue, IndexValue: TResEvalValue;
- Int: TMaxPrecInt;
- Param0: TPasExpr;
- MaxIndex: Integer;
- begin
- Result:=nil;
- ArrayValue:=Eval(Expr.Value,Flags);
- if ArrayValue=nil then
- begin
- if [refConst,refConstExt]*Flags<>[] then
- RaiseConstantExprExp(20170711181321,Expr.Value);
- exit;
- end;
- IndexValue:=nil;
- try
- case ArrayValue.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString,
- {$endif}
- revkUnicodeString:
- begin
- // string[index]
- Param0:=Expr.Params[0];
- IndexValue:=Eval(Param0,Flags);
- if IndexValue=nil then
- begin
- if [refConst,refConstExt]*Flags<>[] then
- RaiseConstantExprExp(20170711181603,Param0);
- exit;
- end;
- case IndexValue.Kind of
- revkInt: Int:=TResEvalInt(IndexValue).Int;
- revkUInt:
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- if TResEvalUInt(IndexValue).UInt>HighIntAsUInt then
- RaiseRangeCheck(20170711182006,Param0)
- else
- Int:=TResEvalUInt(IndexValue).UInt;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalParamsExpr string[',IndexValue.AsDebugString,']');
- {$ENDIF}
- RaiseNotYetImplemented(20170711182100,Expr);
- end;
- {$ifdef FPC_HAS_CPSTRING}
- if ArrayValue.Kind=revkString then
- MaxIndex:=length(TResEvalString(ArrayValue).S)
- else
- {$endif}
- MaxIndex:=length(TResEvalUTF16(ArrayValue).S);
- if (Int<1) or (Int>MaxIndex) then
- EmitRangeCheckConst(20170711183058,IntToStr(Int),'1',IntToStr(MaxIndex),Param0,mtError);
- {$ifdef FPC_HAS_CPSTRING}
- if ArrayValue.Kind=revkString then
- Result:=TResEvalString.CreateValue(TResEvalString(ArrayValue).S[Int])
- else
- {$endif}
- Result:=TResEvalUTF16.CreateValue(TResEvalUTF16(ArrayValue).S[Int]);
- exit;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalParamsExpr Array=',ArrayValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711181507,Expr);
- end;
- if [refConst,refConstExt]*Flags<>[] then
- RaiseConstantExprExp(20170522173150,Expr);
- finally
- ReleaseEvalValue(ArrayValue);
- ReleaseEvalValue(IndexValue);
- end;
- end;
- function TResExprEvaluator.EvalSetParamsExpr(Expr: TParamsExpr;
- Flags: TResEvalFlags): TResEvalSet;
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.EvalSetParamsExpr length(Expr.Params)=',length(Expr.Params));
- {$ENDIF}
- Result:=EvalSetExpr(Expr,Expr.Params,Flags);
- end;
- function TResExprEvaluator.EvalSetExpr(Expr: TPasExpr;
- ExprArray: TPasExprArray; Flags: TResEvalFlags): TResEvalSet;
- var
- i: Integer;
- RangeStart, RangeEnd: TMaxPrecInt;
- Value: TResEvalValue;
- ok, OnlyConstElements: Boolean;
- El: TPasExpr;
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.EvalSetExpr Expr=',GetObjName(Expr),' length(ExprArray)=',length(ExprArray));
- {$ENDIF}
- Result:=TResEvalSet.Create;
- if Expr=nil then ;
- Value:=nil;
- OnlyConstElements:=true;
- ok:=false;
- try
- for i:=0 to length(ExprArray)-1 do
- begin
- El:=ExprArray[i];
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.EvalSetExpr ',i,' of ',length(ExprArray),' El=',GetObjName(El));
- {$ENDIF}
- Value:=Eval(El,Flags);
- if Value=nil then
- begin
- // element is not a const -> the set is not a const
- OnlyConstElements:=false;
- continue;
- end;
- {$IFDEF VerbosePasResEval}
- //writeln('TResExprEvaluator.EvalSetExpr ',i,' of ',length(ExprArray),' Value=',Value.AsDebugString);
- {$ENDIF}
- case Value.Kind of
- revkBool:
- begin
- if Result.ElKind=revskNone then
- Result.ElKind:=revskBool
- else if Result.ElKind<>revskBool then
- RaiseNotYetImplemented(20170714132843,El);
- RangeStart:=ord(TResEvalBool(Value).B);
- RangeEnd:=RangeStart;
- end;
- revkInt:
- begin
- if Result.ElKind=revskNone then
- Result.ElKind:=revskInt
- else if Result.ElKind<>revskInt then
- RaiseNotYetImplemented(20170713201208,El);
- RangeStart:=TResEvalInt(Value).Int;
- RangeEnd:=RangeStart;
- end;
- revkUInt:
- begin
- if Result.ElKind=revskNone then
- Result.ElKind:=revskInt
- else if Result.ElKind<>revskInt then
- RaiseNotYetImplemented(20170713201230,El)
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- else if TResEvalUInt(Value).UInt>HighIntAsUInt then
- EmitRangeCheckConst(20170713201306,Value.AsString,
- '0',IntToStr(High(TMaxPrecInt)),El,mtError);
- RangeStart:=TResEvalUInt(Value).UInt;
- RangeEnd:=RangeStart;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- begin
- if Result.ElKind=revskNone then
- Result.ElKind:=revskChar
- else if Result.ElKind<>revskChar then
- RaiseNotYetImplemented(20170713201456,El);
- RangeStart:=StringToOrd(Value,nil);
- if RangeStart>$ffff then
- begin
- // set of string (not of char)
- ReleaseEvalValue(TResEvalValue(Result));
- exit;
- end;
- RangeEnd:=RangeStart;
- end;
- {$endif}
- revkUnicodeString:
- begin
- if Result.ElKind=revskNone then
- Result.ElKind:=revskChar
- else if Result.ElKind<>revskChar then
- RaiseNotYetImplemented(20170713201516,El);
- if length(TResEvalUTF16(Value).S)<>1 then
- begin
- // set of string (not of char)
- ReleaseEvalValue(TResEvalValue(Result));
- exit;
- end;
- RangeStart:=ord(TResEvalUTF16(Value).S[1]);
- RangeEnd:=RangeStart;
- end;
- revkEnum:
- begin
- if Result.ElKind=revskNone then
- begin
- Result.ElKind:=revskEnum;
- Result.ElType:=Value.IdentEl.Parent as TPasEnumType;
- end
- else if Result.ElKind<>revskEnum then
- RaiseNotYetImplemented(20170713143559,El)
- else if Result.ElType<>TResEvalEnum(Value).ElType then
- RaiseNotYetImplemented(20170713201021,El);
- RangeStart:=TResEvalEnum(Value).Index;
- RangeEnd:=RangeStart;
- end;
- revkRangeInt:
- begin
- if Result.ElKind=revskNone then
- begin
- Result.ElKind:=TResEvalRangeInt(Value).ElKind;
- if Result.ElKind=revskEnum then
- Result.ElType:=TResEvalRangeInt(Value).ElType;
- end
- else if Result.ElKind<>TResEvalRangeInt(Value).ElKind then
- RaiseNotYetImplemented(20170714101910,El);
- RangeStart:=TResEvalRangeInt(Value).RangeStart;
- RangeEnd:=TResEvalRangeInt(Value).RangeEnd;
- end;
- revkRangeUInt:
- begin
- if Result.ElKind=revskNone then
- Result.ElKind:=revskInt
- else if Result.ElKind<>revskInt then
- RaiseNotYetImplemented(20170713202934,El)
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- else if TResEvalRangeUInt(Value).RangeEnd>HighIntAsUInt then
- EmitRangeCheckConst(20170713203034,Value.AsString,
- '0',IntToStr(High(TMaxPrecInt)),El,mtError);
- RangeStart:=TResEvalRangeUInt(Value).RangeStart;
- RangeEnd:=TResEvalRangeUInt(Value).RangeEnd;
- end
- else
- {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
- writeln('TResExprEvaluator.EvalSetExpr Result.ElKind=',Result.ElKind,' Value.Kind=',Value.Kind);
- {$ENDIF}
- RaiseNotYetImplemented(20170713143422,El);
- end;
- if Result.Intersects(RangeStart,RangeEnd)>=0 then
- begin
- {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
- writeln('TResExprEvaluator.EvalSetExpr Value=',Value.AsDebugString,' Range=',RangeStart,'..',RangeEnd,' Result=',Result.AsDebugString);
- {$ENDIF}
- RaiseMsg(20170714141326,nRangeCheckInSetConstructor,
- sRangeCheckInSetConstructor,[],El);
- end;
- Result.Add(RangeStart,RangeEnd);
- ReleaseEvalValue(Value);
- end;
- ok:=OnlyConstElements;
- finally
- ReleaseEvalValue(Value);
- if not ok then
- ReleaseEvalValue(TResEvalValue(Result));
- end;
- end;
- function TResExprEvaluator.EvalArrayValuesExpr(Expr: TArrayValues;
- Flags: TResEvalFlags): TResEvalSet;
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.EvalArrayValuesExpr length(Expr.Values)=',length(Expr.Values));
- {$ENDIF}
- Result:=EvalSetExpr(Expr,Expr.Values,Flags);
- end;
- function TResExprEvaluator.EvalBinaryPowerExpr(Expr: TBinaryExpr; LeftValue,
- RightValue: TResEvalValue): TResEvalValue;
- var
- Int: TMaxPrecInt;
- Flo: TMaxPrecFloat;
- aCurrency: TMaxPrecCurrency;
- begin
- Result:=nil;
- case LeftValue.Kind of
- revkInt:
- case RightValue.Kind of
- revkInt:
- // int^^int
- try
- {$Q+}{$R+}
- Int:=trunc(Math.power(TResEvalInt(LeftValue).Int,TResEvalInt(RightValue).Int));
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- RaiseOverflowArithmetic(20170530210533,Expr);
- end;
- revkUInt:
- // int^^uint
- try
- {$Q+}{$R+}
- Int:=trunc(Math.power(TResEvalInt(LeftValue).Int,TResEvalUInt(RightValue).UInt));
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- RaiseOverflowArithmetic(20170530211028,Expr);
- end;
- revkFloat:
- // int^^float
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalInt(LeftValue).Int,TResEvalFloat(RightValue).FloatValue);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170816154223,Expr);
- end;
- revkCurrency:
- // int^^currency
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalInt(LeftValue).Int,TResEvalCurrency(RightValue).Value);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20180421165906,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryPowerExpr int ^^ ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530205640,Expr);
- end;
- revkUInt:
- case RightValue.Kind of
- revkInt:
- // uint^^int
- try
- {$Q+}{$R+}
- Int:=trunc(Math.power(TResEvalUInt(LeftValue).UInt,TResEvalInt(RightValue).Int));
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- RaiseOverflowArithmetic(20170530211102,Expr);
- end;
- revkUInt:
- // uint^^uint
- try
- {$Q+}{$R+}
- Int:=trunc(Math.power(TResEvalUInt(LeftValue).UInt,TResEvalUInt(RightValue).UInt));
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalInt.CreateValue(Int);
- except
- RaiseOverflowArithmetic(20170530211121,Expr);
- end;
- revkFloat:
- // uint^^float
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalUInt(LeftValue).UInt,TResEvalFloat(RightValue).FloatValue);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170816154241,Expr);
- end;
- revkCurrency:
- // uint^^currency
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalUInt(LeftValue).UInt,TResEvalCurrency(RightValue).Value);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20180421165948,Expr);
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryPowerExpr uint ^^ ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170530211140,Expr);
- end;
- revkFloat:
- case RightValue.Kind of
- revkInt:
- // float ^^ int
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalInt(RightValue).Int);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170816153950,Expr);
- end;
- revkUInt:
- // float ^^ uint
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalUInt(RightValue).UInt);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170816154012,Expr);
- end;
- revkFloat:
- // float ^^ float
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalFloat(RightValue).FloatValue);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20170816154012,Expr);
- end;
- revkCurrency:
- // float ^^ currency
- try
- {$Q+}{$R+}
- Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalCurrency(RightValue).Value);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalFloat.CreateValue(Flo);
- except
- RaiseOverflowArithmetic(20180421170016,Expr);
- end;
- end;
- revkCurrency:
- case RightValue.Kind of
- revkInt:
- // currency ^^ int
- try
- {$Q+}{$R+}
- aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalInt(RightValue).Int);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421170235,Expr);
- end;
- revkUInt:
- // currency ^^ uint
- try
- {$Q+}{$R+}
- aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalUInt(RightValue).UInt);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421170240,Expr);
- end;
- revkFloat:
- // currency ^^ float
- try
- {$Q+}{$R+}
- aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalFloat(RightValue).FloatValue);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421170254,Expr);
- end;
- revkCurrency:
- // currency ^^ currency
- try
- {$Q+}{$R+}
- aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalCurrency(RightValue).Value);
- {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
- {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
- Result:=TResEvalCurrency.CreateValue(aCurrency);
- except
- RaiseOverflowArithmetic(20180421170311,Expr);
- end;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryPowerExpr ^^ ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170816153813,Expr);
- end;
- end;
- function TResExprEvaluator.StringToOrd(Value: TResEvalValue;
- PosEl: TPasElement): longword;
- const
- Invalid = $12345678; // bigger than $ffff and smaller than $8000000
- var
- {$ifdef FPC_HAS_CPSTRING}
- S: RawByteString;
- {$endif}
- U: UnicodeString;
- begin
- case Value.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- begin
- // ord(ansichar)
- S:=TResEvalString(Value).S;
- if length(S)=1 then
- Result:=ord(S[1])
- else if (length(S)=0) or (length(S)>4) then
- begin
- if PosEl<>nil then
- RaiseMsg(20170522221143,nXExpectedButYFound,sXExpectedButYFound,
- ['char','string'],PosEl)
- else
- exit(Invalid);
- end
- else
- begin
- U:=GetUnicodeStr(S,nil);
- if length(U)<>1 then
- begin
- if PosEl<>nil then
- RaiseMsg(20190124180407,nXExpectedButYFound,sXExpectedButYFound,
- ['char','string'],PosEl)
- else
- exit(Invalid);
- end;
- Result:=ord(U[1]);
- end;
- end;
- {$endif}
- revkUnicodeString:
- begin
- // ord(widechar)
- U:=TResEvalUTF16(Value).S;
- if length(U)<>1 then
- begin
- if PosEl<>nil then
- RaiseMsg(20170522221358,nXExpectedButYFound,sXExpectedButYFound,
- ['char','string'],PosEl)
- else
- exit(Invalid);
- end
- else
- Result:=ord(U[1]);
- end;
- else
- RaiseNotYetImplemented(20170522220959,PosEl);
- end;
- end;
- function TResExprEvaluator.EvalPrimitiveExprString(Expr: TPrimitiveExpr
- ): TResEvalValue;
- //Extracts the value from a Pascal string literal
- //
- // S is a Pascal string literal e.g. 'Line'#10
- // '' empty string
- // '''' => "'"
- // #decimal
- // #$hex
- // ^l l is a letter a-z
- //
- // Codepage:
- // For example {$codepage utf8}var s: AnsiString(CP_1251) = 'a';
- // Source codepage is CP_UTF8, target codepage is CP_1251
- //
- // Source codepage is needed for reading non ASCII string literals 'ä'.
- // Target codepage is needed for reading non ASCII # literals.
- // Target codepage costs time to compute.
- var
- Value: TResEvalValue;
- procedure RangeError(id: TMaxPrecInt);
- begin
- Value.Free;
- RaiseRangeCheck(id,Expr);
- end;
- {$IFDEF FPC_HAS_CPSTRING}
- var
- TargetCPValid: boolean;
- TargetCP: word;
- SourceCPValid: boolean;
- SourceCP: word;
- procedure FetchSourceCP;
- begin
- if SourceCPValid then exit;
- SourceCP:=GetExprStringSourceCP(Expr);
- if SourceCP=DefaultSystemCodePage then
- SourceCP:=CP_ACP;
- SourceCPValid:=true;
- end;
- procedure FetchTargetCP;
- begin
- if TargetCPValid then exit;
- TargetCP:=GetExprStringTargetCP(Expr);
- if TargetCP=DefaultSystemCodePage then
- TargetCP:=CP_ACP;
- TargetCPValid:=true;
- end;
- procedure ForceUTF16;
- var
- h: RawByteString;
- begin
- if Value.Kind=revkString then
- begin
- // switch to unicodestring
- h:=TResEvalString(Value).S;
- Value.Free;
- Value:=nil; // in case of exception in GetUnicodeStr
- Value:=TResEvalUTF16.CreateValue(GetUnicodeStr(h,Expr));
- end;
- end;
- {$ENDIF}
- procedure AddSrc(h: String);
- {$ifdef FPC_HAS_CPSTRING}
- var
- ValueAnsi: TResEvalString;
- OnlyASCII: Boolean;
- i: Integer;
- {$ENDIF}
- begin
- if h='' then exit;
- //writeln('AddSrc ',length(h),' ',ord(h[1]),' ',stringcodepage(h),' ',defaultsystemcodepage);
- {$ifdef FPC_HAS_CPSTRING}
- OnlyASCII:=true;
- for i:=1 to length(h) do
- if ord(h[i])>127 then
- begin
- // append non ASCII -> needs codepage
- OnlyASCII:=false;
- FetchSourceCP;
- SetCodePage(rawbytestring(h),SourceCP,false);
- break;
- end;
- if Value.Kind=revkString then
- begin
- ValueAnsi:=TResEvalString(Value);
- if OnlyASCII and ValueAnsi.OnlyASCII then
- begin
- // concatenate ascii strings
- ValueAnsi.S:=ValueAnsi.S+h;
- exit;
- end;
- // concatenate non ascii strings
- FetchTargetCP;
- case TargetCP of
- CP_UTF16:
- begin
- ForceUTF16;
- TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+GetUnicodeStr(h,Expr);
- //writeln('AddSrc len(h)=',length(h),' StringCodePage=',StringCodePage(h),' GetCodePage=',GetCodePage(h),' S=',length(TResEvalUTF16(Value).S));
- end;
- CP_UTF16BE:
- RaiseNotYetImplemented(20201220222608,Expr);
- else
- begin
- if ValueAnsi.S<>'' then
- begin
- if ValueAnsi.OnlyASCII then
- SetCodePage(ValueAnsi.S,TargetCP,false);
- ValueAnsi.S:=ValueAnsi.S+h;
- end else begin
- ValueAnsi.S:=h;
- end;
- end;
- end;
- end
- else
- TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+GetUnicodeStr(h,Expr);
- {$else}
- TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+h;
- {$endif}
- end;
- procedure AddHash(u: longword);
- {$ifdef FPC_HAS_CPSTRING}
- begin
- if Value.Kind=revkString then
- TResEvalString(Value).s:=TResEvalString(Value).S+Chr(u)
- else
- TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+WideChar(u);
- end;
- {$else}
- begin
- TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+WideChar(u);
- end;
- {$endif}
- function ReadHash(const S: string; p, l: integer): integer;
- var
- StartP: Integer;
- u: longword;
- c: Char;
- {$ifdef FPC_HAS_CPSTRING}
- ValueAnsi: TResEvalString;
- ValueUTF16: TResEvalUTF16;
- OldCP: TSystemCodePage;
- {$ENDIF}
- begin
- //writeln('ReadHash S="',S,'" p=',p,' l=',l,' ',StringCodePage(S));
- Result:=p;
- inc(Result);
- if Result>l then
- RaiseInternalError(20181016121354); // error in scanner
- if S[Result]='$' then
- begin
- // #$hexnumber
- inc(Result);
- StartP:=Result;
- u:=0;
- while Result<=l do
- begin
- c:=S[Result];
- case c of
- '0'..'9': u:=u*16+longword(ord(c)-ord('0'));
- 'a'..'f': u:=u*16+longword(ord(c)-ord('a'))+10;
- 'A'..'F': u:=u*16+longword(ord(c)-ord('A'))+10;
- else break;
- end;
- if u>$10FFFF then
- RangeError(20170523115712);
- inc(Result);
- end;
- end
- else
- begin
- // #decimalnumber
- StartP:=Result;
- u:=0;
- while Result<=l do
- begin
- c:=S[Result];
- case c of
- '0'..'9': u:=u*10+longword(ord(c)-ord('0'));
- else break;
- end;
- if u>$ffff then
- RangeError(20170523123137);
- inc(Result);
- end;
- end;
- if Result=StartP then
- RaiseInternalError(20170523123806);
- {$IFDEF FPC_HAS_CPSTRING}
- if u<128 then
- begin
- // ASCII
- AddHash(u);
- exit;
- end;
- // non ASCII
- FetchTargetCP;
- if (TargetCP=CP_UTF16) or (TargetCP=CP_UTF16BE) or (u>255) then
- begin
- ForceUTF16;
- ValueUTF16:=TResEvalUTF16(Value);
- if u>$ffff then
- begin
- // split into two
- dec(u,$10000);
- ValueUTF16.S:=ValueUTF16.S
- +WideChar($D800+(u shr 10))+WideChar($DC00+(u and $3ff));
- end
- else
- ValueUTF16.S:=ValueUTF16.S+WideChar(u);
- if TargetCP=CP_UTF16BE then
- RaiseNotYetImplemented(20201220212206,Expr);
- end
- else
- begin
- // byte encoding
- ValueAnsi:=TResEvalString(Value);
- if ValueAnsi.S<>'' then
- begin
- // append
- OldCP:=StringCodePage(ValueAnsi.S);
- if OldCP<>TargetCP then
- SetCodePage(ValueAnsi.S,TargetCP,false);
- ValueAnsi.S:=ValueAnsi.S+Chr(u);
- end
- else
- begin
- // start
- ValueAnsi.S:=Chr(u);
- SetCodePage(ValueAnsi.S,TargetCP,false);
- end;
- ValueAnsi.OnlyASCII:=false;
- end;
- {$ELSE}
- if u>$ffff then
- begin
- // split into two
- dec(u,$10000);
- AddHash($D800+(u shr 10));
- AddHash($DC00+(u and $3ff));
- end
- else
- AddHash(u);
- {$ENDIF}
- end;
- var
- p, StartP, l: integer;
- c: Char;
- S: String;
- begin
- Result:=nil;
- S:=Expr.Value;
- {$IFDEF VerbosePasResEval}
- //writeln('TResExprEvaluator.EvalPrimitiveExprString (',S,')');
- {$ENDIF}
- l:=length(S);
- if l=0 then
- RaiseInternalError(20170523113809);
- {$ifdef FPC_HAS_CPSTRING}
- TargetCPValid:=false;
- TargetCP:=CP_ACP;
- SourceCPValid:=false;
- SourceCP:=CP_ACP;
- Value:=TResEvalString.Create;
- {$else}
- Value:=TResEvalUTF16.Create;
- {$endif}
- p:=1;
- //writeln('TResExprEvaluator.EvalPrimitiveExprString ',GetObjPath(Expr),' ',Expr.SourceFilename,' ',Expr.SourceLinenumber div 2048,' S=[',S,']');
- while p<=l do
- case S[p] of
- {$ifdef UsePChar}
- #0: break;
- {$endif}
- '''':
- begin
- inc(p);
- StartP:=p;
- repeat
- if p>l then
- RaiseInternalError(20170523113938);
- c:=S[p];
- case c of
- '''':
- begin
- if p>StartP then
- AddSrc(copy(S,StartP,p-StartP));
- inc(p);
- StartP:=p;
- if (p>l) or (S[p]<>'''') then
- break;
- AddSrc('''');
- inc(p);
- StartP:=p;
- end;
- else
- inc(p);
- end;
- until false;
- if p>StartP then
- AddSrc(copy(S,StartP,p-StartP));
- end;
- '#':
- p:=ReadHash(S,p,l);
- '^':
- begin
- // ^A is #1
- inc(p);
- if p>l then
- RaiseInternalError(20181016121520);
- c:=S[p];
- case c of
- 'a'..'z': AddHash(ord(c)-ord('a')+1);
- 'A'..'Z': AddHash(ord(c)-ord('A')+1);
- else RaiseInternalError(20170523123809);
- end;
- inc(p);
- end;
- else
- RaiseNotYetImplemented(20170523123815,Expr,'ord='+IntToStr(ord(S[p])));
- end;
- Result:=Value;
- {$IFDEF VerbosePasResEval}
- //writeln('TResExprEvaluator.EvalPrimitiveExprString Result=',Result.AsString);
- {$ENDIF}
- end;
- function TResExprEvaluator.CreateResEvalInt(UInt: TMaxPrecUInt): TResEvalValue;
- begin
- if UInt<=HighIntAsUInt then
- Result:=TResEvalInt.CreateValue(TMaxPrecInt(UInt))
- else
- Result:=TResEvalUInt.CreateValue(UInt);
- end;
- constructor TResExprEvaluator.Create;
- begin
- inherited Create;
- FAllowedInts:=ReitDefaults;
- {$ifdef FPC_HAS_CPSTRING}
- FDefaultSourceEncoding:=system.DefaultSystemCodePage;
- FDefaultStringEncoding:=CP_ACP;
- {$endif}
- end;
- function TResExprEvaluator.Eval(Expr: TPasExpr; Flags: TResEvalFlags
- ): TResEvalValue;
- var
- C: TClass;
- Code: integer;
- Int: TMaxPrecInt;
- UInt: TMaxPrecUInt;
- Flo: TMaxPrecFloat;
- begin
- Result:=nil;
- if Expr.CustomData is TResEvalValue then
- begin
- Result:=TResEvalValue(Expr.CustomData);
- exit;
- end;
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.Eval Expr=',GetObjName(Expr),' Flags=',dbgs(Flags));
- {$ENDIF}
- if refAutoConst in Flags then
- begin
- Exclude(Flags,refAutoConst);
- if IsConst(Expr) then
- Include(Flags,refConst);
- end;
- if refAutoConstExt in Flags then
- begin
- Exclude(Flags,refAutoConstExt);
- if IsConst(Expr) then
- Include(Flags,refConstExt);
- end;
- C:=Expr.ClassType;
- if C=TPrimitiveExpr then
- begin
- case TPrimitiveExpr(Expr).Kind of
- pekIdent:
- begin
- Result:=OnEvalIdentifier(Self,TPrimitiveExpr(Expr),Flags);
- //writeln('TResExprEvaluator.Eval primitiv result=',Result<>nil,' ',dbgs(Result));
- end;
- pekNumber:
- begin
- // try TMaxPrecInt
- val(TPrimitiveExpr(Expr).Value,Int,Code);
- if Code=0 then
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.Eval Int=',Int,' Value="',TPrimitiveExpr(Expr).Value,'"');
- {$ENDIF}
- if (Int<0) and (Pos('-',TPrimitiveExpr(Expr).Value)<1) then
- // FPC str() converts $8000000000000000 to a negative int64 -> ignore
- else
- begin
- Result:=TResEvalInt.CreateValue(Int);
- exit;
- end;
- end;
- // try TMaxPrecUInt
- val(TPrimitiveExpr(Expr).Value,UInt,Code);
- if Code=0 then
- begin
- Result:=TResEvalUInt.CreateValue(UInt);
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.Eval UInt=',UInt,' Value="',TPrimitiveExpr(Expr).Value,'"');
- {$ENDIF}
- exit;
- end;
- // try TMaxPrecFloat
- val(TPrimitiveExpr(Expr).Value,Flo,Code);
- if Code=0 then
- begin
- Result:=TResEvalFloat.CreateValue(Flo);
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.Eval Float=',Flo,' Value="',TPrimitiveExpr(Expr).Value,'"');
- {$ENDIF}
- exit;
- end;
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.Eval Value="',TPrimitiveExpr(Expr).Value,'"');
- {$ENDIF}
- RaiseRangeCheck(20170518202252,Expr);
- end;
- pekString:
- begin
- Result:=EvalPrimitiveExprString(TPrimitiveExpr(Expr));
- exit;
- end;
- else
- RaiseNotYetImplemented(20170518200951,Expr);
- end;
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.Eval primitiv end result=',Result<>nil,' ',dbgs(Result));
- {$ENDIF}
- end
- else if C=TNilExpr then
- Result:=TResEvalValue.CreateKind(revkNil)
- else if C=TBoolConstExpr then
- Result:=TResEvalBool.CreateValue(TBoolConstExpr(Expr).Value)
- else if C=TUnaryExpr then
- Result:=EvalUnaryExpr(TUnaryExpr(Expr),Flags)
- else if C=TBinaryExpr then
- Result:=EvalBinaryExpr(TBinaryExpr(Expr),Flags)
- else if C=TParamsExpr then
- Result:=EvalParamsExpr(TParamsExpr(Expr),Flags)
- else if C=TArrayValues then
- Result:=EvalArrayValuesExpr(TArrayValues(Expr),Flags)
- else if [refConst,refConstExt]*Flags<>[] then
- RaiseConstantExprExp(20170518213800,Expr);
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.Eval END ',Expr.ClassName,' result=',Result<>nil,' ',dbgs(Result));
- {$ENDIF}
- end;
- function TResExprEvaluator.IsInRange(Expr, RangeExpr: TPasExpr;
- EmitHints: boolean): boolean;
- var
- Value, RangeValue: TResEvalValue;
- begin
- Value:=Eval(Expr,[refAutoConst]);
- if Value=nil then
- exit(true); // a variable -> ok
- RangeValue:=nil;
- try
- RangeValue:=Eval(RangeExpr,[]);
- if RangeValue=nil then
- RaiseNotYetImplemented(20170522171226,RangeExpr);
- Result:=IsInRange(Value,Expr,RangeValue,RangeExpr,EmitHints);
- finally
- ReleaseEvalValue(Value);
- ReleaseEvalValue(RangeValue);
- end;
- end;
- function TResExprEvaluator.IsInRange(Value: TResEvalValue; ValueExpr: TPasExpr;
- RangeValue: TResEvalValue; RangeExpr: TPasExpr; EmitHints: boolean): boolean;
- var
- RgInt: TResEvalRangeInt;
- RgUInt: TResEvalRangeUInt;
- CharIndex: LongWord;
- begin
- Result:=false;
- {$IFDEF VerbosePasResEval}
- //writeln('TResExprEvaluator.IsInRange Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
- {$ENDIF}
- case RangeValue.Kind of
- revkRangeInt:
- begin
- RgInt:=TResEvalRangeInt(RangeValue);
- case RgInt.ElKind of
- revskBool:
- if Value.Kind=revkBool then
- exit(true)
- else
- RaiseNotYetImplemented(20170522220104,ValueExpr);
- revskEnum:
- begin
- if Value.Kind<>revkEnum then
- RaiseInternalError(20170522172754)
- else if TResEvalEnum(Value).ElType<>RgInt.ElType then
- RaiseInternalError(20170522174028)
- else if (TResEvalEnum(Value).Index<RgInt.RangeStart)
- or (TResEvalEnum(Value).Index>RgInt.RangeEnd) then
- begin
- if EmitHints then
- EmitRangeCheckConst(20170522174406,Value.AsString,
- RgInt.ElementAsString(RgInt.RangeStart),
- RgInt.ElementAsString(RgInt.RangeEnd),
- ValueExpr);
- exit(false);
- end
- else
- exit(true);
- end;
- revskInt: // int..int
- if Value.Kind=revkInt then
- begin
- // int in int..int
- if (TResEvalInt(Value).Int<RgInt.RangeStart)
- or (TResEvalInt(Value).Int>RgInt.RangeEnd) then
- begin
- if EmitHints then
- EmitRangeCheckConst(20170522174958,Value.AsString,
- RgInt.ElementAsString(RgInt.RangeStart),
- RgInt.ElementAsString(RgInt.RangeEnd),
- ValueExpr);
- exit(false);
- end
- else
- exit(true);
- end
- else if Value.Kind=revkUInt then
- begin
- // uint in int..int
- if (TResEvalUInt(Value).UInt>HighIntAsUInt)
- or (TMaxPrecInt(TResEvalUInt(Value).UInt)<RgInt.RangeStart)
- or (TMaxPrecInt(TResEvalUInt(Value).UInt)>RgInt.RangeEnd) then
- begin
- if EmitHints then
- EmitRangeCheckConst(20170522215852,Value.AsString,
- RgInt.ElementAsString(RgInt.RangeStart),
- RgInt.ElementAsString(RgInt.RangeEnd),
- ValueExpr);
- exit(false);
- end
- else
- exit(true);
- end
- else
- begin
- {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
- writeln('TResExprEvaluator.IsInRange Kind=',Value.Kind,' ',Value.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170522215906,ValueExpr);
- end;
- revskChar:
- if Value.Kind in revkAllStrings then
- begin
- // string in char..char
- CharIndex:=StringToOrd(Value,ValueExpr);
- if (CharIndex<RgInt.RangeStart) or (CharIndex>RgInt.RangeEnd) then
- begin
- if EmitHints then
- EmitRangeCheckConst(20170522221709,Value.AsString,
- RgInt.ElementAsString(RgInt.RangeStart),
- RgInt.ElementAsString(RgInt.RangeEnd),
- ValueExpr);
- exit(false);
- end
- else
- exit(true);
- end
- else
- RaiseNotYetImplemented(20170522220210,ValueExpr);
- else
- RaiseInternalError(20170522172630);
- end;
- end;
- revkRangeUInt:
- if Value.Kind=revkInt then
- begin
- // int in uint..uint
- RgUInt:=TResEvalRangeUInt(RangeValue);
- if (TResEvalInt(Value).Int<0)
- or (TMaxPrecUInt(TResEvalInt(Value).Int)<RgUInt.RangeStart)
- or (TMaxPrecUInt(TResEvalInt(Value).Int)>RgUInt.RangeEnd) then
- begin
- if EmitHints then
- EmitRangeCheckConst(20170522172250,Value.AsString,
- IntToStr(RgUInt.RangeStart),
- IntToStr(RgUInt.RangeEnd),ValueExpr);
- exit(false);
- end
- else
- exit(true);
- end
- else if Value.Kind=revkUInt then
- begin
- // uint in uint..uint
- RgUInt:=TResEvalRangeUInt(RangeValue);
- if (TResEvalUInt(Value).UInt<RgUInt.RangeStart)
- or (TResEvalUInt(Value).UInt>RgUInt.RangeEnd) then
- begin
- if EmitHints then
- EmitRangeCheckConst(20170522172544,IntToStr(TResEvalUInt(Value).UInt),
- IntToStr(RgUInt.RangeStart),
- IntToStr(RgUInt.RangeEnd),ValueExpr);
- exit(false);
- end
- else
- exit(true);
- end
- else
- begin
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.IsInRange Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
- {$ENDIF}
- RaiseNotYetImplemented(20170522171551,ValueExpr);
- end;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.IsInRange Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
- {$ENDIF}
- RaiseNotYetImplemented(20170522171307,RangeExpr);
- end;
- end;
- function TResExprEvaluator.IsSetCompatible(Value: TResEvalValue;
- ValueExpr: TPasExpr; RangeValue: TResEvalValue; EmitHints: boolean): boolean;
- // checks if Value fits into a set of RangeValue
- var
- RightSet: TResEvalSet;
- LeftRange: TResEvalRangeInt;
- MinVal, MaxVal: TMaxPrecInt;
- begin
- Result:=true;
- case Value.Kind of
- revkSetOfInt:
- begin
- RightSet:=TResEvalSet(Value);
- if RightSet.ElKind=revskNone then
- exit(true); // empty set always fits
- case RangeValue.Kind of
- revkRangeInt:
- begin
- LeftRange:=TResEvalRangeInt(RangeValue);
- if (LeftRange.ElKind<>RightSet.ElKind)
- or (LeftRange.ElType<>RightSet.ElType) then
- begin
- {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
- writeln('TResExprEvaluator.IsSetCompatible Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
- {$ENDIF}
- RaiseNotYetImplemented(20170714201425,ValueExpr);
- end;
- if length(RightSet.Ranges)=0 then
- exit(true); // empty typed set fits
- MinVal:=RightSet.Ranges[0].RangeStart;
- MaxVal:=RightSet.Ranges[length(RightSet.Ranges)-1].RangeEnd;
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.IsSetCompatible Value=',dbgs(Value),' MinVal=',MinVal,' MaxVal=',MaxVal,' RangeValue=',dbgs(RangeValue));
- {$ENDIF}
- if (MinVal<LeftRange.RangeStart) then
- if EmitHints then
- EmitRangeCheckConst(20170714202813,RightSet.ElementAsString(MinVal),
- LeftRange.ElementAsString(LeftRange.RangeStart),
- LeftRange.ElementAsString(LeftRange.RangeEnd),ValueExpr,mtError)
- else
- exit(false);
- if (MaxVal>LeftRange.RangeEnd) then
- if EmitHints then
- EmitRangeCheckConst(20170714203134,RightSet.ElementAsString(MaxVal),
- LeftRange.ElementAsString(LeftRange.RangeStart),
- LeftRange.ElementAsString(LeftRange.RangeEnd),ValueExpr,mtError)
- else
- exit(false);
- end;
- else
- {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
- writeln('TResExprEvaluator.IsSetCompatible Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
- {$ENDIF}
- RaiseNotYetImplemented(20170714201121,ValueExpr);
- end;
- end
- else
- {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
- writeln('TResExprEvaluator.IsSetCompatible Value=',Value.Kind,' ',dbgs(RangeValue));
- {$ENDIF}
- RaiseNotYetImplemented(20170714195815,ValueExpr);
- end;
- end;
- function TResExprEvaluator.IsConst(Expr: TPasExpr): boolean;
- var
- El: TPasElement;
- C: TClass;
- begin
- El:=Expr;
- while El<>nil do
- begin
- C:=El.ClassType;
- if C.InheritsFrom(TPasProcedure) then exit(true);
- if C.InheritsFrom(TPasImplBlock) then exit(false);
- El:=El.Parent;
- end;
- Result:=true;
- end;
- function TResExprEvaluator.IsSimpleExpr(Expr: TPasExpr): boolean;
- var
- C: TClass;
- begin
- C:=Expr.ClassType;
- Result:=(C=TNilExpr)
- or (C=TBoolConstExpr)
- or (C=TPrimitiveExpr);
- end;
- procedure TResExprEvaluator.EmitRangeCheckConst(id: TMaxPrecInt; const aValue,
- MinVal, MaxVal: String; PosEl: TPasElement; MsgType: TMessageType);
- begin
- if Assigned(OnRangeCheckEl) then
- OnRangeCheckEl(Self,PosEl,MsgType);
- LogMsg(id,MsgType,nRangeCheckEvaluatingConstantsVMinMax,
- sRangeCheckEvaluatingConstantsVMinMax,[aValue,MinVal,MaxVal],PosEl);
- end;
- procedure TResExprEvaluator.EmitRangeCheckConst(id: TMaxPrecInt;
- const aValue: String; MinVal, MaxVal: TMaxPrecInt; PosEl: TPasElement;
- MsgType: TMessageType);
- begin
- EmitRangeCheckConst(id,aValue,IntToStr(MinVal),IntToStr(MaxVal),PosEl,MsgType);
- end;
- function TResExprEvaluator.ChrValue(Value: TResEvalValue; ErrorEl: TPasElement
- ): TResEvalValue;
- var
- Int: TMaxPrecInt;
- begin
- Result:=nil;
- case Value.Kind of
- revkInt,revkUInt:
- begin
- if Value.Kind=revkUInt then
- begin
- if TResEvalUInt(Value).UInt>$ffff then
- EmitRangeCheckConst(20170711195605,Value.AsString,0,$ffff,ErrorEl,mtError)
- else
- Int:=TResEvalUInt(Value).UInt;
- end
- else
- Int:=TResEvalInt(Value).Int;
- if (Int<0) or (Int>$ffff) then
- EmitRangeCheckConst(20170711195747,Value.AsString,0,$ffff,ErrorEl,mtError);
- {$ifdef FPC_HAS_CPSTRING}
- if Int<=$ff then
- Result:=TResEvalString.CreateValue(chr(Int))
- else
- {$endif}
- Result:=TResEvalUTF16.CreateValue(WideChar(Int))
- end;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.ChrValue ',Value.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170711195440,ErrorEl);
- end;
- end;
- function TResExprEvaluator.OrdValue(Value: TResEvalValue; ErrorEl: TPasElement
- ): TResEvalValue;
- var
- v: longword;
- begin
- Result:=nil;
- v:=0;
- case Value.Kind of
- revkBool:
- if TResEvalBool(Value).B then
- v:=1
- else
- v:=0;
- revkInt,revkUInt:
- exit(Value);
- {$ifdef FPC_HAS_CPSTRING}
- revkString,
- {$endif}
- revkUnicodeString:
- v:=StringToOrd(Value,ErrorEl);
- revkEnum:
- v:=TResEvalEnum(Value).Index;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.OrdValue ',Value.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170624155932,ErrorEl);
- end;
- if v>$ffff then exit;
- Result:=TResEvalInt.CreateValue(v);
- end;
- procedure TResExprEvaluator.PredValue(Value: TResEvalValue; ErrorEl: TPasElement
- );
- begin
- case Value.Kind of
- revkBool:
- PredBool(TResEvalBool(Value),ErrorEl);
- revkInt:
- PredInt(TResEvalInt(Value),ErrorEl);
- revkUInt:
- PredUInt(TResEvalUInt(Value),ErrorEl);
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- PredString(TResEvalString(Value),ErrorEl);
- {$endif}
- revkUnicodeString:
- PredUnicodeString(TResEvalUTF16(Value),ErrorEl);
- revkEnum:
- PredEnum(TResEvalEnum(Value),ErrorEl);
- else
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.PredValue ',Value.AsDebugString);
- {$ENDIF}
- ReleaseEvalValue(Value);
- RaiseNotYetImplemented(20170624135738,ErrorEl);
- end;
- end;
- procedure TResExprEvaluator.SuccValue(Value: TResEvalValue; ErrorEl: TPasElement
- );
- begin
- case Value.Kind of
- revkBool:
- SuccBool(TResEvalBool(Value),ErrorEl);
- revkInt:
- SuccInt(TResEvalInt(Value),ErrorEl);
- revkUInt:
- SuccUInt(TResEvalUInt(Value),ErrorEl);
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- SuccString(TResEvalString(Value),ErrorEl);
- {$endif}
- revkUnicodeString:
- SuccUnicodeString(TResEvalUTF16(Value),ErrorEl);
- revkEnum:
- SuccEnum(TResEvalEnum(Value),ErrorEl);
- else
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.SuccValue ',Value.AsDebugString);
- {$ENDIF}
- ReleaseEvalValue(Value);
- RaiseNotYetImplemented(20170624151252,ErrorEl);
- end;
- end;
- function TResExprEvaluator.EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags
- ): TResEvalValue;
- var
- AllConst: Boolean;
- function EvalFormat(Expr: TPasExpr; MinVal, MaxVal: TMaxPrecInt): TMaxPrecInt;
- var
- Value: TResEvalValue;
- begin
- Value:=Eval(Expr,Flags);
- if Value=nil then
- begin
- AllConst:=false;
- exit(-1);
- end;
- if Value.Kind<>revkInt then
- RaiseNotYetImplemented(20170717144010,Expr);
- Result:=TResEvalInt(Value).Int;
- if (Result<MinVal) or (Result>MaxVal) then
- EmitRangeCheckConst(20170717144609,IntToStr(Result),MinVal,MaxVal,Expr,mtError);
- end;
- var
- i: Integer;
- Param: TPasExpr;
- S, ValStr: String;
- Value: TResEvalValue;
- Format1, Format2: TMaxPrecInt;
- begin
- Result:=nil;
- Value:=nil;
- AllConst:=true;
- S:='';
- for i:=0 to length(Params.Params)-1 do
- begin
- Param:=Params.Params[i];
- {$IFDEF VerbosePasResEval}
- writeln('TPasResolver.BI_StrFunc_OnEval i=',i,' of ',length(Params.Params),' Param=',GetObjName(Param));
- {$ENDIF}
- Value:=Eval(Param,Flags);
- if Value=nil then
- begin
- AllConst:=false;
- continue;
- end;
- Format1:=-1;
- Format2:=-1;
- try
- ValStr:='';
- if Param.format1<>nil then
- begin
- Format1:=EvalFormat(Param.format1,1,255);
- if Format1<0 then
- continue;
- if Param.format2<>nil then
- begin
- Format2:=EvalFormat(Param.format2,0,255);
- if Format2<0 then
- continue;
- end;
- end;
- case Value.Kind of
- revkBool:
- if Format1<0 then
- str(TResEvalBool(Value).B,ValStr)
- else
- str(TResEvalBool(Value).B:Format1,ValStr);
- revkInt:
- if Format1<0 then
- str(TResEvalInt(Value).Int,ValStr)
- else
- str(TResEvalInt(Value).Int:Format1,ValStr);
- revkUInt:
- if Format1<0 then
- str(TResEvalUInt(Value).UInt,ValStr)
- else
- str(TResEvalUInt(Value).UInt:Format1,ValStr);
- revkFloat:
- if Format1<0 then
- str(TResEvalFloat(Value).FloatValue,ValStr)
- else if Format2<0 then
- str(TResEvalFloat(Value).FloatValue:Format1,ValStr)
- else
- str(TResEvalFloat(Value).FloatValue:Format1:Format2,ValStr);
- revkCurrency:
- if Format1<0 then
- str(TResEvalCurrency(Value).Value,ValStr)
- else if Format2<0 then
- str(TResEvalCurrency(Value).Value:Format1,ValStr)
- else
- str(TResEvalCurrency(Value).Value:Format1:Format2,ValStr);
- revkEnum:
- begin
- ValStr:=TResEvalEnum(Value).AsString;
- if Format1>0 then
- ValStr:=StringOfChar(' ',Format1)+ValStr;
- end;
- else
- AllConst:=false;
- continue;
- end;
- finally
- ReleaseEvalValue(Value);
- ReleaseEvalValue(Value);
- ReleaseEvalValue(Value);
- end;
- S:=S+ValStr;
- end;
- if AllConst then
- {$ifdef FPC_HAS_CPSTRING}
- Result:=TResEvalString.CreateValue(S);
- {$else}
- Result:=TResEvalUTF16.CreateValue(S);
- {$endif}
- end;
- function TResExprEvaluator.EvalStringAddExpr(Expr, LeftExpr,
- RightExpr: TPasExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
- {$ifdef FPC_HAS_CPSTRING}
- var
- LeftCP, RightCP: TSystemCodePage;
- {$endif}
- begin
- case LeftValue.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- case RightValue.Kind of
- revkString:
- begin
- LeftCP:=GetCodePage(TResEvalString(LeftValue).S);
- RightCP:=GetCodePage(TResEvalString(RightValue).S);
- if (LeftCP=RightCP) then
- begin
- Result:=TResEvalString.Create;
- TResEvalString(Result).S:=TResEvalString(LeftValue).S+TResEvalString(RightValue).S;
- end
- else
- begin
- Result:=TResEvalUTF16.Create;
- TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,LeftExpr)
- +GetUnicodeStr(TResEvalString(RightValue).S,RightExpr);
- end;
- end;
- revkUnicodeString:
- begin
- Result:=TResEvalUTF16.Create;
- TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,LeftExpr)
- +TResEvalUTF16(RightValue).S;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryAddExpr string+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170601141834,Expr);
- end;
- {$endif}
- revkUnicodeString:
- case RightValue.Kind of
- {$ifdef FPC_HAS_CPSTRING}
- revkString:
- begin
- Result:=TResEvalUTF16.Create;
- TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S
- +GetUnicodeStr(TResEvalString(RightValue).S,RightExpr);
- end;
- {$endif}
- revkUnicodeString:
- begin
- Result:=TResEvalUTF16.Create;
- TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S+TResEvalUTF16(RightValue).S;
- end;
- else
- {$IFDEF VerbosePasResolver}
- writeln('TResExprEvaluator.EvalBinaryAddExpr utf16+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20170601141811,Expr);
- end;
- else
- {$ifndef FPC_HAS_CPSTRING}
- if LeftExpr=nil then ; // no Parameter "LeftExpr" not used
- if RightExpr=nil then ; // no Parameter "RightExpr" not used
- {$endif}
- RaiseNotYetImplemented(20181219233139,Expr);
- end;
- end;
- function TResExprEvaluator.LoHiValue(Value: TResEvalValue; ShiftSize: Integer;
- Mask: LongWord; ErrorEl: TPasElement): TResEvalValue;
- var
- uint: LongWord;
- begin
- case Value.Kind of
- revkInt:
- {$IFDEF Pas2js}
- if ShiftSize=32 then
- uint := longword(TResEvalInt(Value).Int div $100000000)
- else
- {$ENDIF}
- uint := (TResEvalInt(Value).Int shr ShiftSize) and Mask;
- revkUInt:
- {$IFDEF Pas2js}
- if ShiftSize=32 then
- uint := longword(TResEvalUInt(Value).UInt div $100000000)
- else
- {$ENDIF}
- uint := (TResEvalUInt(Value).UInt shr ShiftSize) and Mask;
- else
- {$IFDEF VerbosePasResEval}
- writeln('TResExprEvaluator.LoHiValue ',Value.AsDebugString);
- {$ENDIF}
- RaiseNotYetImplemented(20190129012100,ErrorEl);
- end;
- Result := TResEvalInt.CreateValue(uint);
- end;
- function TResExprEvaluator.EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
- Flags: TResEvalFlags): TResEvalEnum;
- var
- Value: TResEvalValue;
- MaxIndex, Index: Integer;
- begin
- Result:=nil;
- Value:=Eval(Expr,Flags);
- if Value=nil then exit;
- try
- MaxIndex:=EnumType.Values.Count-1;
- case Value.Kind of
- revkInt:
- if TResEvalInt(Value).Int>High(Index) then
- EmitRangeCheckConst(20170713105944,
- IntToStr(TResEvalInt(Value).Int),'0',IntToStr(MaxIndex),Expr,mtError)
- else
- Index:=TResEvalInt(Value).Int;
- revkUInt:
- if TResEvalUInt(Value).UInt>MaxIndex then
- EmitRangeCheckConst(20170713105944,
- IntToStr(TResEvalUInt(Value).UInt),'0',IntToStr(MaxIndex),Expr,mtError)
- else
- Index:=TResEvalUInt(Value).UInt;
- else
- RaiseNotYetImplemented(20170713105625,Expr);
- end;
- if (Index<0) or (Index>MaxIndex) then
- EmitRangeCheckConst(20170713110232,
- IntToStr(Index),'0',IntToStr(MaxIndex),Expr,mtError);
- Result:=TResEvalEnum.CreateValue(Index,TPasEnumValue(EnumType.Values[Index]));
- finally
- ReleaseEvalValue(Value);
- end;
- end;
- {$ifdef FPC_HAS_CPSTRING}
- function TResExprEvaluator.CheckValidUTF8(const s: RawByteString;
- ErrorEl: TPasElement): boolean;
- var
- p, EndP: PChar;
- l: SizeInt;
- begin
- p:=PChar(s);
- EndP:=p+length(s);
- while p<EndP do
- begin
- l:=Utf8CodePointLen(p,EndP-p,false);
- if l<=0 then
- if ErrorEl<>nil then
- RaiseMsg(20170711211841,nIllegalChar,sIllegalChar,[],ErrorEl)
- else
- exit(false);
- inc(p,l);
- end;
- Result:=true;
- end;
- function TResExprEvaluator.GetCodePage(const s: RawByteString): TSystemCodePage;
- begin
- if s='' then exit(DefaultSourceCodePage);
- Result:=StringCodePage(s);
- if (Result=CP_ACP) or (Result=CP_NONE) then
- begin
- Result:=DefaultSourceCodePage;
- if (Result=CP_ACP) or (Result=CP_NONE) then
- begin
- Result:=System.DefaultSystemCodePage;
- if Result=CP_NONE then
- Result:=CP_ACP;
- end;
- end;
- end;
- function TResExprEvaluator.GetRawByteString(const s: UnicodeString;
- CodePage: TSystemCodePage; ErrorEl: TPasElement): RawByteString;
- var
- ok: Boolean;
- begin
- Result:=UTF8Encode(s);
- if (CodePage=CP_UTF8)
- or ((DefaultSystemCodePage=CP_UTF8) and ((CodePage=CP_ACP) or (CodePage=CP_NONE))) then
- begin
- // to UTF-8
- SetCodePage(Result,CodePage,false);
- end
- else
- begin
- // to non UTF-8 -> possible loss
- ok:=false;
- try
- SetCodePage(Result,CodePage,true);
- ok:=true;
- except
- end;
- if (not ok) or (GetUnicodeStr(Result,ErrorEl)<>s) then
- LogMsg(20190204165110,mtWarning,nImplictConversionUnicodeToAnsi,
- sImplictConversionUnicodeToAnsi,[],ErrorEl);
- end;
- end;
- function TResExprEvaluator.GetUTF8Str(const s: RawByteString;
- ErrorEl: TPasElement): String;
- var
- CP: TSystemCodePage;
- begin
- if s='' then exit('');
- CP:=GetCodePage(s);
- if CP=CP_UTF8 then
- begin
- if ErrorEl<>nil then
- CheckValidUTF8(s,ErrorEl);
- Result:=s;
- end
- else
- // use default conversion
- Result:=UTF8Encode(UnicodeString(s));
- end;
- function TResExprEvaluator.GetUnicodeStr(const s: RawByteString;
- ErrorEl: TPasElement): UnicodeString;
- var
- CP: TSystemCodePage;
- begin
- if s='' then exit('');
- CP:=GetCodePage(s);
- if (CP=CP_UTF8) or ((CP=CP_ACP) and (DefaultSystemCodePage=CP_UTF8)) then
- begin
- if ErrorEl<>nil then
- CheckValidUTF8(s,ErrorEl);
- Result:=UTF8Decode(s);
- end
- else
- // use default conversion
- Result:=UnicodeString(s);
- end;
- function TResExprEvaluator.GetWideChar(const s: RawByteString; out w: WideChar
- ): boolean;
- var
- CP: TSystemCodePage;
- u: UnicodeString;
- begin
- w:=#0;
- Result:=false;
- if s='' then exit;
- CP:=GetCodePage(s);
- if CP=CP_UTF8 then
- begin
- if length(s)>4 then exit;
- u:=UTF8Decode(s);
- if length(u)<>1 then exit;
- w:=u[1];
- Result:=true;
- end
- else if length(s)=1 then
- begin
- w:=s[1];
- Result:=true;
- end;
- end;
- function TResExprEvaluator.GetExprStringTargetCP(Expr: TPasExpr
- ): TSystemCodePage;
- begin
- Result:=DefaultStringCodePage;
- if Expr=nil then ;
- end;
- function TResExprEvaluator.GetExprStringSourceCP(Expr: TPasExpr
- ): TSystemCodePage;
- begin
- Result:=DefaultSourceCodePage;
- if Expr=nil then ;
- end;
- {$endif}
- procedure TResExprEvaluator.PredBool(Value: TResEvalBool; ErrorEl: TPasElement);
- begin
- if Value.B=false then
- EmitRangeCheckConst(20170624140251,Value.AsString,
- 'true','true',ErrorEl);
- Value.B:=not Value.B;
- end;
- procedure TResExprEvaluator.SuccBool(Value: TResEvalBool; ErrorEl: TPasElement);
- begin
- if Value.B=true then
- EmitRangeCheckConst(20170624142316,Value.AsString,
- 'false','false',ErrorEl);
- Value.B:=not Value.B;
- end;
- procedure TResExprEvaluator.PredInt(Value: TResEvalInt; ErrorEl: TPasElement);
- begin
- if Value.Int=low(TMaxPrecInt) then
- begin
- EmitRangeCheckConst(20170624142511,IntToStr(Value.Int),
- IntToStr(succ(low(TMaxPrecInt))),IntToStr(high(TMaxPrecInt)),ErrorEl);
- Value.Int:=high(Value.Int);
- end
- else
- dec(Value.Int);
- end;
- procedure TResExprEvaluator.SuccInt(Value: TResEvalInt; ErrorEl: TPasElement);
- begin
- if Value.Int=high(TMaxPrecInt) then
- begin
- EmitRangeCheckConst(20170624142920,IntToStr(Value.Int),
- IntToStr(low(TMaxPrecInt)),IntToStr(pred(high(TMaxPrecInt))),ErrorEl);
- Value.Int:=low(Value.Int);
- end
- else
- inc(Value.Int);
- end;
- procedure TResExprEvaluator.PredUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
- begin
- if Value.UInt=low(TMaxPrecUInt) then
- begin
- EmitRangeCheckConst(20170624143122,IntToStr(Value.UInt),
- IntToStr(succ(low(TMaxPrecUInt))),IntToStr(high(TMaxPrecUInt)),ErrorEl);
- Value.UInt:=high(Value.UInt);
- end
- else
- dec(Value.UInt);
- end;
- procedure TResExprEvaluator.SuccUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
- begin
- // Note: when FPC compares int64 with qword it converts the qword to an int64
- if Value.UInt=HighIntAsUInt then
- begin
- EmitRangeCheckConst(20170624142921,IntToStr(Value.UInt),
- IntToStr(low(TMaxPrecUInt)),IntToStr(pred(high(TMaxPrecUInt))),ErrorEl);
- Value.UInt:=low(Value.UInt);
- end
- else
- inc(Value.UInt);
- end;
- {$ifdef FPC_HAS_CPSTRING}
- procedure TResExprEvaluator.PredString(Value: TResEvalString;
- ErrorEl: TPasElement);
- begin
- if length(Value.S)<>1 then
- RaiseRangeCheck(20170624150138,ErrorEl);
- if Value.S[1]=#0 then
- begin
- EmitRangeCheckConst(20170624150220,Value.AsString,'#1','#255',ErrorEl);
- Value.S:=#255;
- end
- else
- Value.S:=pred(Value.S[1]);
- end;
- procedure TResExprEvaluator.SuccString(Value: TResEvalString;
- ErrorEl: TPasElement);
- begin
- if length(Value.S)<>1 then
- RaiseRangeCheck(20170624150432,ErrorEl);
- if Value.S[1]=#255 then
- begin
- EmitRangeCheckConst(20170624150441,Value.AsString,'#0','#254',ErrorEl);
- Value.S:=#0;
- end
- else
- Value.S:=succ(Value.S[1]);
- end;
- {$endif}
- procedure TResExprEvaluator.PredUnicodeString(Value: TResEvalUTF16;
- ErrorEl: TPasElement);
- begin
- if length(Value.S)<>1 then
- RaiseRangeCheck(20170624150703,ErrorEl);
- if Value.S[1]=#0 then
- begin
- EmitRangeCheckConst(20170624150710,Value.AsString,'#1','#65535',ErrorEl);
- Value.S:=WideChar(#65535);
- end
- else
- Value.S:=pred(Value.S[1]);
- end;
- procedure TResExprEvaluator.SuccUnicodeString(Value: TResEvalUTF16;
- ErrorEl: TPasElement);
- begin
- if length(Value.S)<>1 then
- RaiseRangeCheck(20170624150849,ErrorEl);
- if Value.S[1]=#65535 then
- begin
- EmitRangeCheckConst(20170624150910,Value.AsString,'#0','#65534',ErrorEl);
- Value.S:=#0;
- end
- else
- Value.S:=succ(Value.S[1]);
- end;
- procedure TResExprEvaluator.PredEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
- var
- EnumType: TPasEnumType;
- begin
- EnumType:=Value.ElType as TPasEnumType;
- if EnumType=nil then
- RaiseInternalError(20170821174038,dbgs(Value));
- if Value.Index<=0 then
- begin
- EmitRangeCheckConst(20170624144332,Value.AsString,
- TPasEnumValue(EnumType.Values[Min(1,EnumType.Values.Count-1)]).Name,
- TPasEnumValue(EnumType.Values[EnumType.Values.Count-1]).Name,ErrorEl);
- Value.Index:=EnumType.Values.Count-1;
- end
- else
- dec(Value.Index);
- Value.IdentEl:=TPasEnumValue(EnumType.Values[Value.Index]);
- end;
- procedure TResExprEvaluator.SuccEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
- var
- EnumType: TPasEnumType;
- begin
- EnumType:=Value.ElType as TPasEnumType;
- if EnumType=nil then
- RaiseInternalError(20170821174058,dbgs(Value));
- if Value.Index>=EnumType.Values.Count-1 then
- begin
- EmitRangeCheckConst(20170624145013,Value.AsString,
- TPasEnumValue(EnumType.Values[0]).Name,
- TPasEnumValue(EnumType.Values[Max(0,EnumType.Values.Count-2)]).Name,ErrorEl);
- Value.Index:=0;
- end
- else
- inc(Value.Index);
- Value.IdentEl:=TPasEnumValue(EnumType.Values[Value.Index]);
- end;
- { TResolveData }
- procedure TResolveData.SetElement(AValue: TPasElement);
- begin
- if FElement=AValue then Exit;
- if Element<>nil then
- Element.Release{$IFDEF CheckPasTreeRefCount}(ClassName+'.SetElement'){$ENDIF};
- FElement:=AValue;
- if Element<>nil then
- Element.AddRef{$IFDEF CheckPasTreeRefCount}(ClassName+'.SetElement'){$ENDIF};
- end;
- constructor TResolveData.Create;
- begin
- end;
- destructor TResolveData.Destroy;
- begin
- {$IFDEF VerbosePasResolverMem}
- writeln('TResolveData.Destroy START ',ClassName);
- {$ENDIF}
- Element:=nil;
- Owner:=nil;
- Next:=nil;
- inherited Destroy;
- {$IFDEF VerbosePasResolverMem}
- writeln('TResolveData.Destroy END ',ClassName);
- {$ENDIF}
- end;
- { TResEvalValue }
- constructor TResEvalValue.CreateKind(const aKind: TREVKind);
- begin
- Create;
- Kind:=aKind;
- end;
- function TResEvalValue.Clone: TResEvalValue;
- begin
- Result:=TResEvalValueClass(ClassType).Create;
- Result.Kind:=Kind;
- Result.IdentEl:=IdentEl;
- end;
- function TResEvalValue.AsDebugString: string;
- begin
- str(Kind,Result);
- Result:=Result+'='+AsString;
- end;
- function TResEvalValue.AsString: string;
- begin
- case Kind of
- revkNone: Result:='<None>';
- revkNil: Result:='nil';
- else
- str(Kind,Result);
- end;
- end;
- function TResEvalValue.TypeAsString: string;
- begin
- case Kind of
- revkNil: Result:='nil';
- else
- Result:='';
- end;
- end;
- { TResEvalUInt }
- constructor TResEvalUInt.Create;
- begin
- inherited Create;
- Kind:=revkUInt;
- end;
- constructor TResEvalUInt.CreateValue(const aValue: TMaxPrecUInt);
- begin
- Create;
- UInt:=aValue;
- end;
- function TResEvalUInt.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalUInt(Result).UInt:=UInt;
- end;
- function TResEvalUInt.AsString: string;
- begin
- Result:=IntToStr(UInt);
- end;
- function TResEvalUInt.TypeAsString: string;
- begin
- Result:='unsigned int';
- end;
- { TResEvalInt }
- constructor TResEvalInt.Create;
- begin
- inherited Create;
- Kind:=revkInt;
- end;
- constructor TResEvalInt.CreateValue(const aValue: TMaxPrecInt);
- begin
- Create;
- Int:=aValue;
- end;
- constructor TResEvalInt.CreateValue(const aValue: TMaxPrecInt; aTyped: TResEvalTypedInt
- );
- begin
- Create;
- Int:=aValue;
- Typed:=aTyped;
- end;
- function TResEvalInt.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalInt(Result).Int:=Int;
- TResEvalInt(Result).Typed:=Typed;
- end;
- function TResEvalInt.AsString: string;
- begin
- Result:=IntToStr(Int);
- end;
- function TResEvalInt.AsDebugString: string;
- begin
- if Typed=reitNone then
- Result:=inherited AsDebugString
- else
- begin
- str(Kind,Result);
- case Typed of
- reitByte: Result:=Result+':byte';
- reitShortInt: Result:=Result+':shortint';
- reitWord: Result:=Result+':word';
- reitSmallInt: Result:=Result+':smallint';
- reitUIntSingle: Result:=Result+':uintsingle';
- reitIntSingle: Result:=Result+':intsingle';
- reitLongWord: Result:=Result+':longword';
- reitLongInt: Result:=Result+':longint';
- reitUIntDouble: Result:=Result+':uintdouble';
- reitIntDouble: Result:=Result+':intdouble';
- end;
- Result:=Result+'='+AsString;
- end;
- end;
- function TResEvalInt.TypeAsString: string;
- begin
- case Typed of
- reitByte: Result:='byte';
- reitShortInt: Result:='shortint';
- reitWord: Result:='word';
- reitSmallInt: Result:='smallint';
- reitUIntSingle: Result:='unsinged int single';
- reitIntSingle: Result:='int single';
- reitLongWord: Result:='longword';
- reitLongInt: Result:='longint';
- reitUIntDouble: Result:='unsigned int double';
- reitIntDouble: Result:='int double';
- else
- Result:='int';
- end;
- end;
- { TResEvalFloat }
- constructor TResEvalFloat.Create;
- begin
- inherited Create;
- Kind:=revkFloat;
- end;
- constructor TResEvalFloat.CreateValue(const aValue: TMaxPrecFloat);
- begin
- Create;
- FloatValue:=aValue;
- end;
- function TResEvalFloat.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalFloat(Result).FloatValue:=FloatValue;
- end;
- function TResEvalFloat.AsString: string;
- begin
- str(FloatValue,Result);
- end;
- function TResEvalFloat.IsInt(out Int: TMaxPrecInt): boolean;
- begin
- Int:=0;
- if Frac(FloatValue)<>0 then exit(false);
- if FloatValue<TMaxPrecFloat(low(TMaxPrecInt)) then exit(false);
- if FloatValue>TMaxPrecFloat(high(TMaxPrecInt)) then exit(false);
- Int:=Trunc(FloatValue);
- Result:=true;
- end;
- function TResEvalFloat.TypeAsString: string;
- begin
- Result:='float';
- end;
- {$ifdef FPC_HAS_CPSTRING}
- { TResEvalString }
- constructor TResEvalString.Create;
- begin
- inherited Create;
- OnlyASCII:=true;
- Kind:=revkString;
- end;
- constructor TResEvalString.CreateValue(const aValue: RawByteString);
- begin
- Create;
- S:=aValue;
- end;
- function TResEvalString.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalString(Result).S:=S;
- TResEvalString(Result).OnlyASCII:=OnlyASCII;
- end;
- function TResEvalString.AsString: string;
- begin
- Result:=RawStrToCaption(S,60);
- end;
- function TResEvalString.TypeAsString: string;
- begin
- if OnlyASCII then
- Result:='string'
- else
- Result:='ansistring';
- end;
- {$endif}
- { TResEvalUTF16 }
- constructor TResEvalUTF16.Create;
- begin
- inherited Create;
- Kind:=revkUnicodeString;
- end;
- constructor TResEvalUTF16.CreateValue(const aValue: UnicodeString);
- begin
- Create;
- S:=aValue;
- end;
- function TResEvalUTF16.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalUTF16(Result).S:=S;
- end;
- function TResEvalUTF16.AsString: string;
- begin
- Result:=String(UnicodeStrToCaption(S,60));
- end;
- function TResEvalUTF16.TypeAsString: string;
- begin
- Result:='unicodestring';
- end;
- { TResEvalEnum }
- constructor TResEvalEnum.Create;
- begin
- inherited Create;
- Kind:=revkEnum;
- end;
- constructor TResEvalEnum.CreateValue(const aValue: integer;
- aIdentEl: TPasEnumValue);
- begin
- Create;
- Index:=aValue;
- IdentEl:=aIdentEl;
- ElType:=IdentEl.Parent as TPasEnumType;
- if ElType=nil then
- raise Exception.Create('');
- end;
- function TResEvalEnum.GetEnumValue: TPasEnumValue;
- begin
- Result:=nil;
- if ElType<>nil then
- if (Index>=0) and (Index<ElType.Values.Count) then
- Result:=TObject(ElType.Values[Index]) as TPasEnumValue;
- end;
- function TResEvalEnum.GetEnumName: String;
- var
- V: TPasEnumValue;
- begin
- V:=GetEnumValue;
- if V<>nil then
- Result:=V.Name
- else
- Result:='';
- end;
- function TResEvalEnum.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalEnum(Result).Index:=Index;
- TResEvalEnum(Result).ElType:=ElType;
- end;
- function TResEvalEnum.AsDebugString: string;
- begin
- str(Kind,Result);
- Result:=Result+'='+AsString+'='+IntToStr(Index);
- end;
- function TResEvalEnum.AsString: string;
- begin
- if IdentEl<>nil then
- begin
- Result:=IdentEl.Name;
- if Result<>'' then exit;
- end;
- Result:=GetEnumName;
- if Result<>'' then exit;
- Result:=ElType.Name+'('+IntToStr(Index)+')';
- end;
- function TResEvalEnum.TypeAsString: string;
- begin
- Result:=ElType.Name;
- if Result='' then
- Result:='enum';
- end;
- { TResEvalRangeInt }
- constructor TResEvalRangeInt.Create;
- begin
- inherited Create;
- Kind:=revkRangeInt;
- end;
- constructor TResEvalRangeInt.CreateValue(const aElKind: TRESetElKind;
- aElType: TPasType; const aRangeStart, aRangeEnd: TMaxPrecInt);
- begin
- Create;
- ElKind:=aElKind;
- ElType:=aElType;
- RangeStart:=aRangeStart;
- RangeEnd:=aRangeEnd;
- end;
- function TResEvalRangeInt.Clone: TResEvalValue;
- begin
- Result:=inherited Clone;
- TResEvalRangeInt(Result).ElKind:=ElKind;
- TResEvalRangeInt(Result).RangeStart:=RangeStart;
- TResEvalRangeInt(Result).RangeEnd:=RangeEnd;
- end;
- function TResEvalRangeInt.AsString: string;
- begin
- Result:=ElementAsString(RangeStart)+'..'+ElementAsString(RangeEnd);
- end;
- function TResEvalRangeInt.AsDebugString: string;
- var
- s: string;
- begin
- str(Kind,Result);
- str(ElKind,s);
- Result:=Result+'/'+s+':'+GetObjName(ElType)+'='+AsString;
- end;
- function TResEvalRangeInt.ElementAsString(El: TMaxPrecInt): string;
- var
- EnumValue: TPasEnumValue;
- EnumType: TPasEnumType;
- begin
- case ElKind of
- revskBool:
- if El=0 then
- Result:='false'
- else
- Result:='true';
- revskEnum:
- begin
- EnumType:=ElType as TPasEnumType;
- if (El>=0) and (El<EnumType.Values.Count) then
- begin
- EnumValue:=TPasEnumValue(EnumType.Values[El]);
- Result:=EnumValue.Name;
- end
- else
- Result:=ElType.Name+'('+IntToStr(El)+')';
- end;
- revskInt: Result:=IntToStr(El);
- revskChar:
- if ((El>=32) and (El<=38)) or ((El>=40) and (El<=126)) then
- Result:=''''+Chr(El)+''''
- else
- Result:='#'+IntToStr(El);
- end;
- end;
- function TResEvalRangeInt.TypeAsString: string;
- begin
- case ElKind of
- revskEnum: Result:='enum range';
- revskInt: Result:='integer range';
- revskChar: Result:='char range';
- revskBool: Result:='boolean range';
- else
- Result:='integer range';
- end;
- end;
- { TResEvalSet }
- constructor TResEvalSet.Create;
- begin
- inherited Create;
- Kind:=revkSetOfInt;
- end;
- constructor TResEvalSet.CreateEmpty(const aElKind: TRESetElKind;
- aElType: TPasType);
- begin
- Create;
- ElKind:=aElKind;
- ElType:=aElType;
- end;
- constructor TResEvalSet.CreateEmptySameKind(aSet: TResEvalSet);
- begin
- Create;
- IdentEl:=aSet.IdentEl;
- ElKind:=aSet.ElKind;
- ElType:=aSet.ElType;
- end;
- constructor TResEvalSet.CreateValue(const aElKind: TRESetElKind;
- aElType: TPasType; const aRangeStart, aRangeEnd: TMaxPrecInt);
- begin
- inherited CreateValue(aElKind, aElType, aRangeStart, aRangeEnd);
- Add(aRangeStart,aRangeEnd);
- end;
- function TResEvalSet.Clone: TResEvalValue;
- var
- RS: TResEvalSet;
- i: Integer;
- begin
- Result:=inherited Clone;
- RS:=TResEvalSet(Result);
- RS.ElKind:=ElKind;
- RS.ElType:=ElType;
- SetLength(RS.Ranges,length(Ranges));
- for i:=0 to length(Ranges)-1 do
- RS.Ranges[i]:=Ranges[i];
- end;
- function TResEvalSet.AsString: string;
- var
- i: Integer;
- begin
- Result:='[';
- for i:=0 to length(Ranges)-1 do
- begin
- if i>0 then Result:=Result+',';
- Result:=Result+ElementAsString(Ranges[i].RangeStart);
- if Ranges[i].RangeStart<>Ranges[i].RangeEnd then
- Result:=Result+'..'+ElementAsString(Ranges[i].RangeEnd);
- end;
- Result:=Result+']';
- end;
- function TResEvalSet.TypeAsString: string;
- begin
- Result:='set';
- end;
- function TResEvalSet.Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean;
- {$IF FPC_FULLVERSION<30101}
- procedure Insert(const Item: TItem; var Items: TItems; Index: integer);
- var
- i: Integer;
- begin
- Setlength(Items,length(Items)+1);
- for i:=length(Items)-1 downto Index+1 do
- Items[i]:=Items[i-1];
- Items[Index]:=Item;
- end;
- procedure Delete(var Items: TItems; Start, Size: integer);
- var
- i: Integer;
- begin
- if Size=0 then exit;
- for i:=Start+Size to length(Items)-1 do
- Items[i-Size]:=Items[i];
- Setlength(Items,length(Items)-Size);
- end;
- {$ENDIF}
- var
- StartIndex, l, EndIndex: Integer;
- Item: TItem;
- begin
- Result:=false;
- {$IFDEF VerbosePasResEval}
- writeln('TResEvalSetInt.Add ',aRangeStart,'..',aRangeEnd);
- {$ENDIF}
- if aRangeStart>aRangeEnd then
- raise Exception.Create('');
- if ElKind=revskNone then
- raise Exception.Create('');
- l:=length(Ranges);
- if l=0 then
- begin
- // first range
- RangeStart:=aRangeStart;
- RangeEnd:=aRangeEnd;
- SetLength(Ranges,1);
- Ranges[0].RangeStart:=aRangeStart;
- Ranges[0].RangeEnd:=aRangeEnd;
- exit(true);
- end;
- if RangeStart>aRangeStart then
- RangeStart:=aRangeStart;
- if RangeEnd<aRangeEnd then
- RangeEnd:=aRangeEnd;
- // find insert position
- StartIndex:=IndexOfRange(aRangeStart,true);
- if (StartIndex>0) and (Ranges[StartIndex-1].RangeEnd=aRangeStart-1) then
- dec(StartIndex);
- if StartIndex=l then
- begin
- // add new range
- Item.RangeStart:=aRangeStart;
- Item.RangeEnd:=aRangeEnd;
- Insert(Item,Ranges,StartIndex);
- Result:=true;
- end
- else
- begin
- // StartIndex is now the first affected range
- EndIndex:=IndexOfRange(aRangeEnd,true);
- if (EndIndex>StartIndex) then
- if (EndIndex=l) or (Ranges[EndIndex].RangeStart>aRangeEnd+1) then
- dec(EndIndex);
- // EndIndex is now the last affected range
- if StartIndex>EndIndex then
- raise Exception.Create('');
- if StartIndex=EndIndex then
- begin
- if (Ranges[StartIndex].RangeStart>aRangeEnd) then
- begin
- // range in front
- if (Ranges[StartIndex].RangeStart>aRangeEnd+1) then
- begin
- // insert new range
- Item.RangeStart:=aRangeStart;
- Item.RangeEnd:=aRangeEnd;
- Insert(Item,Ranges,StartIndex);
- Result:=true;
- end
- else
- begin
- // enlarge range at its start
- Ranges[StartIndex].RangeStart:=aRangeStart;
- Result:=true;
- end;
- end
- else if Ranges[StartIndex].RangeEnd<aRangeStart then
- begin
- // range behind
- if Ranges[StartIndex].RangeEnd+1<aRangeStart then
- begin
- // insert new range
- Item.RangeStart:=aRangeStart;
- Item.RangeEnd:=aRangeEnd;
- Insert(Item,Ranges,StartIndex+1);
- Result:=true;
- end
- else
- begin
- // enlarge range at its end
- Ranges[StartIndex].RangeEnd:=aRangeEnd;
- Result:=true;
- end;
- end
- else
- begin
- // intersection -> enlarge to union range
- Result:=false;
- if (Ranges[StartIndex].RangeStart>aRangeStart) then
- Ranges[StartIndex].RangeStart:=aRangeStart;
- if (Ranges[StartIndex].RangeEnd<aRangeEnd) then
- Ranges[StartIndex].RangeEnd:=aRangeEnd;
- end;
- end
- else
- begin
- // multiple ranges are merged to one
- Result:=false;
- if Ranges[StartIndex].RangeStart>aRangeStart then
- Ranges[StartIndex].RangeStart:=aRangeStart;
- if aRangeEnd<Ranges[EndIndex].RangeEnd then
- aRangeEnd:=Ranges[EndIndex].RangeEnd;
- Ranges[StartIndex].RangeEnd:=aRangeEnd;
- Delete(Ranges,StartIndex+1,EndIndex-StartIndex);
- end;
- end;
- {$IFDEF VerbosePasResEval}
- writeln('TResEvalSetInt.Add END ',AsDebugString);
- ConsistencyCheck;
- {$ENDIF}
- end;
- function TResEvalSet.IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean
- ): integer;
- var
- l, r, m: Integer;
- begin
- l:=0;
- r:=length(Ranges)-1;
- while l<=r do
- begin
- m:=(l+r) div 2;
- if Ranges[m].RangeStart>Index then
- r:=m-1
- else if Ranges[m].RangeEnd<Index then
- l:=m+1
- else
- exit(m);
- end;
- if not FindInsertPos then
- exit(-1);
- // find insert position
- if length(Ranges)=0 then
- exit(0)
- else if l>m then
- exit(l)
- else
- exit(m);
- Result:=-1;
- end;
- function TResEvalSet.Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer;
- var
- Index: Integer;
- begin
- Index:=IndexOfRange(aRangeStart,true);
- if (Index=length(Ranges)) or (Ranges[Index].RangeStart>aRangeEnd) then
- Result:=-1
- else
- Result:=Index;
- end;
- procedure TResEvalSet.ConsistencyCheck;
- procedure E(Msg: string);
- begin
- raise Exception.Create(Msg);
- end;
- var
- i: Integer;
- begin
- if (ElKind=revskNone) and (length(Ranges)>0) then
- E('');
- for i:=0 to length(Ranges)-1 do
- begin
- if Ranges[i].RangeStart>Ranges[i].RangeEnd then
- E('');
- if (i>0) and (Ranges[i-1].RangeEnd+1>=Ranges[i].RangeStart) then
- E('missing gap');
- if RangeStart>Ranges[i].RangeStart then
- E('wrong RangeStart='+IntToStr(RangeStart));
- if RangeEnd<Ranges[i].RangeEnd then
- E('wrong RangeEnd='+IntToStr(RangeEnd));
- end;
- end;
- end.
|