tcmodules.pas 449 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382153831538415385153861538715388153891539015391153921539315394153951539615397153981539915400154011540215403154041540515406154071540815409154101541115412154131541415415154161541715418154191542015421154221542315424154251542615427154281542915430154311543215433154341543515436154371543815439154401544115442154431544415445154461544715448154491545015451154521545315454154551545615457154581545915460154611546215463154641546515466154671546815469154701547115472154731547415475154761547715478154791548015481154821548315484154851548615487154881548915490154911549215493154941549515496154971549815499155001550115502155031550415505155061550715508155091551015511155121551315514155151551615517155181551915520155211552215523155241552515526155271552815529155301553115532155331553415535155361553715538155391554015541155421554315544155451554615547155481554915550155511555215553155541555515556155571555815559155601556115562155631556415565155661556715568155691557015571155721557315574155751557615577155781557915580155811558215583155841558515586155871558815589155901559115592155931559415595155961559715598155991560015601156021560315604156051560615607156081560915610156111561215613156141561515616156171561815619156201562115622156231562415625156261562715628156291563015631156321563315634156351563615637156381563915640156411564215643156441564515646156471564815649156501565115652156531565415655156561565715658156591566015661156621566315664156651566615667156681566915670156711567215673156741567515676156771567815679156801568115682156831568415685156861568715688156891569015691156921569315694156951569615697156981569915700157011570215703157041570515706157071570815709157101571115712157131571415715157161571715718157191572015721157221572315724157251572615727157281572915730157311573215733157341573515736157371573815739157401574115742157431574415745157461574715748157491575015751157521575315754157551575615757157581575915760157611576215763157641576515766157671576815769157701577115772157731577415775157761577715778157791578015781157821578315784157851578615787157881578915790157911579215793157941579515796157971579815799158001580115802158031580415805158061580715808158091581015811158121581315814158151581615817158181581915820158211582215823158241582515826158271582815829158301583115832158331583415835158361583715838158391584015841158421584315844158451584615847158481584915850158511585215853158541585515856158571585815859158601586115862158631586415865158661586715868158691587015871158721587315874158751587615877158781587915880158811588215883158841588515886158871588815889158901589115892158931589415895158961589715898158991590015901159021590315904159051590615907159081590915910159111591215913159141591515916159171591815919159201592115922159231592415925159261592715928159291593015931159321593315934159351593615937159381593915940159411594215943159441594515946159471594815949159501595115952159531595415955159561595715958159591596015961159621596315964159651596615967159681596915970159711597215973159741597515976159771597815979159801598115982159831598415985159861598715988159891599015991159921599315994159951599615997159981599916000160011600216003160041600516006160071600816009160101601116012160131601416015160161601716018160191602016021160221602316024160251602616027160281602916030160311603216033160341603516036160371603816039160401604116042160431604416045160461604716048160491605016051160521605316054160551605616057160581605916060160611606216063160641606516066160671606816069160701607116072160731607416075160761607716078160791608016081160821608316084160851608616087160881608916090160911609216093160941609516096160971609816099161001610116102161031610416105161061610716108161091611016111161121611316114161151611616117161181611916120161211612216123161241612516126161271612816129161301613116132161331613416135161361613716138161391614016141161421614316144161451614616147161481614916150161511615216153161541615516156161571615816159161601616116162161631616416165161661616716168161691617016171161721617316174161751617616177161781617916180161811618216183161841618516186161871618816189161901619116192161931619416195161961619716198161991620016201162021620316204162051620616207162081620916210162111621216213162141621516216162171621816219162201622116222162231622416225162261622716228162291623016231162321623316234162351623616237162381623916240162411624216243162441624516246162471624816249162501625116252162531625416255162561625716258162591626016261162621626316264162651626616267162681626916270162711627216273162741627516276162771627816279162801628116282162831628416285162861628716288162891629016291162921629316294162951629616297162981629916300163011630216303163041630516306163071630816309163101631116312163131631416315163161631716318163191632016321163221632316324163251632616327163281632916330163311633216333163341633516336163371633816339163401634116342163431634416345163461634716348163491635016351163521635316354163551635616357163581635916360163611636216363163641636516366163671636816369163701637116372163731637416375163761637716378163791638016381163821638316384163851638616387163881638916390163911639216393163941639516396163971639816399164001640116402164031640416405164061640716408164091641016411164121641316414164151641616417164181641916420164211642216423164241642516426164271642816429164301643116432164331643416435164361643716438164391644016441164421644316444164451644616447164481644916450164511645216453164541645516456164571645816459164601646116462164631646416465164661646716468164691647016471164721647316474164751647616477164781647916480164811648216483164841648516486164871648816489164901649116492164931649416495164961649716498164991650016501165021650316504165051650616507165081650916510165111651216513165141651516516165171651816519165201652116522165231652416525165261652716528165291653016531165321653316534165351653616537165381653916540165411654216543165441654516546165471654816549165501655116552165531655416555165561655716558165591656016561165621656316564165651656616567165681656916570165711657216573165741657516576165771657816579165801658116582165831658416585165861658716588165891659016591165921659316594165951659616597165981659916600166011660216603166041660516606166071660816609166101661116612166131661416615166161661716618166191662016621166221662316624166251662616627166281662916630166311663216633166341663516636166371663816639166401664116642166431664416645166461664716648166491665016651166521665316654166551665616657166581665916660166611666216663166641666516666166671666816669166701667116672166731667416675166761667716678166791668016681166821668316684166851668616687166881668916690166911669216693166941669516696166971669816699167001670116702167031670416705167061670716708167091671016711167121671316714167151671616717167181671916720167211672216723167241672516726167271672816729167301673116732167331673416735167361673716738167391674016741167421674316744167451674616747167481674916750167511675216753167541675516756167571675816759167601676116762167631676416765167661676716768167691677016771167721677316774167751677616777167781677916780167811678216783167841678516786167871678816789167901679116792167931679416795167961679716798167991680016801168021680316804168051680616807168081680916810168111681216813168141681516816168171681816819168201682116822168231682416825168261682716828168291683016831168321683316834168351683616837168381683916840168411684216843168441684516846168471684816849168501685116852168531685416855168561685716858168591686016861168621686316864168651686616867168681686916870168711687216873168741687516876168771687816879168801688116882168831688416885168861688716888168891689016891168921689316894168951689616897168981689916900169011690216903169041690516906
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 2018 by Michael Van Canneyt
  4. Unit tests for Pascal-to-Javascript converter class.
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************
  11. Examples:
  12. ./testpas2js --suite=TTestModule.TestEmptyProgram
  13. ./testpas2js --suite=TTestModule.TestEmptyUnit
  14. }
  15. unit tcmodules;
  16. {$mode objfpc}{$H+}
  17. interface
  18. uses
  19. Classes, SysUtils, fpcunit, testregistry, contnrs,
  20. jstree, jswriter, jsbase,
  21. PasTree, PScanner, PasResolver, PParser, PasResolveEval,
  22. FPPas2Js;
  23. const
  24. // default parser+scanner options
  25. po_tcmodules = po_Pas2js+[po_KeepScannerError];
  26. co_tcmodules = [coNoTypeInfo];
  27. type
  28. { TTestPasParser }
  29. TTestPasParser = Class(TPasParser)
  30. end;
  31. TOnFindUnit = function(const aUnitName: String): TPasModule of object;
  32. { TTestEnginePasResolver }
  33. TTestEnginePasResolver = class(TPas2JsResolver)
  34. private
  35. FFilename: string;
  36. FModule: TPasModule;
  37. FOnFindUnit: TOnFindUnit;
  38. FParser: TTestPasParser;
  39. FStreamResolver: TStreamResolver;
  40. FScanner: TPascalScanner;
  41. FSource: string;
  42. procedure SetModule(AValue: TPasModule);
  43. public
  44. destructor Destroy; override;
  45. function FindUnit(const AName, InFilename: String; NameExpr,
  46. InFileExpr: TPasExpr): TPasModule; override;
  47. procedure UsedInterfacesFinished(Section: TPasSection); override;
  48. property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
  49. property Filename: string read FFilename write FFilename;
  50. property StreamResolver: TStreamResolver read FStreamResolver write FStreamResolver;
  51. property Scanner: TPascalScanner read FScanner write FScanner;
  52. property Parser: TTestPasParser read FParser write FParser;
  53. property Source: string read FSource write FSource;
  54. property Module: TPasModule read FModule write SetModule;
  55. end;
  56. { TCustomTestModule }
  57. TCustomTestModule = Class(TTestCase)
  58. private
  59. FConverter: TPasToJSConverter;
  60. FEngine: TTestEnginePasResolver;
  61. FExpectedErrorClass: ExceptClass;
  62. FExpectedErrorMsg: string;
  63. FExpectedErrorNumber: integer;
  64. FFilename: string;
  65. FFileResolver: TStreamResolver;
  66. FJSImplementationSrc: TJSSourceElements;
  67. FJSImplementationUses: TJSArrayLiteral;
  68. FJSInitBody: TJSFunctionBody;
  69. FJSImplentationUses: TJSArrayLiteral;
  70. FJSInterfaceUses: TJSArrayLiteral;
  71. FJSModule: TJSSourceElements;
  72. FJSModuleSrc: TJSSourceElements;
  73. FJSSource: TStringList;
  74. FModule: TPasModule;
  75. FJSModuleCallArgs: TJSArguments;
  76. FModules: TObjectList;// list of TTestEnginePasResolver
  77. FParser: TTestPasParser;
  78. FPasProgram: TPasProgram;
  79. FJSRegModuleCall: TJSCallExpression;
  80. FScanner: TPascalScanner;
  81. FSkipTests: boolean;
  82. FSource: TStringList;
  83. FFirstPasStatement: TPasImplBlock;
  84. function GetResolverCount: integer;
  85. function GetResolvers(Index: integer): TTestEnginePasResolver;
  86. function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
  87. protected
  88. procedure SetUp; override;
  89. function CreateConverter: TPasToJSConverter; virtual;
  90. function LoadUnit(const aUnitName: String): TPasModule;
  91. procedure InitScanner(aScanner: TPascalScanner); virtual;
  92. procedure TearDown; override;
  93. Procedure Add(Line: string); virtual;
  94. Procedure Add(const Lines: array of string);
  95. Procedure StartParsing; virtual;
  96. procedure ParseModuleQueue; virtual;
  97. procedure ParseModule; virtual;
  98. procedure ParseProgram; virtual;
  99. procedure ParseUnit; virtual;
  100. protected
  101. function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
  102. function AddModule(aFilename: string): TTestEnginePasResolver; virtual;
  103. function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
  104. function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  105. ImplementationSrc: string): TTestEnginePasResolver; virtual;
  106. procedure AddSystemUnit; virtual;
  107. procedure StartProgram(NeedSystemUnit: boolean); virtual;
  108. procedure StartUnit(NeedSystemUnit: boolean); virtual;
  109. procedure ConvertModule; virtual;
  110. procedure ConvertProgram; virtual;
  111. procedure ConvertUnit; virtual;
  112. function ConvertJSModuleToString(El: TJSElement): string; virtual;
  113. procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
  114. function GetDottedIdentifier(El: TJSElement): string;
  115. procedure CheckSource(Msg,Statements: String; InitStatements: string = '';
  116. ImplStatements: string = ''); virtual;
  117. procedure CheckDiff(Msg, Expected, Actual: string); virtual;
  118. procedure CheckUnit(Filename, ExpectedSrc: string); virtual;
  119. procedure SetExpectedScannerError(Msg: string; MsgNumber: integer);
  120. procedure SetExpectedParserError(Msg: string; MsgNumber: integer);
  121. procedure SetExpectedPasResolverError(Msg: string; MsgNumber: integer);
  122. procedure SetExpectedConverterError(Msg: string; MsgNumber: integer);
  123. function IsErrorExpected(E: Exception): boolean;
  124. procedure HandleScannerError(E: EScannerError);
  125. procedure HandleParserError(E: EParserError);
  126. procedure HandlePasResolveError(E: EPasResolve);
  127. procedure HandlePas2JSError(E: EPas2JS);
  128. procedure HandleException(E: Exception);
  129. procedure FailException(E: Exception);
  130. procedure WriteSources(const aFilename: string; aRow, aCol: integer);
  131. function IndexOfResolver(const Filename: string): integer;
  132. function GetResolver(const Filename: string): TTestEnginePasResolver;
  133. function GetDefaultNamespace: string;
  134. property PasProgram: TPasProgram Read FPasProgram;
  135. property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
  136. property ResolverCount: integer read GetResolverCount;
  137. property Engine: TTestEnginePasResolver read FEngine;
  138. property Filename: string read FFilename;
  139. Property Module: TPasModule Read FModule;
  140. property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
  141. property Converter: TPasToJSConverter read FConverter;
  142. property JSSource: TStringList read FJSSource;
  143. property JSModule: TJSSourceElements read FJSModule;
  144. property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
  145. property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
  146. property JSImplementationUses: TJSArrayLiteral read FJSImplementationUses;
  147. property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
  148. property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
  149. property JSInitBody: TJSFunctionBody read FJSInitBody;
  150. property JSImplementationSrc: TJSSourceElements read FJSImplementationSrc;
  151. property ExpectedErrorClass: ExceptClass read FExpectedErrorClass write FExpectedErrorClass;
  152. property ExpectedErrorMsg: string read FExpectedErrorMsg write FExpectedErrorMsg;
  153. property ExpectedErrorNumber: integer read FExpectedErrorNumber write FExpectedErrorNumber;
  154. property SkipTests: boolean read FSkipTests write FSkipTests;
  155. public
  156. property Source: TStringList read FSource;
  157. property FileResolver: TStreamResolver read FFileResolver;
  158. property Scanner: TPascalScanner read FScanner;
  159. property Parser: TTestPasParser read FParser;
  160. end;
  161. { TTestModule }
  162. TTestModule = class(TCustomTestModule)
  163. Published
  164. // program/units
  165. Procedure TestEmptyProgram;
  166. Procedure TestEmptyProgramUseStrict;
  167. Procedure TestEmptyUnit;
  168. Procedure TestEmptyUnitUseStrict;
  169. Procedure TestDottedUnitNames;
  170. Procedure TestDottedUnitNameImpl;
  171. Procedure TestDottedUnitExpr;
  172. Procedure Test_ModeFPCFail;
  173. Procedure Test_ModeSwitchCBlocksFail;
  174. Procedure TestUnit_Intf1Impl2Intf1;
  175. // vars/const
  176. Procedure TestVarInt;
  177. Procedure TestVarBaseTypes;
  178. Procedure TestBaseTypeSingleFail;
  179. Procedure TestBaseTypeExtendedFail;
  180. Procedure TestConstBaseTypes;
  181. Procedure TestUnitImplVars;
  182. Procedure TestUnitImplConsts;
  183. Procedure TestUnitImplRecord;
  184. Procedure TestRenameJSNameConflict;
  185. Procedure TestLocalConst;
  186. Procedure TestVarExternal;
  187. Procedure TestVarExternalOtherUnit;
  188. Procedure TestVarAbsoluteFail;
  189. // numbers
  190. Procedure TestDouble;
  191. Procedure TestInteger;
  192. Procedure TestIntegerRange;
  193. Procedure TestForBoolDo;
  194. Procedure TestForIntDo;
  195. Procedure TestForIntInDo;
  196. // strings
  197. Procedure TestCharConst;
  198. Procedure TestChar_Compare;
  199. Procedure TestChar_Ord;
  200. Procedure TestChar_Chr;
  201. Procedure TestStringConst;
  202. Procedure TestStringConstSurrogate;
  203. Procedure TestString_Length;
  204. Procedure TestString_Compare;
  205. Procedure TestString_SetLength;
  206. Procedure TestString_CharAt;
  207. Procedure TestStr;
  208. Procedure TestBaseType_AnsiStringFail;
  209. Procedure TestBaseType_WideStringFail;
  210. Procedure TestBaseType_ShortStringFail;
  211. Procedure TestBaseType_RawByteStringFail;
  212. Procedure TestTypeShortstring_Fail;
  213. Procedure TestCharSet_Custom;
  214. Procedure TestForCharDo;
  215. Procedure TestForCharInDo;
  216. // alias types
  217. Procedure TestAliasTypeRef;
  218. Procedure TestTypeCast_BaseTypes;
  219. Procedure TestTypeCast_AliasBaseTypes;
  220. // functions
  221. Procedure TestEmptyProc;
  222. Procedure TestProcOneParam;
  223. Procedure TestFunctionWithoutParams;
  224. Procedure TestProcedureWithoutParams;
  225. Procedure TestPrgProcVar;
  226. Procedure TestProcTwoArgs;
  227. Procedure TestProc_DefaultValue;
  228. Procedure TestUnitProcVar;
  229. Procedure TestImplProc;
  230. Procedure TestFunctionResult;
  231. Procedure TestNestedProc;
  232. Procedure TestNestedProc_ResultString;
  233. Procedure TestForwardProc;
  234. Procedure TestNestedForwardProc;
  235. Procedure TestAssignFunctionResult;
  236. Procedure TestFunctionResultInCondition;
  237. Procedure TestExit;
  238. Procedure TestBreak;
  239. Procedure TestBreakAsVar;
  240. Procedure TestContinue;
  241. Procedure TestProc_External;
  242. Procedure TestProc_ExternalOtherUnit;
  243. Procedure TestProc_Asm;
  244. Procedure TestProc_Assembler;
  245. Procedure TestProc_VarParam;
  246. Procedure TestProc_VarParamString;
  247. Procedure TestProc_VarParamV;
  248. Procedure TestProc_Overload;
  249. Procedure TestProc_OverloadForward;
  250. Procedure TestProc_OverloadIntfImpl;
  251. Procedure TestProc_OverloadNested;
  252. Procedure TestProc_OverloadUnitCycle;
  253. Procedure TestProc_Varargs;
  254. Procedure TestProc_ConstOrder;
  255. Procedure TestProc_LocalVarAbsolute;
  256. // enums, sets
  257. Procedure TestEnum_Name;
  258. Procedure TestEnum_Number;
  259. Procedure TestEnum_ConstFail;
  260. Procedure TestEnum_Functions;
  261. Procedure TestEnum_AsParams;
  262. Procedure TestEnumRange_Array;
  263. Procedure TestEnum_ForIn;
  264. Procedure TestEnum_ScopedNumber;
  265. Procedure TestSet;
  266. Procedure TestSet_Operators;
  267. Procedure TestSet_Operator_In;
  268. Procedure TestSet_Functions;
  269. Procedure TestSet_PassAsArgClone;
  270. Procedure TestSet_AsParams;
  271. Procedure TestSet_Property;
  272. Procedure TestSet_EnumConst;
  273. Procedure TestSet_AnonymousEnumType;
  274. Procedure TestSet_ConstEnum;
  275. Procedure TestSet_ConstChar;
  276. Procedure TestSet_ConstInt;
  277. Procedure TestSet_ForIn;
  278. // statements
  279. Procedure TestNestBegin;
  280. Procedure TestIncDec;
  281. Procedure TestAssignments;
  282. Procedure TestArithmeticOperators1;
  283. Procedure TestLogicalOperators;
  284. Procedure TestBitwiseOperators;
  285. Procedure TestFunctionInt;
  286. Procedure TestFunctionString;
  287. Procedure TestForLoop;
  288. Procedure TestForLoopInsideFunction;
  289. Procedure TestForLoop_ReadVarAfter;
  290. Procedure TestForLoop_Nested;
  291. Procedure TestRepeatUntil;
  292. Procedure TestAsmBlock;
  293. Procedure TestAsmPas_Impl; // ToDo
  294. Procedure TestTryFinally;
  295. Procedure TestTryExcept;
  296. Procedure TestCaseOf;
  297. Procedure TestCaseOf_UseSwitch;
  298. Procedure TestCaseOfNoElse;
  299. Procedure TestCaseOfNoElse_UseSwitch;
  300. Procedure TestCaseOfRange;
  301. // arrays
  302. Procedure TestArray_Dynamic;
  303. Procedure TestArray_Dynamic_Nil;
  304. Procedure TestArray_DynMultiDimensional;
  305. Procedure TestArray_StaticInt;
  306. Procedure TestArray_StaticBool;
  307. Procedure TestArray_StaticChar;
  308. Procedure TestArray_StaticMultiDim; // ToDo
  309. Procedure TestArrayOfRecord;
  310. // ToDo: Procedure TestArrayOfSet;
  311. Procedure TestArray_DynAsParam;
  312. Procedure TestArray_StaticAsParam;
  313. Procedure TestArrayElement_AsParams;
  314. Procedure TestArrayElementFromFuncResult_AsParams;
  315. Procedure TestArrayEnumTypeRange;
  316. Procedure TestArray_SetLengthOutArg;
  317. Procedure TestArray_SetLengthProperty;
  318. Procedure TestArray_SetLengthMultiDim;
  319. Procedure TestArray_OpenArrayOfString;
  320. Procedure TestArray_Concat;
  321. Procedure TestArray_Copy;
  322. Procedure TestArray_InsertDelete;
  323. Procedure TestArray_DynArrayConst;
  324. Procedure TestExternalClass_TypeCastArrayToExternalArray;
  325. Procedure TestExternalClass_TypeCastArrayFromExternalArray;
  326. // record
  327. Procedure TestRecord_Empty;
  328. Procedure TestRecord_Var;
  329. Procedure TestWithRecordDo;
  330. Procedure TestRecord_Assign;
  331. Procedure TestRecord_PassAsArgClone;
  332. Procedure TestRecord_AsParams;
  333. Procedure TestRecordElement_AsParams;
  334. Procedure TestRecordElementFromFuncResult_AsParams;
  335. Procedure TestRecordElementFromWith_AsParams;
  336. Procedure TestRecord_Equal;
  337. Procedure TestRecord_TypeCastJSValueToRecord;
  338. Procedure TestRecord_VariantFail;
  339. // ToDo: const record
  340. // classes
  341. Procedure TestClass_TObjectDefaultConstructor;
  342. Procedure TestClass_TObjectConstructorWithParams;
  343. Procedure TestClass_TObjectConstructorWithDefaultParam;
  344. Procedure TestClass_Var;
  345. Procedure TestClass_Method;
  346. Procedure TestClass_Implementation;
  347. Procedure TestClass_Inheritance;
  348. Procedure TestClass_AbstractMethod;
  349. Procedure TestClass_CallInherited_NoParams;
  350. Procedure TestClass_CallInherited_WithParams;
  351. Procedure TestClasS_CallInheritedConstructor;
  352. Procedure TestClass_ClassVar;
  353. Procedure TestClass_CallClassMethod;
  354. Procedure TestClass_Property;
  355. Procedure TestClass_Property_ClassMethod;
  356. Procedure TestClass_Property_Indexed;
  357. Procedure TestClass_Property_IndexSpec;
  358. Procedure TestClass_PropertyOfTypeArray;
  359. Procedure TestClass_PropertyDefault;
  360. Procedure TestClass_PropertyOverride;
  361. Procedure TestClass_PropertyIncVisibility;
  362. Procedure TestClass_Assigned;
  363. Procedure TestClass_WithClassDoCreate;
  364. Procedure TestClass_WithClassInstDoProperty;
  365. Procedure TestClass_WithClassInstDoPropertyWithParams;
  366. Procedure TestClass_WithClassInstDoFunc;
  367. Procedure TestClass_TypeCast;
  368. Procedure TestClass_TypeCastUntypedParam;
  369. Procedure TestClass_Overloads;
  370. Procedure TestClass_OverloadsAncestor;
  371. Procedure TestClass_OverloadConstructor;
  372. Procedure TestClass_OverloadDelphiOverride;
  373. Procedure TestClass_ReintroducedVar;
  374. Procedure TestClass_RaiseDescendant;
  375. Procedure TestClass_ExternalMethod;
  376. Procedure TestClass_ExternalVirtualNameMismatchFail;
  377. Procedure TestClass_ExternalOverrideFail;
  378. Procedure TestClass_ExternalVar;
  379. Procedure TestClass_Const;
  380. Procedure TestClass_LocalVarSelfFail;
  381. Procedure TestClass_ArgSelfFail;
  382. Procedure TestClass_NestedProcSelf;
  383. Procedure TestClass_NestedProcSelf2;
  384. Procedure TestClass_NestedProcClassSelf;
  385. Procedure TestClass_NestedProcCallInherited;
  386. Procedure TestClass_TObjectFree;
  387. Procedure TestClass_TObjectFreeNewInstance;
  388. Procedure TestClass_TObjectFreeLowerCase;
  389. Procedure TestClass_TObjectFreeFunctionFail;
  390. Procedure TestClass_TObjectFreePropertyFail;
  391. Procedure TestClass_ForIn;
  392. // class of
  393. Procedure TestClassOf_Create;
  394. Procedure TestClassOf_Call;
  395. Procedure TestClassOf_Assign;
  396. Procedure TestClassOf_Is;
  397. Procedure TestClassOf_Compare;
  398. Procedure TestClassOf_ClassVar;
  399. Procedure TestClassOf_ClassMethod;
  400. Procedure TestClassOf_ClassProperty;
  401. Procedure TestClassOf_ClassMethodSelf;
  402. Procedure TestClassOf_TypeCast;
  403. Procedure TestClassOf_ImplicitFunctionCall;
  404. Procedure TestClassOf_Const;
  405. // nested class
  406. Procedure TestNestedClass_Fail;
  407. // external class
  408. Procedure TestExternalClass_Var;
  409. Procedure TestExternalClass_Const;
  410. Procedure TestExternalClass_Dollar;
  411. Procedure TestExternalClass_DuplicateVarFail;
  412. Procedure TestExternalClass_Method;
  413. Procedure TestExternalClass_ClassMethod;
  414. Procedure TestExternalClass_NonExternalOverride;
  415. Procedure TestExternalClass_Property;
  416. Procedure TestExternalClass_ClassProperty;
  417. Procedure TestExternalClass_ClassOf;
  418. Procedure TestExternalClass_ClassOtherUnit;
  419. Procedure TestExternalClass_Is;
  420. Procedure TestExternalClass_As;
  421. Procedure TestExternalClass_DestructorFail;
  422. Procedure TestExternalClass_New;
  423. Procedure TestExternalClass_ClassOf_New;
  424. Procedure TestExternalClass_FuncClassOf_New;
  425. Procedure TestExternalClass_LocalConstSameName;
  426. Procedure TestExternalClass_ReintroduceOverload;
  427. Procedure TestExternalClass_Inherited;
  428. Procedure TestExternalClass_PascalAncestorFail;
  429. Procedure TestExternalClass_NewInstance;
  430. Procedure TestExternalClass_NewInstance_NonVirtualFail;
  431. Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
  432. Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail;
  433. Procedure TestExternalClass_PascalProperty;
  434. Procedure TestExternalClass_TypeCastToRootClass;
  435. Procedure TestExternalClass_TypeCastStringToExternalString;
  436. Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
  437. Procedure TestExternalClass_BracketAccessor;
  438. Procedure TestExternalClass_BracketAccessor_2ParamsFail;
  439. Procedure TestExternalClass_BracketAccessor_ReadOnly;
  440. Procedure TestExternalClass_BracketAccessor_WriteOnly;
  441. Procedure TestExternalClass_BracketAccessor_MultiType;
  442. Procedure TestExternalClass_BracketAccessor_Index;
  443. // class interfaces
  444. Procedure TestClassInterface_Ignore;
  445. // proc types
  446. Procedure TestProcType;
  447. Procedure TestProcType_Arg;
  448. Procedure TestProcType_FunctionFPC;
  449. Procedure TestProcType_FunctionDelphi;
  450. Procedure TestProcType_ProcedureDelphi;
  451. Procedure TestProcType_AsParam;
  452. Procedure TestProcType_MethodFPC;
  453. Procedure TestProcType_MethodDelphi;
  454. Procedure TestProcType_PropertyFPC;
  455. Procedure TestProcType_PropertyDelphi;
  456. Procedure TestProcType_WithClassInstDoPropertyFPC;
  457. Procedure TestProcType_Nested;
  458. Procedure TestProcType_NestedOfObject;
  459. Procedure TestProcType_ReferenceToProc;
  460. Procedure TestProcType_ReferenceToMethod;
  461. Procedure TestProcType_Typecast;
  462. Procedure TestProcType_PassProcToUntyped;
  463. Procedure TestProcType_PassProcToArray;
  464. // pointer
  465. Procedure TestPointer;
  466. Procedure TestPointer_Proc;
  467. Procedure TestPointer_AssignRecordFail;
  468. Procedure TestPointer_AssignStaticArrayFail;
  469. Procedure TestPointer_ArrayParamsFail;
  470. Procedure TestPointer_TypeCastJSValueToPointer;
  471. // jsvalue
  472. Procedure TestJSValue_AssignToJSValue;
  473. Procedure TestJSValue_TypeCastToBaseType;
  474. Procedure TestJSValue_Equal;
  475. Procedure TestJSValue_If;
  476. Procedure TestJSValue_Enum;
  477. Procedure TestJSValue_ClassInstance;
  478. Procedure TestJSValue_ClassOf;
  479. Procedure TestJSValue_ArrayOfJSValue;
  480. Procedure TestJSValue_Params;
  481. Procedure TestJSValue_UntypedParam;
  482. Procedure TestJSValue_FuncResultType;
  483. Procedure TestJSValue_ProcType_Assign;
  484. Procedure TestJSValue_ProcType_Equal;
  485. Procedure TestJSValue_ProcType_Param;
  486. Procedure TestJSValue_AssignToPointerFail;
  487. Procedure TestJSValue_OverloadDouble;
  488. Procedure TestJSValue_OverloadNativeInt;
  489. Procedure TestJSValue_OverloadWord;
  490. Procedure TestJSValue_OverloadString;
  491. Procedure TestJSValue_OverloadChar;
  492. Procedure TestJSValue_OverloadPointer;
  493. // RTTI
  494. Procedure TestRTTI_ProcType;
  495. Procedure TestRTTI_ProcType_ArgFromOtherUnit;
  496. Procedure TestRTTI_EnumAndSetType;
  497. Procedure TestRTTI_EnumRange;
  498. Procedure TestRTTI_AnonymousEnumType;
  499. Procedure TestRTTI_StaticArray;
  500. Procedure TestRTTI_DynArray;
  501. Procedure TestRTTI_ArrayNestedAnonymous;
  502. // ToDo: Procedure TestRTTI_Pointer;
  503. Procedure TestRTTI_PublishedMethodOverloadFail;
  504. Procedure TestRTTI_PublishedMethodExternalFail;
  505. Procedure TestRTTI_PublishedClassPropertyFail;
  506. Procedure TestRTTI_PublishedClassFieldFail;
  507. Procedure TestRTTI_PublishedFieldExternalFail;
  508. Procedure TestRTTI_IndexModifier;
  509. Procedure TestRTTI_StoredModifier;
  510. Procedure TestRTTI_DefaultValue;
  511. Procedure TestRTTI_DefaultValueSet;
  512. Procedure TestRTTI_DefaultValueRangeType;
  513. Procedure TestRTTI_Class_Field;
  514. Procedure TestRTTI_Class_Method;
  515. Procedure TestRTTI_Class_MethodArgFlags;
  516. Procedure TestRTTI_Class_Property;
  517. Procedure TestRTTI_Class_PropertyParams;
  518. Procedure TestRTTI_OverrideMethod;
  519. Procedure TestRTTI_OverloadProperty;
  520. // ToDo: array argument
  521. Procedure TestRTTI_ClassForward;
  522. Procedure TestRTTI_ClassOf;
  523. Procedure TestRTTI_Record;
  524. Procedure TestRTTI_RecordAnonymousArray;
  525. Procedure TestRTTI_LocalTypes;
  526. Procedure TestRTTI_TypeInfo_BaseTypes;
  527. Procedure TestRTTI_TypeInfo_LocalFail;
  528. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  529. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  530. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  531. Procedure TestRTTI_TypeInfo_FunctionClassType;
  532. // Resourcestring
  533. Procedure TestResourcestringProgram;
  534. Procedure TestResourcestringUnit;
  535. Procedure TestResourcestringImplementation;
  536. // ToDo: in unit interface and implementation
  537. // Attributes
  538. Procedure TestAtributes_Ignore;
  539. // Assertions, checks
  540. procedure TestAssert;
  541. procedure TestAssert_SysUtils;
  542. procedure TestObjectChecks;
  543. procedure TestRangeChecks_Assign;
  544. end;
  545. function LinesToStr(Args: array of const): string;
  546. function ExtractFileUnitName(aFilename: string): string;
  547. function JSToStr(El: TJSElement): string;
  548. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  549. implementation
  550. function LinesToStr(Args: array of const): string;
  551. var
  552. s: String;
  553. i: Integer;
  554. begin
  555. s:='';
  556. for i:=Low(Args) to High(Args) do
  557. case Args[i].VType of
  558. vtChar: s += Args[i].VChar+LineEnding;
  559. vtString: s += Args[i].VString^+LineEnding;
  560. vtPChar: s += Args[i].VPChar+LineEnding;
  561. vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
  562. vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
  563. vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
  564. vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
  565. vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
  566. end;
  567. Result:=s;
  568. end;
  569. function ExtractFileUnitName(aFilename: string): string;
  570. var
  571. p: Integer;
  572. begin
  573. Result:=ExtractFileName(aFilename);
  574. if Result='' then exit;
  575. for p:=length(Result) downto 1 do
  576. case Result[p] of
  577. '/','\': exit;
  578. '.':
  579. begin
  580. Delete(Result,p,length(Result));
  581. exit;
  582. end;
  583. end;
  584. end;
  585. function JSToStr(El: TJSElement): string;
  586. var
  587. aWriter: TBufferWriter;
  588. aJSWriter: TJSWriter;
  589. begin
  590. aJSWriter:=nil;
  591. aWriter:=TBufferWriter.Create(1000);
  592. try
  593. aJSWriter:=TJSWriter.Create(aWriter);
  594. aJSWriter.IndentSize:=2;
  595. aJSWriter.WriteJS(El);
  596. Result:=aWriter.AsAnsistring;
  597. finally
  598. aJSWriter.Free;
  599. aWriter.Free;
  600. end;
  601. end;
  602. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  603. // search diff, ignore changes in spaces
  604. const
  605. SpaceChars = [#9,#10,#13,' '];
  606. var
  607. ExpectedP, ActualP: PChar;
  608. function FindLineEnd(p: PChar): PChar;
  609. begin
  610. Result:=p;
  611. while not (Result^ in [#0,#10,#13]) do inc(Result);
  612. end;
  613. function FindLineStart(p, MinP: PChar): PChar;
  614. begin
  615. while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
  616. Result:=p;
  617. end;
  618. procedure SkipLineEnd(var p: PChar);
  619. begin
  620. if p^ in [#10,#13] then
  621. begin
  622. if (p[1] in [#10,#13]) and (p^<>p[1]) then
  623. inc(p,2)
  624. else
  625. inc(p);
  626. end;
  627. end;
  628. procedure DiffFound;
  629. var
  630. ActLineStartP, ActLineEndP, p, StartPos: PChar;
  631. ExpLine, ActLine: String;
  632. i, LineNo, DiffLineNo: Integer;
  633. begin
  634. writeln('Diff found "',Msg,'". Lines:');
  635. // write correct lines
  636. p:=PChar(Expected);
  637. LineNo:=0;
  638. DiffLineNo:=0;
  639. repeat
  640. StartPos:=p;
  641. while not (p^ in [#0,#10,#13]) do inc(p);
  642. ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
  643. SkipLineEnd(p);
  644. inc(LineNo);
  645. if (p<=ExpectedP) and (p^<>#0) then
  646. begin
  647. writeln('= ',ExpLine);
  648. end else begin
  649. // diff line
  650. if DiffLineNo=0 then DiffLineNo:=LineNo;
  651. // write actual line
  652. ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
  653. ActLineEndP:=FindLineEnd(ActualP);
  654. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  655. writeln('- ',ActLine);
  656. // write expected line
  657. writeln('+ ',ExpLine);
  658. // write empty line with pointer ^
  659. for i:=1 to 2+ExpectedP-StartPos do write(' ');
  660. writeln('^');
  661. Msg:='expected "'+ExpLine+'", but got "'+ActLine+'".';
  662. CheckSrcDiff:=false;
  663. // write up to three following actual lines to get some context
  664. for i:=1 to 3 do begin
  665. ActLineStartP:=ActLineEndP;
  666. SkipLineEnd(ActLineStartP);
  667. if ActLineStartP^=#0 then break;
  668. ActLineEndP:=FindLineEnd(ActLineStartP);
  669. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  670. writeln('~ ',ActLine);
  671. end;
  672. exit;
  673. end;
  674. until p^=#0;
  675. writeln('DiffFound Actual:-----------------------');
  676. writeln(Actual);
  677. writeln('DiffFound Expected:---------------------');
  678. writeln(Expected);
  679. writeln('DiffFound ------------------------------');
  680. Msg:='diff found, but lines are the same, internal error';
  681. CheckSrcDiff:=false;
  682. end;
  683. var
  684. IsSpaceNeeded: Boolean;
  685. LastChar, Quote: Char;
  686. begin
  687. Result:=true;
  688. Msg:='';
  689. if Expected='' then Expected:=' ';
  690. if Actual='' then Actual:=' ';
  691. ExpectedP:=PChar(Expected);
  692. ActualP:=PChar(Actual);
  693. repeat
  694. //writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
  695. case ExpectedP^ of
  696. #0:
  697. begin
  698. // check that rest of Actual has only spaces
  699. while ActualP^ in SpaceChars do inc(ActualP);
  700. if ActualP^<>#0 then
  701. begin
  702. DiffFound;
  703. exit;
  704. end;
  705. exit(true);
  706. end;
  707. ' ',#9,#10,#13:
  708. begin
  709. // skip space in Expected
  710. IsSpaceNeeded:=false;
  711. if ExpectedP>PChar(Expected) then
  712. LastChar:=ExpectedP[-1]
  713. else
  714. LastChar:=#0;
  715. while ExpectedP^ in SpaceChars do inc(ExpectedP);
  716. if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
  717. and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
  718. IsSpaceNeeded:=true;
  719. if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
  720. begin
  721. DiffFound;
  722. exit;
  723. end;
  724. while ActualP^ in SpaceChars do inc(ActualP);
  725. end;
  726. '''','"':
  727. begin
  728. while ActualP^ in SpaceChars do inc(ActualP);
  729. if ExpectedP^<>ActualP^ then
  730. begin
  731. DiffFound;
  732. exit;
  733. end;
  734. Quote:=ExpectedP^;
  735. repeat
  736. inc(ExpectedP);
  737. inc(ActualP);
  738. if ExpectedP^<>ActualP^ then
  739. begin
  740. DiffFound;
  741. exit;
  742. end;
  743. if (ExpectedP^ in [#0,#10,#13]) then
  744. break
  745. else if (ExpectedP^=Quote) then
  746. begin
  747. inc(ExpectedP);
  748. inc(ActualP);
  749. break;
  750. end;
  751. until false;
  752. end;
  753. else
  754. while ActualP^ in SpaceChars do inc(ActualP);
  755. if ExpectedP^<>ActualP^ then
  756. begin
  757. DiffFound;
  758. exit;
  759. end;
  760. inc(ExpectedP);
  761. inc(ActualP);
  762. end;
  763. until false;
  764. end;
  765. { TTestEnginePasResolver }
  766. procedure TTestEnginePasResolver.SetModule(AValue: TPasModule);
  767. begin
  768. if FModule=AValue then Exit;
  769. if Module<>nil then
  770. Module.Release;
  771. FModule:=AValue;
  772. if Module<>nil then
  773. Module.AddRef;
  774. end;
  775. destructor TTestEnginePasResolver.Destroy;
  776. begin
  777. FreeAndNil(FStreamResolver);
  778. Module:=nil;
  779. FreeAndNil(FParser);
  780. FreeAndNil(FScanner);
  781. FreeAndNil(FStreamResolver);
  782. inherited Destroy;
  783. end;
  784. function TTestEnginePasResolver.FindUnit(const AName, InFilename: String;
  785. NameExpr, InFileExpr: TPasExpr): TPasModule;
  786. begin
  787. Result:=nil;
  788. if InFilename<>'' then
  789. RaiseNotYetImplemented(20180224101926,InFileExpr,'Use testcase tcunitsearch instead');
  790. if Assigned(OnFindUnit) then
  791. Result:=OnFindUnit(AName);
  792. if NameExpr=nil then ;
  793. end;
  794. procedure TTestEnginePasResolver.UsedInterfacesFinished(Section: TPasSection);
  795. begin
  796. // do not parse recursively
  797. // parse via the queue
  798. if Section=nil then ;
  799. end;
  800. { TCustomTestModule }
  801. function TCustomTestModule.GetResolverCount: integer;
  802. begin
  803. Result:=FModules.Count;
  804. end;
  805. function TCustomTestModule.GetResolvers(Index: integer
  806. ): TTestEnginePasResolver;
  807. begin
  808. Result:=TTestEnginePasResolver(FModules[Index]);
  809. end;
  810. function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
  811. ): TPasModule;
  812. var
  813. DefNamespace: String;
  814. begin
  815. //writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
  816. if (Pos('.',aUnitName)<1) then
  817. begin
  818. DefNamespace:=GetDefaultNamespace;
  819. if DefNamespace<>'' then
  820. begin
  821. Result:=LoadUnit(DefNamespace+'.'+aUnitName);
  822. if Result<>nil then exit;
  823. end;
  824. end;
  825. Result:=LoadUnit(aUnitName);
  826. if Result<>nil then exit;
  827. writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
  828. Fail('can''t find unit "'+aUnitName+'"');
  829. end;
  830. function TCustomTestModule.LoadUnit(const aUnitName: String): TPasModule;
  831. var
  832. i: Integer;
  833. CurEngine: TTestEnginePasResolver;
  834. CurUnitName: String;
  835. begin
  836. //writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
  837. Result:=nil;
  838. if (Module.ClassType=TPasModule)
  839. and (CompareText(Module.Name,aUnitName)=0) then
  840. exit(Module);
  841. for i:=0 to ResolverCount-1 do
  842. begin
  843. CurEngine:=Resolvers[i];
  844. CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
  845. //writeln('TTestModule.FindUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
  846. if CompareText(aUnitName,CurUnitName)=0 then
  847. begin
  848. Result:=CurEngine.Module;
  849. if Result<>nil then exit;
  850. //writeln('TTestModule.FindUnit PARSING unit "',CurEngine.Filename,'"');
  851. FileResolver.FindSourceFile(aUnitName);
  852. CurEngine.StreamResolver:=TStreamResolver.Create;
  853. CurEngine.StreamResolver.OwnsStreams:=True;
  854. //writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
  855. CurEngine.StreamResolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
  856. CurEngine.Scanner:=TPascalScanner.Create(CurEngine.StreamResolver);
  857. InitScanner(CurEngine.Scanner);
  858. CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.StreamResolver,CurEngine);
  859. CurEngine.Parser.Options:=po_tcmodules;
  860. if CompareText(CurUnitName,'System')=0 then
  861. CurEngine.Parser.ImplicitUses.Clear;
  862. CurEngine.Scanner.OpenFile(CurEngine.Filename);
  863. try
  864. CurEngine.Parser.NextToken;
  865. CurEngine.Parser.ParseUnit(CurEngine.FModule);
  866. except
  867. on E: Exception do
  868. HandleException(E);
  869. end;
  870. //writeln('TTestModule.FindUnit END ',CurUnitName);
  871. Result:=CurEngine.Module;
  872. exit;
  873. end;
  874. end;
  875. end;
  876. procedure TCustomTestModule.SetUp;
  877. begin
  878. inherited SetUp;
  879. FSkipTests:=false;
  880. FSource:=TStringList.Create;
  881. FModules:=TObjectList.Create(true);
  882. FFilename:='test1.pp';
  883. FFileResolver:=TStreamResolver.Create;
  884. FFileResolver.OwnsStreams:=True;
  885. FScanner:=TPascalScanner.Create(FFileResolver);
  886. InitScanner(FScanner);
  887. FEngine:=AddModule(Filename);
  888. FEngine.Scanner:=FScanner;
  889. FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
  890. FEngine.Parser:=FParser;
  891. Parser.Options:=po_tcmodules;
  892. FModule:=Nil;
  893. FConverter:=CreateConverter;
  894. FExpectedErrorClass:=nil;
  895. end;
  896. function TCustomTestModule.CreateConverter: TPasToJSConverter;
  897. begin
  898. Result:=TPasToJSConverter.Create;
  899. Result.Options:=co_tcmodules;
  900. end;
  901. procedure TCustomTestModule.InitScanner(aScanner: TPascalScanner);
  902. begin
  903. aScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
  904. aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
  905. aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
  906. aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
  907. aScanner.CurrentBoolSwitches:=[bsHints,bsNotes,bsWarnings];
  908. end;
  909. procedure TCustomTestModule.TearDown;
  910. begin
  911. FSkipTests:=false;
  912. FJSModule:=nil;
  913. FJSRegModuleCall:=nil;
  914. FJSModuleCallArgs:=nil;
  915. FJSImplentationUses:=nil;
  916. FJSInterfaceUses:=nil;
  917. FJSModuleSrc:=nil;
  918. FJSInitBody:=nil;
  919. FreeAndNil(FJSSource);
  920. FreeAndNil(FJSModule);
  921. FreeAndNil(FConverter);
  922. Engine.Clear;
  923. if Assigned(FModule) then
  924. begin
  925. FModule.Release;
  926. FModule:=nil;
  927. end;
  928. FreeAndNil(FSource);
  929. FreeAndNil(FFileResolver);
  930. if FModules<>nil then
  931. begin
  932. FreeAndNil(FModules);
  933. FEngine:=nil;
  934. end;
  935. inherited TearDown;
  936. end;
  937. procedure TCustomTestModule.Add(Line: string);
  938. begin
  939. Source.Add(Line);
  940. end;
  941. procedure TCustomTestModule.Add(const Lines: array of string);
  942. var
  943. i: Integer;
  944. begin
  945. for i:=low(Lines) to high(Lines) do
  946. Add(Lines[i]);
  947. end;
  948. procedure TCustomTestModule.StartParsing;
  949. var
  950. Src: String;
  951. begin
  952. Src:=Source.Text;
  953. FEngine.Source:=Src;
  954. FileResolver.AddStream(FileName,TStringStream.Create(Src));
  955. Scanner.OpenFile(FileName);
  956. Writeln('// Test : ',Self.TestName);
  957. Writeln(Src);
  958. end;
  959. procedure TCustomTestModule.ParseModuleQueue;
  960. var
  961. i: Integer;
  962. CurResolver: TTestEnginePasResolver;
  963. Found: Boolean;
  964. Section: TPasSection;
  965. begin
  966. // parse til exception or all modules finished
  967. while not SkipTests do
  968. begin
  969. Found:=false;
  970. for i:=0 to ResolverCount-1 do
  971. begin
  972. CurResolver:=Resolvers[i];
  973. if CurResolver.CurrentParser=nil then continue;
  974. if not CurResolver.CurrentParser.CanParseContinue(Section) then
  975. continue;
  976. CurResolver.Parser.ParseContinue;
  977. Found:=true;
  978. break;
  979. end;
  980. if not Found then break;
  981. end;
  982. for i:=0 to ResolverCount-1 do
  983. begin
  984. CurResolver:=Resolvers[i];
  985. if CurResolver.Parser=nil then
  986. begin
  987. if CurResolver.CurrentParser<>nil then
  988. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' '+GetObjName(CurResolver.Parser)+'=Parser<>CurrentParser='+GetObjName(CurResolver.CurrentParser));
  989. continue;
  990. end;
  991. if CurResolver.Parser.CurModule<>nil then
  992. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' NOT FINISHED CurModule='+GetObjName(CurResolver.Parser.CurModule));
  993. end;
  994. end;
  995. procedure TCustomTestModule.ParseModule;
  996. begin
  997. if SkipTests then exit;
  998. FFirstPasStatement:=nil;
  999. try
  1000. StartParsing;
  1001. Parser.ParseMain(FModule);
  1002. ParseModuleQueue;
  1003. except
  1004. on E: Exception do
  1005. HandleException(E);
  1006. end;
  1007. if SkipTests then exit;
  1008. AssertNotNull('Module resulted in Module',FModule);
  1009. AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
  1010. TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
  1011. end;
  1012. procedure TCustomTestModule.ParseProgram;
  1013. begin
  1014. if SkipTests then exit;
  1015. ParseModule;
  1016. if SkipTests then exit;
  1017. AssertEquals('Has program',TPasProgram,Module.ClassType);
  1018. FPasProgram:=TPasProgram(Module);
  1019. AssertNotNull('Has program section',PasProgram.ProgramSection);
  1020. AssertNotNull('Has initialization section',PasProgram.InitializationSection);
  1021. if (PasProgram.InitializationSection.Elements.Count>0) then
  1022. if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
  1023. FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
  1024. end;
  1025. procedure TCustomTestModule.ParseUnit;
  1026. begin
  1027. if SkipTests then exit;
  1028. ParseModule;
  1029. if SkipTests then exit;
  1030. AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
  1031. AssertNotNull('Has interface section',Module.InterfaceSection);
  1032. AssertNotNull('Has implementation section',Module.ImplementationSection);
  1033. if (Module.InitializationSection<>nil)
  1034. and (Module.InitializationSection.Elements.Count>0)
  1035. and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
  1036. FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
  1037. end;
  1038. function TCustomTestModule.FindModuleWithFilename(aFilename: string
  1039. ): TTestEnginePasResolver;
  1040. var
  1041. i: Integer;
  1042. begin
  1043. for i:=0 to ResolverCount-1 do
  1044. if CompareText(Resolvers[i].Filename,aFilename)=0 then
  1045. exit(Resolvers[i]);
  1046. Result:=nil;
  1047. end;
  1048. function TCustomTestModule.AddModule(aFilename: string
  1049. ): TTestEnginePasResolver;
  1050. begin
  1051. //writeln('TTestModuleConverter.AddModule ',aFilename);
  1052. if FindModuleWithFilename(aFilename)<>nil then
  1053. Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
  1054. Result:=TTestEnginePasResolver.Create;
  1055. Result.Filename:=aFilename;
  1056. Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
  1057. Result.OnFindUnit:=@OnPasResolverFindUnit;
  1058. FModules.Add(Result);
  1059. end;
  1060. function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
  1061. ): TTestEnginePasResolver;
  1062. begin
  1063. Result:=AddModule(aFilename);
  1064. Result.Source:=Src;
  1065. end;
  1066. function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  1067. ImplementationSrc: string): TTestEnginePasResolver;
  1068. var
  1069. Src: String;
  1070. begin
  1071. Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
  1072. Src+=LineEnding;
  1073. Src+='interface'+LineEnding;
  1074. Src+=LineEnding;
  1075. Src+=InterfaceSrc;
  1076. Src+='implementation'+LineEnding;
  1077. Src+=LineEnding;
  1078. Src+=ImplementationSrc;
  1079. Src+='end.'+LineEnding;
  1080. Result:=AddModuleWithSrc(aFilename,Src);
  1081. end;
  1082. procedure TCustomTestModule.AddSystemUnit;
  1083. begin
  1084. AddModuleWithIntfImplSrc('system.pp',
  1085. // interface
  1086. LinesToStr([
  1087. 'type',
  1088. ' integer=longint;',
  1089. 'var',
  1090. ' ExitCode: Longint;',
  1091. ''
  1092. // implementation
  1093. ]),LinesToStr([
  1094. ''
  1095. ]));
  1096. end;
  1097. procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean);
  1098. begin
  1099. if NeedSystemUnit then
  1100. AddSystemUnit
  1101. else
  1102. Parser.ImplicitUses.Clear;
  1103. Add('program '+ExtractFileUnitName(Filename)+';');
  1104. Add('');
  1105. end;
  1106. procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean);
  1107. begin
  1108. if NeedSystemUnit then
  1109. AddSystemUnit
  1110. else
  1111. Parser.ImplicitUses.Clear;
  1112. Add('unit Test1;');
  1113. Add('');
  1114. end;
  1115. procedure TCustomTestModule.ConvertModule;
  1116. procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
  1117. out UsesLit: TJSArrayLiteral);
  1118. var
  1119. i: Integer;
  1120. Item: TJSElement;
  1121. Lit: TJSLiteral;
  1122. begin
  1123. UsesLit:=nil;
  1124. AssertNotNull(UsesName+' uses section',Arg.Expr);
  1125. if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
  1126. exit; // null is ok
  1127. AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
  1128. FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
  1129. for i:=0 to FJSInterfaceUses.Elements.Count-1 do
  1130. begin
  1131. Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
  1132. AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
  1133. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
  1134. Lit:=TJSLiteral(Item);
  1135. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
  1136. ord(jsbase.jstString),ord(Lit.Value.ValueType));
  1137. end;
  1138. end;
  1139. procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
  1140. out Src: TJSSourceElements);
  1141. var
  1142. FunDecl: TJSFunctionDeclarationStatement;
  1143. FunDef: TJSFuncDef;
  1144. FunBody: TJSFunctionBody;
  1145. begin
  1146. Src:=nil;
  1147. AssertNotNull(ParamName,Arg.Expr);
  1148. AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
  1149. FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
  1150. AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
  1151. AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
  1152. FunDef:=FunDecl.AFunction as TJSFuncDef;
  1153. AssertEquals(ParamName+' name empty','',String(FunDef.Name));
  1154. AssertNotNull(ParamName+' body',FunDef.Body);
  1155. AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
  1156. FunBody:=FunDef.Body as TJSFunctionBody;
  1157. AssertNotNull(ParamName+' body.A',FunBody.A);
  1158. AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
  1159. Src:=FunBody.A as TJSSourceElements;
  1160. end;
  1161. var
  1162. ModuleNameExpr: TJSLiteral;
  1163. InitFunction: TJSFunctionDeclarationStatement;
  1164. InitAssign: TJSSimpleAssignStatement;
  1165. InitName: String;
  1166. LastNode: TJSElement;
  1167. Arg: TJSArrayLiteralElement;
  1168. begin
  1169. if SkipTests then exit;
  1170. try
  1171. FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
  1172. except
  1173. on E: Exception do
  1174. HandleException(E);
  1175. end;
  1176. if SkipTests then exit;
  1177. if ExpectedErrorClass<>nil then
  1178. Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
  1179. FJSSource:=TStringList.Create;
  1180. FJSSource.Text:=ConvertJSModuleToString(JSModule);
  1181. {$IFDEF VerbosePas2JS}
  1182. writeln('TTestModule.ConvertModule JS:');
  1183. write(FJSSource.Text);
  1184. {$ENDIF}
  1185. // rtl.module(...
  1186. AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
  1187. AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
  1188. AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
  1189. FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
  1190. AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
  1191. AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
  1192. AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
  1193. FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
  1194. // parameter 'unitname'
  1195. if JSModuleCallArgs.Elements.Count<1 then
  1196. Fail('rtl.module first param unit missing');
  1197. Arg:=JSModuleCallArgs.Elements.Elements[0];
  1198. AssertNotNull('module name param',Arg.Expr);
  1199. ModuleNameExpr:=Arg.Expr as TJSLiteral;
  1200. AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
  1201. if Module is TPasProgram then
  1202. AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
  1203. else
  1204. AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
  1205. // main uses section
  1206. if JSModuleCallArgs.Elements.Count<2 then
  1207. Fail('rtl.module second param main uses missing');
  1208. Arg:=JSModuleCallArgs.Elements.Elements[1];
  1209. CheckUsesList('interface',Arg,FJSInterfaceUses);
  1210. // program/library/interface function()
  1211. if JSModuleCallArgs.Elements.Count<3 then
  1212. Fail('rtl.module third param intf-function missing');
  1213. Arg:=JSModuleCallArgs.Elements.Elements[2];
  1214. CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
  1215. // search for $mod.$init or $mod.$main - the last statement
  1216. if Module is TPasProgram then
  1217. begin
  1218. InitName:='$main';
  1219. AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
  1220. end
  1221. else
  1222. InitName:='$init';
  1223. FJSInitBody:=nil;
  1224. if JSModuleSrc.Statements.Count>0 then
  1225. begin
  1226. LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
  1227. if LastNode is TJSSimpleAssignStatement then
  1228. begin
  1229. InitAssign:=LastNode as TJSSimpleAssignStatement;
  1230. if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
  1231. begin
  1232. InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
  1233. FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
  1234. end
  1235. else if Module is TPasProgram then
  1236. CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
  1237. end;
  1238. end;
  1239. // optional: implementation uses section
  1240. if JSModuleCallArgs.Elements.Count<4 then
  1241. exit;
  1242. Arg:=JSModuleCallArgs.Elements.Elements[3];
  1243. CheckUsesList('implementation',Arg,FJSImplentationUses);
  1244. // optional: implementation function()
  1245. if JSModuleCallArgs.Elements.Count<5 then
  1246. exit;
  1247. Arg:=JSModuleCallArgs.Elements.Elements[4];
  1248. CheckFunctionParam('module impl-function',Arg,FJSImplementationSrc);
  1249. end;
  1250. procedure TCustomTestModule.ConvertProgram;
  1251. begin
  1252. Add('end.');
  1253. ParseProgram;
  1254. ConvertModule;
  1255. end;
  1256. procedure TCustomTestModule.ConvertUnit;
  1257. begin
  1258. Add('end.');
  1259. ParseUnit;
  1260. ConvertModule;
  1261. end;
  1262. function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
  1263. begin
  1264. Result:=tcmodules.JSToStr(El);
  1265. end;
  1266. procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
  1267. DottedName: string);
  1268. begin
  1269. if DottedName='' then
  1270. begin
  1271. AssertNull(Msg,El);
  1272. end
  1273. else
  1274. begin
  1275. AssertNotNull(Msg,El);
  1276. AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
  1277. end;
  1278. end;
  1279. function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
  1280. begin
  1281. if El=nil then
  1282. Result:=''
  1283. else if El is TJSPrimaryExpressionIdent then
  1284. Result:=String(TJSPrimaryExpressionIdent(El).Name)
  1285. else if El is TJSDotMemberExpression then
  1286. Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
  1287. else
  1288. AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
  1289. end;
  1290. procedure TCustomTestModule.CheckSource(Msg, Statements: String;
  1291. InitStatements: string; ImplStatements: string);
  1292. var
  1293. ActualSrc, ExpectedSrc, InitName: String;
  1294. begin
  1295. ActualSrc:=JSToStr(JSModuleSrc);
  1296. ExpectedSrc:=
  1297. 'var $mod = this;'+LineEnding
  1298. +Statements;
  1299. if coUseStrict in Converter.Options then
  1300. ExpectedSrc:='"use strict";'+LineEnding+ExpectedSrc;
  1301. if Module is TPasProgram then
  1302. InitName:='$main'
  1303. else
  1304. InitName:='$init';
  1305. if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
  1306. ExpectedSrc:=ExpectedSrc+LineEnding
  1307. +'$mod.'+InitName+' = function () {'+LineEnding
  1308. +InitStatements
  1309. +'};'+LineEnding;
  1310. //writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
  1311. //writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
  1312. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1313. if (JSImplementationSrc<>nil) then
  1314. begin
  1315. ActualSrc:=JSToStr(JSImplementationSrc);
  1316. ExpectedSrc:=
  1317. 'var $mod = this;'+LineEnding
  1318. +'var $impl = $mod.$impl;'+LineEnding
  1319. +ImplStatements;
  1320. end
  1321. else
  1322. begin
  1323. ActualSrc:='';
  1324. ExpectedSrc:=ImplStatements;
  1325. end;
  1326. //writeln('TTestModule.CheckSource InitStatements="',InitStatements,'"');
  1327. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1328. end;
  1329. procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
  1330. // search diff, ignore changes in spaces
  1331. var
  1332. s: string;
  1333. begin
  1334. if CheckSrcDiff(Expected,Actual,s) then exit;
  1335. Fail(Msg+': '+s);
  1336. end;
  1337. procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
  1338. var
  1339. aResolver: TTestEnginePasResolver;
  1340. aConverter: TPasToJSConverter;
  1341. aJSModule: TJSSourceElements;
  1342. ActualSrc: String;
  1343. begin
  1344. aResolver:=GetResolver(Filename);
  1345. AssertNotNull('missing resolver of unit '+Filename,aResolver);
  1346. {$IFDEF VerbosePas2JS}
  1347. writeln('CheckUnit '+Filename+' converting ...');
  1348. {$ENDIF}
  1349. aConverter:=CreateConverter;
  1350. try
  1351. try
  1352. aJSModule:=aConverter.ConvertPasElement(aResolver.Module,aResolver) as TJSSourceElements;
  1353. except
  1354. on E: Exception do
  1355. HandleException(E);
  1356. end;
  1357. ActualSrc:=ConvertJSModuleToString(aJSModule);
  1358. {$IFDEF VerbosePas2JS}
  1359. writeln('TTestModule.CheckUnit ',Filename,' Pas:');
  1360. write(aResolver.Source);
  1361. writeln('TTestModule.CheckUnit ',Filename,' JS:');
  1362. write(ActualSrc);
  1363. {$ENDIF}
  1364. CheckDiff('Converted unit: "'+ChangeFileExt(Filename,'.js')+'"',ExpectedSrc,ActualSrc);
  1365. finally
  1366. aConverter.Free;
  1367. end;
  1368. end;
  1369. procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
  1370. MsgNumber: integer);
  1371. begin
  1372. ExpectedErrorClass:=EScannerError;
  1373. ExpectedErrorMsg:=Msg;
  1374. ExpectedErrorNumber:=MsgNumber;
  1375. end;
  1376. procedure TCustomTestModule.SetExpectedParserError(Msg: string;
  1377. MsgNumber: integer);
  1378. begin
  1379. ExpectedErrorClass:=EParserError;
  1380. ExpectedErrorMsg:=Msg;
  1381. ExpectedErrorNumber:=MsgNumber;
  1382. end;
  1383. procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
  1384. MsgNumber: integer);
  1385. begin
  1386. ExpectedErrorClass:=EPasResolve;
  1387. ExpectedErrorMsg:=Msg;
  1388. ExpectedErrorNumber:=MsgNumber;
  1389. end;
  1390. procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
  1391. MsgNumber: integer);
  1392. begin
  1393. ExpectedErrorClass:=EPas2JS;
  1394. ExpectedErrorMsg:=Msg;
  1395. ExpectedErrorNumber:=MsgNumber;
  1396. end;
  1397. function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
  1398. var
  1399. MsgNumber: Integer;
  1400. Msg: String;
  1401. begin
  1402. Result:=false;
  1403. if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
  1404. Msg:=E.Message;
  1405. if E is EPas2JS then
  1406. MsgNumber:=EPas2JS(E).MsgNumber
  1407. else if E is EPasResolve then
  1408. MsgNumber:=EPasResolve(E).MsgNumber
  1409. else if E is EParserError then
  1410. MsgNumber:=Parser.LastMsgNumber
  1411. else if E is EScannerError then
  1412. begin
  1413. MsgNumber:=Scanner.LastMsgNumber;
  1414. Msg:=Scanner.LastMsg;
  1415. end
  1416. else
  1417. MsgNumber:=0;
  1418. Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
  1419. if Result then
  1420. SkipTests:=true;
  1421. end;
  1422. procedure TCustomTestModule.HandleScannerError(E: EScannerError);
  1423. begin
  1424. if IsErrorExpected(E) then exit;
  1425. WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
  1426. writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
  1427. +' '+Scanner.CurFilename
  1428. +'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
  1429. FailException(E);
  1430. end;
  1431. procedure TCustomTestModule.HandleParserError(E: EParserError);
  1432. begin
  1433. if IsErrorExpected(E) then exit;
  1434. WriteSources(E.Filename,E.Row,E.Column);
  1435. writeln('ERROR: TCustomTestModule.HandleParserError '+E.ClassName+':'+E.Message
  1436. +' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')'
  1437. +' MainModuleScannerLine="'+Scanner.CurLine+'"'
  1438. );
  1439. FailException(E);
  1440. end;
  1441. procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
  1442. var
  1443. P: TPasSourcePos;
  1444. begin
  1445. if IsErrorExpected(E) then exit;
  1446. P:=E.SourcePos;
  1447. WriteSources(P.FileName,P.Row,P.Column);
  1448. writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
  1449. +' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
  1450. FailException(E);
  1451. end;
  1452. procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
  1453. var
  1454. Row, Col: integer;
  1455. begin
  1456. if IsErrorExpected(E) then exit;
  1457. Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
  1458. WriteSources(E.PasElement.SourceFilename,Row,Col);
  1459. writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
  1460. +' '+E.PasElement.SourceFilename
  1461. +'('+IntToStr(Row)+','+IntToStr(Col)+')');
  1462. FailException(E);
  1463. end;
  1464. procedure TCustomTestModule.HandleException(E: Exception);
  1465. begin
  1466. if E is EScannerError then
  1467. HandleScannerError(EScannerError(E))
  1468. else if E is EParserError then
  1469. HandleParserError(EParserError(E))
  1470. else if E is EPasResolve then
  1471. HandlePasResolveError(EPasResolve(E))
  1472. else if E is EPas2JS then
  1473. HandlePas2JSError(EPas2JS(E))
  1474. else
  1475. begin
  1476. if IsErrorExpected(E) then exit;
  1477. if not (E is EAssertionFailedError) then
  1478. begin
  1479. WriteSources('',0,0);
  1480. writeln('ERROR: TCustomTestModule.HandleException '+E.ClassName+':'+E.Message);
  1481. end;
  1482. FailException(E);
  1483. end;
  1484. end;
  1485. procedure TCustomTestModule.FailException(E: Exception);
  1486. var
  1487. MsgNumber: Integer;
  1488. begin
  1489. if ExpectedErrorClass<>nil then
  1490. begin
  1491. if FExpectedErrorClass=E.ClassType then
  1492. begin
  1493. if E is EPas2JS then
  1494. MsgNumber:=EPas2JS(E).MsgNumber
  1495. else if E is EPasResolve then
  1496. MsgNumber:=EPasResolve(E).MsgNumber
  1497. else if E is EParserError then
  1498. MsgNumber:=Parser.LastMsgNumber
  1499. else if E is EScannerError then
  1500. MsgNumber:=Scanner.LastMsgNumber
  1501. else
  1502. MsgNumber:=0;
  1503. AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
  1504. AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
  1505. ExpectedErrorNumber,MsgNumber);
  1506. end else begin
  1507. AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
  1508. end;
  1509. end;
  1510. Fail(E.Message);
  1511. end;
  1512. procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
  1513. aCol: integer);
  1514. var
  1515. IsSrc: Boolean;
  1516. i, j: Integer;
  1517. SrcLines: TStringList;
  1518. Line: string;
  1519. aModule: TTestEnginePasResolver;
  1520. begin
  1521. writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
  1522. for i:=0 to ResolverCount-1 do
  1523. begin
  1524. aModule:=Resolvers[i];
  1525. SrcLines:=TStringList.Create;
  1526. try
  1527. SrcLines.Text:=aModule.Source;
  1528. IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
  1529. writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
  1530. for j:=1 to SrcLines.Count do
  1531. begin
  1532. Line:=SrcLines[j-1];
  1533. if IsSrc and (j=aRow) then
  1534. begin
  1535. write('*');
  1536. Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
  1537. end;
  1538. writeln(Format('%:4d: ',[j]),Line);
  1539. end;
  1540. finally
  1541. SrcLines.Free;
  1542. end;
  1543. end;
  1544. end;
  1545. function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
  1546. var
  1547. i: Integer;
  1548. begin
  1549. for i:=0 to ResolverCount-1 do
  1550. if Filename=Resolvers[i].Filename then exit(i);
  1551. Result:=-1;
  1552. end;
  1553. function TCustomTestModule.GetResolver(const Filename: string
  1554. ): TTestEnginePasResolver;
  1555. var
  1556. i: Integer;
  1557. begin
  1558. i:=IndexOfResolver(Filename);
  1559. if i<0 then exit(nil);
  1560. Result:=Resolvers[i];
  1561. end;
  1562. function TCustomTestModule.GetDefaultNamespace: string;
  1563. var
  1564. C: TClass;
  1565. begin
  1566. Result:='';
  1567. if FModule=nil then exit;
  1568. C:=FModule.ClassType;
  1569. if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
  1570. Result:=Engine.DefaultNameSpace;
  1571. end;
  1572. { TTestModule }
  1573. procedure TTestModule.TestEmptyProgram;
  1574. begin
  1575. StartProgram(false);
  1576. Add('begin');
  1577. ConvertProgram;
  1578. CheckSource('TestEmptyProgram','','');
  1579. end;
  1580. procedure TTestModule.TestEmptyProgramUseStrict;
  1581. begin
  1582. Converter.Options:=Converter.Options+[coUseStrict];
  1583. StartProgram(false);
  1584. Add('begin');
  1585. ConvertProgram;
  1586. CheckSource('TestEmptyProgramUseStrict','','');
  1587. end;
  1588. procedure TTestModule.TestEmptyUnit;
  1589. begin
  1590. StartUnit(false);
  1591. Add('interface');
  1592. Add('implementation');
  1593. ConvertUnit;
  1594. CheckSource('TestEmptyUnit',
  1595. LinesToStr([
  1596. ]),
  1597. '');
  1598. end;
  1599. procedure TTestModule.TestEmptyUnitUseStrict;
  1600. begin
  1601. Converter.Options:=Converter.Options+[coUseStrict];
  1602. StartUnit(false);
  1603. Add('interface');
  1604. Add('implementation');
  1605. ConvertUnit;
  1606. CheckSource('TestEmptyUnitUseStrict',
  1607. LinesToStr([
  1608. ''
  1609. ]),
  1610. '');
  1611. end;
  1612. procedure TTestModule.TestDottedUnitNames;
  1613. begin
  1614. AddModuleWithIntfImplSrc('NS1.Unit2.pas',
  1615. LinesToStr([
  1616. 'var iV: longint;'
  1617. ]),
  1618. '');
  1619. FFilename:='ns1.test1.pp';
  1620. StartProgram(true);
  1621. Add('uses unIt2;');
  1622. Add('implementation');
  1623. Add('var');
  1624. Add(' i: longint;');
  1625. Add('begin');
  1626. Add(' i:=iv;');
  1627. Add(' i:=uNit2.iv;');
  1628. Add(' i:=Ns1.TEst1.i;');
  1629. ConvertProgram;
  1630. CheckSource('TestDottedUnitNames',
  1631. LinesToStr([
  1632. 'this.i = 0;',
  1633. '']),
  1634. LinesToStr([ // this.$init
  1635. '$mod.i = pas["NS1.Unit2"].iV;',
  1636. '$mod.i = pas["NS1.Unit2"].iV;',
  1637. '$mod.i = $mod.i;',
  1638. '']) );
  1639. end;
  1640. procedure TTestModule.TestDottedUnitNameImpl;
  1641. begin
  1642. AddModuleWithIntfImplSrc('TEST.UnitA.pas',
  1643. LinesToStr([
  1644. 'type',
  1645. ' TObject = class end;',
  1646. ' TTestA = class',
  1647. ' end;'
  1648. ]),
  1649. LinesToStr(['uses TEST.UnitB;'])
  1650. );
  1651. AddModuleWithIntfImplSrc('TEST.UnitB.pas',
  1652. LinesToStr([
  1653. 'uses TEST.UnitA;',
  1654. 'type TTestB = class(TTestA);'
  1655. ]),
  1656. ''
  1657. );
  1658. StartProgram(true);
  1659. Add('uses TEST.UnitA;');
  1660. Add('begin');
  1661. ConvertProgram;
  1662. CheckSource('TestDottedUnitNameImpl',
  1663. LinesToStr([
  1664. '']),
  1665. LinesToStr([ // this.$init
  1666. '']) );
  1667. CheckUnit('TEST.UnitA.pas',
  1668. LinesToStr([
  1669. 'rtl.module("TEST.UnitA", ["system"], function () {',
  1670. ' var $mod = this;',
  1671. ' rtl.createClass($mod, "TObject", null, function () {',
  1672. ' this.$init = function () {',
  1673. ' };',
  1674. ' this.$final = function () {',
  1675. ' };',
  1676. ' });',
  1677. ' rtl.createClass($mod, "TTestA", $mod.TObject, function () {',
  1678. ' });',
  1679. '}, ["TEST.UnitB"]);'
  1680. ]));
  1681. CheckUnit('TEST.UnitB.pas',
  1682. LinesToStr([
  1683. 'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
  1684. ' var $mod = this;',
  1685. ' rtl.createClass($mod, "TTestB", pas["TEST.UnitA"].TTestA, function () {',
  1686. ' });',
  1687. '});'
  1688. ]));
  1689. end;
  1690. procedure TTestModule.TestDottedUnitExpr;
  1691. begin
  1692. AddModuleWithIntfImplSrc('NS2.SubNs2.Unit2.pas',
  1693. LinesToStr([
  1694. 'procedure DoIt;'
  1695. ]),
  1696. 'procedure DoIt; begin end;');
  1697. FFilename:='Ns1.SubNs1.Test1.pp';
  1698. StartProgram(true);
  1699. Add('uses Ns2.sUbnS2.unIt2;');
  1700. Add('implementation');
  1701. Add('var');
  1702. Add(' i: longint;');
  1703. Add('begin');
  1704. Add(' ns2.subns2.unit2.doit;');
  1705. Add(' i:=Ns1.SubNS1.TEst1.i;');
  1706. ConvertProgram;
  1707. CheckSource('TestDottedUnitExpr',
  1708. LinesToStr([
  1709. 'this.i = 0;',
  1710. '']),
  1711. LinesToStr([ // this.$init
  1712. 'pas["NS2.SubNs2.Unit2"].DoIt();',
  1713. '$mod.i = $mod.i;',
  1714. '']) );
  1715. end;
  1716. procedure TTestModule.Test_ModeFPCFail;
  1717. begin
  1718. StartProgram(false);
  1719. Add('{$mode FPC}');
  1720. Add('begin');
  1721. SetExpectedScannerError('Invalid mode: "FPC"',nErrInvalidMode);
  1722. ConvertProgram;
  1723. end;
  1724. procedure TTestModule.Test_ModeSwitchCBlocksFail;
  1725. begin
  1726. StartProgram(false);
  1727. Add('{$modeswitch cblocks-}');
  1728. Add('begin');
  1729. SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
  1730. ConvertProgram;
  1731. end;
  1732. procedure TTestModule.TestUnit_Intf1Impl2Intf1;
  1733. begin
  1734. AddModuleWithIntfImplSrc('unit1.pp',
  1735. LinesToStr([
  1736. 'type number = longint;']),
  1737. LinesToStr([
  1738. 'uses test1;',
  1739. 'procedure DoIt;',
  1740. 'begin',
  1741. ' i:=3;',
  1742. 'end;']));
  1743. StartUnit(true);
  1744. Add([
  1745. 'interface',
  1746. 'uses unit1;',
  1747. 'var i: number;',
  1748. 'implementation']);
  1749. ConvertUnit;
  1750. CheckSource('TestUnit_Intf1Impl2Intf1',
  1751. LinesToStr([
  1752. 'this.i = 0;',
  1753. '']),
  1754. LinesToStr([
  1755. '']) );
  1756. end;
  1757. procedure TTestModule.TestVarInt;
  1758. begin
  1759. StartProgram(false);
  1760. Add('var MyI: longint;');
  1761. Add('begin');
  1762. ConvertProgram;
  1763. CheckSource('TestVarInt','this.MyI=0;','');
  1764. end;
  1765. procedure TTestModule.TestVarBaseTypes;
  1766. begin
  1767. StartProgram(false);
  1768. Add('var');
  1769. Add(' i: longint;');
  1770. Add(' s: string;');
  1771. Add(' c: char;');
  1772. Add(' b: boolean;');
  1773. Add(' d: double;');
  1774. Add(' i2: longint = 3;');
  1775. Add(' s2: string = ''foo'';');
  1776. Add(' c2: char = ''4'';');
  1777. Add(' b2: boolean = true;');
  1778. Add(' d2: double = 5.6;');
  1779. Add(' i3: longint = $707;');
  1780. Add(' i4: nativeint = 4503599627370495;');
  1781. Add(' i5: nativeint = -4503599627370496;');
  1782. Add(' i6: nativeint = $fffffffffffff;');
  1783. Add(' i7: nativeint = -$10000000000000;');
  1784. Add(' u8: nativeuint = $fffffffffffff;');
  1785. Add(' u9: nativeuint = $0000000000000;');
  1786. Add('begin');
  1787. ConvertProgram;
  1788. CheckSource('TestVarBaseTypes',
  1789. LinesToStr([
  1790. 'this.i=0;',
  1791. 'this.s="";',
  1792. 'this.c="";',
  1793. 'this.b=false;',
  1794. 'this.d=0.0;',
  1795. 'this.i2=3;',
  1796. 'this.s2="foo";',
  1797. 'this.c2="4";',
  1798. 'this.b2=true;',
  1799. 'this.d2=5.6;',
  1800. 'this.i3=0x707;',
  1801. 'this.i4= 4503599627370495;',
  1802. 'this.i5= -4503599627370496;',
  1803. 'this.i6= 0xfffffffffffff;',
  1804. 'this.i7=-0x10000000000000;',
  1805. 'this.u8= 0xfffffffffffff;',
  1806. 'this.u9= 0x0000000000000;'
  1807. ]),
  1808. '');
  1809. end;
  1810. procedure TTestModule.TestBaseTypeSingleFail;
  1811. begin
  1812. StartProgram(false);
  1813. Add('var s: single;');
  1814. SetExpectedPasResolverError('identifier not found "single"',PasResolveEval.nIdentifierNotFound);
  1815. ConvertProgram;
  1816. end;
  1817. procedure TTestModule.TestBaseTypeExtendedFail;
  1818. begin
  1819. StartProgram(false);
  1820. Add('var e: extended;');
  1821. SetExpectedPasResolverError('identifier not found "extended"',PasResolveEval.nIdentifierNotFound);
  1822. ConvertProgram;
  1823. end;
  1824. procedure TTestModule.TestConstBaseTypes;
  1825. begin
  1826. StartProgram(false);
  1827. Add('const');
  1828. Add(' i: longint = 3;');
  1829. Add(' s: string = ''foo'';');
  1830. Add(' c: char = ''4'';');
  1831. Add(' b: boolean = true;');
  1832. Add(' d: double = 5.6;');
  1833. Add(' e = low(word);');
  1834. Add(' f = high(word);');
  1835. Add('begin');
  1836. ConvertProgram;
  1837. CheckSource('TestVarBaseTypes',
  1838. LinesToStr([
  1839. 'this.i=3;',
  1840. 'this.s="foo";',
  1841. 'this.c="4";',
  1842. 'this.b=true;',
  1843. 'this.d=5.6;',
  1844. 'this.e = 0;',
  1845. 'this.f = 65535;'
  1846. ]),
  1847. '');
  1848. end;
  1849. procedure TTestModule.TestAliasTypeRef;
  1850. begin
  1851. StartProgram(false);
  1852. Add('type');
  1853. Add(' a=longint;');
  1854. Add(' b=a;');
  1855. Add('var');
  1856. Add(' c: A;');
  1857. Add(' d: B;');
  1858. Add('begin');
  1859. ConvertProgram;
  1860. CheckSource('TestAliasTypeRef',
  1861. LinesToStr([ // statements
  1862. 'this.c = 0;',
  1863. 'this.d = 0;'
  1864. ]),
  1865. LinesToStr([ // this.$main
  1866. ''
  1867. ]));
  1868. end;
  1869. procedure TTestModule.TestTypeCast_BaseTypes;
  1870. begin
  1871. StartProgram(false);
  1872. Add([
  1873. 'var',
  1874. ' i: longint;',
  1875. ' b: boolean;',
  1876. ' d: double;',
  1877. ' s: string;',
  1878. ' c: char;',
  1879. 'begin',
  1880. ' i:=longint(i);',
  1881. ' i:=longint(b);',
  1882. ' b:=boolean(b);',
  1883. ' b:=boolean(i);',
  1884. ' d:=double(d);',
  1885. ' d:=double(i);',
  1886. ' s:=string(s);',
  1887. ' s:=string(c);',
  1888. ' c:=char(c);',
  1889. ' c:=char(i);',
  1890. ' c:=char(65);',
  1891. '']);
  1892. ConvertProgram;
  1893. CheckSource('TestAliasTypeRef',
  1894. LinesToStr([ // statements
  1895. 'this.i = 0;',
  1896. 'this.b = false;',
  1897. 'this.d = 0.0;',
  1898. 'this.s = "";',
  1899. 'this.c = "";',
  1900. '']),
  1901. LinesToStr([ // this.$main
  1902. '$mod.i = $mod.i;',
  1903. '$mod.i = ($mod.b ? 1 : 0);',
  1904. '$mod.b = $mod.b;',
  1905. '$mod.b = $mod.i != 0;',
  1906. '$mod.d = $mod.d;',
  1907. '$mod.d = $mod.i;',
  1908. '$mod.s = $mod.s;',
  1909. '$mod.s = $mod.c;',
  1910. '$mod.c = $mod.c;',
  1911. '$mod.c = String.fromCharCode($mod.i);',
  1912. '$mod.c = "A";',
  1913. '']));
  1914. end;
  1915. procedure TTestModule.TestTypeCast_AliasBaseTypes;
  1916. begin
  1917. StartProgram(false);
  1918. Add('type');
  1919. Add(' integer = longint;');
  1920. Add(' TYesNo = boolean;');
  1921. Add(' TFloat = double;');
  1922. Add(' TCaption = string;');
  1923. Add(' TChar = char;');
  1924. Add('var');
  1925. Add(' i: integer;');
  1926. Add(' b: TYesNo;');
  1927. Add(' d: TFloat;');
  1928. Add(' s: TCaption;');
  1929. Add(' c: TChar;');
  1930. Add('begin');
  1931. Add(' i:=integer(i);');
  1932. Add(' i:=integer(b);');
  1933. Add(' b:=TYesNo(b);');
  1934. Add(' b:=TYesNo(i);');
  1935. Add(' d:=TFloat(d);');
  1936. Add(' d:=TFloat(i);');
  1937. Add(' s:=TCaption(s);');
  1938. Add(' s:=TCaption(c);');
  1939. Add(' c:=TChar(c);');
  1940. ConvertProgram;
  1941. CheckSource('TestAliasTypeRef',
  1942. LinesToStr([ // statements
  1943. 'this.i = 0;',
  1944. 'this.b = false;',
  1945. 'this.d = 0.0;',
  1946. 'this.s = "";',
  1947. 'this.c = "";',
  1948. '']),
  1949. LinesToStr([ // this.$main
  1950. '$mod.i = $mod.i;',
  1951. '$mod.i = ($mod.b ? 1 : 0);',
  1952. '$mod.b = $mod.b;',
  1953. '$mod.b = $mod.i != 0;',
  1954. '$mod.d = $mod.d;',
  1955. '$mod.d = $mod.i;',
  1956. '$mod.s = $mod.s;',
  1957. '$mod.s = $mod.c;',
  1958. '$mod.c = $mod.c;',
  1959. '']));
  1960. end;
  1961. procedure TTestModule.TestEmptyProc;
  1962. begin
  1963. StartProgram(false);
  1964. Add('procedure Test;');
  1965. Add('begin');
  1966. Add('end;');
  1967. Add('begin');
  1968. ConvertProgram;
  1969. CheckSource('TestEmptyProc',
  1970. LinesToStr([ // statements
  1971. 'this.Test = function () {',
  1972. '};'
  1973. ]),
  1974. LinesToStr([ // this.$main
  1975. ''
  1976. ]));
  1977. end;
  1978. procedure TTestModule.TestProcOneParam;
  1979. begin
  1980. StartProgram(false);
  1981. Add('procedure ProcA(i: longint);');
  1982. Add('begin');
  1983. Add('end;');
  1984. Add('begin');
  1985. Add(' PROCA(3);');
  1986. ConvertProgram;
  1987. CheckSource('TestProcOneParam',
  1988. LinesToStr([ // statements
  1989. 'this.ProcA = function (i) {',
  1990. '};'
  1991. ]),
  1992. LinesToStr([ // this.$main
  1993. '$mod.ProcA(3);'
  1994. ]));
  1995. end;
  1996. procedure TTestModule.TestFunctionWithoutParams;
  1997. begin
  1998. StartProgram(false);
  1999. Add('function FuncA: longint;');
  2000. Add('begin');
  2001. Add('end;');
  2002. Add('var i: longint;');
  2003. Add('begin');
  2004. Add(' I:=FUNCA();');
  2005. Add(' I:=FUNCA;');
  2006. Add(' FUNCA();');
  2007. Add(' FUNCA;');
  2008. ConvertProgram;
  2009. CheckSource('TestProcWithoutParams',
  2010. LinesToStr([ // statements
  2011. 'this.FuncA = function () {',
  2012. ' var Result = 0;',
  2013. ' return Result;',
  2014. '};',
  2015. 'this.i=0;'
  2016. ]),
  2017. LinesToStr([ // this.$main
  2018. '$mod.i=$mod.FuncA();',
  2019. '$mod.i=$mod.FuncA();',
  2020. '$mod.FuncA();',
  2021. '$mod.FuncA();'
  2022. ]));
  2023. end;
  2024. procedure TTestModule.TestProcedureWithoutParams;
  2025. begin
  2026. StartProgram(false);
  2027. Add('procedure ProcA;');
  2028. Add('begin');
  2029. Add('end;');
  2030. Add('begin');
  2031. Add(' PROCA();');
  2032. Add(' PROCA;');
  2033. ConvertProgram;
  2034. CheckSource('TestProcWithoutParams',
  2035. LinesToStr([ // statements
  2036. 'this.ProcA = function () {',
  2037. '};'
  2038. ]),
  2039. LinesToStr([ // this.$main
  2040. '$mod.ProcA();',
  2041. '$mod.ProcA();'
  2042. ]));
  2043. end;
  2044. procedure TTestModule.TestIncDec;
  2045. begin
  2046. StartProgram(false);
  2047. Add([
  2048. 'procedure DoIt(var i: longint);',
  2049. 'begin',
  2050. ' inc(i);',
  2051. ' inc(i,2);',
  2052. 'end;',
  2053. 'var',
  2054. ' Bar: longint;',
  2055. 'begin',
  2056. ' inc(bar);',
  2057. ' inc(bar,2);',
  2058. ' dec(bar);',
  2059. ' dec(bar,3);',
  2060. '']);
  2061. ConvertProgram;
  2062. CheckSource('TestIncDec',
  2063. LinesToStr([ // statements
  2064. 'this.DoIt = function (i) {',
  2065. ' i.set(i.get()+1);',
  2066. ' i.set(i.get()+2);',
  2067. '};',
  2068. 'this.Bar = 0;'
  2069. ]),
  2070. LinesToStr([ // this.$main
  2071. '$mod.Bar+=1;',
  2072. '$mod.Bar+=2;',
  2073. '$mod.Bar-=1;',
  2074. '$mod.Bar-=3;'
  2075. ]));
  2076. end;
  2077. procedure TTestModule.TestAssignments;
  2078. begin
  2079. StartProgram(false);
  2080. Parser.Options:=Parser.Options+[po_cassignments];
  2081. Add('var');
  2082. Add(' Bar:longint;');
  2083. Add('begin');
  2084. Add(' bar:=3;');
  2085. Add(' bar+=4;');
  2086. Add(' bar-=5;');
  2087. Add(' bar*=6;');
  2088. ConvertProgram;
  2089. CheckSource('TestAssignments',
  2090. LinesToStr([ // statements
  2091. 'this.Bar = 0;'
  2092. ]),
  2093. LinesToStr([ // this.$main
  2094. '$mod.Bar=3;',
  2095. '$mod.Bar+=4;',
  2096. '$mod.Bar-=5;',
  2097. '$mod.Bar*=6;'
  2098. ]));
  2099. end;
  2100. procedure TTestModule.TestArithmeticOperators1;
  2101. begin
  2102. StartProgram(false);
  2103. Add('var');
  2104. Add(' vA,vB,vC:longint;');
  2105. Add('begin');
  2106. Add(' va:=1;');
  2107. Add(' vb:=va+va;');
  2108. Add(' vb:=va div vb;');
  2109. Add(' vb:=va mod vb;');
  2110. Add(' vb:=va+va*vb+va div vb;');
  2111. Add(' vc:=-va;');
  2112. Add(' va:=va-vb;');
  2113. Add(' vb:=va;');
  2114. Add(' if va<vb then vc:=va else vc:=vb;');
  2115. ConvertProgram;
  2116. CheckSource('TestArithmeticOperators1',
  2117. LinesToStr([ // statements
  2118. 'this.vA = 0;',
  2119. 'this.vB = 0;',
  2120. 'this.vC = 0;'
  2121. ]),
  2122. LinesToStr([ // this.$main
  2123. '$mod.vA = 1;',
  2124. '$mod.vB = $mod.vA + $mod.vA;',
  2125. '$mod.vB = Math.floor($mod.vA / $mod.vB);',
  2126. '$mod.vB = $mod.vA % $mod.vB;',
  2127. '$mod.vB = ($mod.vA + ($mod.vA * $mod.vB)) + Math.floor($mod.vA / $mod.vB);',
  2128. '$mod.vC = -$mod.vA;',
  2129. '$mod.vA = $mod.vA - $mod.vB;',
  2130. '$mod.vB = $mod.vA;',
  2131. 'if ($mod.vA < $mod.vB){ $mod.vC = $mod.vA } else $mod.vC = $mod.vB;'
  2132. ]));
  2133. end;
  2134. procedure TTestModule.TestLogicalOperators;
  2135. begin
  2136. StartProgram(false);
  2137. Add('var');
  2138. Add(' vA,vB,vC:boolean;');
  2139. Add('begin');
  2140. Add(' va:=vb and vc;');
  2141. Add(' va:=vb or vc;');
  2142. Add(' va:=vb xor vc;');
  2143. Add(' va:=true and vc;');
  2144. Add(' va:=(vb and vc) or (va and vb);');
  2145. Add(' va:=not vb;');
  2146. ConvertProgram;
  2147. CheckSource('TestLogicalOperators',
  2148. LinesToStr([ // statements
  2149. 'this.vA = false;',
  2150. 'this.vB = false;',
  2151. 'this.vC = false;'
  2152. ]),
  2153. LinesToStr([ // this.$main
  2154. '$mod.vA = $mod.vB && $mod.vC;',
  2155. '$mod.vA = $mod.vB || $mod.vC;',
  2156. '$mod.vA = $mod.vB ^ $mod.vC;',
  2157. '$mod.vA = true && $mod.vC;',
  2158. '$mod.vA = ($mod.vB && $mod.vC) || ($mod.vA && $mod.vB);',
  2159. '$mod.vA = !$mod.vB;'
  2160. ]));
  2161. end;
  2162. procedure TTestModule.TestBitwiseOperators;
  2163. begin
  2164. StartProgram(false);
  2165. Add('var');
  2166. Add(' vA,vB,vC:longint;');
  2167. Add('begin');
  2168. Add(' va:=vb and vc;');
  2169. Add(' va:=vb or vc;');
  2170. Add(' va:=vb xor vc;');
  2171. Add(' va:=vb shl vc;');
  2172. Add(' va:=vb shr vc;');
  2173. Add(' va:=3 and vc;');
  2174. Add(' va:=(vb and vc) or (va and vb);');
  2175. Add(' va:=not vb;');
  2176. ConvertProgram;
  2177. CheckSource('TestBitwiseOperators',
  2178. LinesToStr([ // statements
  2179. 'this.vA = 0;',
  2180. 'this.vB = 0;',
  2181. 'this.vC = 0;'
  2182. ]),
  2183. LinesToStr([ // this.$main
  2184. '$mod.vA = $mod.vB & $mod.vC;',
  2185. '$mod.vA = $mod.vB | $mod.vC;',
  2186. '$mod.vA = $mod.vB ^ $mod.vC;',
  2187. '$mod.vA = $mod.vB << $mod.vC;',
  2188. '$mod.vA = $mod.vB >>> $mod.vC;',
  2189. '$mod.vA = 3 & $mod.vC;',
  2190. '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
  2191. '$mod.vA = ~$mod.vB;'
  2192. ]));
  2193. end;
  2194. procedure TTestModule.TestPrgProcVar;
  2195. begin
  2196. StartProgram(false);
  2197. Add('procedure Proc1;');
  2198. Add('type');
  2199. Add(' t1=longint;');
  2200. Add('var');
  2201. Add(' vA:t1;');
  2202. Add('begin');
  2203. Add('end;');
  2204. Add('begin');
  2205. ConvertProgram;
  2206. CheckSource('TestPrgProcVar',
  2207. LinesToStr([ // statements
  2208. 'this.Proc1 = function () {',
  2209. ' var vA=0;',
  2210. '};'
  2211. ]),
  2212. LinesToStr([ // this.$main
  2213. ''
  2214. ]));
  2215. end;
  2216. procedure TTestModule.TestUnitProcVar;
  2217. begin
  2218. StartUnit(false);
  2219. Add('interface');
  2220. Add('');
  2221. Add('type tA=string; // unit scope');
  2222. Add('procedure Proc1;');
  2223. Add('');
  2224. Add('implementation');
  2225. Add('');
  2226. Add('procedure Proc1;');
  2227. Add('type tA=longint; // local proc scope');
  2228. Add('var v1:tA; // using local tA');
  2229. Add('begin');
  2230. Add('end;');
  2231. Add('var v2:tA; // using interface tA');
  2232. ConvertUnit;
  2233. CheckSource('TestUnitProcVar',
  2234. LinesToStr([ // statements
  2235. 'var $impl = $mod.$impl;',
  2236. 'this.Proc1 = function () {',
  2237. ' var v1 = 0;',
  2238. '};',
  2239. '']),
  2240. // this.$init
  2241. '',
  2242. // implementation
  2243. LinesToStr([
  2244. '$impl.v2 = "";',
  2245. '']));
  2246. end;
  2247. procedure TTestModule.TestImplProc;
  2248. begin
  2249. StartUnit(false);
  2250. Add('interface');
  2251. Add('');
  2252. Add('procedure Proc1;');
  2253. Add('');
  2254. Add('implementation');
  2255. Add('');
  2256. Add('procedure Proc1; begin end;');
  2257. Add('procedure Proc2; begin end;');
  2258. Add('initialization');
  2259. Add(' Proc1;');
  2260. Add(' Proc2;');
  2261. ConvertUnit;
  2262. CheckSource('TestImplProc',
  2263. LinesToStr([ // statements
  2264. 'var $impl = $mod.$impl;',
  2265. 'this.Proc1 = function () {',
  2266. '};',
  2267. '']),
  2268. LinesToStr([ // this.$init
  2269. '$mod.Proc1();',
  2270. '$impl.Proc2();',
  2271. '']),
  2272. LinesToStr([ // implementation
  2273. '$impl.Proc2 = function () {',
  2274. '};',
  2275. ''])
  2276. );
  2277. end;
  2278. procedure TTestModule.TestFunctionResult;
  2279. begin
  2280. StartProgram(false);
  2281. Add('function Func1: longint;');
  2282. Add('begin');
  2283. Add(' Result:=3;');
  2284. Add(' Func1:=4;');
  2285. Add('end;');
  2286. Add('begin');
  2287. ConvertProgram;
  2288. CheckSource('TestFunctionResult',
  2289. LinesToStr([ // statements
  2290. 'this.Func1 = function () {',
  2291. ' var Result = 0;',
  2292. ' Result = 3;',
  2293. ' Result = 4;',
  2294. ' return Result;',
  2295. '};'
  2296. ]),
  2297. '');
  2298. end;
  2299. procedure TTestModule.TestNestedProc;
  2300. begin
  2301. StartProgram(false);
  2302. Add([
  2303. 'var vInUnit: longint;',
  2304. 'function DoIt(pA,pD: longint): longint;',
  2305. 'var',
  2306. ' vB: longint;',
  2307. ' vC: longint;',
  2308. ' function Nesty(pA: longint): longint; ',
  2309. ' var vB: longint;',
  2310. ' begin',
  2311. ' Result:=pa+vb+vc+pd+vInUnit;',
  2312. ' nesty:=3;',
  2313. ' doit:=4;',
  2314. ' exit;',
  2315. ' end;',
  2316. 'begin',
  2317. ' Result:=pa+vb+vc;',
  2318. ' doit:=6;',
  2319. ' exit;',
  2320. 'end;',
  2321. 'begin']);
  2322. ConvertProgram;
  2323. CheckSource('TestNestedProc',
  2324. LinesToStr([ // statements
  2325. 'this.vInUnit = 0;',
  2326. 'this.DoIt = function (pA, pD) {',
  2327. ' var Result = 0;',
  2328. ' var vB = 0;',
  2329. ' var vC = 0;',
  2330. ' function Nesty(pA) {',
  2331. ' var Result$1 = 0;',
  2332. ' var vB = 0;',
  2333. ' Result$1 = (((pA + vB) + vC) + pD) + $mod.vInUnit;',
  2334. ' Result$1 = 3;',
  2335. ' Result = 4;',
  2336. ' return Result$1;',
  2337. ' return Result$1;',
  2338. ' };',
  2339. ' Result = (pA + vB) + vC;',
  2340. ' Result = 6;',
  2341. ' return Result;',
  2342. ' return Result;',
  2343. '};'
  2344. ]),
  2345. '');
  2346. end;
  2347. procedure TTestModule.TestNestedProc_ResultString;
  2348. begin
  2349. StartProgram(false);
  2350. Add([
  2351. 'function DoIt: string;',
  2352. ' function Nesty: string; ',
  2353. ' begin',
  2354. ' nesty:=#65#66;',
  2355. ' nesty[1]:=#67;',
  2356. ' doit:=#68;',
  2357. ' doit[2]:=#69;',
  2358. ' end;',
  2359. 'begin',
  2360. ' doit:=#70;',
  2361. ' doit[3]:=#71;',
  2362. 'end;',
  2363. 'begin']);
  2364. ConvertProgram;
  2365. CheckSource('TestNestedProc_ResultString',
  2366. LinesToStr([ // statements
  2367. 'this.DoIt = function () {',
  2368. ' var Result = "";',
  2369. ' function Nesty() {',
  2370. ' var Result$1 = "";',
  2371. ' Result$1 = "AB";',
  2372. ' Result$1 = rtl.setCharAt(Result$1, 0, "C");',
  2373. ' Result = "D";',
  2374. ' Result = rtl.setCharAt(Result, 1, "E");',
  2375. ' return Result$1;',
  2376. ' };',
  2377. ' Result = "F";',
  2378. ' Result = rtl.setCharAt(Result, 2, "G");',
  2379. ' return Result;',
  2380. '};'
  2381. ]),
  2382. '');
  2383. end;
  2384. procedure TTestModule.TestForwardProc;
  2385. begin
  2386. StartProgram(false);
  2387. Add('procedure FuncA(Bar: longint); forward;');
  2388. Add('procedure FuncB(Bar: longint);');
  2389. Add('begin');
  2390. Add(' funca(bar);');
  2391. Add('end;');
  2392. Add('procedure funca(bar: longint);');
  2393. Add('begin');
  2394. Add(' if bar=3 then ;');
  2395. Add('end;');
  2396. Add('begin');
  2397. Add(' funca(4);');
  2398. Add(' funcb(5);');
  2399. ConvertProgram;
  2400. CheckSource('TestForwardProc',
  2401. LinesToStr([ // statements'
  2402. 'this.FuncB = function (Bar) {',
  2403. ' $mod.FuncA(Bar);',
  2404. '};',
  2405. 'this.FuncA = function (Bar) {',
  2406. ' if (Bar === 3);',
  2407. '};'
  2408. ]),
  2409. LinesToStr([
  2410. '$mod.FuncA(4);',
  2411. '$mod.FuncB(5);'
  2412. ])
  2413. );
  2414. end;
  2415. procedure TTestModule.TestNestedForwardProc;
  2416. begin
  2417. StartProgram(false);
  2418. Add('procedure FuncA;');
  2419. Add(' procedure FuncB(i: longint); forward;');
  2420. Add(' procedure FuncC(i: longint);');
  2421. Add(' begin');
  2422. Add(' funcb(i);');
  2423. Add(' end;');
  2424. Add(' procedure FuncB(i: longint);');
  2425. Add(' begin');
  2426. Add(' if i=3 then ;');
  2427. Add(' end;');
  2428. Add('begin');
  2429. Add(' funcc(4)');
  2430. Add('end;');
  2431. Add('begin');
  2432. Add(' funca;');
  2433. ConvertProgram;
  2434. CheckSource('TestNestedForwardProc',
  2435. LinesToStr([ // statements'
  2436. 'this.FuncA = function () {',
  2437. ' function FuncC(i) {',
  2438. ' FuncB(i);',
  2439. ' };',
  2440. ' function FuncB(i) {',
  2441. ' if (i === 3);',
  2442. ' };',
  2443. ' FuncC(4);',
  2444. '};'
  2445. ]),
  2446. LinesToStr([
  2447. '$mod.FuncA();'
  2448. ])
  2449. );
  2450. end;
  2451. procedure TTestModule.TestAssignFunctionResult;
  2452. begin
  2453. StartProgram(false);
  2454. Add('function Func1: longint;');
  2455. Add('begin');
  2456. Add('end;');
  2457. Add('var i: longint;');
  2458. Add('begin');
  2459. Add(' i:=func1();');
  2460. Add(' i:=func1()+func1();');
  2461. ConvertProgram;
  2462. CheckSource('TestAssignFunctionResult',
  2463. LinesToStr([ // statements
  2464. 'this.Func1 = function () {',
  2465. ' var Result = 0;',
  2466. ' return Result;',
  2467. '};',
  2468. 'this.i = 0;'
  2469. ]),
  2470. LinesToStr([
  2471. '$mod.i = $mod.Func1();',
  2472. '$mod.i = $mod.Func1() + $mod.Func1();'
  2473. ]));
  2474. end;
  2475. procedure TTestModule.TestFunctionResultInCondition;
  2476. begin
  2477. StartProgram(false);
  2478. Add('function Func1: longint;');
  2479. Add('begin');
  2480. Add('end;');
  2481. Add('function Func2: boolean;');
  2482. Add('begin');
  2483. Add('end;');
  2484. Add('var i: longint;');
  2485. Add('begin');
  2486. Add(' if func2 then ;');
  2487. Add(' if i=func1() then ;');
  2488. Add(' if i=func1 then ;');
  2489. ConvertProgram;
  2490. CheckSource('TestFunctionResultInCondition',
  2491. LinesToStr([ // statements
  2492. 'this.Func1 = function () {',
  2493. ' var Result = 0;',
  2494. ' return Result;',
  2495. '};',
  2496. 'this.Func2 = function () {',
  2497. ' var Result = false;',
  2498. ' return Result;',
  2499. '};',
  2500. 'this.i = 0;'
  2501. ]),
  2502. LinesToStr([
  2503. 'if ($mod.Func2());',
  2504. 'if ($mod.i === $mod.Func1());',
  2505. 'if ($mod.i === $mod.Func1());'
  2506. ]));
  2507. end;
  2508. procedure TTestModule.TestExit;
  2509. begin
  2510. StartProgram(false);
  2511. Add('procedure ProcA;');
  2512. Add('begin');
  2513. Add(' exit;');
  2514. Add('end;');
  2515. Add('function FuncB: longint;');
  2516. Add('begin');
  2517. Add(' exit;');
  2518. Add(' exit(3);');
  2519. Add('end;');
  2520. Add('function FuncC: string;');
  2521. Add('begin');
  2522. Add(' exit;');
  2523. Add(' exit(''a'');');
  2524. Add(' exit(''abc'');');
  2525. Add('end;');
  2526. Add('begin');
  2527. Add(' exit;');
  2528. Add(' exit(1);');
  2529. ConvertProgram;
  2530. CheckSource('TestExit',
  2531. LinesToStr([ // statements
  2532. 'this.ProcA = function () {',
  2533. ' return;',
  2534. '};',
  2535. 'this.FuncB = function () {',
  2536. ' var Result = 0;',
  2537. ' return Result;',
  2538. ' return 3;',
  2539. ' return Result;',
  2540. '};',
  2541. 'this.FuncC = function () {',
  2542. ' var Result = "";',
  2543. ' return Result;',
  2544. ' return "a";',
  2545. ' return "abc";',
  2546. ' return Result;',
  2547. '};'
  2548. ]),
  2549. LinesToStr([
  2550. 'return;',
  2551. 'return 1;',
  2552. '']));
  2553. end;
  2554. procedure TTestModule.TestBreak;
  2555. begin
  2556. StartProgram(false);
  2557. Add([
  2558. 'var',
  2559. ' i: longint;',
  2560. 'begin',
  2561. ' repeat',
  2562. ' break;',
  2563. ' until true;',
  2564. ' while true do',
  2565. ' break;',
  2566. ' for i:=1 to 2 do',
  2567. ' break;']);
  2568. ConvertProgram;
  2569. CheckSource('TestBreak',
  2570. LinesToStr([ // statements
  2571. 'this.i = 0;'
  2572. ]),
  2573. LinesToStr([
  2574. 'do {',
  2575. ' break;',
  2576. '} while (!true);',
  2577. 'while (true) break;',
  2578. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) break;',
  2579. '']));
  2580. end;
  2581. procedure TTestModule.TestBreakAsVar;
  2582. begin
  2583. StartProgram(false);
  2584. Add([
  2585. 'procedure DoIt(break: boolean);',
  2586. 'begin',
  2587. ' if break then ;',
  2588. 'end;',
  2589. 'var',
  2590. ' break: boolean;',
  2591. 'begin',
  2592. ' if break then ;']);
  2593. ConvertProgram;
  2594. CheckSource('TestBreakAsVar',
  2595. LinesToStr([ // statements
  2596. 'this.DoIt = function (Break) {',
  2597. ' if (Break) ;',
  2598. '};',
  2599. 'this.Break = false;',
  2600. '']),
  2601. LinesToStr([
  2602. 'if($mod.Break) ;',
  2603. '']));
  2604. end;
  2605. procedure TTestModule.TestContinue;
  2606. begin
  2607. StartProgram(false);
  2608. Add('var i: longint;');
  2609. Add('begin');
  2610. Add(' repeat');
  2611. Add(' continue;');
  2612. Add(' until true;');
  2613. Add(' while true do');
  2614. Add(' continue;');
  2615. Add(' for i:=1 to 2 do');
  2616. Add(' continue;');
  2617. ConvertProgram;
  2618. CheckSource('TestContinue',
  2619. LinesToStr([ // statements
  2620. 'this.i = 0;'
  2621. ]),
  2622. LinesToStr([
  2623. 'do {',
  2624. ' continue;',
  2625. '} while (!true);',
  2626. 'while (true) continue;',
  2627. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) continue;',
  2628. '']));
  2629. end;
  2630. procedure TTestModule.TestProc_External;
  2631. begin
  2632. StartProgram(false);
  2633. Add('procedure Foo; external name ''console.log'';');
  2634. Add('function Bar: longint; external name ''get.item'';');
  2635. Add('function Bla(s: string): longint; external name ''apply.something'';');
  2636. Add('var');
  2637. Add(' i: longint;');
  2638. Add('begin');
  2639. Add(' Foo;');
  2640. Add(' i:=Bar;');
  2641. Add(' i:=Bla(''abc'');');
  2642. ConvertProgram;
  2643. CheckSource('TestProc_External',
  2644. LinesToStr([ // statements
  2645. 'this.i = 0;'
  2646. ]),
  2647. LinesToStr([
  2648. 'console.log();',
  2649. '$mod.i = get.item();',
  2650. '$mod.i = apply.something("abc");'
  2651. ]));
  2652. end;
  2653. procedure TTestModule.TestProc_ExternalOtherUnit;
  2654. begin
  2655. AddModuleWithIntfImplSrc('unit2.pas',
  2656. LinesToStr([
  2657. 'procedure Now; external name ''Date.now'';',
  2658. 'procedure DoIt;'
  2659. ]),
  2660. 'procedure doit; begin end;');
  2661. StartUnit(true);
  2662. Add('interface');
  2663. Add('uses unit2;');
  2664. Add('implementation');
  2665. Add('begin');
  2666. Add(' now;');
  2667. Add(' now();');
  2668. Add(' uNit2.now;');
  2669. Add(' uNit2.now();');
  2670. Add(' doit;');
  2671. Add(' uNit2.doit;');
  2672. ConvertUnit;
  2673. CheckSource('TestProc_ExternalOtherUnit',
  2674. LinesToStr([
  2675. '']),
  2676. LinesToStr([
  2677. 'Date.now();',
  2678. 'Date.now();',
  2679. 'Date.now();',
  2680. 'Date.now();',
  2681. 'pas.unit2.DoIt();',
  2682. 'pas.unit2.DoIt();',
  2683. '']));
  2684. end;
  2685. procedure TTestModule.TestProc_Asm;
  2686. begin
  2687. StartProgram(false);
  2688. Add([
  2689. 'function DoIt: longint;',
  2690. 'begin;',
  2691. ' asm',
  2692. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2693. ' end;',
  2694. ' asm console.log(); end;',
  2695. 'end;',
  2696. 'begin']);
  2697. ConvertProgram;
  2698. CheckSource('TestProc_Asm',
  2699. LinesToStr([ // statements
  2700. 'this.DoIt = function () {',
  2701. ' var Result = 0;',
  2702. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2703. ' console.log();',
  2704. ' return Result;',
  2705. '};'
  2706. ]),
  2707. LinesToStr([
  2708. ''
  2709. ]));
  2710. end;
  2711. procedure TTestModule.TestProc_Assembler;
  2712. begin
  2713. StartProgram(false);
  2714. Add('function DoIt: longint; assembler;');
  2715. Add('asm');
  2716. Add('{ a:{ b:{}, c:[]}, d:''1'' };');
  2717. Add('end;');
  2718. Add('begin');
  2719. ConvertProgram;
  2720. CheckSource('TestProc_Assembler',
  2721. LinesToStr([ // statements
  2722. 'this.DoIt = function () {',
  2723. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2724. '};'
  2725. ]),
  2726. LinesToStr([
  2727. ''
  2728. ]));
  2729. end;
  2730. procedure TTestModule.TestProc_VarParam;
  2731. begin
  2732. StartProgram(false);
  2733. Add('type integer = longint;');
  2734. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  2735. Add('var vJ: integer;');
  2736. Add('begin');
  2737. Add(' vg:=vg+1;');
  2738. Add(' vj:=vh+2;');
  2739. Add(' vi:=vi+3;');
  2740. Add(' doit(vg,vg,vg);');
  2741. Add(' doit(vh,vh,vj);');
  2742. Add(' doit(vi,vi,vi);');
  2743. Add(' doit(vj,vj,vj);');
  2744. Add('end;');
  2745. Add('var i: integer;');
  2746. Add('begin');
  2747. Add(' doit(i,i,i);');
  2748. ConvertProgram;
  2749. CheckSource('TestProc_VarParam',
  2750. LinesToStr([ // statements
  2751. 'this.DoIt = function (vG,vH,vI) {',
  2752. ' var vJ = 0;',
  2753. ' vG = vG + 1;',
  2754. ' vJ = vH + 2;',
  2755. ' vI.set(vI.get()+3);',
  2756. ' $mod.DoIt(vG, vG, {',
  2757. ' get: function () {',
  2758. ' return vG;',
  2759. ' },',
  2760. ' set: function (v) {',
  2761. ' vG = v;',
  2762. ' }',
  2763. ' });',
  2764. ' $mod.DoIt(vH, vH, {',
  2765. ' get: function () {',
  2766. ' return vJ;',
  2767. ' },',
  2768. ' set: function (v) {',
  2769. ' vJ = v;',
  2770. ' }',
  2771. ' });',
  2772. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  2773. ' $mod.DoIt(vJ, vJ, {',
  2774. ' get: function () {',
  2775. ' return vJ;',
  2776. ' },',
  2777. ' set: function (v) {',
  2778. ' vJ = v;',
  2779. ' }',
  2780. ' });',
  2781. '};',
  2782. 'this.i = 0;'
  2783. ]),
  2784. LinesToStr([
  2785. '$mod.DoIt($mod.i,$mod.i,{',
  2786. ' p: $mod,',
  2787. ' get: function () {',
  2788. ' return this.p.i;',
  2789. ' },',
  2790. ' set: function (v) {',
  2791. ' this.p.i = v;',
  2792. ' }',
  2793. '});'
  2794. ]));
  2795. end;
  2796. procedure TTestModule.TestProc_VarParamString;
  2797. begin
  2798. StartProgram(false);
  2799. Add(['type TCaption = string;',
  2800. 'procedure DoIt(vA: TCaption; var vB: TCaption; out vC: TCaption);',
  2801. 'var c: char;',
  2802. 'begin',
  2803. ' va[1]:=c;',
  2804. ' vb[2]:=c;',
  2805. ' vc[3]:=c;',
  2806. 'end;',
  2807. 'begin']);
  2808. ConvertProgram;
  2809. CheckSource('TestProc_VarParamString',
  2810. LinesToStr([ // statements
  2811. 'this.DoIt = function (vA,vB,vC) {',
  2812. ' var c = "";',
  2813. ' vA = rtl.setCharAt(vA, 0, c);',
  2814. ' vB.set(rtl.setCharAt(vB.get(), 1, c));',
  2815. ' vC.set(rtl.setCharAt(vC.get(), 2, c));',
  2816. '};',
  2817. '']),
  2818. LinesToStr([
  2819. ]));
  2820. end;
  2821. procedure TTestModule.TestProc_VarParamV;
  2822. begin
  2823. StartProgram(false);
  2824. Add([
  2825. 'procedure Inc2(var i: longint);',
  2826. 'begin',
  2827. ' i:=i+2;',
  2828. 'end;',
  2829. 'procedure DoIt(v: longint);',
  2830. 'var p: array of longint;',
  2831. 'begin',
  2832. ' Inc2(v);',
  2833. ' Inc2(p[v]);',
  2834. 'end;',
  2835. 'begin']);
  2836. ConvertProgram;
  2837. CheckSource('TestProc_VarParamV',
  2838. LinesToStr([ // statements
  2839. 'this.Inc2 = function (i) {',
  2840. ' i.set(i.get()+2);',
  2841. '};',
  2842. 'this.DoIt = function (v) {',
  2843. ' var p = [];',
  2844. ' $mod.Inc2({get: function () {',
  2845. ' return v;',
  2846. ' }, set: function (w) {',
  2847. ' v = w;',
  2848. ' }});',
  2849. ' $mod.Inc2({',
  2850. ' a: v,',
  2851. ' p: p,',
  2852. ' get: function () {',
  2853. ' return this.p[this.a];',
  2854. ' },',
  2855. ' set: function (v) {',
  2856. ' this.p[this.a] = v;',
  2857. ' }',
  2858. ' });',
  2859. '};',
  2860. '']),
  2861. LinesToStr([
  2862. '']));
  2863. end;
  2864. procedure TTestModule.TestProc_Overload;
  2865. begin
  2866. StartProgram(false);
  2867. Add('procedure DoIt(vI: longint); begin end;');
  2868. Add('procedure DoIt(vI, vJ: longint); begin end;');
  2869. Add('procedure DoIt(vD: double); begin end;');
  2870. Add('begin');
  2871. Add(' DoIt(1);');
  2872. Add(' DoIt(2,3);');
  2873. Add(' DoIt(4.5);');
  2874. ConvertProgram;
  2875. CheckSource('TestProcedureOverload',
  2876. LinesToStr([ // statements
  2877. 'this.DoIt = function (vI) {',
  2878. '};',
  2879. 'this.DoIt$1 = function (vI, vJ) {',
  2880. '};',
  2881. 'this.DoIt$2 = function (vD) {',
  2882. '};',
  2883. '']),
  2884. LinesToStr([
  2885. '$mod.DoIt(1);',
  2886. '$mod.DoIt$1(2, 3);',
  2887. '$mod.DoIt$2(4.5);',
  2888. '']));
  2889. end;
  2890. procedure TTestModule.TestProc_OverloadForward;
  2891. begin
  2892. StartProgram(false);
  2893. Add('procedure DoIt(vI: longint); forward;');
  2894. Add('procedure DoIt(vI, vJ: longint); begin end;');
  2895. Add('procedure doit(vi: longint); begin end;');
  2896. Add('begin');
  2897. Add(' doit(1);');
  2898. Add(' doit(2,3);');
  2899. ConvertProgram;
  2900. CheckSource('TestProcedureOverloadForward',
  2901. LinesToStr([ // statements
  2902. 'this.DoIt$1 = function (vI, vJ) {',
  2903. '};',
  2904. 'this.DoIt = function (vI) {',
  2905. '};',
  2906. '']),
  2907. LinesToStr([
  2908. '$mod.DoIt(1);',
  2909. '$mod.DoIt$1(2, 3);',
  2910. '']));
  2911. end;
  2912. procedure TTestModule.TestProc_OverloadIntfImpl;
  2913. begin
  2914. StartUnit(false);
  2915. Add('interface');
  2916. Add('procedure DoIt(vI: longint);');
  2917. Add('procedure DoIt(vI, vJ: longint);');
  2918. Add('implementation');
  2919. Add('procedure DoIt(vI, vJ, vK, vL, vM: longint); forward;');
  2920. Add('procedure DoIt(vI, vJ, vK: longint); begin end;');
  2921. Add('procedure DoIt(vi: longint); begin end;');
  2922. Add('procedure DoIt(vI, vJ, vK, vL: longint); begin end;');
  2923. Add('procedure DoIt(vi, vj: longint); begin end;');
  2924. Add('procedure DoIt(vi, vj, vk, vl, vm: longint); begin end;');
  2925. Add('begin');
  2926. Add(' doit(1);');
  2927. Add(' doit(2,3);');
  2928. Add(' doit(4,5,6);');
  2929. Add(' doit(7,8,9,10);');
  2930. Add(' doit(11,12,13,14,15);');
  2931. ConvertUnit;
  2932. CheckSource('TestProcedureOverloadUnit',
  2933. LinesToStr([ // statements
  2934. 'var $impl = $mod.$impl;',
  2935. 'this.DoIt = function (vI) {',
  2936. '};',
  2937. 'this.DoIt$1 = function (vI, vJ) {',
  2938. '};',
  2939. '']),
  2940. LinesToStr([ // this.$init
  2941. '$mod.DoIt(1);',
  2942. '$mod.DoIt$1(2, 3);',
  2943. '$impl.DoIt$3(4,5,6);',
  2944. '$impl.DoIt$4(7,8,9,10);',
  2945. '$impl.DoIt$2(11,12,13,14,15);',
  2946. '']),
  2947. LinesToStr([ // implementation
  2948. '$impl.DoIt$3 = function (vI, vJ, vK) {',
  2949. '};',
  2950. '$impl.DoIt$4 = function (vI, vJ, vK, vL) {',
  2951. '};',
  2952. '$impl.DoIt$2 = function (vI, vJ, vK, vL, vM) {',
  2953. '};',
  2954. '']));
  2955. end;
  2956. procedure TTestModule.TestProc_OverloadNested;
  2957. begin
  2958. StartProgram(false);
  2959. Add([
  2960. 'procedure DoIt(vA: longint); overload; forward;',
  2961. 'procedure DoIt(vB, vC: longint); overload;',
  2962. 'begin // 2 param overload',
  2963. ' doit(1);',
  2964. ' doit(1,2);',
  2965. 'end;',
  2966. 'procedure doit(vA: longint);',
  2967. ' procedure DoIt(vA, vB, vC: longint); overload; forward;',
  2968. ' procedure DoIt(vA, vB, vC, vD: longint); overload;',
  2969. ' begin // 4 param overload',
  2970. ' doit(1);',
  2971. ' doit(1,2);',
  2972. ' doit(1,2,3);',
  2973. ' doit(1,2,3,4);',
  2974. ' end;',
  2975. ' procedure doit(vA, vB, vC: longint);',
  2976. ' procedure DoIt(vA, vB, vC, vD, vE: longint); overload; forward;',
  2977. ' procedure DoIt(vA, vB, vC, vD, vE, vF: longint); overload;',
  2978. ' begin // 6 param overload',
  2979. ' doit(1);',
  2980. ' doit(1,2);',
  2981. ' doit(1,2,3);',
  2982. ' doit(1,2,3,4);',
  2983. ' doit(1,2,3,4,5);',
  2984. ' doit(1,2,3,4,5,6);',
  2985. ' end;',
  2986. ' procedure doit(vA, vB, vC, vD, vE: longint);',
  2987. ' begin // 5 param overload',
  2988. ' doit(1);',
  2989. ' doit(1,2);',
  2990. ' doit(1,2,3);',
  2991. ' doit(1,2,3,4);',
  2992. ' doit(1,2,3,4,5);',
  2993. ' doit(1,2,3,4,5,6);',
  2994. ' end;',
  2995. ' begin // 3 param overload',
  2996. ' doit(1);',
  2997. ' doit(1,2);',
  2998. ' doit(1,2,3);',
  2999. ' doit(1,2,3,4);',
  3000. ' doit(1,2,3,4,5);',
  3001. ' doit(1,2,3,4,5,6);',
  3002. ' end;',
  3003. 'begin // 1 param overload',
  3004. ' doit(1);',
  3005. ' doit(1,2);',
  3006. ' doit(1,2,3);',
  3007. ' doit(1,2,3,4);',
  3008. 'end;',
  3009. 'begin // main',
  3010. ' doit(1);',
  3011. ' doit(1,2);']);
  3012. ConvertProgram;
  3013. CheckSource('TestProcedureOverloadNested',
  3014. LinesToStr([ // statements
  3015. 'this.DoIt$1 = function (vB, vC) {',
  3016. ' $mod.DoIt(1);',
  3017. ' $mod.DoIt$1(1, 2);',
  3018. '};',
  3019. 'this.DoIt = function (vA) {',
  3020. ' function DoIt$3(vA, vB, vC, vD) {',
  3021. ' $mod.DoIt(1);',
  3022. ' $mod.DoIt$1(1, 2);',
  3023. ' DoIt$2(1, 2, 3);',
  3024. ' DoIt$3(1, 2, 3, 4);',
  3025. ' };',
  3026. ' function DoIt$2(vA, vB, vC) {',
  3027. ' function DoIt$5(vA, vB, vC, vD, vE, vF) {',
  3028. ' $mod.DoIt(1);',
  3029. ' $mod.DoIt$1(1, 2);',
  3030. ' DoIt$2(1, 2, 3);',
  3031. ' DoIt$3(1, 2, 3, 4);',
  3032. ' DoIt$4(1, 2, 3, 4, 5);',
  3033. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3034. ' };',
  3035. ' function DoIt$4(vA, vB, vC, vD, vE) {',
  3036. ' $mod.DoIt(1);',
  3037. ' $mod.DoIt$1(1, 2);',
  3038. ' DoIt$2(1, 2, 3);',
  3039. ' DoIt$3(1, 2, 3, 4);',
  3040. ' DoIt$4(1, 2, 3, 4, 5);',
  3041. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3042. ' };',
  3043. ' $mod.DoIt(1);',
  3044. ' $mod.DoIt$1(1, 2);',
  3045. ' DoIt$2(1, 2, 3);',
  3046. ' DoIt$3(1, 2, 3, 4);',
  3047. ' DoIt$4(1, 2, 3, 4, 5);',
  3048. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3049. ' };',
  3050. ' $mod.DoIt(1);',
  3051. ' $mod.DoIt$1(1, 2);',
  3052. ' DoIt$2(1, 2, 3);',
  3053. ' DoIt$3(1, 2, 3, 4);',
  3054. '};',
  3055. '']),
  3056. LinesToStr([
  3057. '$mod.DoIt(1);',
  3058. '$mod.DoIt$1(1, 2);',
  3059. '']));
  3060. end;
  3061. procedure TTestModule.TestProc_OverloadUnitCycle;
  3062. begin
  3063. AddModuleWithIntfImplSrc('Unit2.pas',
  3064. LinesToStr([
  3065. 'type',
  3066. ' TObject = class',
  3067. ' procedure DoIt(b: boolean); virtual; abstract;',
  3068. ' procedure DoIt(i: longint); virtual; abstract;',
  3069. ' end;',
  3070. '']),
  3071. 'uses test1;');
  3072. StartUnit(true);
  3073. Add([
  3074. 'interface',
  3075. 'uses unit2;',
  3076. 'type',
  3077. ' TEagle = class(TObject)',
  3078. ' procedure DoIt(b: boolean); override;',
  3079. ' procedure DoIt(i: longint); override;',
  3080. ' end;',
  3081. 'implementation',
  3082. 'procedure TEagle.DoIt(b: boolean); begin end;',
  3083. 'procedure TEagle.DoIt(i: longint); begin end;',
  3084. '']);
  3085. ConvertUnit;
  3086. CheckSource('TestProc_OverloadUnitCycle',
  3087. LinesToStr([ // statements
  3088. 'rtl.createClass($mod, "TEagle", pas.Unit2.TObject, function () {',
  3089. ' this.DoIt = function (b) {',
  3090. ' };',
  3091. ' this.DoIt$1 = function (i) {',
  3092. ' };',
  3093. '});',
  3094. '']),
  3095. '',
  3096. LinesToStr([
  3097. '']));
  3098. end;
  3099. procedure TTestModule.TestProc_Varargs;
  3100. begin
  3101. StartProgram(false);
  3102. Add([
  3103. 'procedure ProcA(i:longint); varargs; external name ''ProcA'';',
  3104. 'procedure ProcB; varargs; external name ''ProcB'';',
  3105. 'procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';',
  3106. 'function GetIt: longint; begin end;',
  3107. 'begin',
  3108. ' ProcA(1);',
  3109. ' ProcA(1,2);',
  3110. ' ProcA(1,2.0);',
  3111. ' ProcA(1,2,3);',
  3112. ' ProcA(1,''2'');',
  3113. ' ProcA(2,'''');',
  3114. ' ProcA(3,false);',
  3115. ' ProcB;',
  3116. ' ProcB();',
  3117. ' ProcB(4);',
  3118. ' ProcB(''foo'');',
  3119. ' ProcC;',
  3120. ' ProcC();',
  3121. ' ProcC(4);',
  3122. ' ProcC(5,''foo'');',
  3123. ' ProcB(GetIt);',
  3124. ' ProcB(GetIt());',
  3125. ' ProcB(GetIt,GetIt());']);
  3126. ConvertProgram;
  3127. CheckSource('TestProc_Varargs',
  3128. LinesToStr([ // statements
  3129. 'this.GetIt = function () {',
  3130. ' var Result = 0;',
  3131. ' return Result;',
  3132. '};',
  3133. '']),
  3134. LinesToStr([
  3135. 'ProcA(1);',
  3136. 'ProcA(1, 2);',
  3137. 'ProcA(1, 2.0);',
  3138. 'ProcA(1, 2, 3);',
  3139. 'ProcA(1, "2");',
  3140. 'ProcA(2, "");',
  3141. 'ProcA(3, false);',
  3142. 'ProcB();',
  3143. 'ProcB();',
  3144. 'ProcB(4);',
  3145. 'ProcB("foo");',
  3146. 'ProcC(17);',
  3147. 'ProcC(17);',
  3148. 'ProcC(4);',
  3149. 'ProcC(5, "foo");',
  3150. 'ProcB($mod.GetIt());',
  3151. 'ProcB($mod.GetIt());',
  3152. 'ProcB($mod.GetIt(), $mod.GetIt());',
  3153. '']));
  3154. end;
  3155. procedure TTestModule.TestProc_ConstOrder;
  3156. begin
  3157. StartProgram(false);
  3158. Add([
  3159. 'const A = 3;',
  3160. 'const B = A+1;',
  3161. 'procedure DoIt;',
  3162. 'const C = A+1;',
  3163. 'const D = B+1;',
  3164. 'const E = D+C+B+A;',
  3165. 'begin',
  3166. 'end;',
  3167. 'begin'
  3168. ]);
  3169. ConvertProgram;
  3170. CheckSource('TestProc_ConstOrder',
  3171. LinesToStr([ // statements
  3172. 'this.A = 3;',
  3173. 'this.B = 3 + 1;',
  3174. 'var C = 3 + 1;',
  3175. 'var D = 4 + 1;',
  3176. 'var E = ((5 + 4) + 4) + 3;',
  3177. 'this.DoIt = function () {',
  3178. '};',
  3179. '']),
  3180. LinesToStr([
  3181. ''
  3182. ]));
  3183. end;
  3184. procedure TTestModule.TestProc_LocalVarAbsolute;
  3185. begin
  3186. StartProgram(false);
  3187. Add([
  3188. 'type',
  3189. ' TObject = class',
  3190. ' Index: longint;',
  3191. ' end;',
  3192. 'procedure DoIt(i: longint);',
  3193. 'var',
  3194. ' d: double absolute i;',
  3195. ' s: string absolute d;',
  3196. ' o: TObject absolute i;',
  3197. 'begin',
  3198. ' if d=d then d:=d;',
  3199. ' if s=s then s:=s;',
  3200. ' if o.Index<o.Index then o.Index:=o.Index;',
  3201. 'end;',
  3202. 'begin']);
  3203. ConvertProgram;
  3204. CheckSource('TestProc_LocalVarAbsolute',
  3205. LinesToStr([ // statements
  3206. 'rtl.createClass($mod, "TObject", null, function () {',
  3207. ' this.$init = function () {',
  3208. ' this.Index = 0;',
  3209. ' };',
  3210. ' this.$final = function () {',
  3211. ' };',
  3212. '});',
  3213. 'this.DoIt = function (i) {',
  3214. ' if (i === i) i = i;',
  3215. ' if (i === i) i = i;',
  3216. ' if (i.Index < i.Index) i.Index = i.Index;',
  3217. '};'
  3218. ]),
  3219. LinesToStr([
  3220. ]));
  3221. end;
  3222. procedure TTestModule.TestEnum_Name;
  3223. begin
  3224. StartProgram(false);
  3225. Add('type TMyEnum = (Red, Green, Blue);');
  3226. Add('var e: TMyEnum;');
  3227. Add('var f: TMyEnum = Blue;');
  3228. Add('begin');
  3229. Add(' e:=green;');
  3230. ConvertProgram;
  3231. CheckSource('TestEnumName',
  3232. LinesToStr([ // statements
  3233. 'this.TMyEnum = {',
  3234. ' "0":"Red",',
  3235. ' Red:0,',
  3236. ' "1":"Green",',
  3237. ' Green:1,',
  3238. ' "2":"Blue",',
  3239. ' Blue:2',
  3240. ' };',
  3241. 'this.e = 0;',
  3242. 'this.f = $mod.TMyEnum.Blue;'
  3243. ]),
  3244. LinesToStr([
  3245. '$mod.e=$mod.TMyEnum.Green;'
  3246. ]));
  3247. end;
  3248. procedure TTestModule.TestEnum_Number;
  3249. begin
  3250. Converter.Options:=Converter.Options+[coEnumNumbers];
  3251. StartProgram(false);
  3252. Add('type TMyEnum = (Red, Green);');
  3253. Add('var');
  3254. Add(' e: TMyEnum;');
  3255. Add(' f: TMyEnum = Green;');
  3256. Add(' i: longint;');
  3257. Add('begin');
  3258. Add(' e:=green;');
  3259. Add(' i:=longint(e);');
  3260. ConvertProgram;
  3261. CheckSource('TestEnumNumber',
  3262. LinesToStr([ // statements
  3263. 'this.TMyEnum = {',
  3264. ' "0":"Red",',
  3265. ' Red:0,',
  3266. ' "1":"Green",',
  3267. ' Green:1',
  3268. ' };',
  3269. 'this.e = 0;',
  3270. 'this.f = 1;',
  3271. 'this.i = 0;'
  3272. ]),
  3273. LinesToStr([
  3274. '$mod.e=1;',
  3275. '$mod.i=$mod.e;'
  3276. ]));
  3277. end;
  3278. procedure TTestModule.TestEnum_ConstFail;
  3279. begin
  3280. StartProgram(false);
  3281. Add([
  3282. 'type TMyEnum = (Red = 100, Green = 101);',
  3283. 'var',
  3284. ' e: TMyEnum;',
  3285. ' f: TMyEnum = Green;',
  3286. 'begin',
  3287. ' e:=green;']);
  3288. SetExpectedPasResolverError('not yet implemented: Red:TPasEnumValue [20180126202434] enum const',3002);
  3289. ConvertProgram;
  3290. end;
  3291. procedure TTestModule.TestEnum_Functions;
  3292. begin
  3293. StartProgram(false);
  3294. Add('type TMyEnum = (Red, Green);');
  3295. Add('var');
  3296. Add(' e: TMyEnum;');
  3297. Add(' i: longint;');
  3298. Add(' s: string;');
  3299. Add(' b: boolean;');
  3300. Add('begin');
  3301. Add(' i:=ord(red);');
  3302. Add(' i:=ord(green);');
  3303. Add(' i:=ord(e);');
  3304. Add(' i:=ord(b);');
  3305. Add(' e:=low(tmyenum);');
  3306. Add(' e:=low(e);');
  3307. Add(' b:=low(boolean);');
  3308. Add(' e:=high(tmyenum);');
  3309. Add(' e:=high(e);');
  3310. Add(' b:=high(boolean);');
  3311. Add(' e:=pred(green);');
  3312. Add(' e:=pred(e);');
  3313. Add(' b:=pred(b);');
  3314. Add(' e:=succ(red);');
  3315. Add(' e:=succ(e);');
  3316. Add(' b:=succ(b);');
  3317. Add(' e:=tmyenum(1);');
  3318. Add(' e:=tmyenum(i);');
  3319. Add(' s:=str(e);');
  3320. Add(' str(e,s);');
  3321. Add(' s:=str(e:3);');
  3322. Add(' e:=TMyEnum(i);');
  3323. Add(' i:=longint(e);');
  3324. ConvertProgram;
  3325. CheckSource('TestEnum_Functions',
  3326. LinesToStr([ // statements
  3327. 'this.TMyEnum = {',
  3328. ' "0":"Red",',
  3329. ' Red:0,',
  3330. ' "1":"Green",',
  3331. ' Green:1',
  3332. ' };',
  3333. 'this.e = 0;',
  3334. 'this.i = 0;',
  3335. 'this.s = "";',
  3336. 'this.b = false;',
  3337. '']),
  3338. LinesToStr([
  3339. '$mod.i=$mod.TMyEnum.Red;',
  3340. '$mod.i=$mod.TMyEnum.Green;',
  3341. '$mod.i=$mod.e;',
  3342. '$mod.i=$mod.b+0;',
  3343. '$mod.e=$mod.TMyEnum.Red;',
  3344. '$mod.e=$mod.TMyEnum.Red;',
  3345. '$mod.b=false;',
  3346. '$mod.e=$mod.TMyEnum.Green;',
  3347. '$mod.e=$mod.TMyEnum.Green;',
  3348. '$mod.b=true;',
  3349. '$mod.e=$mod.TMyEnum.Green-1;',
  3350. '$mod.e=$mod.e-1;',
  3351. '$mod.b=false;',
  3352. '$mod.e=$mod.TMyEnum.Red+1;',
  3353. '$mod.e=$mod.e+1;',
  3354. '$mod.b=true;',
  3355. '$mod.e=1;',
  3356. '$mod.e=$mod.i;',
  3357. '$mod.s = $mod.TMyEnum[$mod.e];',
  3358. '$mod.s = $mod.TMyEnum[$mod.e];',
  3359. '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
  3360. '$mod.e=$mod.i;',
  3361. '$mod.i=$mod.e;',
  3362. '']));
  3363. end;
  3364. procedure TTestModule.TestEnum_AsParams;
  3365. begin
  3366. StartProgram(false);
  3367. Add('type TEnum = (Red,Blue);');
  3368. Add('procedure DoIt(vG: TEnum; const vH: TEnum; var vI: TEnum);');
  3369. Add('var vJ: TEnum;');
  3370. Add('begin');
  3371. Add(' vg:=vg;');
  3372. Add(' vj:=vh;');
  3373. Add(' vi:=vi;');
  3374. Add(' doit(vg,vg,vg);');
  3375. Add(' doit(vh,vh,vj);');
  3376. Add(' doit(vi,vi,vi);');
  3377. Add(' doit(vj,vj,vj);');
  3378. Add('end;');
  3379. Add('var i: TEnum;');
  3380. Add('begin');
  3381. Add(' doit(i,i,i);');
  3382. ConvertProgram;
  3383. CheckSource('TestEnum_AsParams',
  3384. LinesToStr([ // statements
  3385. 'this.TEnum = {',
  3386. ' "0": "Red",',
  3387. ' Red: 0,',
  3388. ' "1": "Blue",',
  3389. ' Blue: 1',
  3390. '};',
  3391. 'this.DoIt = function (vG,vH,vI) {',
  3392. ' var vJ = 0;',
  3393. ' vG = vG;',
  3394. ' vJ = vH;',
  3395. ' vI.set(vI.get());',
  3396. ' $mod.DoIt(vG, vG, {',
  3397. ' get: function () {',
  3398. ' return vG;',
  3399. ' },',
  3400. ' set: function (v) {',
  3401. ' vG = v;',
  3402. ' }',
  3403. ' });',
  3404. ' $mod.DoIt(vH, vH, {',
  3405. ' get: function () {',
  3406. ' return vJ;',
  3407. ' },',
  3408. ' set: function (v) {',
  3409. ' vJ = v;',
  3410. ' }',
  3411. ' });',
  3412. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  3413. ' $mod.DoIt(vJ, vJ, {',
  3414. ' get: function () {',
  3415. ' return vJ;',
  3416. ' },',
  3417. ' set: function (v) {',
  3418. ' vJ = v;',
  3419. ' }',
  3420. ' });',
  3421. '};',
  3422. 'this.i = 0;'
  3423. ]),
  3424. LinesToStr([
  3425. '$mod.DoIt($mod.i,$mod.i,{',
  3426. ' p: $mod,',
  3427. ' get: function () {',
  3428. ' return this.p.i;',
  3429. ' },',
  3430. ' set: function (v) {',
  3431. ' this.p.i = v;',
  3432. ' }',
  3433. '});'
  3434. ]));
  3435. end;
  3436. procedure TTestModule.TestEnumRange_Array;
  3437. begin
  3438. StartProgram(false);
  3439. Add([
  3440. 'type',
  3441. ' TEnum = (Red, Green, Blue);',
  3442. ' TEnumRg = green..blue;',
  3443. ' TArr = array[TEnumRg] of byte;',
  3444. ' TArr2 = array[green..blue] of byte;',
  3445. 'var',
  3446. ' a: TArr;',
  3447. ' b: TArr = (3,4);',
  3448. ' c: TArr2 = (5,6);',
  3449. 'begin',
  3450. ' a[green] := b[blue];',
  3451. ' c[green] := c[blue];',
  3452. '']);
  3453. ConvertProgram;
  3454. CheckSource('TestEnumRange_Array',
  3455. LinesToStr([ // statements
  3456. 'this.TEnum = {',
  3457. ' "0": "Red",',
  3458. ' Red: 0,',
  3459. ' "1": "Green",',
  3460. ' Green: 1,',
  3461. ' "2": "Blue",',
  3462. ' Blue: 2',
  3463. '};',
  3464. 'this.a = rtl.arraySetLength(null, 0, 2);',
  3465. 'this.b = [3, 4];',
  3466. 'this.c = [5, 6];',
  3467. '']),
  3468. LinesToStr([
  3469. ' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
  3470. ' $mod.c[$mod.TEnum.Green - 1] = $mod.c[$mod.TEnum.Blue - 1];',
  3471. '']));
  3472. end;
  3473. procedure TTestModule.TestEnum_ForIn;
  3474. begin
  3475. StartProgram(false);
  3476. Add([
  3477. 'type',
  3478. ' TEnum = (Red, Green, Blue);',
  3479. ' TEnumRg = green..blue;',
  3480. ' TArr = array[TEnum] of byte;',
  3481. ' TArrRg = array[TEnumRg] of byte;',
  3482. 'var',
  3483. ' e: TEnum;',
  3484. ' a1: TArr = (3,4,5);',
  3485. ' a2: TArrRg = (11,12);',
  3486. ' b: byte;',
  3487. 'begin',
  3488. ' for e in TEnum do ;',
  3489. ' for e in TEnumRg do ;',
  3490. ' for e in TArr do ;',
  3491. ' for e in TArrRg do ;',
  3492. ' for b in a1 do ;',
  3493. ' for b in a2 do ;',
  3494. '']);
  3495. ConvertProgram;
  3496. CheckSource('TestEnum_ForIn',
  3497. LinesToStr([ // statements
  3498. 'this.TEnum = {',
  3499. ' "0": "Red",',
  3500. ' Red: 0,',
  3501. ' "1": "Green",',
  3502. ' Green: 1,',
  3503. ' "2": "Blue",',
  3504. ' Blue: 2',
  3505. '};',
  3506. 'this.e = 0;',
  3507. 'this.a1 = [3, 4, 5];',
  3508. 'this.a2 = [11, 12];',
  3509. 'this.b = 0;',
  3510. '']),
  3511. LinesToStr([
  3512. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  3513. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  3514. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  3515. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  3516. ' for (var $in1 = $mod.a1, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.b = $in1[$l2];',
  3517. ' for (var $in4 = $mod.a2, $l5 = 0, $end6 = rtl.length($in4) - 1; $l5 <= $end6; $l5++) $mod.b = $in4[$l5];',
  3518. '']));
  3519. end;
  3520. procedure TTestModule.TestEnum_ScopedNumber;
  3521. begin
  3522. Converter.Options:=Converter.Options+[coEnumNumbers];
  3523. StartProgram(false);
  3524. Add([
  3525. 'type',
  3526. ' TEnum = (Red, Green);',
  3527. 'var',
  3528. ' e: TEnum;',
  3529. 'begin',
  3530. ' e:=TEnum.Green;',
  3531. '']);
  3532. ConvertProgram;
  3533. CheckSource('TestEnum_ScopedNumber',
  3534. LinesToStr([ // statements
  3535. 'this.TEnum = {',
  3536. ' "0": "Red",',
  3537. ' Red: 0,',
  3538. ' "1": "Green",',
  3539. ' Green: 1',
  3540. '};',
  3541. 'this.e = 0;',
  3542. '']),
  3543. LinesToStr([
  3544. '$mod.e = 1;']));
  3545. end;
  3546. procedure TTestModule.TestSet;
  3547. begin
  3548. StartProgram(false);
  3549. Add([
  3550. 'type',
  3551. ' TColor = (Red, Green, Blue);',
  3552. ' TColors = set of TColor;',
  3553. 'var',
  3554. ' c: TColor;',
  3555. ' s: TColors;',
  3556. ' t: TColors = [];',
  3557. ' u: TColors = [Red];',
  3558. 'begin',
  3559. ' s:=[];',
  3560. ' s:=[Green];',
  3561. ' s:=[Green,Blue];',
  3562. ' s:=[Red..Blue];',
  3563. ' s:=[Red,Green..Blue];',
  3564. ' s:=[Red,c];',
  3565. ' s:=t;']);
  3566. ConvertProgram;
  3567. CheckSource('TestEnumName',
  3568. LinesToStr([ // statements
  3569. 'this.TColor = {',
  3570. ' "0":"Red",',
  3571. ' Red:0,',
  3572. ' "1":"Green",',
  3573. ' Green:1,',
  3574. ' "2":"Blue",',
  3575. ' Blue:2',
  3576. ' };',
  3577. 'this.c = 0;',
  3578. 'this.s = {};',
  3579. 'this.t = {};',
  3580. 'this.u = rtl.createSet($mod.TColor.Red);'
  3581. ]),
  3582. LinesToStr([
  3583. '$mod.s={};',
  3584. '$mod.s=rtl.createSet($mod.TColor.Green);',
  3585. '$mod.s=rtl.createSet($mod.TColor.Green,$mod.TColor.Blue);',
  3586. '$mod.s=rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);',
  3587. '$mod.s=rtl.createSet($mod.TColor.Red,null,$mod.TColor.Green,$mod.TColor.Blue);',
  3588. '$mod.s=rtl.createSet($mod.TColor.Red,$mod.c);',
  3589. '$mod.s=rtl.refSet($mod.t);',
  3590. '']));
  3591. end;
  3592. procedure TTestModule.TestSet_Operators;
  3593. begin
  3594. StartProgram(false);
  3595. Add('type');
  3596. Add(' TColor = (Red, Green, Blue);');
  3597. Add(' TColors = set of tcolor;');
  3598. Add('var');
  3599. Add(' vC: TColor;');
  3600. Add(' vS: TColors;');
  3601. Add(' vT: TColors;');
  3602. Add(' vU: TColors;');
  3603. Add(' B: boolean;');
  3604. Add('begin');
  3605. Add(' include(vs,green);');
  3606. Add(' exclude(vs,vc);');
  3607. Add(' vs:=vt+vu;');
  3608. Add(' vs:=vt+[red];');
  3609. Add(' vs:=[red]+vt;');
  3610. Add(' vs:=[red]+[green];');
  3611. Add(' vs:=vt-vu;');
  3612. Add(' vs:=vt-[red];');
  3613. Add(' vs:=[red]-vt;');
  3614. Add(' vs:=[red]-[green];');
  3615. Add(' vs:=vt*vu;');
  3616. Add(' vs:=vt*[red];');
  3617. Add(' vs:=[red]*vt;');
  3618. Add(' vs:=[red]*[green];');
  3619. Add(' vs:=vt><vu;');
  3620. Add(' vs:=vt><[red];');
  3621. Add(' vs:=[red]><vt;');
  3622. Add(' vs:=[red]><[green];');
  3623. Add(' b:=vt=vu;');
  3624. Add(' b:=vt=[red];');
  3625. Add(' b:=[red]=vt;');
  3626. Add(' b:=[red]=[green];');
  3627. Add(' b:=vt<>vu;');
  3628. Add(' b:=vt<>[red];');
  3629. Add(' b:=[red]<>vt;');
  3630. Add(' b:=[red]<>[green];');
  3631. Add(' b:=vt<=vu;');
  3632. Add(' b:=vt<=[red];');
  3633. Add(' b:=[red]<=vt;');
  3634. Add(' b:=[red]<=[green];');
  3635. Add(' b:=vt>=vu;');
  3636. Add(' b:=vt>=[red];');
  3637. Add(' b:=[red]>=vt;');
  3638. Add(' b:=[red]>=[green];');
  3639. ConvertProgram;
  3640. CheckSource('TestSet_Operators',
  3641. LinesToStr([ // statements
  3642. 'this.TColor = {',
  3643. ' "0":"Red",',
  3644. ' Red:0,',
  3645. ' "1":"Green",',
  3646. ' Green:1,',
  3647. ' "2":"Blue",',
  3648. ' Blue:2',
  3649. ' };',
  3650. 'this.vC = 0;',
  3651. 'this.vS = {};',
  3652. 'this.vT = {};',
  3653. 'this.vU = {};',
  3654. 'this.B = false;'
  3655. ]),
  3656. LinesToStr([
  3657. '$mod.vS = rtl.includeSet($mod.vS,$mod.TColor.Green);',
  3658. '$mod.vS = rtl.excludeSet($mod.vS,$mod.vC);',
  3659. '$mod.vS = rtl.unionSet($mod.vT, $mod.vU);',
  3660. '$mod.vS = rtl.unionSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3661. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3662. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3663. '$mod.vS = rtl.diffSet($mod.vT, $mod.vU);',
  3664. '$mod.vS = rtl.diffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3665. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3666. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3667. '$mod.vS = rtl.intersectSet($mod.vT, $mod.vU);',
  3668. '$mod.vS = rtl.intersectSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3669. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3670. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3671. '$mod.vS = rtl.symDiffSet($mod.vT, $mod.vU);',
  3672. '$mod.vS = rtl.symDiffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3673. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3674. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3675. '$mod.B = rtl.eqSet($mod.vT, $mod.vU);',
  3676. '$mod.B = rtl.eqSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3677. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3678. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3679. '$mod.B = rtl.neSet($mod.vT, $mod.vU);',
  3680. '$mod.B = rtl.neSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3681. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3682. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3683. '$mod.B = rtl.leSet($mod.vT, $mod.vU);',
  3684. '$mod.B = rtl.leSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3685. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3686. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3687. '$mod.B = rtl.geSet($mod.vT, $mod.vU);',
  3688. '$mod.B = rtl.geSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3689. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3690. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3691. '']));
  3692. end;
  3693. procedure TTestModule.TestSet_Operator_In;
  3694. begin
  3695. StartProgram(false);
  3696. Add('type');
  3697. Add(' TColor = (Red, Green, Blue);');
  3698. Add(' TColors = set of tcolor;');
  3699. Add('var');
  3700. Add(' vC: tcolor;');
  3701. Add(' vT: tcolors;');
  3702. Add(' B: boolean;');
  3703. Add('begin');
  3704. Add(' b:=red in vt;');
  3705. Add(' b:=vc in vt;');
  3706. Add(' b:=green in [red..blue];');
  3707. Add(' b:=vc in [red..blue];');
  3708. Add(' ');
  3709. Add(' if red in vt then ;');
  3710. Add(' while vC in vt do ;');
  3711. Add(' repeat');
  3712. Add(' until vC in vt;');
  3713. ConvertProgram;
  3714. CheckSource('TestSet_Operator_In',
  3715. LinesToStr([ // statements
  3716. 'this.TColor = {',
  3717. ' "0":"Red",',
  3718. ' Red:0,',
  3719. ' "1":"Green",',
  3720. ' Green:1,',
  3721. ' "2":"Blue",',
  3722. ' Blue:2',
  3723. ' };',
  3724. 'this.vC = 0;',
  3725. 'this.vT = {};',
  3726. 'this.B = false;'
  3727. ]),
  3728. LinesToStr([
  3729. '$mod.B = $mod.TColor.Red in $mod.vT;',
  3730. '$mod.B = $mod.vC in $mod.vT;',
  3731. '$mod.B = $mod.TColor.Green in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  3732. '$mod.B = $mod.vC in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  3733. 'if ($mod.TColor.Red in $mod.vT) ;',
  3734. 'while ($mod.vC in $mod.vT) {',
  3735. '};',
  3736. 'do {',
  3737. '} while (!($mod.vC in $mod.vT));',
  3738. '']));
  3739. end;
  3740. procedure TTestModule.TestSet_Functions;
  3741. begin
  3742. StartProgram(false);
  3743. Add('type');
  3744. Add(' TMyEnum = (Red, Green);');
  3745. Add(' TMyEnums = set of TMyEnum;');
  3746. Add('var');
  3747. Add(' e: TMyEnum;');
  3748. Add(' s: TMyEnums;');
  3749. Add('begin');
  3750. Add(' e:=Low(TMyEnums);');
  3751. Add(' e:=Low(s);');
  3752. Add(' e:=High(TMyEnums);');
  3753. Add(' e:=High(s);');
  3754. ConvertProgram;
  3755. CheckSource('TestSetFunctions',
  3756. LinesToStr([ // statements
  3757. 'this.TMyEnum = {',
  3758. ' "0":"Red",',
  3759. ' Red:0,',
  3760. ' "1":"Green",',
  3761. ' Green:1',
  3762. ' };',
  3763. 'this.e = 0;',
  3764. 'this.s = {};'
  3765. ]),
  3766. LinesToStr([
  3767. '$mod.e=$mod.TMyEnum.Red;',
  3768. '$mod.e=$mod.TMyEnum.Red;',
  3769. '$mod.e=$mod.TMyEnum.Green;',
  3770. '$mod.e=$mod.TMyEnum.Green;',
  3771. '']));
  3772. end;
  3773. procedure TTestModule.TestSet_PassAsArgClone;
  3774. begin
  3775. StartProgram(false);
  3776. Add('type');
  3777. Add(' TMyEnum = (Red, Green);');
  3778. Add(' TMyEnums = set of TMyEnum;');
  3779. Add('procedure DoDefault(s: tmyenums); begin end;');
  3780. Add('procedure DoConst(const s: tmyenums); begin end;');
  3781. Add('var');
  3782. Add(' aSet: tmyenums;');
  3783. Add('begin');
  3784. Add(' dodefault(aset);');
  3785. Add(' doconst(aset);');
  3786. ConvertProgram;
  3787. CheckSource('TestSetFunctions',
  3788. LinesToStr([ // statements
  3789. 'this.TMyEnum = {',
  3790. ' "0":"Red",',
  3791. ' Red:0,',
  3792. ' "1":"Green",',
  3793. ' Green:1',
  3794. ' };',
  3795. 'this.DoDefault = function (s) {',
  3796. '};',
  3797. 'this.DoConst = function (s) {',
  3798. '};',
  3799. 'this.aSet = {};'
  3800. ]),
  3801. LinesToStr([
  3802. '$mod.DoDefault(rtl.refSet($mod.aSet));',
  3803. '$mod.DoConst($mod.aSet);',
  3804. '']));
  3805. end;
  3806. procedure TTestModule.TestSet_AsParams;
  3807. begin
  3808. StartProgram(false);
  3809. Add('type TEnum = (Red,Blue);');
  3810. Add('type TEnums = set of TEnum;');
  3811. Add('procedure DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums);');
  3812. Add('var vJ: TEnums;');
  3813. Add('begin');
  3814. Add(' vg:=vg;');
  3815. Add(' vj:=vh;');
  3816. Add(' vi:=vi;');
  3817. Add(' doit(vg,vg,vg);');
  3818. Add(' doit(vh,vh,vj);');
  3819. Add(' doit(vi,vi,vi);');
  3820. Add(' doit(vj,vj,vj);');
  3821. Add('end;');
  3822. Add('var i: TEnums;');
  3823. Add('begin');
  3824. Add(' doit(i,i,i);');
  3825. ConvertProgram;
  3826. CheckSource('TestSet_AsParams',
  3827. LinesToStr([ // statements
  3828. 'this.TEnum = {',
  3829. ' "0": "Red",',
  3830. ' Red: 0,',
  3831. ' "1": "Blue",',
  3832. ' Blue: 1',
  3833. '};',
  3834. 'this.DoIt = function (vG,vH,vI) {',
  3835. ' var vJ = {};',
  3836. ' vG = rtl.refSet(vG);',
  3837. ' vJ = rtl.refSet(vH);',
  3838. ' vI.set(rtl.refSet(vI.get()));',
  3839. ' $mod.DoIt(rtl.refSet(vG), vG, {',
  3840. ' get: function () {',
  3841. ' return vG;',
  3842. ' },',
  3843. ' set: function (v) {',
  3844. ' vG = v;',
  3845. ' }',
  3846. ' });',
  3847. ' $mod.DoIt(rtl.refSet(vH), vH, {',
  3848. ' get: function () {',
  3849. ' return vJ;',
  3850. ' },',
  3851. ' set: function (v) {',
  3852. ' vJ = v;',
  3853. ' }',
  3854. ' });',
  3855. ' $mod.DoIt(rtl.refSet(vI.get()), vI.get(), vI);',
  3856. ' $mod.DoIt(rtl.refSet(vJ), vJ, {',
  3857. ' get: function () {',
  3858. ' return vJ;',
  3859. ' },',
  3860. ' set: function (v) {',
  3861. ' vJ = v;',
  3862. ' }',
  3863. ' });',
  3864. '};',
  3865. 'this.i = {};'
  3866. ]),
  3867. LinesToStr([
  3868. '$mod.DoIt(rtl.refSet($mod.i),$mod.i,{',
  3869. ' p: $mod,',
  3870. ' get: function () {',
  3871. ' return this.p.i;',
  3872. ' },',
  3873. ' set: function (v) {',
  3874. ' this.p.i = v;',
  3875. ' }',
  3876. '});'
  3877. ]));
  3878. end;
  3879. procedure TTestModule.TestSet_Property;
  3880. begin
  3881. StartProgram(false);
  3882. Add('type');
  3883. Add(' TEnum = (Red,Blue);');
  3884. Add(' TEnums = set of TEnum;');
  3885. Add(' TObject = class');
  3886. Add(' function GetColors: TEnums; external name ''GetColors'';');
  3887. Add(' procedure SetColors(const Value: TEnums); external name ''SetColors'';');
  3888. Add(' property Colors: TEnums read GetColors write SetColors;');
  3889. Add(' end;');
  3890. Add('procedure DoIt(i: TEnums; const j: TEnums; var k: TEnums; out l: TEnums);');
  3891. Add('begin end;');
  3892. Add('var Obj: TObject;');
  3893. Add('begin');
  3894. Add(' Include(Obj.Colors,Red);');
  3895. Add(' Exclude(Obj.Colors,Red);');
  3896. //Add(' DoIt(Obj.Colors,Obj.Colors,Obj.Colors,Obj.Colors);');
  3897. ConvertProgram;
  3898. CheckSource('TestSet_Property',
  3899. LinesToStr([ // statements
  3900. 'this.TEnum = {',
  3901. ' "0": "Red",',
  3902. ' Red: 0,',
  3903. ' "1": "Blue",',
  3904. ' Blue: 1',
  3905. '};',
  3906. 'rtl.createClass($mod, "TObject", null, function () {',
  3907. ' this.$init = function () {',
  3908. ' };',
  3909. ' this.$final = function () {',
  3910. ' };',
  3911. '});',
  3912. 'this.DoIt = function (i, j, k, l) {',
  3913. '};',
  3914. 'this.Obj = null;',
  3915. '']),
  3916. LinesToStr([
  3917. '$mod.Obj.SetColors(rtl.includeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  3918. '$mod.Obj.SetColors(rtl.excludeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  3919. '']));
  3920. end;
  3921. procedure TTestModule.TestSet_EnumConst;
  3922. begin
  3923. StartProgram(false);
  3924. Add('type');
  3925. Add(' TEnum = (Red,Blue);');
  3926. Add(' TEnums = set of TEnum;');
  3927. Add('const');
  3928. Add(' Orange = red;');
  3929. Add('var');
  3930. Add(' Enum: tenum;');
  3931. Add(' Enums: tenums;');
  3932. Add('begin');
  3933. Add(' Include(enums,orange);');
  3934. Add(' Exclude(enums,orange);');
  3935. Add(' if orange in enums then;');
  3936. Add(' if orange in [orange,red] then;');
  3937. ConvertProgram;
  3938. CheckSource('TestEnumConst',
  3939. LinesToStr([ // statements
  3940. 'this.TEnum = {',
  3941. ' "0": "Red",',
  3942. ' Red: 0,',
  3943. ' "1": "Blue",',
  3944. ' Blue: 1',
  3945. '};',
  3946. 'this.Orange = $mod.TEnum.Red;',
  3947. 'this.Enum = 0;',
  3948. 'this.Enums = {};',
  3949. '']),
  3950. LinesToStr([
  3951. '$mod.Enums = rtl.includeSet($mod.Enums, $mod.TEnum.Red);',
  3952. '$mod.Enums = rtl.excludeSet($mod.Enums, $mod.TEnum.Red);',
  3953. 'if ($mod.TEnum.Red in $mod.Enums) ;',
  3954. 'if ($mod.TEnum.Red in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Red)) ;',
  3955. '']));
  3956. end;
  3957. procedure TTestModule.TestSet_AnonymousEnumType;
  3958. begin
  3959. StartProgram(false);
  3960. Add('type');
  3961. Add(' TFlags = set of (red, green);');
  3962. Add('const');
  3963. Add(' favorite = red;');
  3964. Add('var');
  3965. Add(' f: TFlags;');
  3966. Add(' i: longint;');
  3967. Add('begin');
  3968. Add(' Include(f,red);');
  3969. Add(' Include(f,favorite);');
  3970. Add(' i:=ord(red);');
  3971. Add(' i:=ord(favorite);');
  3972. Add(' i:=ord(low(TFlags));');
  3973. Add(' i:=ord(low(f));');
  3974. Add(' i:=ord(low(favorite));');
  3975. Add(' i:=ord(high(TFlags));');
  3976. Add(' i:=ord(high(f));');
  3977. Add(' i:=ord(high(favorite));');
  3978. Add(' f:=[green,favorite];');
  3979. ConvertProgram;
  3980. CheckSource('TestSet_AnonymousEnumType',
  3981. LinesToStr([ // statements
  3982. 'this.TFlags$a = {',
  3983. ' "0": "red",',
  3984. ' red: 0,',
  3985. ' "1": "green",',
  3986. ' green: 1',
  3987. '};',
  3988. 'this.favorite = $mod.TFlags$a.red;',
  3989. 'this.f = {};',
  3990. 'this.i = 0;',
  3991. '']),
  3992. LinesToStr([
  3993. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  3994. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  3995. '$mod.i = $mod.TFlags$a.red;',
  3996. '$mod.i = $mod.TFlags$a.red;',
  3997. '$mod.i = $mod.TFlags$a.red;',
  3998. '$mod.i = $mod.TFlags$a.red;',
  3999. '$mod.i = $mod.TFlags$a.red;',
  4000. '$mod.i = $mod.TFlags$a.green;',
  4001. '$mod.i = $mod.TFlags$a.green;',
  4002. '$mod.i = $mod.TFlags$a.green;',
  4003. '$mod.f = rtl.createSet($mod.TFlags$a.green, $mod.TFlags$a.red);',
  4004. '']));
  4005. end;
  4006. procedure TTestModule.TestSet_ConstEnum;
  4007. begin
  4008. StartProgram(false);
  4009. Add([
  4010. 'type',
  4011. ' TEnum = (red,blue,green);',
  4012. ' TEnums = set of TEnum;',
  4013. 'const',
  4014. ' teAny = [low(TEnum)..high(TEnum)];',
  4015. ' teRedBlue = [low(TEnum)..pred(high(TEnum))];',
  4016. 'var',
  4017. ' e: TEnum;',
  4018. ' s: TEnums;',
  4019. 'begin',
  4020. ' if blue in teAny then;',
  4021. ' if blue in teAny+[e] then;',
  4022. ' if blue in teAny+teRedBlue then;',
  4023. ' if e in [red,blue] then;',
  4024. ' s:=teAny;',
  4025. ' s:=teAny+[e];',
  4026. ' s:=[e]+teAny;',
  4027. ' s:=teAny+teRedBlue;',
  4028. ' s:=teAny+teRedBlue+[e];',
  4029. '']);
  4030. ConvertProgram;
  4031. CheckSource('TestSet_ConstEnum',
  4032. LinesToStr([ // statements
  4033. 'this.TEnum = {',
  4034. ' "0": "red",',
  4035. ' red: 0,',
  4036. ' "1": "blue",',
  4037. ' blue: 1,',
  4038. ' "2": "green",',
  4039. ' green: 2',
  4040. '};',
  4041. 'this.teAny = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green);',
  4042. 'this.teRedBlue = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green - 1);',
  4043. 'this.e = 0;',
  4044. 'this.s = {};',
  4045. '']),
  4046. LinesToStr([
  4047. 'if ($mod.TEnum.blue in $mod.teAny) ;',
  4048. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, rtl.createSet($mod.e))) ;',
  4049. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, $mod.teRedBlue)) ;',
  4050. 'if ($mod.e in rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)) ;',
  4051. '$mod.s = rtl.refSet($mod.teAny);',
  4052. '$mod.s = rtl.unionSet($mod.teAny, rtl.createSet($mod.e));',
  4053. '$mod.s = rtl.unionSet(rtl.createSet($mod.e), $mod.teAny);',
  4054. '$mod.s = rtl.unionSet($mod.teAny, $mod.teRedBlue);',
  4055. '$mod.s = rtl.unionSet(rtl.unionSet($mod.teAny, $mod.teRedBlue), rtl.createSet($mod.e));',
  4056. '']));
  4057. end;
  4058. procedure TTestModule.TestSet_ConstChar;
  4059. begin
  4060. StartProgram(false);
  4061. Add([
  4062. 'const',
  4063. ' LowChars = [''a''..''z''];',
  4064. ' Chars = LowChars+[''A''..''Z''];',
  4065. 'var',
  4066. ' c: char;',
  4067. ' s: string;',
  4068. 'begin',
  4069. ' if c in lowchars then ;',
  4070. ' if ''a'' in lowchars then ;',
  4071. ' if s[1] in lowchars then ;',
  4072. ' if c in chars then ;',
  4073. ' if c in [''a''..''z'',''_''] then ;',
  4074. ' if ''b'' in [''a''..''z'',''_''] then ;',
  4075. '']);
  4076. ConvertProgram;
  4077. CheckSource('TestSet_ConstChar',
  4078. LinesToStr([ // statements
  4079. 'this.LowChars = rtl.createSet(null, 97, 122);',
  4080. 'this.Chars = rtl.unionSet($mod.LowChars, rtl.createSet(null, 65, 90));',
  4081. 'this.c = "";',
  4082. 'this.s = "";',
  4083. '']),
  4084. LinesToStr([
  4085. 'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
  4086. 'if (97 in $mod.LowChars) ;',
  4087. 'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
  4088. 'if ($mod.c.charCodeAt() in $mod.Chars) ;',
  4089. 'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
  4090. 'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
  4091. '']));
  4092. end;
  4093. procedure TTestModule.TestSet_ConstInt;
  4094. begin
  4095. StartProgram(false);
  4096. Add([
  4097. 'const',
  4098. ' Months = [1..12];',
  4099. ' Mirror = [-12..-1]+Months;',
  4100. 'var',
  4101. ' i: smallint;',
  4102. 'begin',
  4103. ' if 3 in Months then;',
  4104. ' if i in Months+[i] then;',
  4105. ' if i in Months+Mirror then;',
  4106. ' if i in [4..6,8] then;',
  4107. '']);
  4108. ConvertProgram;
  4109. CheckSource('TestSet_ConstInt',
  4110. LinesToStr([ // statements
  4111. 'this.Months = rtl.createSet(null, 1, 12);',
  4112. 'this.Mirror = rtl.unionSet(rtl.createSet(null, -12, -1), $mod.Months);',
  4113. 'this.i = 0;',
  4114. '']),
  4115. LinesToStr([
  4116. 'if (3 in $mod.Months) ;',
  4117. 'if ($mod.i in rtl.unionSet($mod.Months, rtl.createSet($mod.i))) ;',
  4118. 'if ($mod.i in rtl.unionSet($mod.Months, $mod.Mirror)) ;',
  4119. 'if ($mod.i in rtl.createSet(null, 4, 6, 8)) ;',
  4120. '']));
  4121. end;
  4122. procedure TTestModule.TestSet_ForIn;
  4123. begin
  4124. StartProgram(false);
  4125. Add([
  4126. 'type',
  4127. ' TEnum = (Red, Green, Blue);',
  4128. ' TEnumRg = green..blue;',
  4129. ' TSetOfEnum = set of TEnum;',
  4130. ' TSetOfEnumRg = set of TEnumRg;',
  4131. 'var',
  4132. ' e, e2: TEnum;',
  4133. ' er: TEnum;',
  4134. ' s: TSetOfEnum;',
  4135. 'begin',
  4136. ' for e in TSetOfEnum do ;',
  4137. ' for e in TSetOfEnumRg do ;',
  4138. ' for e in [] do e2:=e;',
  4139. ' for e in [red..green] do e2:=e;',
  4140. ' for e in [green,blue] do e2:=e;',
  4141. ' for e in [red,blue] do e2:=e;',
  4142. ' for e in s do e2:=e;',
  4143. ' for er in TSetOfEnumRg do ;',
  4144. '']);
  4145. ConvertProgram;
  4146. CheckSource('TestEnumName',
  4147. LinesToStr([ // statements
  4148. 'this.TEnum = {',
  4149. ' "0":"Red",',
  4150. ' Red:0,',
  4151. ' "1":"Green",',
  4152. ' Green:1,',
  4153. ' "2":"Blue",',
  4154. ' Blue:2',
  4155. ' };',
  4156. 'this.e = 0;',
  4157. 'this.e2 = 0;',
  4158. 'this.er = 0;',
  4159. 'this.s = {};',
  4160. '']),
  4161. LinesToStr([
  4162. 'for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  4163. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  4164. 'for ($mod.e = 0; $mod.e <= 1; $mod.e++) $mod.e2 = $mod.e;',
  4165. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) $mod.e2 = $mod.e;',
  4166. 'for ($mod.e in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Blue)) $mod.e2 = $mod.e;',
  4167. 'for ($mod.e in $mod.s) $mod.e2 = $mod.e;',
  4168. 'for ($mod.er = 1; $mod.er <= 2; $mod.er++) ;',
  4169. '']));
  4170. end;
  4171. procedure TTestModule.TestNestBegin;
  4172. begin
  4173. StartProgram(false);
  4174. Add('begin');
  4175. Add(' begin');
  4176. Add(' begin');
  4177. Add(' end;');
  4178. Add(' begin');
  4179. Add(' if true then ;');
  4180. Add(' end;');
  4181. Add(' end;');
  4182. ConvertProgram;
  4183. CheckSource('TestNestBegin',
  4184. '',
  4185. 'if (true) ;');
  4186. end;
  4187. procedure TTestModule.TestUnitImplVars;
  4188. begin
  4189. StartUnit(false);
  4190. Add('interface');
  4191. Add('implementation');
  4192. Add('var');
  4193. Add(' V1:longint;');
  4194. Add(' V2:longint = 3;');
  4195. Add(' V3:string = ''abc'';');
  4196. ConvertUnit;
  4197. CheckSource('TestUnitImplVars',
  4198. LinesToStr([ // statements
  4199. 'var $impl = $mod.$impl;',
  4200. '']),
  4201. '', // this.$init
  4202. LinesToStr([ // implementation
  4203. '$impl.V1 = 0;',
  4204. '$impl.V2 = 3;',
  4205. '$impl.V3 = "abc";',
  4206. '']) );
  4207. end;
  4208. procedure TTestModule.TestUnitImplConsts;
  4209. begin
  4210. StartUnit(false);
  4211. Add('interface');
  4212. Add('implementation');
  4213. Add('const');
  4214. Add(' v1 = 3;');
  4215. Add(' v2:longint = 4;');
  4216. Add(' v3:string = ''abc'';');
  4217. ConvertUnit;
  4218. CheckSource('TestUnitImplConsts',
  4219. LinesToStr([ // statements
  4220. 'var $impl = $mod.$impl;',
  4221. '']),
  4222. '', // this.$init
  4223. LinesToStr([ // implementation
  4224. '$impl.v1 = 3;',
  4225. '$impl.v2 = 4;',
  4226. '$impl.v3 = "abc";',
  4227. '']) );
  4228. end;
  4229. procedure TTestModule.TestUnitImplRecord;
  4230. begin
  4231. StartUnit(false);
  4232. Add('interface');
  4233. Add('implementation');
  4234. Add('type');
  4235. Add(' TMyRecord = record');
  4236. Add(' i: longint;');
  4237. Add(' end;');
  4238. Add('var aRec: TMyRecord;');
  4239. Add('initialization');
  4240. Add(' arec.i:=3;');
  4241. ConvertUnit;
  4242. CheckSource('TestUnitImplRecord',
  4243. LinesToStr([ // statements
  4244. 'var $impl = $mod.$impl;',
  4245. '']),
  4246. // this.$init
  4247. '$impl.aRec.i = 3;',
  4248. LinesToStr([ // implementation
  4249. '$impl.TMyRecord = function (s) {',
  4250. ' if (s) {',
  4251. ' this.i = s.i;',
  4252. ' } else {',
  4253. ' this.i = 0;',
  4254. ' };',
  4255. ' this.$equal = function (b) {',
  4256. ' return this.i === b.i;',
  4257. ' };',
  4258. '};',
  4259. '$impl.aRec = new $impl.TMyRecord();',
  4260. '']) );
  4261. end;
  4262. procedure TTestModule.TestRenameJSNameConflict;
  4263. begin
  4264. StartProgram(false);
  4265. Add('var apply: longint;');
  4266. Add('var bind: longint;');
  4267. Add('var call: longint;');
  4268. Add('begin');
  4269. ConvertProgram;
  4270. CheckSource('TestRenameJSNameConflict',
  4271. LinesToStr([ // statements
  4272. 'this.Apply = 0;',
  4273. 'this.Bind = 0;',
  4274. 'this.Call = 0;'
  4275. ]),
  4276. LinesToStr([ // this.$main
  4277. ''
  4278. ]));
  4279. end;
  4280. procedure TTestModule.TestLocalConst;
  4281. begin
  4282. StartProgram(false);
  4283. Add('procedure DoIt;');
  4284. Add('const');
  4285. Add(' cA: longint = 1;');
  4286. Add(' cB = 2;');
  4287. Add(' procedure Sub;');
  4288. Add(' const');
  4289. Add(' csA = 3;');
  4290. Add(' cB: double = 4;');
  4291. Add(' begin');
  4292. Add(' cb:=cb+csa;');
  4293. Add(' ca:=ca+csa+5;');
  4294. Add(' end;');
  4295. Add('begin');
  4296. Add(' ca:=ca+cb+6;');
  4297. Add('end;');
  4298. Add('begin');
  4299. ConvertProgram;
  4300. CheckSource('TestLocalConst',
  4301. LinesToStr([
  4302. 'var cA = 1;',
  4303. 'var cB = 2;',
  4304. 'var csA = 3;',
  4305. 'var cB$1 = 4;',
  4306. 'this.DoIt = function () {',
  4307. ' function Sub() {',
  4308. ' cB$1 = cB$1 + 3;',
  4309. ' cA = (cA + 3) + 5;',
  4310. ' };',
  4311. ' cA = (cA + 2) + 6;',
  4312. '};'
  4313. ]),
  4314. LinesToStr([
  4315. ]));
  4316. end;
  4317. procedure TTestModule.TestVarExternal;
  4318. begin
  4319. StartProgram(false);
  4320. Add('var');
  4321. Add(' NaN: double; external name ''Global.NaN'';');
  4322. Add(' d: double;');
  4323. Add('begin');
  4324. Add(' d:=NaN;');
  4325. ConvertProgram;
  4326. CheckSource('TestVarExternal',
  4327. LinesToStr([
  4328. 'this.d = 0.0;'
  4329. ]),
  4330. LinesToStr([
  4331. '$mod.d = Global.NaN;'
  4332. ]));
  4333. end;
  4334. procedure TTestModule.TestVarExternalOtherUnit;
  4335. begin
  4336. AddModuleWithIntfImplSrc('unit2.pas',
  4337. LinesToStr([
  4338. 'var NaN: double; external name ''Global.NaN'';',
  4339. 'var iV: longint;'
  4340. ]),
  4341. '');
  4342. StartUnit(true);
  4343. Add('interface');
  4344. Add('uses unit2;');
  4345. Add('implementation');
  4346. Add('var');
  4347. Add(' d: double;');
  4348. Add(' i: longint; external name ''$i'';');
  4349. Add('begin');
  4350. Add(' d:=nan;');
  4351. Add(' d:=uNit2.nan;');
  4352. Add(' d:=test1.d;');
  4353. Add(' i:=iv;');
  4354. Add(' i:=uNit2.iv;');
  4355. Add(' i:=test1.i;');
  4356. ConvertUnit;
  4357. CheckSource('TestVarExternalOtherUnit',
  4358. LinesToStr([
  4359. 'var $impl = $mod.$impl;',
  4360. '']),
  4361. LinesToStr([ // this.$init
  4362. '$impl.d = Global.NaN;',
  4363. '$impl.d = Global.NaN;',
  4364. '$impl.d = $impl.d;',
  4365. '$i = pas.unit2.iV;',
  4366. '$i = pas.unit2.iV;',
  4367. '$i = $i;',
  4368. '']),
  4369. LinesToStr([ // implementation
  4370. '$impl.d = 0.0;',
  4371. '']) );
  4372. end;
  4373. procedure TTestModule.TestVarAbsoluteFail;
  4374. begin
  4375. StartProgram(false);
  4376. Add([
  4377. 'var',
  4378. ' a: longint;',
  4379. ' b: longword absolute a;',
  4380. 'begin']);
  4381. SetExpectedPasResolverError('Invalid variable modifier "absolute"',nInvalidVariableModifier);
  4382. ConvertProgram;
  4383. end;
  4384. procedure TTestModule.TestDouble;
  4385. begin
  4386. StartProgram(false);
  4387. Add([
  4388. 'type',
  4389. ' TDateTime = double;',
  4390. 'const',
  4391. ' a = TDateTime(2.7);',
  4392. ' b = a + TDateTime(1.7);',
  4393. ' c = 0.9 + 0.1;',
  4394. ' f0_1 = 0.1;',
  4395. ' f0_3 = 0.3;',
  4396. ' fn0_1 = -0.1;',
  4397. ' fn0_3 = -0.3;',
  4398. ' fn0_003 = -0.003;',
  4399. ' fn0_123456789 = -0.123456789;',
  4400. ' fn300_0 = -300.0;',
  4401. ' fn123456_0 = -123456.0;',
  4402. ' fn1234567_8 = -1234567.8;',
  4403. ' fn12345678_9 = -12345678.9;',
  4404. ' f1_0En12 = 1E-12;',
  4405. ' fn1_0En12 = -1E-12;',
  4406. ' maxdouble = 1.7e+308;',
  4407. ' mindouble = -1.7e+308;',
  4408. ' MinSafeIntDouble = -$10000000000000;',
  4409. ' MaxSafeIntDouble = $fffffffffffff;',
  4410. 'var',
  4411. ' d: double = b;',
  4412. 'begin',
  4413. ' d:=1.0;',
  4414. ' d:=1.0/3.0;',
  4415. ' d:=1/3;',
  4416. ' d:=5.0E-324;',
  4417. ' d:=1.7E308;',
  4418. ' d:=10**3;',
  4419. ' d:=10 mod 3;',
  4420. ' d:=10 div 3;',
  4421. ' d:=c;',
  4422. ' d:=f0_1;',
  4423. ' d:=f0_3;',
  4424. ' d:=fn0_1;',
  4425. ' d:=fn0_3;',
  4426. ' d:=fn0_003;',
  4427. ' d:=fn0_123456789;',
  4428. ' d:=fn300_0;',
  4429. ' d:=fn123456_0;',
  4430. ' d:=fn1234567_8;',
  4431. ' d:=fn12345678_9;',
  4432. ' d:=f1_0En12;',
  4433. ' d:=fn1_0En12;',
  4434. ' d:=maxdouble;',
  4435. ' d:=mindouble;',
  4436. ' d:=MinSafeIntDouble;',
  4437. ' d:=MaxSafeIntDouble;',
  4438. '']);
  4439. ConvertProgram;
  4440. CheckSource('TestDouble',
  4441. LinesToStr([
  4442. 'this.a = 2.7;',
  4443. 'this.b = 2.7 + 1.7;',
  4444. 'this.c = 0.9 + 0.1;',
  4445. 'this.f0_1 = 0.1;',
  4446. 'this.f0_3 = 0.3;',
  4447. 'this.fn0_1 = -0.1;',
  4448. 'this.fn0_3 = -0.3;',
  4449. 'this.fn0_003 = -0.003;',
  4450. 'this.fn0_123456789 = -0.123456789;',
  4451. 'this.fn300_0 = -300.0;',
  4452. 'this.fn123456_0 = -123456.0;',
  4453. 'this.fn1234567_8 = -1234567.8;',
  4454. 'this.fn12345678_9 = -12345678.9;',
  4455. 'this.f1_0En12 = 1E-12;',
  4456. 'this.fn1_0En12 = -1E-12;',
  4457. 'this.maxdouble = 1.7e+308;',
  4458. 'this.mindouble = -1.7e+308;',
  4459. 'this.MinSafeIntDouble = -0x10000000000000;',
  4460. 'this.MaxSafeIntDouble = 0xfffffffffffff;',
  4461. 'this.d = 4.4;'
  4462. ]),
  4463. LinesToStr([
  4464. '$mod.d = 1.0;',
  4465. '$mod.d = 1.0 / 3.0;',
  4466. '$mod.d = 1 / 3;',
  4467. '$mod.d = 5.0E-324;',
  4468. '$mod.d = 1.7E308;',
  4469. '$mod.d = Math.pow(10, 3);',
  4470. '$mod.d = 10 % 3;',
  4471. '$mod.d = Math.floor(10 / 3);',
  4472. '$mod.d = 1;',
  4473. '$mod.d = 0.1;',
  4474. '$mod.d = 0.3;',
  4475. '$mod.d = -0.1;',
  4476. '$mod.d = -0.3;',
  4477. '$mod.d = -0.003;',
  4478. '$mod.d = -0.123456789;',
  4479. '$mod.d = -300;',
  4480. '$mod.d = -123456;',
  4481. '$mod.d = -1234567.8;',
  4482. '$mod.d = -1.23456789E7;',
  4483. '$mod.d = 1E-12;',
  4484. '$mod.d = -1E-12;',
  4485. '$mod.d = 1.7E308;',
  4486. '$mod.d = -1.7E308;',
  4487. '$mod.d = -4503599627370496;',
  4488. '$mod.d = 4503599627370495;',
  4489. '']));
  4490. end;
  4491. procedure TTestModule.TestInteger;
  4492. begin
  4493. StartProgram(false);
  4494. Add([
  4495. 'const',
  4496. ' MinInt = low(NativeInt);',
  4497. ' MaxInt = high(NativeInt);',
  4498. 'type',
  4499. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  4500. 'const',
  4501. ' a = low(TMyInt)+High(TMyInt);',
  4502. 'var',
  4503. ' i: TMyInt;',
  4504. 'begin',
  4505. ' i:=-MinInt;']);
  4506. ConvertProgram;
  4507. CheckSource('TestIntegerRange',
  4508. LinesToStr([
  4509. 'this.MinInt = -4503599627370496;',
  4510. 'this.MaxInt = 4503599627370495;',
  4511. 'this.a = -4503599627370496 + 4503599627370495;',
  4512. 'this.i = -4503599627370496;',
  4513. '']),
  4514. LinesToStr([
  4515. '$mod.i = - -4503599627370496;',
  4516. '']));
  4517. end;
  4518. procedure TTestModule.TestIntegerRange;
  4519. begin
  4520. StartProgram(false);
  4521. Add([
  4522. 'const',
  4523. ' MinInt = -1;',
  4524. ' MaxInt = +1;',
  4525. 'type',
  4526. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  4527. ' TInt2 = 1..3;',
  4528. 'const',
  4529. ' a = low(TMyInt)+High(TMyInt);',
  4530. ' b = low(TInt2)+High(TInt2);',
  4531. ' s1 = [1];',
  4532. ' s2 = [1,2];',
  4533. ' s3 = [1..3];',
  4534. ' s4 = [low(shortint)..high(shortint)];',
  4535. ' s5 = [succ(low(shortint))..pred(high(shortint))];',
  4536. ' s6 = 1 in s2;',
  4537. 'var',
  4538. ' i: TMyInt;',
  4539. ' i2: TInt2;',
  4540. 'begin',
  4541. ' i:=i2;',
  4542. ' if i=i2 then ;']);
  4543. ConvertProgram;
  4544. CheckSource('TestIntegerRange',
  4545. LinesToStr([
  4546. 'this.MinInt = -1;',
  4547. 'this.MaxInt = +1;',
  4548. 'this.a = -1 + 1;',
  4549. 'this.b = 1 + 3;',
  4550. 'this.s1 = rtl.createSet(1);',
  4551. 'this.s2 = rtl.createSet(1, 2);',
  4552. 'this.s3 = rtl.createSet(null, 1, 3);',
  4553. 'this.s4 = rtl.createSet(null, -128, 127);',
  4554. 'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
  4555. 'this.s6 = 1 in $mod.s2;',
  4556. 'this.i = -1;',
  4557. 'this.i2 = 1;',
  4558. '']),
  4559. LinesToStr([
  4560. '$mod.i = $mod.i2;',
  4561. 'if ($mod.i === $mod.i2) ;',
  4562. '']));
  4563. end;
  4564. procedure TTestModule.TestForBoolDo;
  4565. begin
  4566. StartProgram(false);
  4567. Add([
  4568. 'var b: boolean;',
  4569. 'begin',
  4570. ' for b:=false to true do ;',
  4571. ' for b:=b downto false do ;',
  4572. ' for b in boolean do ;',
  4573. '']);
  4574. ConvertProgram;
  4575. CheckSource('TestForBoolDo',
  4576. LinesToStr([ // statements
  4577. 'this.b = false;']),
  4578. LinesToStr([ // this.$main
  4579. 'for (var $l1 = 0; $l1 <= 1; $l1++) $mod.b = $l1 !== 0;',
  4580. 'for (var $l2 = +$mod.b; $l2 >= 0; $l2--) $mod.b = $l2 !== 0;',
  4581. 'for (var $l3 = 0; $l3 <= 1; $l3++) $mod.b = $l3 !== 0;',
  4582. '']));
  4583. end;
  4584. procedure TTestModule.TestForIntDo;
  4585. begin
  4586. StartProgram(false);
  4587. Add([
  4588. 'var i: longint;',
  4589. 'begin',
  4590. ' for i:=3 to 5 do ;',
  4591. ' for i:=i downto 2 do ;',
  4592. ' for i in byte do ;',
  4593. '']);
  4594. ConvertProgram;
  4595. CheckSource('TestForIntDo',
  4596. LinesToStr([ // statements
  4597. 'this.i = 0;']),
  4598. LinesToStr([ // this.$main
  4599. 'for ($mod.i = 3; $mod.i <= 5; $mod.i++) ;',
  4600. 'for (var $l1 = $mod.i; $l1 >= 2; $l1--) $mod.i = $l1;',
  4601. 'for (var $l2 = 0; $l2 <= 255; $l2++) $mod.i = $l2;',
  4602. '']));
  4603. end;
  4604. procedure TTestModule.TestForIntInDo;
  4605. begin
  4606. StartProgram(false);
  4607. Add([
  4608. 'type',
  4609. ' TSetOfInt = set of byte;',
  4610. ' TIntRg = 3..7;',
  4611. ' TSetOfIntRg = set of TIntRg;',
  4612. 'var',
  4613. ' i,i2: longint;',
  4614. ' a1: array of byte;',
  4615. ' a2: array[1..3] of byte;',
  4616. ' soi: TSetOfInt;',
  4617. ' soir: TSetOfIntRg;',
  4618. ' ir: TIntRg;',
  4619. 'begin',
  4620. ' for i in byte do ;',
  4621. ' for i in a1 do ;',
  4622. ' for i in a2 do ;',
  4623. ' for i in [11..13] do ;',
  4624. ' for i in TSetOfInt do ;',
  4625. ' for i in TIntRg do ;',
  4626. ' for i in soi do i2:=i;',
  4627. ' for i in TSetOfIntRg do ;',
  4628. ' for i in soir do ;',
  4629. ' for ir in TIntRg do ;',
  4630. ' for ir in TSetOfIntRg do ;',
  4631. ' for ir in soir do ;',
  4632. '']);
  4633. ConvertProgram;
  4634. CheckSource('TestForIntInDo',
  4635. LinesToStr([ // statements
  4636. 'this.i = 0;',
  4637. 'this.i2 = 0;',
  4638. 'this.a1 = [];',
  4639. 'this.a2 = rtl.arraySetLength(null, 0, 3);',
  4640. 'this.soi = {};',
  4641. 'this.soir = {};',
  4642. 'this.ir = 3;',
  4643. '']),
  4644. LinesToStr([ // this.$main
  4645. 'for (var $l1 = 0; $l1 <= 255; $l1++) $mod.i = $l1;',
  4646. 'for (var $in2 = $mod.a1, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) $mod.i = $in2[$l3];',
  4647. 'for (var $in5 = $mod.a2, $l6 = 0, $end7 = rtl.length($in5) - 1; $l6 <= $end7; $l6++) $mod.i = $in5[$l6];',
  4648. 'for (var $l8 = 11; $l8 <= 13; $l8++) $mod.i = $l8;',
  4649. 'for (var $l9 = 0; $l9 <= 255; $l9++) $mod.i = $l9;',
  4650. 'for (var $l10 = 3; $l10 <= 7; $l10++) $mod.i = $l10;',
  4651. 'for ($mod.i in $mod.soi) $mod.i2 = $mod.i;',
  4652. 'for (var $l11 = 3; $l11 <= 7; $l11++) $mod.i = $l11;',
  4653. 'for ($mod.i in $mod.soir) ;',
  4654. 'for (var $l12 = 3; $l12 <= 7; $l12++) $mod.ir = $l12;',
  4655. 'for (var $l13 = 3; $l13 <= 7; $l13++) $mod.ir = $l13;',
  4656. 'for ($mod.ir in $mod.soir) ;',
  4657. '']));
  4658. end;
  4659. procedure TTestModule.TestCharConst;
  4660. begin
  4661. StartProgram(false);
  4662. Add('const');
  4663. Add(' c: char = ''1'';');
  4664. Add('begin');
  4665. Add(' c:=#0;');
  4666. Add(' c:=#1;');
  4667. Add(' c:=#9;');
  4668. Add(' c:=#10;');
  4669. Add(' c:=#13;');
  4670. Add(' c:=#31;');
  4671. Add(' c:=#32;');
  4672. Add(' c:=#$A;');
  4673. Add(' c:=#$0A;');
  4674. Add(' c:=#$b;');
  4675. Add(' c:=#$0b;');
  4676. Add(' c:=^A;');
  4677. Add(' c:=''"'';');
  4678. ConvertProgram;
  4679. CheckSource('TestCharConst',
  4680. LinesToStr([
  4681. 'this.c="1";'
  4682. ]),
  4683. LinesToStr([
  4684. '$mod.c="\x00";',
  4685. '$mod.c="\x01";',
  4686. '$mod.c="\t";',
  4687. '$mod.c="\n";',
  4688. '$mod.c="\r";',
  4689. '$mod.c="\x1F";',
  4690. '$mod.c=" ";',
  4691. '$mod.c="\n";',
  4692. '$mod.c="\n";',
  4693. '$mod.c="\x0B";',
  4694. '$mod.c="\x0B";',
  4695. '$mod.c="\x01";',
  4696. '$mod.c=''"'';'
  4697. ]));
  4698. end;
  4699. procedure TTestModule.TestChar_Compare;
  4700. begin
  4701. StartProgram(false);
  4702. Add('var');
  4703. Add(' c: char;');
  4704. Add(' b: boolean;');
  4705. Add('begin');
  4706. Add(' b:=c=''1'';');
  4707. Add(' b:=''2''=c;');
  4708. Add(' b:=''3''=''4'';');
  4709. Add(' b:=c<>''5'';');
  4710. Add(' b:=''6''<>c;');
  4711. Add(' b:=c>''7'';');
  4712. Add(' b:=''8''>c;');
  4713. Add(' b:=c>=''9'';');
  4714. Add(' b:=''A''>=c;');
  4715. Add(' b:=c<''B'';');
  4716. Add(' b:=''C''<c;');
  4717. Add(' b:=c<=''D'';');
  4718. Add(' b:=''E''<=c;');
  4719. ConvertProgram;
  4720. CheckSource('TestChar_Compare',
  4721. LinesToStr([
  4722. 'this.c="";',
  4723. 'this.b = false;'
  4724. ]),
  4725. LinesToStr([
  4726. '$mod.b = $mod.c === "1";',
  4727. '$mod.b = "2" === $mod.c;',
  4728. '$mod.b = "3" === "4";',
  4729. '$mod.b = $mod.c !== "5";',
  4730. '$mod.b = "6" !== $mod.c;',
  4731. '$mod.b = $mod.c > "7";',
  4732. '$mod.b = "8" > $mod.c;',
  4733. '$mod.b = $mod.c >= "9";',
  4734. '$mod.b = "A" >= $mod.c;',
  4735. '$mod.b = $mod.c < "B";',
  4736. '$mod.b = "C" < $mod.c;',
  4737. '$mod.b = $mod.c <= "D";',
  4738. '$mod.b = "E" <= $mod.c;',
  4739. '']));
  4740. end;
  4741. procedure TTestModule.TestChar_Ord;
  4742. begin
  4743. StartProgram(false);
  4744. Add('var');
  4745. Add(' c: char;');
  4746. Add(' i: longint;');
  4747. Add(' s: string;');
  4748. Add('begin');
  4749. Add(' i:=ord(c);');
  4750. Add(' i:=ord(s[i]);');
  4751. ConvertProgram;
  4752. CheckSource('TestChar_Ord',
  4753. LinesToStr([
  4754. 'this.c = "";',
  4755. 'this.i = 0;',
  4756. 'this.s = "";'
  4757. ]),
  4758. LinesToStr([
  4759. '$mod.i = $mod.c.charCodeAt();',
  4760. '$mod.i = $mod.s.charCodeAt($mod.i-1);',
  4761. '']));
  4762. end;
  4763. procedure TTestModule.TestChar_Chr;
  4764. begin
  4765. StartProgram(false);
  4766. Add('var');
  4767. Add(' c: char;');
  4768. Add(' i: longint;');
  4769. Add('begin');
  4770. Add(' c:=chr(i);');
  4771. ConvertProgram;
  4772. CheckSource('TestChar_Chr',
  4773. LinesToStr([
  4774. 'this.c = "";',
  4775. 'this.i = 0;'
  4776. ]),
  4777. LinesToStr([
  4778. '$mod.c = String.fromCharCode($mod.i);',
  4779. '']));
  4780. end;
  4781. procedure TTestModule.TestStringConst;
  4782. begin
  4783. StartProgram(false);
  4784. Add([
  4785. 'var',
  4786. ' s: string = ''abc'';',
  4787. 'begin',
  4788. ' s:='''';',
  4789. ' s:=#13#10;',
  4790. ' s:=#9''foo'';',
  4791. ' s:=#$A9;',
  4792. ' s:=''foo''#13''bar'';',
  4793. ' s:=''"'';',
  4794. ' s:=''"''''"'';',
  4795. '']);
  4796. ConvertProgram;
  4797. CheckSource('TestStringConst',
  4798. LinesToStr([
  4799. 'this.s="abc";'
  4800. ]),
  4801. LinesToStr([
  4802. '$mod.s="";',
  4803. '$mod.s="\r\n";',
  4804. '$mod.s="\tfoo";',
  4805. '$mod.s="©";',
  4806. '$mod.s="foo\rbar";',
  4807. '$mod.s=''"'';',
  4808. '$mod.s=''"\''"'';'
  4809. ]));
  4810. end;
  4811. procedure TTestModule.TestStringConstSurrogate;
  4812. begin
  4813. StartProgram(false);
  4814. Add([
  4815. 'var',
  4816. ' s: string;',
  4817. 'begin',
  4818. ' s:=''😊'';', // 1F60A
  4819. '']);
  4820. ConvertProgram;
  4821. CheckSource('TestStringConstSurrogate',
  4822. LinesToStr([
  4823. 'this.s="";'
  4824. ]),
  4825. LinesToStr([
  4826. '$mod.s="😊";'
  4827. ]));
  4828. end;
  4829. procedure TTestModule.TestString_Length;
  4830. begin
  4831. StartProgram(false);
  4832. Add('const c = ''foo'';');
  4833. Add('var');
  4834. Add(' s: string;');
  4835. Add(' i: longint;');
  4836. Add('begin');
  4837. Add(' i:=length(s);');
  4838. Add(' i:=length(s+s);');
  4839. Add(' i:=length(''abc'');');
  4840. Add(' i:=length(c);');
  4841. ConvertProgram;
  4842. CheckSource('TestString_Length',
  4843. LinesToStr([
  4844. 'this.c = "foo";',
  4845. 'this.s = "";',
  4846. 'this.i = 0;',
  4847. '']),
  4848. LinesToStr([
  4849. '$mod.i = $mod.s.length;',
  4850. '$mod.i = ($mod.s+$mod.s).length;',
  4851. '$mod.i = "abc".length;',
  4852. '$mod.i = $mod.c.length;',
  4853. '']));
  4854. end;
  4855. procedure TTestModule.TestString_Compare;
  4856. begin
  4857. StartProgram(false);
  4858. Add('var');
  4859. Add(' s, t: string;');
  4860. Add(' b: boolean;');
  4861. Add('begin');
  4862. Add(' b:=s=t;');
  4863. Add(' b:=s<>t;');
  4864. Add(' b:=s>t;');
  4865. Add(' b:=s>=t;');
  4866. Add(' b:=s<t;');
  4867. Add(' b:=s<=t;');
  4868. ConvertProgram;
  4869. CheckSource('TestString_Compare',
  4870. LinesToStr([ // statements
  4871. 'this.s = "";',
  4872. 'this.t = "";',
  4873. 'this.b =false;'
  4874. ]),
  4875. LinesToStr([ // this.$main
  4876. '$mod.b = $mod.s === $mod.t;',
  4877. '$mod.b = $mod.s !== $mod.t;',
  4878. '$mod.b = $mod.s > $mod.t;',
  4879. '$mod.b = $mod.s >= $mod.t;',
  4880. '$mod.b = $mod.s < $mod.t;',
  4881. '$mod.b = $mod.s <= $mod.t;',
  4882. '']));
  4883. end;
  4884. procedure TTestModule.TestString_SetLength;
  4885. begin
  4886. StartProgram(false);
  4887. Add([
  4888. 'procedure DoIt(var s: string);',
  4889. 'begin',
  4890. ' SetLength(s,2);',
  4891. 'end;',
  4892. 'var s: string;',
  4893. 'begin',
  4894. ' SetLength(s,3);',
  4895. '']);
  4896. ConvertProgram;
  4897. CheckSource('TestString_SetLength',
  4898. LinesToStr([ // statements
  4899. 'this.DoIt = function (s) {',
  4900. ' s.set(rtl.strSetLength(s.get(), 2));',
  4901. '};',
  4902. 'this.s = "";',
  4903. '']),
  4904. LinesToStr([ // this.$main
  4905. '$mod.s = rtl.strSetLength($mod.s, 3);'
  4906. ]));
  4907. end;
  4908. procedure TTestModule.TestString_CharAt;
  4909. begin
  4910. StartProgram(false);
  4911. Add([
  4912. 'var',
  4913. ' s: string;',
  4914. ' c: char;',
  4915. ' b: boolean;',
  4916. 'begin',
  4917. ' b:= s[1] = c;',
  4918. ' b:= c = s[1];',
  4919. ' b:= c <> s[1];',
  4920. ' b:= c > s[1];',
  4921. ' b:= c >= s[1];',
  4922. ' b:= c < s[2];',
  4923. ' b:= c <= s[1];',
  4924. ' s[1] := c;',
  4925. ' s[2+3] := c;']);
  4926. ConvertProgram;
  4927. CheckSource('TestString_CharAt',
  4928. LinesToStr([ // statements
  4929. 'this.s = "";',
  4930. 'this.c = "";',
  4931. 'this.b = false;'
  4932. ]),
  4933. LinesToStr([ // this.$main
  4934. '$mod.b = $mod.s.charAt(0) === $mod.c;',
  4935. '$mod.b = $mod.c === $mod.s.charAt(0);',
  4936. '$mod.b = $mod.c !== $mod.s.charAt(0);',
  4937. '$mod.b = $mod.c > $mod.s.charAt(0);',
  4938. '$mod.b = $mod.c >= $mod.s.charAt(0);',
  4939. '$mod.b = $mod.c < $mod.s.charAt(1);',
  4940. '$mod.b = $mod.c <= $mod.s.charAt(0);',
  4941. '$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
  4942. '$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
  4943. '']));
  4944. end;
  4945. procedure TTestModule.TestStr;
  4946. begin
  4947. StartProgram(false);
  4948. Add('var');
  4949. Add(' b: boolean;');
  4950. Add(' i: longint;');
  4951. Add(' d: double;');
  4952. Add(' s: string;');
  4953. Add('begin');
  4954. Add(' str(b,s);');
  4955. Add(' str(i,s);');
  4956. Add(' str(d,s);');
  4957. Add(' str(i:3,s);');
  4958. Add(' str(d:3:2,s);');
  4959. Add(' Str(12.456:12:1,s);');
  4960. Add(' Str(12.456:12,s);');
  4961. Add(' s:=str(b);');
  4962. Add(' s:=str(i);');
  4963. Add(' s:=str(d);');
  4964. Add(' s:=str(i,i);');
  4965. Add(' s:=str(i:3);');
  4966. Add(' s:=str(d:3:2);');
  4967. Add(' s:=str(i:4,i);');
  4968. Add(' s:=str(i,i:5);');
  4969. Add(' s:=str(i:4,i:5);');
  4970. Add(' s:=str(s,s);');
  4971. Add(' s:=str(s,''foo'');');
  4972. ConvertProgram;
  4973. CheckSource('TestStr',
  4974. LinesToStr([ // statements
  4975. 'this.b = false;',
  4976. 'this.i = 0;',
  4977. 'this.d = 0.0;',
  4978. 'this.s = "";',
  4979. '']),
  4980. LinesToStr([ // this.$main
  4981. '$mod.s = ""+$mod.b;',
  4982. '$mod.s = ""+$mod.i;',
  4983. '$mod.s = rtl.floatToStr($mod.d);',
  4984. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  4985. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  4986. '$mod.s = rtl.floatToStr(12.456,12,1);',
  4987. '$mod.s = rtl.floatToStr(12.456,12);',
  4988. '$mod.s = ""+$mod.b;',
  4989. '$mod.s = ""+$mod.i;',
  4990. '$mod.s = rtl.floatToStr($mod.d);',
  4991. '$mod.s = (""+$mod.i)+$mod.i;',
  4992. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  4993. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  4994. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
  4995. '$mod.s = ("" + $mod.i) + rtl.spaceLeft("" + $mod.i, 5);',
  4996. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
  4997. '$mod.s = $mod.s + $mod.s;',
  4998. '$mod.s = $mod.s + "foo";',
  4999. '']));
  5000. end;
  5001. procedure TTestModule.TestBaseType_AnsiStringFail;
  5002. begin
  5003. StartProgram(false);
  5004. Add('var s: AnsiString');
  5005. SetExpectedPasResolverError('identifier not found "AnsiString"',PasResolveEval.nIdentifierNotFound);
  5006. ConvertProgram;
  5007. end;
  5008. procedure TTestModule.TestBaseType_WideStringFail;
  5009. begin
  5010. StartProgram(false);
  5011. Add('var s: WideString');
  5012. SetExpectedPasResolverError('identifier not found "WideString"',PasResolveEval.nIdentifierNotFound);
  5013. ConvertProgram;
  5014. end;
  5015. procedure TTestModule.TestBaseType_ShortStringFail;
  5016. begin
  5017. StartProgram(false);
  5018. Add('var s: ShortString');
  5019. SetExpectedPasResolverError('identifier not found "ShortString"',PasResolveEval.nIdentifierNotFound);
  5020. ConvertProgram;
  5021. end;
  5022. procedure TTestModule.TestBaseType_RawByteStringFail;
  5023. begin
  5024. StartProgram(false);
  5025. Add('var s: RawByteString');
  5026. SetExpectedPasResolverError('identifier not found "RawByteString"',PasResolveEval.nIdentifierNotFound);
  5027. ConvertProgram;
  5028. end;
  5029. procedure TTestModule.TestTypeShortstring_Fail;
  5030. begin
  5031. StartProgram(false);
  5032. Add('type t = string[12];');
  5033. Add('var s: t;');
  5034. Add('begin');
  5035. SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
  5036. ConvertProgram;
  5037. end;
  5038. procedure TTestModule.TestCharSet_Custom;
  5039. begin
  5040. StartProgram(false);
  5041. Add([
  5042. 'type',
  5043. ' TCharRg = ''a''..''z'';',
  5044. ' TSetOfCharRg = set of TCharRg;',
  5045. ' TCharRg2 = ''m''..''p'';',
  5046. 'const',
  5047. ' crg: TCharRg = ''b'';',
  5048. 'var',
  5049. ' c: char;',
  5050. ' crg2: TCharRg2;',
  5051. ' s: TSetOfCharRg;',
  5052. 'begin',
  5053. ' c:=crg;',
  5054. ' crg:=c;',
  5055. ' crg2:=crg;',
  5056. ' if c=crg then ;',
  5057. ' if crg=c then ;',
  5058. ' if crg=crg2 then ;',
  5059. ' if c in s then ;',
  5060. ' if crg2 in s then ;',
  5061. '']);
  5062. ConvertProgram;
  5063. CheckSource('TestCharSet_Custom',
  5064. LinesToStr([ // statements
  5065. 'this.crg = "b";',
  5066. 'this.c = "";',
  5067. 'this.crg2 = "m";',
  5068. 'this.s = {};',
  5069. '']),
  5070. LinesToStr([ // this.$main
  5071. '$mod.c = $mod.crg;',
  5072. '$mod.crg = $mod.c;',
  5073. '$mod.crg2 = $mod.crg;',
  5074. 'if ($mod.c === $mod.crg) ;',
  5075. 'if ($mod.crg === $mod.c) ;',
  5076. 'if ($mod.crg === $mod.crg2) ;',
  5077. 'if ($mod.c.charCodeAt() in $mod.s) ;',
  5078. 'if ($mod.crg2.charCodeAt() in $mod.s) ;',
  5079. '']));
  5080. end;
  5081. procedure TTestModule.TestForCharDo;
  5082. begin
  5083. StartProgram(false);
  5084. Add([
  5085. 'var c: char;',
  5086. 'begin',
  5087. ' for c:=''a'' to ''c'' do ;',
  5088. ' for c:=c downto ''a'' do ;',
  5089. '']);
  5090. ConvertProgram;
  5091. CheckSource('TestForCharDo',
  5092. LinesToStr([ // statements
  5093. 'this.c = "";']),
  5094. LinesToStr([ // this.$main
  5095. 'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
  5096. 'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $l2--) $mod.c = String.fromCharCode($l2);',
  5097. '']));
  5098. end;
  5099. procedure TTestModule.TestForCharInDo;
  5100. begin
  5101. StartProgram(false);
  5102. Add([
  5103. 'type',
  5104. ' TSetOfChar = set of char;',
  5105. ' TCharRg = ''a''..''z'';',
  5106. ' TSetOfCharRg = set of TCharRg;',
  5107. 'const Foo = ''foo'';',
  5108. 'var',
  5109. ' c,c2: char;',
  5110. ' s: string;',
  5111. ' a1: array of char;',
  5112. ' a2: array[1..3] of char;',
  5113. ' soc: TSetOfChar;',
  5114. ' socr: TSetOfCharRg;',
  5115. ' cr: TCharRg;',
  5116. 'begin',
  5117. ' for c in foo do ;',
  5118. ' for c in s do ;',
  5119. ' for c in char do ;',
  5120. ' for c in a1 do ;',
  5121. ' for c in a2 do ;',
  5122. ' for c in [''1''..''3''] do ;',
  5123. ' for c in TSetOfChar do ;',
  5124. ' for c in TCharRg do ;',
  5125. ' for c in soc do c2:=c;',
  5126. ' for c in TSetOfCharRg do ;',
  5127. ' for c in socr do ;',
  5128. ' for cr in TCharRg do ;',
  5129. ' for cr in TSetOfCharRg do ;',
  5130. ' for cr in socr do ;',
  5131. '']);
  5132. ConvertProgram;
  5133. CheckSource('TestForCharInDo',
  5134. LinesToStr([ // statements
  5135. 'this.Foo = "foo";',
  5136. 'this.c = "";',
  5137. 'this.c2 = "";',
  5138. 'this.s = "";',
  5139. 'this.a1 = [];',
  5140. 'this.a2 = rtl.arraySetLength(null, "", 3);',
  5141. 'this.soc = {};',
  5142. 'this.socr = {};',
  5143. 'this.cr = "a";',
  5144. '']),
  5145. LinesToStr([ // this.$main
  5146. 'for (var $in1 = $mod.Foo, $l2 = 0, $end3 = $in1.length - 1; $l2 <= $end3; $l2++) $mod.c = $in1.charAt($l2);',
  5147. 'for (var $in4 = $mod.s, $l5 = 0, $end6 = $in4.length - 1; $l5 <= $end6; $l5++) $mod.c = $in4.charAt($l5);',
  5148. 'for (var $l7 = 0; $l7 <= 65535; $l7++) $mod.c = String.fromCharCode($l7);',
  5149. 'for (var $in8 = $mod.a1, $l9 = 0, $end10 = rtl.length($in8) - 1; $l9 <= $end10; $l9++) $mod.c = $in8[$l9];',
  5150. 'for (var $in11 = $mod.a2, $l12 = 0, $end13 = rtl.length($in11) - 1; $l12 <= $end13; $l12++) $mod.c = $in11[$l12];',
  5151. 'for (var $l14 = 49; $l14 <= 51; $l14++) $mod.c = String.fromCharCode($l14);',
  5152. 'for (var $l15 = 0; $l15 <= 65535; $l15++) $mod.c = String.fromCharCode($l15);',
  5153. 'for (var $l16 = 97; $l16 <= 122; $l16++) $mod.c = String.fromCharCode($l16);',
  5154. 'for (var $l17 in $mod.soc) {',
  5155. ' $mod.c = String.fromCharCode($l17);',
  5156. ' $mod.c2 = $mod.c;',
  5157. '};',
  5158. 'for (var $l18 = 97; $l18 <= 122; $l18++) $mod.c = String.fromCharCode($l18);',
  5159. 'for (var $l19 in $mod.socr) $mod.c = String.fromCharCode($l19);',
  5160. 'for (var $l20 = 97; $l20 <= 122; $l20++) $mod.cr = String.fromCharCode($l20);',
  5161. 'for (var $l21 = 97; $l21 <= 122; $l21++) $mod.cr = String.fromCharCode($l21);',
  5162. 'for (var $l22 in $mod.socr) $mod.cr = String.fromCharCode($l22);',
  5163. '']));
  5164. end;
  5165. procedure TTestModule.TestProcTwoArgs;
  5166. begin
  5167. StartProgram(false);
  5168. Add('procedure Test(a,b: longint);');
  5169. Add('begin');
  5170. Add('end;');
  5171. Add('begin');
  5172. ConvertProgram;
  5173. CheckSource('TestProcTwoArgs',
  5174. LinesToStr([ // statements
  5175. 'this.Test = function (a,b) {',
  5176. '};'
  5177. ]),
  5178. LinesToStr([ // this.$main
  5179. ''
  5180. ]));
  5181. end;
  5182. procedure TTestModule.TestProc_DefaultValue;
  5183. begin
  5184. StartProgram(false);
  5185. Add('procedure p1(i: longint = 1);');
  5186. Add('begin');
  5187. Add('end;');
  5188. Add('procedure p2(i: longint = 1; c: char = ''a'');');
  5189. Add('begin');
  5190. Add('end;');
  5191. Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');');
  5192. Add('begin');
  5193. Add('end;');
  5194. Add('begin');
  5195. Add(' p1;');
  5196. Add(' p1();');
  5197. Add(' p1(11);');
  5198. Add(' p2;');
  5199. Add(' p2();');
  5200. Add(' p2(12);');
  5201. Add(' p2(13,''b'');');
  5202. Add(' p3();');
  5203. ConvertProgram;
  5204. CheckSource('TestProc_DefaultValue',
  5205. LinesToStr([ // statements
  5206. 'this.p1 = function (i) {',
  5207. '};',
  5208. 'this.p2 = function (i,c) {',
  5209. '};',
  5210. 'this.p3 = function (d,b,s) {',
  5211. '};'
  5212. ]),
  5213. LinesToStr([ // this.$main
  5214. ' $mod.p1(1);',
  5215. ' $mod.p1(1);',
  5216. ' $mod.p1(11);',
  5217. ' $mod.p2(1,"a");',
  5218. ' $mod.p2(1,"a");',
  5219. ' $mod.p2(12,"a");',
  5220. ' $mod.p2(13,"b");',
  5221. ' $mod.p3(1.0,false,"abc");'
  5222. ]));
  5223. end;
  5224. procedure TTestModule.TestFunctionInt;
  5225. begin
  5226. StartProgram(false);
  5227. Add('function MyTest(Bar: longint): longint;');
  5228. Add('begin');
  5229. Add(' Result:=2*bar');
  5230. Add('end;');
  5231. Add('begin');
  5232. ConvertProgram;
  5233. CheckSource('TestFunctionInt',
  5234. LinesToStr([ // statements
  5235. 'this.MyTest = function (Bar) {',
  5236. ' var Result = 0;',
  5237. ' Result = 2*Bar;',
  5238. ' return Result;',
  5239. '};'
  5240. ]),
  5241. LinesToStr([ // this.$main
  5242. ''
  5243. ]));
  5244. end;
  5245. procedure TTestModule.TestFunctionString;
  5246. begin
  5247. StartProgram(false);
  5248. Add('function Test(Bar: string): string;');
  5249. Add('begin');
  5250. Add(' Result:=bar+BAR');
  5251. Add('end;');
  5252. Add('begin');
  5253. ConvertProgram;
  5254. CheckSource('TestFunctionString',
  5255. LinesToStr([ // statements
  5256. 'this.Test = function (Bar) {',
  5257. ' var Result = "";',
  5258. ' Result = Bar+Bar;',
  5259. ' return Result;',
  5260. '};'
  5261. ]),
  5262. LinesToStr([ // this.$main
  5263. ''
  5264. ]));
  5265. end;
  5266. procedure TTestModule.TestForLoop;
  5267. begin
  5268. StartProgram(false);
  5269. Add('var');
  5270. Add(' vI, vJ, vN: longint;');
  5271. Add('begin');
  5272. Add(' VJ:=0;');
  5273. Add(' VN:=3;');
  5274. Add(' for VI:=1 to VN do');
  5275. Add(' begin');
  5276. Add(' VJ:=VJ+VI;');
  5277. Add(' end;');
  5278. ConvertProgram;
  5279. CheckSource('TestForLoop',
  5280. LinesToStr([ // statements
  5281. 'this.vI = 0;',
  5282. 'this.vJ = 0;',
  5283. 'this.vN = 0;'
  5284. ]),
  5285. LinesToStr([ // this.$main
  5286. ' $mod.vJ = 0;',
  5287. ' $mod.vN = 3;',
  5288. ' for (var $l1 = 1, $end2 = $mod.vN; $l1 <= $end2; $l1++) {',
  5289. ' $mod.vI = $l1;',
  5290. ' $mod.vJ = $mod.vJ + $mod.vI;',
  5291. ' };',
  5292. '']));
  5293. end;
  5294. procedure TTestModule.TestForLoopInsideFunction;
  5295. begin
  5296. StartProgram(false);
  5297. Add('function SumNumbers(Count: longint): longint;');
  5298. Add('var');
  5299. Add(' vI, vJ: longint;');
  5300. Add('begin');
  5301. Add(' vj:=0;');
  5302. Add(' for vi:=1 to count do');
  5303. Add(' begin');
  5304. Add(' vj:=vj+vi;');
  5305. Add(' end;');
  5306. Add('end;');
  5307. Add('begin');
  5308. Add(' sumnumbers(3);');
  5309. ConvertProgram;
  5310. CheckSource('TestForLoopInsideFunction',
  5311. LinesToStr([ // statements
  5312. 'this.SumNumbers = function (Count) {',
  5313. ' var Result = 0;',
  5314. ' var vI = 0;',
  5315. ' var vJ = 0;',
  5316. ' vJ = 0;',
  5317. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  5318. ' vI = $l1;',
  5319. ' vJ = vJ + vI;',
  5320. ' };',
  5321. ' return Result;',
  5322. '};'
  5323. ]),
  5324. LinesToStr([ // $mod.$main
  5325. ' $mod.SumNumbers(3);'
  5326. ]));
  5327. end;
  5328. procedure TTestModule.TestForLoop_ReadVarAfter;
  5329. begin
  5330. StartProgram(false);
  5331. Add('var');
  5332. Add(' vI: longint;');
  5333. Add('begin');
  5334. Add(' for vi:=1 to 2 do ;');
  5335. Add(' if vi=3 then ;');
  5336. ConvertProgram;
  5337. CheckSource('TestForLoop',
  5338. LinesToStr([ // statements
  5339. 'this.vI = 0;'
  5340. ]),
  5341. LinesToStr([ // this.$main
  5342. ' for ($mod.vI = 1; $mod.vI <= 2; $mod.vI++) ;',
  5343. ' if ($mod.vI===3) ;'
  5344. ]));
  5345. end;
  5346. procedure TTestModule.TestForLoop_Nested;
  5347. begin
  5348. StartProgram(false);
  5349. Add('function SumNumbers(Count: longint): longint;');
  5350. Add('var');
  5351. Add(' vI, vJ, vK: longint;');
  5352. Add('begin');
  5353. Add(' VK:=0;');
  5354. Add(' for VI:=1 to count do');
  5355. Add(' begin');
  5356. Add(' for vj:=1 to vi do');
  5357. Add(' begin');
  5358. Add(' vk:=VK+VI;');
  5359. Add(' end;');
  5360. Add(' end;');
  5361. Add('end;');
  5362. Add('begin');
  5363. Add(' sumnumbers(3);');
  5364. ConvertProgram;
  5365. CheckSource('TestForLoopInFunction',
  5366. LinesToStr([ // statements
  5367. 'this.SumNumbers = function (Count) {',
  5368. ' var Result = 0;',
  5369. ' var vI = 0;',
  5370. ' var vJ = 0;',
  5371. ' var vK = 0;',
  5372. ' vK = 0;',
  5373. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  5374. ' vI = $l1;',
  5375. ' for (var $l3 = 1, $end4 = vI; $l3 <= $end4; $l3++) {',
  5376. ' vJ = $l3;',
  5377. ' vK = vK + vI;',
  5378. ' };',
  5379. ' };',
  5380. ' return Result;',
  5381. '};'
  5382. ]),
  5383. LinesToStr([ // $mod.$main
  5384. ' $mod.SumNumbers(3);'
  5385. ]));
  5386. end;
  5387. procedure TTestModule.TestRepeatUntil;
  5388. begin
  5389. StartProgram(false);
  5390. Add('var');
  5391. Add(' vI, vJ, vN: longint;');
  5392. Add('begin');
  5393. Add(' vn:=3;');
  5394. Add(' vj:=0;');
  5395. Add(' VI:=0;');
  5396. Add(' repeat');
  5397. Add(' VI:=vi+1;');
  5398. Add(' vj:=VJ+vI;');
  5399. Add(' until vi>=vn');
  5400. ConvertProgram;
  5401. CheckSource('TestRepeatUntil',
  5402. LinesToStr([ // statements
  5403. 'this.vI = 0;',
  5404. 'this.vJ = 0;',
  5405. 'this.vN = 0;'
  5406. ]),
  5407. LinesToStr([ // $mod.$main
  5408. ' $mod.vN = 3;',
  5409. ' $mod.vJ = 0;',
  5410. ' $mod.vI = 0;',
  5411. ' do{',
  5412. ' $mod.vI = $mod.vI + 1;',
  5413. ' $mod.vJ = $mod.vJ + $mod.vI;',
  5414. ' }while(!($mod.vI>=$mod.vN));'
  5415. ]));
  5416. end;
  5417. procedure TTestModule.TestAsmBlock;
  5418. begin
  5419. StartProgram(false);
  5420. Add('var');
  5421. Add(' vI: longint;');
  5422. Add('begin');
  5423. Add(' vi:=1;');
  5424. Add(' asm');
  5425. Add(' if (vI===1) {');
  5426. Add(' vI=2;');
  5427. Add(' }');
  5428. Add(' if (vI===2){ vI=3; }');
  5429. Add(' end;');
  5430. Add(' VI:=4;');
  5431. ConvertProgram;
  5432. CheckSource('TestAsmBlock',
  5433. LinesToStr([ // statements
  5434. 'this.vI = 0;'
  5435. ]),
  5436. LinesToStr([ // $mod.$main
  5437. '$mod.vI = 1;',
  5438. 'if (vI===1) {',
  5439. ' vI=2;',
  5440. '}',
  5441. 'if (vI===2){ vI=3; }',
  5442. ';',
  5443. '$mod.vI = 4;'
  5444. ]));
  5445. end;
  5446. procedure TTestModule.TestAsmPas_Impl;
  5447. begin
  5448. StartUnit(false);
  5449. Add('interface');
  5450. Add('const cIntf: longint = 1;');
  5451. Add('var vIntf: longint;');
  5452. Add('implementation');
  5453. Add('const cImpl: longint = 2;');
  5454. Add('var vImpl: longint;');
  5455. Add('procedure DoIt;');
  5456. Add('const cLoc: longint = 3;');
  5457. Add('var vLoc: longint;');
  5458. Add('begin;');
  5459. Add(' asm');
  5460. //Add(' pas(vIntf)=pas(cIntf);');
  5461. //Add(' pas(vImpl)=pas(cImpl);');
  5462. //Add(' pas(vLoc)=pas(cLoc);');
  5463. Add(' end;');
  5464. Add('end;');
  5465. ConvertUnit;
  5466. CheckSource('TestAsmPas_Impl',
  5467. LinesToStr([
  5468. 'var $impl = $mod.$impl;',
  5469. 'this.cIntf = 1;',
  5470. 'this.vIntf = 0;',
  5471. '']),
  5472. '', // this.$init
  5473. LinesToStr([ // implementation
  5474. '$impl.cImpl = 2;',
  5475. '$impl.vImpl = 0;',
  5476. 'var cLoc = 3;',
  5477. '$impl.DoIt = function () {',
  5478. ' var vLoc = 0;',
  5479. '};',
  5480. '']) );
  5481. end;
  5482. procedure TTestModule.TestTryFinally;
  5483. begin
  5484. StartProgram(false);
  5485. Add('var i: longint;');
  5486. Add('begin');
  5487. Add(' try');
  5488. Add(' i:=0; i:=2 div i;');
  5489. Add(' finally');
  5490. Add(' i:=3');
  5491. Add(' end;');
  5492. ConvertProgram;
  5493. CheckSource('TestTryFinally',
  5494. LinesToStr([ // statements
  5495. 'this.i = 0;'
  5496. ]),
  5497. LinesToStr([ // $mod.$main
  5498. 'try {',
  5499. ' $mod.i = 0;',
  5500. ' $mod.i = Math.floor(2 / $mod.i);',
  5501. '} finally {',
  5502. ' $mod.i = 3;',
  5503. '};'
  5504. ]));
  5505. end;
  5506. procedure TTestModule.TestTryExcept;
  5507. begin
  5508. StartProgram(false);
  5509. Add('type');
  5510. Add(' TObject = class end;');
  5511. Add(' Exception = class Msg: string; end;');
  5512. Add(' EInvalidCast = class(Exception) end;');
  5513. Add('var vI: longint;');
  5514. Add('begin');
  5515. Add(' try');
  5516. Add(' vi:=1;');
  5517. Add(' except');
  5518. Add(' vi:=2');
  5519. Add(' end;');
  5520. Add(' try');
  5521. Add(' vi:=3;');
  5522. Add(' except');
  5523. Add(' raise;');
  5524. Add(' end;');
  5525. Add(' try');
  5526. Add(' VI:=4;');
  5527. Add(' except');
  5528. Add(' on einvalidcast do');
  5529. Add(' raise;');
  5530. Add(' on E: exception do');
  5531. Add(' if e.msg='''' then');
  5532. Add(' raise e;');
  5533. Add(' else');
  5534. Add(' vi:=5');
  5535. Add(' end;');
  5536. Add(' try');
  5537. Add(' VI:=6;');
  5538. Add(' except');
  5539. Add(' on einvalidcast do ;');
  5540. Add(' end;');
  5541. ConvertProgram;
  5542. CheckSource('TestTryExcept',
  5543. LinesToStr([ // statements
  5544. 'rtl.createClass($mod, "TObject", null, function () {',
  5545. ' this.$init = function () {',
  5546. ' };',
  5547. ' this.$final = function () {',
  5548. ' };',
  5549. '});',
  5550. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  5551. ' this.$init = function () {',
  5552. ' $mod.TObject.$init.call(this);',
  5553. ' this.Msg = "";',
  5554. ' };',
  5555. '});',
  5556. 'rtl.createClass($mod, "EInvalidCast", $mod.Exception, function () {',
  5557. '});',
  5558. 'this.vI = 0;'
  5559. ]),
  5560. LinesToStr([ // $mod.$main
  5561. 'try {',
  5562. ' $mod.vI = 1;',
  5563. '} catch ($e) {',
  5564. ' $mod.vI = 2;',
  5565. '};',
  5566. 'try {',
  5567. ' $mod.vI = 3;',
  5568. '} catch ($e) {',
  5569. ' throw $e;',
  5570. '};',
  5571. 'try {',
  5572. ' $mod.vI = 4;',
  5573. '} catch ($e) {',
  5574. ' if ($mod.EInvalidCast.isPrototypeOf($e)){',
  5575. ' throw $e',
  5576. ' } else if ($mod.Exception.isPrototypeOf($e)) {',
  5577. ' var E = $e;',
  5578. ' if (E.Msg === "") throw E;',
  5579. ' } else {',
  5580. ' $mod.vI = 5;',
  5581. ' }',
  5582. '};',
  5583. 'try {',
  5584. ' $mod.vI = 6;',
  5585. '} catch ($e) {',
  5586. ' if ($mod.EInvalidCast.isPrototypeOf($e)){' ,
  5587. ' } else throw $e',
  5588. '};',
  5589. '']));
  5590. end;
  5591. procedure TTestModule.TestCaseOf;
  5592. begin
  5593. StartProgram(false);
  5594. Add('var vI: longint;');
  5595. Add('begin');
  5596. Add(' case vi of');
  5597. Add(' 1: ;');
  5598. Add(' 2: vi:=3;');
  5599. Add(' else');
  5600. Add(' VI:=4');
  5601. Add(' end;');
  5602. ConvertProgram;
  5603. CheckSource('TestCaseOf',
  5604. LinesToStr([ // statements
  5605. 'this.vI = 0;'
  5606. ]),
  5607. LinesToStr([ // $mod.$main
  5608. 'var $tmp1 = $mod.vI;',
  5609. 'if ($tmp1 === 1) {} else if ($tmp1 === 2){ $mod.vI = 3 }else {',
  5610. ' $mod.vI = 4;',
  5611. '};'
  5612. ]));
  5613. end;
  5614. procedure TTestModule.TestCaseOf_UseSwitch;
  5615. begin
  5616. StartProgram(false);
  5617. Converter.UseSwitchStatement:=true;
  5618. Add('var Vi: longint;');
  5619. Add('begin');
  5620. Add(' case vi of');
  5621. Add(' 1: ;');
  5622. Add(' 2: VI:=3;');
  5623. Add(' else');
  5624. Add(' vi:=4');
  5625. Add(' end;');
  5626. ConvertProgram;
  5627. CheckSource('TestCaseOf_UseSwitch',
  5628. LinesToStr([ // statements
  5629. 'this.Vi = 0;'
  5630. ]),
  5631. LinesToStr([ // $mod.$main
  5632. 'switch ($mod.Vi) {',
  5633. 'case 1:',
  5634. ' break;',
  5635. 'case 2:',
  5636. ' $mod.Vi = 3;',
  5637. ' break;',
  5638. 'default:',
  5639. ' $mod.Vi = 4;',
  5640. '};'
  5641. ]));
  5642. end;
  5643. procedure TTestModule.TestCaseOfNoElse;
  5644. begin
  5645. StartProgram(false);
  5646. Add('var Vi: longint;');
  5647. Add('begin');
  5648. Add(' case vi of');
  5649. Add(' 1: begin vi:=2; VI:=3; end;');
  5650. Add(' end;');
  5651. ConvertProgram;
  5652. CheckSource('TestCaseOfNoElse',
  5653. LinesToStr([ // statements
  5654. 'this.Vi = 0;'
  5655. ]),
  5656. LinesToStr([ // $mod.$main
  5657. 'var $tmp1 = $mod.Vi;',
  5658. 'if ($tmp1 === 1) {',
  5659. ' $mod.Vi = 2;',
  5660. ' $mod.Vi = 3;',
  5661. '};'
  5662. ]));
  5663. end;
  5664. procedure TTestModule.TestCaseOfNoElse_UseSwitch;
  5665. begin
  5666. StartProgram(false);
  5667. Converter.UseSwitchStatement:=true;
  5668. Add('var vI: longint;');
  5669. Add('begin');
  5670. Add(' case vi of');
  5671. Add(' 1: begin VI:=2; vi:=3; end;');
  5672. Add(' end;');
  5673. ConvertProgram;
  5674. CheckSource('TestCaseOfNoElse_UseSwitch',
  5675. LinesToStr([ // statements
  5676. 'this.vI = 0;'
  5677. ]),
  5678. LinesToStr([ // $mod.$main
  5679. 'switch ($mod.vI) {',
  5680. 'case 1:',
  5681. ' $mod.vI = 2;',
  5682. ' $mod.vI = 3;',
  5683. ' break;',
  5684. '};'
  5685. ]));
  5686. end;
  5687. procedure TTestModule.TestCaseOfRange;
  5688. begin
  5689. StartProgram(false);
  5690. Add('var vI: longint;');
  5691. Add('begin');
  5692. Add(' case vi of');
  5693. Add(' 1..3: vi:=14;');
  5694. Add(' 4,5: vi:=16;');
  5695. Add(' 6..7,9..10: ;');
  5696. Add(' else ;');
  5697. Add(' end;');
  5698. ConvertProgram;
  5699. CheckSource('TestCaseOfRange',
  5700. LinesToStr([ // statements
  5701. 'this.vI = 0;'
  5702. ]),
  5703. LinesToStr([ // $mod.$main
  5704. 'var $tmp1 = $mod.vI;',
  5705. 'if (($tmp1 >= 1) && ($tmp1 <= 3)){',
  5706. ' $mod.vI = 14',
  5707. '} else if (($tmp1 === 4) || ($tmp1 === 5)){',
  5708. ' $mod.vI = 16',
  5709. '} else if ((($tmp1 >= 6) && ($tmp1 <= 7)) || (($tmp1 >= 9) && ($tmp1 <= 10))) ;'
  5710. ]));
  5711. end;
  5712. procedure TTestModule.TestArray_Dynamic;
  5713. begin
  5714. StartProgram(false);
  5715. Add('type');
  5716. Add(' TArrayInt = array of longint;');
  5717. Add('var');
  5718. Add(' Arr: TArrayInt;');
  5719. Add(' i: longint;');
  5720. Add(' b: boolean;');
  5721. Add('begin');
  5722. Add(' SetLength(arr,3);');
  5723. Add(' arr[0]:=4;');
  5724. Add(' arr[1]:=length(arr)+arr[0];');
  5725. Add(' arr[i]:=5;');
  5726. Add(' arr[arr[i]]:=arr[6];');
  5727. Add(' i:=low(arr);');
  5728. Add(' i:=high(arr);');
  5729. Add(' b:=Assigned(arr);');
  5730. ConvertProgram;
  5731. CheckSource('TestArray_Dynamic',
  5732. LinesToStr([ // statements
  5733. 'this.Arr = [];',
  5734. 'this.i = 0;',
  5735. 'this.b = false;'
  5736. ]),
  5737. LinesToStr([ // $mod.$main
  5738. '$mod.Arr = rtl.arraySetLength($mod.Arr,0,3);',
  5739. '$mod.Arr[0] = 4;',
  5740. '$mod.Arr[1] = rtl.length($mod.Arr) + $mod.Arr[0];',
  5741. '$mod.Arr[$mod.i] = 5;',
  5742. '$mod.Arr[$mod.Arr[$mod.i]] = $mod.Arr[6];',
  5743. '$mod.i = 0;',
  5744. '$mod.i = rtl.length($mod.Arr) - 1;',
  5745. '$mod.b = rtl.length($mod.Arr) > 0;',
  5746. '']));
  5747. end;
  5748. procedure TTestModule.TestArray_Dynamic_Nil;
  5749. begin
  5750. StartProgram(false);
  5751. Add('type');
  5752. Add(' TArrayInt = array of longint;');
  5753. Add('var');
  5754. Add(' Arr: TArrayInt;');
  5755. Add('procedure DoIt(const i: TArrayInt; j: TArrayInt); begin end;');
  5756. Add('begin');
  5757. Add(' arr:=nil;');
  5758. Add(' if arr=nil then;');
  5759. Add(' if nil=arr then;');
  5760. Add(' if arr<>nil then;');
  5761. Add(' if nil<>arr then;');
  5762. Add(' DoIt(nil,nil);');
  5763. ConvertProgram;
  5764. CheckSource('TestArray_Dynamic',
  5765. LinesToStr([ // statements
  5766. 'this.Arr = [];',
  5767. 'this.DoIt = function(i,j){',
  5768. '};'
  5769. ]),
  5770. LinesToStr([ // $mod.$main
  5771. '$mod.Arr = [];',
  5772. 'if (rtl.length($mod.Arr) === 0) ;',
  5773. 'if (rtl.length($mod.Arr) === 0) ;',
  5774. 'if (rtl.length($mod.Arr) > 0) ;',
  5775. 'if (rtl.length($mod.Arr) > 0) ;',
  5776. '$mod.DoIt([],[]);',
  5777. '']));
  5778. end;
  5779. procedure TTestModule.TestArray_DynMultiDimensional;
  5780. begin
  5781. StartProgram(false);
  5782. Add('type');
  5783. Add(' TArrayInt = array of longint;');
  5784. Add(' TArrayArrayInt = array of TArrayInt;');
  5785. Add('var');
  5786. Add(' Arr: TArrayInt;');
  5787. Add(' Arr2: TArrayArrayInt;');
  5788. Add(' i: longint;');
  5789. Add('begin');
  5790. Add(' arr2:=nil;');
  5791. Add(' if arr2=nil then;');
  5792. Add(' if nil=arr2 then;');
  5793. Add(' i:=low(arr2);');
  5794. Add(' i:=low(arr2[1]);');
  5795. Add(' i:=high(arr2);');
  5796. Add(' i:=high(arr2[2]);');
  5797. Add(' arr2[3]:=arr;');
  5798. Add(' arr2[4][5]:=i;');
  5799. Add(' i:=arr2[6][7];');
  5800. Add(' arr2[8,9]:=i;');
  5801. Add(' i:=arr2[10,11];');
  5802. Add(' SetLength(arr2,14);');
  5803. Add(' SetLength(arr2[15],16);');
  5804. ConvertProgram;
  5805. CheckSource('TestArray_Dynamic',
  5806. LinesToStr([ // statements
  5807. 'this.Arr = [];',
  5808. 'this.Arr2 = [];',
  5809. 'this.i = 0;'
  5810. ]),
  5811. LinesToStr([ // $mod.$main
  5812. '$mod.Arr2 = [];',
  5813. 'if (rtl.length($mod.Arr2) === 0) ;',
  5814. 'if (rtl.length($mod.Arr2) === 0) ;',
  5815. '$mod.i = 0;',
  5816. '$mod.i = 0;',
  5817. '$mod.i = rtl.length($mod.Arr2) - 1;',
  5818. '$mod.i = rtl.length($mod.Arr2[2]) - 1;',
  5819. '$mod.Arr2[3] = $mod.Arr;',
  5820. '$mod.Arr2[4][5] = $mod.i;',
  5821. '$mod.i = $mod.Arr2[6][7];',
  5822. '$mod.Arr2[8][9] = $mod.i;',
  5823. '$mod.i = $mod.Arr2[10][11];',
  5824. '$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
  5825. '$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
  5826. '']));
  5827. end;
  5828. procedure TTestModule.TestArray_StaticInt;
  5829. begin
  5830. StartProgram(false);
  5831. Add('type');
  5832. Add(' TArrayInt = array[2..4] of longint;');
  5833. Add('var');
  5834. Add(' Arr: TArrayInt;');
  5835. Add(' Arr2: TArrayInt = (5,6,7);');
  5836. Add(' i: longint;');
  5837. Add(' b: boolean;');
  5838. Add('begin');
  5839. Add(' arr[2]:=4;');
  5840. Add(' arr[3]:=arr[2]+arr[3];');
  5841. Add(' arr[i]:=5;');
  5842. Add(' arr[arr[i]]:=arr[high(arr)];');
  5843. Add(' i:=low(arr);');
  5844. Add(' i:=high(arr);');
  5845. Add(' b:=arr[2]=arr[3];');
  5846. ConvertProgram;
  5847. CheckSource('TestArray_StaticInt',
  5848. LinesToStr([ // statements
  5849. 'this.Arr = rtl.arraySetLength(null,0,3);',
  5850. 'this.Arr2 = [5, 6, 7];',
  5851. 'this.i = 0;',
  5852. 'this.b = false;'
  5853. ]),
  5854. LinesToStr([ // $mod.$main
  5855. '$mod.Arr[0] = 4;',
  5856. '$mod.Arr[1] = $mod.Arr[0] + $mod.Arr[1];',
  5857. '$mod.Arr[$mod.i-2] = 5;',
  5858. '$mod.Arr[$mod.Arr[$mod.i-2]-2] = $mod.Arr[2];',
  5859. '$mod.i = 2;',
  5860. '$mod.i = 4;',
  5861. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  5862. '']));
  5863. end;
  5864. procedure TTestModule.TestArray_StaticBool;
  5865. begin
  5866. StartProgram(false);
  5867. Add('type');
  5868. Add(' TBools = array[boolean] of boolean;');
  5869. Add(' TBool2 = array[true..true] of boolean;');
  5870. Add('var');
  5871. Add(' Arr: TBools;');
  5872. Add(' Arr2: TBool2;');
  5873. Add(' Arr3: TBools = (true,false);');
  5874. Add(' b: boolean;');
  5875. Add('begin');
  5876. Add(' b:=low(arr);');
  5877. Add(' b:=high(arr);');
  5878. Add(' arr[true]:=false;');
  5879. Add(' arr[false]:=arr[b] or arr[true];');
  5880. Add(' arr[b]:=true;');
  5881. Add(' arr[arr[b]]:=arr[high(arr)];');
  5882. Add(' b:=arr[false]=arr[true];');
  5883. Add(' b:=low(arr2);');
  5884. Add(' b:=high(arr2);');
  5885. Add(' arr2[true]:=true;');
  5886. Add(' arr2[true]:=arr2[true] and arr2[b];');
  5887. Add(' arr2[b]:=false;');
  5888. ConvertProgram;
  5889. CheckSource('TestArray_StaticBool',
  5890. LinesToStr([ // statements
  5891. 'this.Arr = rtl.arraySetLength(null,false,2);',
  5892. 'this.Arr2 = rtl.arraySetLength(null,false,1);',
  5893. 'this.Arr3 = [true, false];',
  5894. 'this.b = false;'
  5895. ]),
  5896. LinesToStr([ // $mod.$main
  5897. '$mod.b = false;',
  5898. '$mod.b = true;',
  5899. '$mod.Arr[1] = false;',
  5900. '$mod.Arr[0] = $mod.Arr[+$mod.b] || $mod.Arr[1];',
  5901. '$mod.Arr[+$mod.b] = true;',
  5902. '$mod.Arr[+$mod.Arr[+$mod.b]] = $mod.Arr[1];',
  5903. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  5904. '$mod.b = true;',
  5905. '$mod.b = true;',
  5906. '$mod.Arr2[0] = true;',
  5907. '$mod.Arr2[0] = $mod.Arr2[0] && $mod.Arr2[1-$mod.b];',
  5908. '$mod.Arr2[1-$mod.b] = false;',
  5909. '']));
  5910. end;
  5911. procedure TTestModule.TestArray_StaticChar;
  5912. begin
  5913. StartProgram(false);
  5914. Add('type');
  5915. Add(' TChars = array[char] of char;');
  5916. Add(' TChars2 = array[''a''..''z''] of char;');
  5917. Add('var');
  5918. Add(' Arr: TChars;');
  5919. Add(' Arr2: TChars2;');
  5920. Add(' Arr3: array[2..4] of char = (''p'',''a'',''s'');');
  5921. Add(' Arr4: array[11..13] of char = ''pas'';');
  5922. Add(' Arr5: array[21..22] of char = ''äö'';');
  5923. Add(' c: char;');
  5924. Add(' b: boolean;');
  5925. Add('begin');
  5926. Add(' c:=low(arr);');
  5927. Add(' c:=high(arr);');
  5928. Add(' arr[''B'']:=''a'';');
  5929. Add(' arr[''D'']:=arr[c];');
  5930. Add(' arr[c]:=arr[''d''];');
  5931. Add(' arr[arr[c]]:=arr[high(arr)];');
  5932. Add(' b:=arr[low(arr)]=arr[''e''];');
  5933. Add(' c:=low(arr2);');
  5934. Add(' c:=high(arr2);');
  5935. Add(' arr2[''b'']:=''f'';');
  5936. Add(' arr2[''a'']:=arr2[c];');
  5937. Add(' arr2[c]:=arr2[''g''];');
  5938. ConvertProgram;
  5939. CheckSource('TestArray_StaticChar',
  5940. LinesToStr([ // statements
  5941. 'this.Arr = rtl.arraySetLength(null, "", 65536);',
  5942. 'this.Arr2 = rtl.arraySetLength(null, "", 26);',
  5943. 'this.Arr3 = ["p", "a", "s"];',
  5944. 'this.Arr4 = ["p", "a", "s"];',
  5945. 'this.Arr5 = ["ä", "ö"];',
  5946. 'this.c = "";',
  5947. 'this.b = false;',
  5948. '']),
  5949. LinesToStr([ // $mod.$main
  5950. '$mod.c = "\x00";',
  5951. '$mod.c = "'#$EF#$BF#$BF'";',
  5952. '$mod.Arr[66] = "a";',
  5953. '$mod.Arr[68] = $mod.Arr[$mod.c.charCodeAt()];',
  5954. '$mod.Arr[$mod.c.charCodeAt()] = $mod.Arr[100];',
  5955. '$mod.Arr[$mod.Arr[$mod.c.charCodeAt()].charCodeAt()] = $mod.Arr[65535];',
  5956. '$mod.b = $mod.Arr[0] === $mod.Arr[101];',
  5957. '$mod.c = "a";',
  5958. '$mod.c = "z";',
  5959. '$mod.Arr2[1] = "f";',
  5960. '$mod.Arr2[0] = $mod.Arr2[$mod.c.charCodeAt() - 97];',
  5961. '$mod.Arr2[$mod.c.charCodeAt() - 97] = $mod.Arr2[6];',
  5962. '']));
  5963. end;
  5964. procedure TTestModule.TestArray_StaticMultiDim;
  5965. begin
  5966. StartProgram(false);
  5967. Add([
  5968. 'type',
  5969. ' TArrayInt = array[1..3] of longint;',
  5970. ' TArrayArrayInt = array[5..6] of TArrayInt;',
  5971. 'var',
  5972. ' Arr: TArrayInt;',
  5973. ' Arr2: TArrayArrayInt;',
  5974. ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
  5975. ' i: longint;',
  5976. 'begin',
  5977. ' i:=low(arr);',
  5978. ' i:=low(arr2);',
  5979. ' i:=low(arr2[5]);',
  5980. ' i:=high(arr);',
  5981. ' i:=high(arr2);',
  5982. ' i:=high(arr2[6]);',
  5983. ' arr2[5]:=arr;',
  5984. ' arr2[6][2]:=i;',
  5985. ' i:=arr2[6][3];',
  5986. ' arr2[6,3]:=i;',
  5987. ' i:=arr2[5,2];',
  5988. ' arr2:=arr2;',// clone multi dim static array
  5989. //' arr3:=arr3;',// clone anonymous multi dim static array
  5990. '']);
  5991. ConvertProgram;
  5992. CheckSource('TestArray_StaticMultiDim',
  5993. LinesToStr([ // statements
  5994. 'this.TArrayArrayInt$clone = function (a) {',
  5995. ' var r = [];',
  5996. ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
  5997. ' return r;',
  5998. '};',
  5999. 'this.Arr = rtl.arraySetLength(null, 0, 3);',
  6000. 'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
  6001. 'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
  6002. 'this.i = 0;'
  6003. ]),
  6004. LinesToStr([ // $mod.$main
  6005. '$mod.i = 1;',
  6006. '$mod.i = 5;',
  6007. '$mod.i = 1;',
  6008. '$mod.i = 3;',
  6009. '$mod.i = 6;',
  6010. '$mod.i = 3;',
  6011. '$mod.Arr2[0] = $mod.Arr.slice(0);',
  6012. '$mod.Arr2[1][1] = $mod.i;',
  6013. '$mod.i = $mod.Arr2[1][2];',
  6014. '$mod.Arr2[1][2] = $mod.i;',
  6015. '$mod.i = $mod.Arr2[0][1];',
  6016. '$mod.Arr2 = $mod.TArrayArrayInt$clone($mod.Arr2);',
  6017. '']));
  6018. end;
  6019. procedure TTestModule.TestArrayOfRecord;
  6020. begin
  6021. StartProgram(false);
  6022. Add('type');
  6023. Add(' TRec = record');
  6024. Add(' Int: longint;');
  6025. Add(' end;');
  6026. Add(' TArrayRec = array of TRec;');
  6027. Add('var');
  6028. Add(' Arr: TArrayRec;');
  6029. Add(' r: TRec;');
  6030. Add(' i: longint;');
  6031. Add('begin');
  6032. Add(' SetLength(arr,3);');
  6033. Add(' arr[0].int:=4;');
  6034. Add(' arr[1].int:=length(arr)+arr[2].int;');
  6035. Add(' arr[arr[i].int].int:=arr[5].int;');
  6036. Add(' arr[7]:=r;');
  6037. Add(' r:=arr[8];');
  6038. Add(' i:=low(arr);');
  6039. Add(' i:=high(arr);');
  6040. ConvertProgram;
  6041. CheckSource('TestArrayOfRecord',
  6042. LinesToStr([ // statements
  6043. 'this.TRec = function (s) {',
  6044. ' if (s) {',
  6045. ' this.Int = s.Int;',
  6046. ' } else {',
  6047. ' this.Int = 0;',
  6048. ' };',
  6049. ' this.$equal = function (b) {',
  6050. ' return this.Int === b.Int;',
  6051. ' };',
  6052. '};',
  6053. 'this.Arr = [];',
  6054. 'this.r = new $mod.TRec();',
  6055. 'this.i = 0;'
  6056. ]),
  6057. LinesToStr([ // $mod.$main
  6058. '$mod.Arr = rtl.arraySetLength($mod.Arr,$mod.TRec,3);',
  6059. '$mod.Arr[0].Int = 4;',
  6060. '$mod.Arr[1].Int = rtl.length($mod.Arr)+$mod.Arr[2].Int;',
  6061. '$mod.Arr[$mod.Arr[$mod.i].Int].Int = $mod.Arr[5].Int;',
  6062. '$mod.Arr[7] = new $mod.TRec($mod.r);',
  6063. '$mod.r = new $mod.TRec($mod.Arr[8]);',
  6064. '$mod.i = 0;',
  6065. '$mod.i = rtl.length($mod.Arr)-1;',
  6066. '']));
  6067. end;
  6068. procedure TTestModule.TestArray_DynAsParam;
  6069. begin
  6070. StartProgram(false);
  6071. Add([
  6072. 'type integer = longint;',
  6073. 'type TArrInt = array of integer;',
  6074. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  6075. 'var vJ: TArrInt;',
  6076. 'begin',
  6077. ' vg:=vg;',
  6078. ' vj:=vh;',
  6079. ' vi:=vi;',
  6080. ' doit(vg,vg,vg);',
  6081. ' doit(vh,vh,vj);',
  6082. ' doit(vi,vi,vi);',
  6083. ' doit(vj,vj,vj);',
  6084. 'end;',
  6085. 'var i: TArrInt;',
  6086. 'begin',
  6087. ' doit(i,i,i);']);
  6088. ConvertProgram;
  6089. CheckSource('TestArray_DynAsParams',
  6090. LinesToStr([ // statements
  6091. 'this.DoIt = function (vG,vH,vI) {',
  6092. ' var vJ = [];',
  6093. ' vG = vG;',
  6094. ' vJ = vH;',
  6095. ' vI.set(vI.get());',
  6096. ' $mod.DoIt(vG, vG, {',
  6097. ' get: function () {',
  6098. ' return vG;',
  6099. ' },',
  6100. ' set: function (v) {',
  6101. ' vG = v;',
  6102. ' }',
  6103. ' });',
  6104. ' $mod.DoIt(vH, vH, {',
  6105. ' get: function () {',
  6106. ' return vJ;',
  6107. ' },',
  6108. ' set: function (v) {',
  6109. ' vJ = v;',
  6110. ' }',
  6111. ' });',
  6112. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  6113. ' $mod.DoIt(vJ, vJ, {',
  6114. ' get: function () {',
  6115. ' return vJ;',
  6116. ' },',
  6117. ' set: function (v) {',
  6118. ' vJ = v;',
  6119. ' }',
  6120. ' });',
  6121. '};',
  6122. 'this.i = [];'
  6123. ]),
  6124. LinesToStr([
  6125. '$mod.DoIt($mod.i,$mod.i,{',
  6126. ' p: $mod,',
  6127. ' get: function () {',
  6128. ' return this.p.i;',
  6129. ' },',
  6130. ' set: function (v) {',
  6131. ' this.p.i = v;',
  6132. ' }',
  6133. '});'
  6134. ]));
  6135. end;
  6136. procedure TTestModule.TestArray_StaticAsParam;
  6137. begin
  6138. StartProgram(false);
  6139. Add([
  6140. 'type integer = longint;',
  6141. 'type TArrInt = array[1..2] of integer;',
  6142. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  6143. 'var vJ: TArrInt;',
  6144. 'begin',
  6145. ' vg:=vg;',
  6146. ' vj:=vh;',
  6147. ' vi:=vi;',
  6148. ' doit(vg,vg,vg);',
  6149. ' doit(vh,vh,vj);',
  6150. ' doit(vi,vi,vi);',
  6151. ' doit(vj,vj,vj);',
  6152. 'end;',
  6153. 'var i: TArrInt;',
  6154. 'begin',
  6155. ' doit(i,i,i);']);
  6156. ConvertProgram;
  6157. CheckSource('TestArray_StaticAsParams',
  6158. LinesToStr([ // statements
  6159. 'this.DoIt = function (vG,vH,vI) {',
  6160. ' var vJ = rtl.arraySetLength(null, 0, 2);',
  6161. ' vG = vG.slice(0);',
  6162. ' vJ = vH.slice(0);',
  6163. ' vI.set(vI.get().slice(0));',
  6164. ' $mod.DoIt(vG.slice(0), vG, {',
  6165. ' get: function () {',
  6166. ' return vG;',
  6167. ' },',
  6168. ' set: function (v) {',
  6169. ' vG = v;',
  6170. ' }',
  6171. ' });',
  6172. ' $mod.DoIt(vH.slice(0), vH, {',
  6173. ' get: function () {',
  6174. ' return vJ;',
  6175. ' },',
  6176. ' set: function (v) {',
  6177. ' vJ = v;',
  6178. ' }',
  6179. ' });',
  6180. ' $mod.DoIt(vI.get().slice(0), vI.get(), vI);',
  6181. ' $mod.DoIt(vJ.slice(0), vJ, {',
  6182. ' get: function () {',
  6183. ' return vJ;',
  6184. ' },',
  6185. ' set: function (v) {',
  6186. ' vJ = v;',
  6187. ' }',
  6188. ' });',
  6189. '};',
  6190. 'this.i = rtl.arraySetLength(null, 0, 2);'
  6191. ]),
  6192. LinesToStr([
  6193. '$mod.DoIt($mod.i.slice(0),$mod.i,{',
  6194. ' p: $mod,',
  6195. ' get: function () {',
  6196. ' return this.p.i;',
  6197. ' },',
  6198. ' set: function (v) {',
  6199. ' this.p.i = v;',
  6200. ' }',
  6201. '});'
  6202. ]));
  6203. end;
  6204. procedure TTestModule.TestArrayElement_AsParams;
  6205. begin
  6206. StartProgram(false);
  6207. Add('type integer = longint;');
  6208. Add('type TArrayInt = array of integer;');
  6209. Add('procedure DoIt(vG: Integer; const vH: Integer; var vI: Integer);');
  6210. Add('var vJ: tarrayint;');
  6211. Add('begin');
  6212. Add(' vi:=vi;');
  6213. Add(' doit(vi,vi,vi);');
  6214. Add(' doit(vj[1+1],vj[1+2],vj[1+3]);');
  6215. Add('end;');
  6216. Add('var a: TArrayInt;');
  6217. Add('begin');
  6218. Add(' doit(a[1+4],a[1+5],a[1+6]);');
  6219. ConvertProgram;
  6220. CheckSource('TestArrayElement_AsParams',
  6221. LinesToStr([ // statements
  6222. 'this.DoIt = function (vG,vH,vI) {',
  6223. ' var vJ = [];',
  6224. ' vI.set(vI.get());',
  6225. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  6226. ' $mod.DoIt(vJ[1+1], vJ[1+2], {',
  6227. ' a:1+3,',
  6228. ' p:vJ,',
  6229. ' get: function () {',
  6230. ' return this.p[this.a];',
  6231. ' },',
  6232. ' set: function (v) {',
  6233. ' this.p[this.a] = v;',
  6234. ' }',
  6235. ' });',
  6236. '};',
  6237. 'this.a = [];'
  6238. ]),
  6239. LinesToStr([
  6240. '$mod.DoIt($mod.a[1+4],$mod.a[1+5],{',
  6241. ' a: 1+6,',
  6242. ' p: $mod.a,',
  6243. ' get: function () {',
  6244. ' return this.p[this.a];',
  6245. ' },',
  6246. ' set: function (v) {',
  6247. ' this.p[this.a] = v;',
  6248. ' }',
  6249. '});'
  6250. ]));
  6251. end;
  6252. procedure TTestModule.TestArrayElementFromFuncResult_AsParams;
  6253. begin
  6254. StartProgram(false);
  6255. Add('type Integer = longint;');
  6256. Add('type TArrayInt = array of integer;');
  6257. Add('function GetArr(vB: integer = 0): tarrayint;');
  6258. Add('begin');
  6259. Add('end;');
  6260. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  6261. Add('begin');
  6262. Add('end;');
  6263. Add('begin');
  6264. Add(' doit(getarr[1+1],getarr[1+2],getarr[1+3]);');
  6265. Add(' doit(getarr()[2+1],getarr()[2+2],getarr()[2+3]);');
  6266. Add(' doit(getarr(7)[3+1],getarr(8)[3+2],getarr(9)[3+3]);');
  6267. ConvertProgram;
  6268. CheckSource('TestArrayElementFromFuncResult_AsParams',
  6269. LinesToStr([ // statements
  6270. 'this.GetArr = function (vB) {',
  6271. ' var Result = [];',
  6272. ' return Result;',
  6273. '};',
  6274. 'this.DoIt = function (vG,vH,vI) {',
  6275. '};'
  6276. ]),
  6277. LinesToStr([
  6278. '$mod.DoIt($mod.GetArr(0)[1+1],$mod.GetArr(0)[1+2],{',
  6279. ' a: 1+3,',
  6280. ' p: $mod.GetArr(0),',
  6281. ' get: function () {',
  6282. ' return this.p[this.a];',
  6283. ' },',
  6284. ' set: function (v) {',
  6285. ' this.p[this.a] = v;',
  6286. ' }',
  6287. '});',
  6288. '$mod.DoIt($mod.GetArr(0)[2+1],$mod.GetArr(0)[2+2],{',
  6289. ' a: 2+3,',
  6290. ' p: $mod.GetArr(0),',
  6291. ' get: function () {',
  6292. ' return this.p[this.a];',
  6293. ' },',
  6294. ' set: function (v) {',
  6295. ' this.p[this.a] = v;',
  6296. ' }',
  6297. '});',
  6298. '$mod.DoIt($mod.GetArr(7)[3+1],$mod.GetArr(8)[3+2],{',
  6299. ' a: 3+3,',
  6300. ' p: $mod.GetArr(9),',
  6301. ' get: function () {',
  6302. ' return this.p[this.a];',
  6303. ' },',
  6304. ' set: function (v) {',
  6305. ' this.p[this.a] = v;',
  6306. ' }',
  6307. '});',
  6308. '']));
  6309. end;
  6310. procedure TTestModule.TestArrayEnumTypeRange;
  6311. begin
  6312. StartProgram(false);
  6313. Add([
  6314. 'type',
  6315. ' TEnum = (red,blue);',
  6316. ' TEnumArray = array[TEnum] of longint;',
  6317. 'var',
  6318. ' e: TEnum;',
  6319. ' i: longint;',
  6320. ' a: TEnumArray;',
  6321. ' numbers: TEnumArray = (1,2);',
  6322. ' names: array[TEnum] of string = (''red'',''blue'');',
  6323. 'begin',
  6324. ' e:=low(a);',
  6325. ' e:=high(a);',
  6326. ' i:=a[red];',
  6327. ' a[e]:=a[e];']);
  6328. ConvertProgram;
  6329. CheckSource('TestArrayEnumTypeRange',
  6330. LinesToStr([ // statements
  6331. ' this.TEnum = {',
  6332. ' "0": "red",',
  6333. ' red: 0,',
  6334. ' "1": "blue",',
  6335. ' blue: 1',
  6336. '};',
  6337. 'this.e = 0;',
  6338. 'this.i = 0;',
  6339. 'this.a = rtl.arraySetLength(null,0,2);',
  6340. 'this.numbers = [1, 2];',
  6341. 'this.names = ["red", "blue"];',
  6342. '']),
  6343. LinesToStr([ // $mod.$main
  6344. '$mod.e = $mod.TEnum.red;',
  6345. '$mod.e = $mod.TEnum.blue;',
  6346. '$mod.i = $mod.a[$mod.TEnum.red];',
  6347. '$mod.a[$mod.e] = $mod.a[$mod.e];',
  6348. '']));
  6349. end;
  6350. procedure TTestModule.TestArray_SetLengthOutArg;
  6351. begin
  6352. StartProgram(false);
  6353. Add([
  6354. 'type TArrInt = array of longint;',
  6355. 'procedure DoIt(out a: TArrInt);',
  6356. 'begin',
  6357. ' SetLength(a,2);',
  6358. 'end;',
  6359. 'begin',
  6360. '']);
  6361. ConvertProgram;
  6362. CheckSource('TestArray_SetLengthOutArg',
  6363. LinesToStr([ // statements
  6364. 'this.DoIt = function (a) {',
  6365. ' a.set(rtl.arraySetLength(a.get(), 0, 2));',
  6366. '};',
  6367. '']),
  6368. LinesToStr([
  6369. '']));
  6370. end;
  6371. procedure TTestModule.TestArray_SetLengthProperty;
  6372. begin
  6373. StartProgram(false);
  6374. Add('type');
  6375. Add(' TArrInt = array of longint;');
  6376. Add(' TObject = class');
  6377. Add(' function GetColors: TArrInt; external name ''GetColors'';');
  6378. Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
  6379. Add(' property Colors: TArrInt read GetColors write SetColors;');
  6380. Add(' end;');
  6381. Add('var Obj: TObject;');
  6382. Add('begin');
  6383. Add(' SetLength(Obj.Colors,2);');
  6384. ConvertProgram;
  6385. CheckSource('TestArray_SetLengthProperty',
  6386. LinesToStr([ // statements
  6387. 'rtl.createClass($mod, "TObject", null, function () {',
  6388. ' this.$init = function () {',
  6389. ' };',
  6390. ' this.$final = function () {',
  6391. ' };',
  6392. '});',
  6393. 'this.Obj = null;',
  6394. '']),
  6395. LinesToStr([
  6396. '$mod.Obj.SetColors(rtl.arraySetLength($mod.Obj.GetColors(), 0, 2));',
  6397. '']));
  6398. end;
  6399. procedure TTestModule.TestArray_SetLengthMultiDim;
  6400. begin
  6401. StartProgram(false);
  6402. Add([
  6403. 'type',
  6404. ' TArrArrInt = array of array of longint;',
  6405. 'var',
  6406. ' a: TArrArrInt;',
  6407. 'begin',
  6408. ' SetLength(a,2);',
  6409. ' SetLength(a,3,4);',
  6410. '']);
  6411. ConvertProgram;
  6412. CheckSource('TestArray_SetLengthMultiDim',
  6413. LinesToStr([ // statements
  6414. 'this.a = [];']),
  6415. LinesToStr([
  6416. '$mod.a = rtl.arraySetLength($mod.a, [], 2);',
  6417. '$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
  6418. '']));
  6419. end;
  6420. procedure TTestModule.TestArray_OpenArrayOfString;
  6421. begin
  6422. StartProgram(false);
  6423. Add('procedure DoIt(const a: array of String);');
  6424. Add('var');
  6425. Add(' i: longint;');
  6426. Add(' s: string;');
  6427. Add('begin');
  6428. Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
  6429. Add('end;');
  6430. Add('var s: string;');
  6431. Add('begin');
  6432. Add(' DoIt([]);');
  6433. Add(' DoIt([s,''foo'','''',s+s]);');
  6434. ConvertProgram;
  6435. CheckSource('TestArray_OpenArrayOfString',
  6436. LinesToStr([ // statements
  6437. 'this.DoIt = function (a) {',
  6438. ' var i = 0;',
  6439. ' var s = "";',
  6440. ' for (var $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
  6441. ' i = $l1;',
  6442. ' s = a[(rtl.length(a) - i) - 1];',
  6443. ' };',
  6444. '};',
  6445. 'this.s = "";',
  6446. '']),
  6447. LinesToStr([
  6448. '$mod.DoIt([]);',
  6449. '$mod.DoIt([$mod.s, "foo", "", $mod.s + $mod.s]);',
  6450. '']));
  6451. end;
  6452. procedure TTestModule.TestArray_Concat;
  6453. begin
  6454. StartProgram(false);
  6455. Add('type');
  6456. Add(' integer = longint;');
  6457. Add(' TFlag = (big,small);');
  6458. Add(' TFlags = set of TFlag;');
  6459. Add(' TRec = record');
  6460. Add(' i: integer;');
  6461. Add(' end;');
  6462. Add(' TArrInt = array of integer;');
  6463. Add(' TArrRec = array of TRec;');
  6464. Add(' TArrSet = array of TFlags;');
  6465. Add(' TArrJSValue = array of jsvalue;');
  6466. Add('var');
  6467. Add(' ArrInt: tarrint;');
  6468. Add(' ArrRec: tarrrec;');
  6469. Add(' ArrSet: tarrset;');
  6470. Add(' ArrJSValue: tarrjsvalue;');
  6471. Add('begin');
  6472. Add(' arrint:=concat(arrint);');
  6473. Add(' arrint:=concat(arrint,arrint);');
  6474. Add(' arrint:=concat(arrint,arrint,arrint);');
  6475. Add(' arrrec:=concat(arrrec);');
  6476. Add(' arrrec:=concat(arrrec,arrrec);');
  6477. Add(' arrrec:=concat(arrrec,arrrec,arrrec);');
  6478. Add(' arrset:=concat(arrset);');
  6479. Add(' arrset:=concat(arrset,arrset);');
  6480. Add(' arrset:=concat(arrset,arrset,arrset);');
  6481. Add(' arrjsvalue:=concat(arrjsvalue);');
  6482. Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue);');
  6483. Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);');
  6484. ConvertProgram;
  6485. CheckSource('TestArray_Concat',
  6486. LinesToStr([ // statements
  6487. 'this.TFlag = {',
  6488. ' "0": "big",',
  6489. ' big: 0,',
  6490. ' "1": "small",',
  6491. ' small: 1',
  6492. '};',
  6493. 'this.TRec = function (s) {',
  6494. ' if (s) {',
  6495. ' this.i = s.i;',
  6496. ' } else {',
  6497. ' this.i = 0;',
  6498. ' };',
  6499. ' this.$equal = function (b) {',
  6500. ' return this.i === b.i;',
  6501. ' };',
  6502. '};',
  6503. 'this.ArrInt = [];',
  6504. 'this.ArrRec = [];',
  6505. 'this.ArrSet = [];',
  6506. 'this.ArrJSValue = [];',
  6507. '']),
  6508. LinesToStr([ // $mod.$main
  6509. '$mod.ArrInt = $mod.ArrInt;',
  6510. '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt);',
  6511. '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt,$mod.ArrInt);',
  6512. '$mod.ArrRec = $mod.ArrRec;',
  6513. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec);',
  6514. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
  6515. '$mod.ArrSet = $mod.ArrSet;',
  6516. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet);',
  6517. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
  6518. '$mod.ArrJSValue = $mod.ArrJSValue;',
  6519. '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue);',
  6520. '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue, $mod.ArrJSValue);',
  6521. '']));
  6522. end;
  6523. procedure TTestModule.TestArray_Copy;
  6524. begin
  6525. StartProgram(false);
  6526. Add('type');
  6527. Add(' integer = longint;');
  6528. Add(' TFlag = (big,small);');
  6529. Add(' TFlags = set of TFlag;');
  6530. Add(' TRec = record');
  6531. Add(' i: integer;');
  6532. Add(' end;');
  6533. Add(' TArrInt = array of integer;');
  6534. Add(' TArrRec = array of TRec;');
  6535. Add(' TArrSet = array of TFlags;');
  6536. Add(' TArrJSValue = array of jsvalue;');
  6537. Add('var');
  6538. Add(' ArrInt: tarrint;');
  6539. Add(' ArrRec: tarrrec;');
  6540. Add(' ArrSet: tarrset;');
  6541. Add(' ArrJSValue: tarrjsvalue;');
  6542. Add('begin');
  6543. Add(' arrint:=copy(arrint);');
  6544. Add(' arrint:=copy(arrint,2);');
  6545. Add(' arrint:=copy(arrint,3,4);');
  6546. Add(' arrrec:=copy(arrrec);');
  6547. Add(' arrrec:=copy(arrrec,5);');
  6548. Add(' arrrec:=copy(arrrec,6,7);');
  6549. Add(' arrset:=copy(arrset);');
  6550. Add(' arrset:=copy(arrset,8);');
  6551. Add(' arrset:=copy(arrset,9,10);');
  6552. Add(' arrjsvalue:=copy(arrjsvalue);');
  6553. Add(' arrjsvalue:=copy(arrjsvalue,11);');
  6554. Add(' arrjsvalue:=copy(arrjsvalue,12,13);');
  6555. ConvertProgram;
  6556. CheckSource('TestArray_Copy',
  6557. LinesToStr([ // statements
  6558. 'this.TFlag = {',
  6559. ' "0": "big",',
  6560. ' big: 0,',
  6561. ' "1": "small",',
  6562. ' small: 1',
  6563. '};',
  6564. 'this.TRec = function (s) {',
  6565. ' if (s) {',
  6566. ' this.i = s.i;',
  6567. ' } else {',
  6568. ' this.i = 0;',
  6569. ' };',
  6570. ' this.$equal = function (b) {',
  6571. ' return this.i === b.i;',
  6572. ' };',
  6573. '};',
  6574. 'this.ArrInt = [];',
  6575. 'this.ArrRec = [];',
  6576. 'this.ArrSet = [];',
  6577. 'this.ArrJSValue = [];',
  6578. '']),
  6579. LinesToStr([ // $mod.$main
  6580. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 0);',
  6581. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 2);',
  6582. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 3, 4);',
  6583. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 0);',
  6584. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 5);',
  6585. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 6, 7);',
  6586. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 0);',
  6587. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 8);',
  6588. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 9, 10);',
  6589. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 0);',
  6590. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 11);',
  6591. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 12, 13);',
  6592. '']));
  6593. end;
  6594. procedure TTestModule.TestArray_InsertDelete;
  6595. begin
  6596. StartProgram(false);
  6597. Add('type');
  6598. Add(' integer = longint;');
  6599. Add(' TFlag = (big,small);');
  6600. Add(' TFlags = set of TFlag;');
  6601. Add(' TRec = record');
  6602. Add(' i: integer;');
  6603. Add(' end;');
  6604. Add(' TArrInt = array of integer;');
  6605. Add(' TArrRec = array of TRec;');
  6606. Add(' TArrSet = array of TFlags;');
  6607. Add(' TArrJSValue = array of jsvalue;');
  6608. Add('var');
  6609. Add(' ArrInt: tarrint;');
  6610. Add(' ArrRec: tarrrec;');
  6611. Add(' ArrSet: tarrset;');
  6612. Add(' ArrJSValue: tarrjsvalue;');
  6613. Add('begin');
  6614. Add(' Insert(1,arrint,2);');
  6615. Add(' Insert(arrint[3],arrint,4);');
  6616. Add(' Insert(arrrec[5],arrrec,6);');
  6617. Add(' Insert(arrset[7],arrset,7);');
  6618. Add(' Insert(arrjsvalue[8],arrjsvalue,9);');
  6619. Add(' Insert(10,arrjsvalue,11);');
  6620. Add(' Delete(arrint,12,13);');
  6621. Add(' Delete(arrrec,14,15);');
  6622. Add(' Delete(arrset,17,18);');
  6623. Add(' Delete(arrjsvalue,19,10);');
  6624. ConvertProgram;
  6625. CheckSource('TestArray_InsertDelete',
  6626. LinesToStr([ // statements
  6627. 'this.TFlag = {',
  6628. ' "0": "big",',
  6629. ' big: 0,',
  6630. ' "1": "small",',
  6631. ' small: 1',
  6632. '};',
  6633. 'this.TRec = function (s) {',
  6634. ' if (s) {',
  6635. ' this.i = s.i;',
  6636. ' } else {',
  6637. ' this.i = 0;',
  6638. ' };',
  6639. ' this.$equal = function (b) {',
  6640. ' return this.i === b.i;',
  6641. ' };',
  6642. '};',
  6643. 'this.ArrInt = [];',
  6644. 'this.ArrRec = [];',
  6645. 'this.ArrSet = [];',
  6646. 'this.ArrJSValue = [];',
  6647. '']),
  6648. LinesToStr([ // $mod.$main
  6649. '$mod.ArrInt.splice(2, 0, 1);',
  6650. '$mod.ArrInt.splice(4, 0, $mod.ArrInt[3]);',
  6651. '$mod.ArrRec.splice(6, 0, $mod.ArrRec[5]);',
  6652. '$mod.ArrSet.splice(7, 0, $mod.ArrSet[7]);',
  6653. '$mod.ArrJSValue.splice(9, 0, $mod.ArrJSValue[8]);',
  6654. '$mod.ArrJSValue.splice(11, 0, 10);',
  6655. '$mod.ArrInt.splice(12, 13);',
  6656. '$mod.ArrRec.splice(14, 15);',
  6657. '$mod.ArrSet.splice(17, 18);',
  6658. '$mod.ArrJSValue.splice(19, 10);',
  6659. '']));
  6660. end;
  6661. procedure TTestModule.TestArray_DynArrayConst;
  6662. begin
  6663. StartProgram(false);
  6664. Add([
  6665. 'type',
  6666. ' integer = longint;',
  6667. ' TArrInt = array of integer;',
  6668. ' TArrStr = array of string;',
  6669. 'const',
  6670. ' Ints: TArrInt = (1,2,3);',
  6671. ' Names: array of string = (''a'',''foo'');',
  6672. ' Aliases: TarrStr = (''foo'',''b'');',
  6673. ' OneInt: TArrInt = (7);',
  6674. ' OneStr: array of integer = (7);',
  6675. //' Chars: array of char = ''aoc'';',
  6676. ' NameCount = low(Names)+high(Names)+length(Names);',
  6677. 'begin',
  6678. '']);
  6679. ConvertProgram;
  6680. CheckSource('TestArray_DynArrayConst',
  6681. LinesToStr([ // statements
  6682. 'this.Ints = [1, 2, 3];',
  6683. 'this.Names = ["a", "foo"];',
  6684. 'this.Aliases = ["foo", "b"];',
  6685. 'this.OneInt = [7];',
  6686. 'this.OneStr = [7];',
  6687. 'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
  6688. '']),
  6689. LinesToStr([ // $mod.$main
  6690. '']));
  6691. end;
  6692. procedure TTestModule.TestExternalClass_TypeCastArrayToExternalArray;
  6693. begin
  6694. StartProgram(false);
  6695. Add([
  6696. '{$modeswitch externalclass}',
  6697. 'type',
  6698. ' TJSArray = class external name ''Array''',
  6699. ' class function isArray(Value: JSValue) : boolean;',
  6700. ' function concat() : TJSArray; varargs;',
  6701. ' end;',
  6702. 'var',
  6703. ' aObj: TJSArray;',
  6704. ' a: array of longint;',
  6705. 'begin',
  6706. ' if TJSArray.isArray(65) then ;',
  6707. ' aObj:=TJSArray(a).concat(a);']);
  6708. ConvertProgram;
  6709. CheckSource('TestExternalClass_TypeCastArrayToExternalArray',
  6710. LinesToStr([ // statements
  6711. 'this.aObj = null;',
  6712. 'this.a = [];',
  6713. '']),
  6714. LinesToStr([ // $mod.$main
  6715. 'if (Array.isArray(65)) ;',
  6716. '$mod.aObj = $mod.a.concat($mod.a);',
  6717. '']));
  6718. end;
  6719. procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalArray;
  6720. begin
  6721. StartProgram(false);
  6722. Add('{$modeswitch externalclass}');
  6723. Add('type');
  6724. Add(' TArrStr = array of string;');
  6725. Add(' TJSArray = class external name ''Array''');
  6726. Add(' end;');
  6727. Add('var');
  6728. Add(' aObj: TJSArray;');
  6729. Add(' a: TArrStr;');
  6730. Add('begin');
  6731. Add(' a:=TArrStr(aObj);');
  6732. Add(' TArrStr(aObj)[1]:=TArrStr(aObj)[2];');
  6733. ConvertProgram;
  6734. CheckSource('TestExternalClass_TypeCastArrayFromExternalArray',
  6735. LinesToStr([ // statements
  6736. 'this.aObj = null;',
  6737. 'this.a = [];',
  6738. '']),
  6739. LinesToStr([ // $mod.$main
  6740. '$mod.a = $mod.aObj;',
  6741. '$mod.aObj[1] = $mod.aObj[2];',
  6742. '']));
  6743. end;
  6744. procedure TTestModule.TestRecord_Empty;
  6745. begin
  6746. StartProgram(false);
  6747. Add(['type',
  6748. ' TRecA = record',
  6749. ' end;',
  6750. 'var a,b: TRecA;',
  6751. 'begin',
  6752. ' if a=b then ;']);
  6753. ConvertProgram;
  6754. CheckSource('TestRecord_Empty',
  6755. LinesToStr([ // statements
  6756. 'this.TRecA = function (s) {',
  6757. ' this.$equal = function (b) {',
  6758. ' return true;',
  6759. ' };',
  6760. '};',
  6761. 'this.a = new $mod.TRecA();',
  6762. 'this.b = new $mod.TRecA();'
  6763. ]),
  6764. LinesToStr([ // $mod.$main
  6765. 'if ($mod.a.$equal($mod.b)) ;'
  6766. ]));
  6767. end;
  6768. procedure TTestModule.TestRecord_Var;
  6769. begin
  6770. StartProgram(false);
  6771. Add('type');
  6772. Add(' TRecA = record');
  6773. Add(' Bold: longint;');
  6774. Add(' end;');
  6775. Add('var Rec: TRecA;');
  6776. Add('begin');
  6777. Add(' rec.bold:=123');
  6778. ConvertProgram;
  6779. CheckSource('TestRecord_Var',
  6780. LinesToStr([ // statements
  6781. 'this.TRecA = function (s) {',
  6782. ' if (s) {',
  6783. ' this.Bold = s.Bold;',
  6784. ' } else {',
  6785. ' this.Bold = 0;',
  6786. ' };',
  6787. ' this.$equal = function (b) {',
  6788. ' return this.Bold === b.Bold;',
  6789. ' };',
  6790. '};',
  6791. 'this.Rec = new $mod.TRecA();'
  6792. ]),
  6793. LinesToStr([ // $mod.$main
  6794. '$mod.Rec.Bold = 123;'
  6795. ]));
  6796. end;
  6797. procedure TTestModule.TestWithRecordDo;
  6798. begin
  6799. StartProgram(false);
  6800. Add('type');
  6801. Add(' TRec = record');
  6802. Add(' vI: longint;');
  6803. Add(' end;');
  6804. Add('var');
  6805. Add(' Int: longint;');
  6806. Add(' r: TRec;');
  6807. Add('begin');
  6808. Add(' with r do');
  6809. Add(' int:=vi;');
  6810. Add(' with r do begin');
  6811. Add(' int:=vi;');
  6812. Add(' vi:=int;');
  6813. Add(' end;');
  6814. ConvertProgram;
  6815. CheckSource('TestWithRecordDo',
  6816. LinesToStr([ // statements
  6817. 'this.TRec = function (s) {',
  6818. ' if (s) {',
  6819. ' this.vI = s.vI;',
  6820. ' } else {',
  6821. ' this.vI = 0;',
  6822. ' };',
  6823. ' this.$equal = function (b) {',
  6824. ' return this.vI === b.vI;',
  6825. ' };',
  6826. '};',
  6827. 'this.Int = 0;',
  6828. 'this.r = new $mod.TRec();'
  6829. ]),
  6830. LinesToStr([ // $mod.$main
  6831. 'var $with1 = $mod.r;',
  6832. '$mod.Int = $with1.vI;',
  6833. 'var $with2 = $mod.r;',
  6834. '$mod.Int = $with2.vI;',
  6835. '$with2.vI = $mod.Int;'
  6836. ]));
  6837. end;
  6838. procedure TTestModule.TestRecord_Assign;
  6839. begin
  6840. StartProgram(false);
  6841. Add('type');
  6842. Add(' TEnum = (red,green);');
  6843. Add(' TEnums = set of TEnum;');
  6844. Add(' TSmallRec = record');
  6845. Add(' N: longint;');
  6846. Add(' end;');
  6847. Add(' TBigRec = record');
  6848. Add(' Int: longint;');
  6849. Add(' D: double;');
  6850. Add(' Arr: array of longint;');
  6851. Add(' Arr2: array[1..2] of longint;');
  6852. Add(' Small: TSmallRec;');
  6853. Add(' Enums: TEnums;');
  6854. Add(' end;');
  6855. Add('var');
  6856. Add(' r, s: TBigRec;');
  6857. Add('begin');
  6858. Add(' r:=s;');
  6859. ConvertProgram;
  6860. CheckSource('TestRecord_Assign',
  6861. LinesToStr([ // statements
  6862. 'this.TEnum = {',
  6863. ' "0": "red",',
  6864. ' red: 0,',
  6865. ' "1": "green",',
  6866. ' green: 1',
  6867. '};',
  6868. 'this.TSmallRec = function (s) {',
  6869. ' if(s){',
  6870. ' this.N = s.N;',
  6871. ' } else {',
  6872. ' this.N = 0;',
  6873. ' };',
  6874. ' this.$equal = function (b) {',
  6875. ' return this.N === b.N;',
  6876. ' };',
  6877. '};',
  6878. 'this.TBigRec = function (s) {',
  6879. ' if(s){',
  6880. ' this.Int = s.Int;',
  6881. ' this.D = s.D;',
  6882. ' this.Arr = s.Arr;',
  6883. ' this.Arr2 = s.Arr2.slice(0);',
  6884. ' this.Small = new $mod.TSmallRec(s.Small);',
  6885. ' this.Enums = rtl.refSet(s.Enums);',
  6886. ' } else {',
  6887. ' this.Int = 0;',
  6888. ' this.D = 0.0;',
  6889. ' this.Arr = [];',
  6890. ' this.Arr2 = rtl.arraySetLength(null, 0, 2);',
  6891. ' this.Small = new $mod.TSmallRec();',
  6892. ' this.Enums = {};',
  6893. ' };',
  6894. ' this.$equal = function (b) {',
  6895. ' return (this.Int === b.Int) && ((this.D === b.D) && ((this.Arr === b.Arr)',
  6896. ' && ((this.Arr2 === b.Arr2)',
  6897. ' && (this.Small.$equal(b.Small) && rtl.eqSet(this.Enums, b.Enums)))));',
  6898. ' };',
  6899. '};',
  6900. 'this.r = new $mod.TBigRec();',
  6901. 'this.s = new $mod.TBigRec();'
  6902. ]),
  6903. LinesToStr([ // $mod.$main
  6904. '$mod.r = new $mod.TBigRec($mod.s);',
  6905. '']));
  6906. end;
  6907. procedure TTestModule.TestRecord_PassAsArgClone;
  6908. begin
  6909. StartProgram(false);
  6910. Add('type');
  6911. Add(' TRecA = record');
  6912. Add(' Bold: longint;');
  6913. Add(' end;');
  6914. Add('procedure DoDefault(r: treca); begin end;');
  6915. Add('procedure DoConst(const r: treca); begin end;');
  6916. Add('var Rec: treca;');
  6917. Add('begin');
  6918. Add(' dodefault(rec);');
  6919. Add(' doconst(rec);');
  6920. ConvertProgram;
  6921. CheckSource('TestRecord_PassAsArgClone',
  6922. LinesToStr([ // statements
  6923. 'this.TRecA = function (s) {',
  6924. ' if (s) {',
  6925. ' this.Bold = s.Bold;',
  6926. ' } else {',
  6927. ' this.Bold = 0;',
  6928. ' };',
  6929. ' this.$equal = function (b) {',
  6930. ' return this.Bold === b.Bold;',
  6931. ' };',
  6932. '};',
  6933. 'this.DoDefault = function (r) {',
  6934. '};',
  6935. 'this.DoConst = function (r) {',
  6936. '};',
  6937. 'this.Rec = new $mod.TRecA();'
  6938. ]),
  6939. LinesToStr([ // $mod.$main
  6940. '$mod.DoDefault(new $mod.TRecA($mod.Rec));',
  6941. '$mod.DoConst($mod.Rec);',
  6942. '']));
  6943. end;
  6944. procedure TTestModule.TestRecord_AsParams;
  6945. begin
  6946. StartProgram(false);
  6947. Add('type');
  6948. Add(' integer = longint;');
  6949. Add(' TRecord = record');
  6950. Add(' i: integer;');
  6951. Add(' end;');
  6952. Add('procedure DoIt(vG: TRecord; const vH: TRecord; var vI: TRecord);');
  6953. Add('var vJ: TRecord;');
  6954. Add('begin');
  6955. Add(' vg:=vg;');
  6956. Add(' vj:=vh;');
  6957. Add(' vi:=vi;');
  6958. Add(' doit(vg,vg,vg);');
  6959. Add(' doit(vh,vh,vj);');
  6960. Add(' doit(vi,vi,vi);');
  6961. Add(' doit(vj,vj,vj);');
  6962. Add('end;');
  6963. Add('var i: TRecord;');
  6964. Add('begin');
  6965. Add(' doit(i,i,i);');
  6966. ConvertProgram;
  6967. CheckSource('TestRecord_AsParams',
  6968. LinesToStr([ // statements
  6969. 'this.TRecord = function (s) {',
  6970. ' if (s) {',
  6971. ' this.i = s.i;',
  6972. ' } else {',
  6973. ' this.i = 0;',
  6974. ' };',
  6975. ' this.$equal = function (b) {',
  6976. ' return this.i === b.i;',
  6977. ' };',
  6978. '};',
  6979. 'this.DoIt = function (vG,vH,vI) {',
  6980. ' var vJ = new $mod.TRecord();',
  6981. ' vG = new $mod.TRecord(vG);',
  6982. ' vJ = new $mod.TRecord(vH);',
  6983. ' vI.set(new $mod.TRecord(vI.get()));',
  6984. ' $mod.DoIt(new $mod.TRecord(vG), vG, {',
  6985. ' get: function () {',
  6986. ' return vG;',
  6987. ' },',
  6988. ' set: function (v) {',
  6989. ' vG = v;',
  6990. ' }',
  6991. ' });',
  6992. ' $mod.DoIt(new $mod.TRecord(vH), vH, {',
  6993. ' get: function () {',
  6994. ' return vJ;',
  6995. ' },',
  6996. ' set: function (v) {',
  6997. ' vJ = v;',
  6998. ' }',
  6999. ' });',
  7000. ' $mod.DoIt(new $mod.TRecord(vI.get()), vI.get(), vI);',
  7001. ' $mod.DoIt(new $mod.TRecord(vJ), vJ, {',
  7002. ' get: function () {',
  7003. ' return vJ;',
  7004. ' },',
  7005. ' set: function (v) {',
  7006. ' vJ = v;',
  7007. ' }',
  7008. ' });',
  7009. '};',
  7010. 'this.i = new $mod.TRecord();'
  7011. ]),
  7012. LinesToStr([
  7013. '$mod.DoIt(new $mod.TRecord($mod.i),$mod.i,{',
  7014. ' p: $mod,',
  7015. ' get: function () {',
  7016. ' return this.p.i;',
  7017. ' },',
  7018. ' set: function (v) {',
  7019. ' this.p.i = v;',
  7020. ' }',
  7021. '});'
  7022. ]));
  7023. end;
  7024. procedure TTestModule.TestRecordElement_AsParams;
  7025. begin
  7026. StartProgram(false);
  7027. Add('type');
  7028. Add(' integer = longint;');
  7029. Add(' TRecord = record');
  7030. Add(' i: integer;');
  7031. Add(' end;');
  7032. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  7033. Add('var vJ: TRecord;');
  7034. Add('begin');
  7035. Add(' doit(vj.i,vj.i,vj.i);');
  7036. Add('end;');
  7037. Add('var r: TRecord;');
  7038. Add('begin');
  7039. Add(' doit(r.i,r.i,r.i);');
  7040. ConvertProgram;
  7041. CheckSource('TestRecordElement_AsParams',
  7042. LinesToStr([ // statements
  7043. 'this.TRecord = function (s) {',
  7044. ' if (s) {',
  7045. ' this.i = s.i;',
  7046. ' } else {',
  7047. ' this.i = 0;',
  7048. ' };',
  7049. ' this.$equal = function (b) {',
  7050. ' return this.i === b.i;',
  7051. ' };',
  7052. '};',
  7053. 'this.DoIt = function (vG,vH,vI) {',
  7054. ' var vJ = new $mod.TRecord();',
  7055. ' $mod.DoIt(vJ.i, vJ.i, {',
  7056. ' p: vJ,',
  7057. ' get: function () {',
  7058. ' return this.p.i;',
  7059. ' },',
  7060. ' set: function (v) {',
  7061. ' this.p.i = v;',
  7062. ' }',
  7063. ' });',
  7064. '};',
  7065. 'this.r = new $mod.TRecord();'
  7066. ]),
  7067. LinesToStr([
  7068. '$mod.DoIt($mod.r.i,$mod.r.i,{',
  7069. ' p: $mod.r,',
  7070. ' get: function () {',
  7071. ' return this.p.i;',
  7072. ' },',
  7073. ' set: function (v) {',
  7074. ' this.p.i = v;',
  7075. ' }',
  7076. '});'
  7077. ]));
  7078. end;
  7079. procedure TTestModule.TestRecordElementFromFuncResult_AsParams;
  7080. begin
  7081. StartProgram(false);
  7082. Add('type');
  7083. Add(' integer = longint;');
  7084. Add(' TRecord = record');
  7085. Add(' i: integer;');
  7086. Add(' end;');
  7087. Add('function GetRec(vB: integer = 0): TRecord;');
  7088. Add('begin');
  7089. Add('end;');
  7090. Add('procedure DoIt(vG: integer; const vH: integer);');
  7091. Add('begin');
  7092. Add('end;');
  7093. Add('begin');
  7094. Add(' doit(getrec.i,getrec.i);');
  7095. Add(' doit(getrec().i,getrec().i);');
  7096. Add(' doit(getrec(1).i,getrec(2).i);');
  7097. ConvertProgram;
  7098. CheckSource('TestRecordElementFromFuncResult_AsParams',
  7099. LinesToStr([ // statements
  7100. 'this.TRecord = function (s) {',
  7101. ' if (s) {',
  7102. ' this.i = s.i;',
  7103. ' } else {',
  7104. ' this.i = 0;',
  7105. ' };',
  7106. ' this.$equal = function (b) {',
  7107. ' return this.i === b.i;',
  7108. ' };',
  7109. '};',
  7110. 'this.GetRec = function (vB) {',
  7111. ' var Result = new $mod.TRecord();',
  7112. ' return Result;',
  7113. '};',
  7114. 'this.DoIt = function (vG,vH) {',
  7115. '};'
  7116. ]),
  7117. LinesToStr([
  7118. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  7119. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  7120. '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);',
  7121. '']));
  7122. end;
  7123. procedure TTestModule.TestRecordElementFromWith_AsParams;
  7124. begin
  7125. StartProgram(false);
  7126. Add('type');
  7127. Add(' integer = longint;');
  7128. Add(' TRecord = record');
  7129. Add(' i: integer;');
  7130. Add(' end;');
  7131. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  7132. Add('begin');
  7133. Add('end;');
  7134. Add('var r: trecord;');
  7135. Add('begin');
  7136. Add(' with r do ');
  7137. Add(' doit(i,i,i);');
  7138. ConvertProgram;
  7139. CheckSource('TestRecordElementFromWith_AsParams',
  7140. LinesToStr([ // statements
  7141. 'this.TRecord = function (s) {',
  7142. ' if (s) {',
  7143. ' this.i = s.i;',
  7144. ' } else {',
  7145. ' this.i = 0;',
  7146. ' };',
  7147. ' this.$equal = function (b) {',
  7148. ' return this.i === b.i;',
  7149. ' };',
  7150. '};',
  7151. 'this.DoIt = function (vG,vH,vI) {',
  7152. '};',
  7153. 'this.r = new $mod.TRecord();'
  7154. ]),
  7155. LinesToStr([
  7156. 'var $with1 = $mod.r;',
  7157. '$mod.DoIt($with1.i,$with1.i,{',
  7158. ' p: $with1,',
  7159. ' get: function () {',
  7160. ' return this.p.i;',
  7161. ' },',
  7162. ' set: function (v) {',
  7163. ' this.p.i = v;',
  7164. ' }',
  7165. '});',
  7166. '']));
  7167. end;
  7168. procedure TTestModule.TestRecord_Equal;
  7169. begin
  7170. StartProgram(false);
  7171. Add('type');
  7172. Add(' integer = longint;');
  7173. Add(' TFlag = (red,blue);');
  7174. Add(' TFlags = set of TFlag;');
  7175. Add(' TProc = procedure;');
  7176. Add(' TRecord = record');
  7177. Add(' i: integer;');
  7178. Add(' Event: TProc;');
  7179. Add(' f: TFlags;');
  7180. Add(' end;');
  7181. Add(' TNested = record');
  7182. Add(' r: TRecord;');
  7183. Add(' end;');
  7184. Add('var');
  7185. Add(' b: boolean;');
  7186. Add(' r,s: trecord;');
  7187. Add('begin');
  7188. Add(' b:=r=s;');
  7189. Add(' b:=r<>s;');
  7190. ConvertProgram;
  7191. CheckSource('TestRecord_Equal',
  7192. LinesToStr([ // statements
  7193. 'this.TFlag = {',
  7194. ' "0": "red",',
  7195. ' red: 0,',
  7196. ' "1": "blue",',
  7197. ' blue: 1',
  7198. '};',
  7199. 'this.TRecord = function (s) {',
  7200. ' if (s) {',
  7201. ' this.i = s.i;',
  7202. ' this.Event = s.Event;',
  7203. ' this.f = rtl.refSet(s.f);',
  7204. ' } else {',
  7205. ' this.i = 0;',
  7206. ' this.Event = null;',
  7207. ' this.f = {};',
  7208. ' };',
  7209. ' this.$equal = function (b) {',
  7210. ' return (this.i === b.i) && (rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f));',
  7211. ' };',
  7212. '};',
  7213. 'this.TNested = function (s) {',
  7214. ' if (s) {',
  7215. ' this.r = new $mod.TRecord(s.r);',
  7216. ' } else {',
  7217. ' this.r = new $mod.TRecord();',
  7218. ' };',
  7219. ' this.$equal = function (b) {',
  7220. ' return this.r.$equal(b.r);',
  7221. ' };',
  7222. '};',
  7223. 'this.b = false;',
  7224. 'this.r = new $mod.TRecord();',
  7225. 'this.s = new $mod.TRecord();'
  7226. ]),
  7227. LinesToStr([
  7228. '$mod.b = $mod.r.$equal($mod.s);',
  7229. '$mod.b = !$mod.r.$equal($mod.s);',
  7230. '']));
  7231. end;
  7232. procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
  7233. begin
  7234. StartProgram(false);
  7235. Add('type');
  7236. Add(' TRecord = record');
  7237. Add(' i: longint;');
  7238. Add(' end;');
  7239. Add('var');
  7240. Add(' Jv: jsvalue;');
  7241. Add(' Rec: trecord;');
  7242. Add('begin');
  7243. Add(' rec:=trecord(jv);');
  7244. ConvertProgram;
  7245. CheckSource('TestRecord_TypeCastJSValueToRecord',
  7246. LinesToStr([ // statements
  7247. 'this.TRecord = function (s) {',
  7248. ' if (s) {',
  7249. ' this.i = s.i;',
  7250. ' } else {',
  7251. ' this.i = 0;',
  7252. ' };',
  7253. ' this.$equal = function (b) {',
  7254. ' return this.i === b.i;',
  7255. ' };',
  7256. '};',
  7257. 'this.Jv = undefined;',
  7258. 'this.Rec = new $mod.TRecord();'
  7259. ]),
  7260. LinesToStr([
  7261. '$mod.Rec = new $mod.TRecord(rtl.getObject($mod.Jv));',
  7262. '']));
  7263. end;
  7264. procedure TTestModule.TestRecord_VariantFail;
  7265. begin
  7266. StartProgram(false);
  7267. Add([
  7268. 'type',
  7269. ' TRec = record',
  7270. ' case word of',
  7271. ' 0: (b0, b1: Byte);',
  7272. ' 1: (i: word);',
  7273. ' end;',
  7274. 'begin']);
  7275. SetExpectedPasResolverError('variant record is not supported',
  7276. nXIsNotSupported);
  7277. ConvertProgram;
  7278. end;
  7279. procedure TTestModule.TestClass_TObjectDefaultConstructor;
  7280. begin
  7281. StartProgram(false);
  7282. Add('type');
  7283. Add(' TObject = class');
  7284. Add(' public');
  7285. Add(' constructor Create;');
  7286. Add(' destructor Destroy;');
  7287. Add(' end;');
  7288. Add(' TBird = TObject;');
  7289. Add('constructor tobject.create;');
  7290. Add('begin end;');
  7291. Add('destructor tobject.destroy;');
  7292. Add('begin end;');
  7293. Add('var Obj: tobject;');
  7294. Add('begin');
  7295. Add(' obj:=tobject.create;');
  7296. Add(' obj:=tbird.create;');
  7297. Add(' obj.destroy;');
  7298. ConvertProgram;
  7299. CheckSource('TestClass_TObjectDefaultConstructor',
  7300. LinesToStr([ // statements
  7301. 'rtl.createClass($mod,"TObject",null,function(){',
  7302. ' this.$init = function () {',
  7303. ' };',
  7304. ' this.$final = function () {',
  7305. ' };',
  7306. ' this.Create = function(){',
  7307. ' };',
  7308. ' this.Destroy = function(){',
  7309. ' };',
  7310. '});',
  7311. 'this.Obj = null;'
  7312. ]),
  7313. LinesToStr([ // $mod.$main
  7314. '$mod.Obj = $mod.TObject.$create("Create");',
  7315. '$mod.Obj = $mod.TObject.$create("Create");',
  7316. '$mod.Obj.$destroy("Destroy");',
  7317. '']));
  7318. end;
  7319. procedure TTestModule.TestClass_TObjectConstructorWithParams;
  7320. begin
  7321. StartProgram(false);
  7322. Add('type');
  7323. Add(' TObject = class');
  7324. Add(' public');
  7325. Add(' constructor Create(Par: longint);');
  7326. Add(' end;');
  7327. Add('constructor tobject.create(par: longint);');
  7328. Add('begin end;');
  7329. Add('var Obj: tobject;');
  7330. Add('begin');
  7331. Add(' obj:=tobject.create(3);');
  7332. ConvertProgram;
  7333. CheckSource('TestClass_TObjectConstructorWithParams',
  7334. LinesToStr([ // statements
  7335. 'rtl.createClass($mod,"TObject",null,function(){',
  7336. ' this.$init = function () {',
  7337. ' };',
  7338. ' this.$final = function () {',
  7339. ' };',
  7340. ' this.Create = function(Par){',
  7341. ' };',
  7342. '});',
  7343. 'this.Obj = null;'
  7344. ]),
  7345. LinesToStr([ // $mod.$main
  7346. '$mod.Obj = $mod.TObject.$create("Create",[3]);'
  7347. ]));
  7348. end;
  7349. procedure TTestModule.TestClass_TObjectConstructorWithDefaultParam;
  7350. begin
  7351. StartProgram(false);
  7352. Add('type');
  7353. Add(' TObject = class');
  7354. Add(' public');
  7355. Add(' constructor Create;');
  7356. Add(' end;');
  7357. Add(' TTest = class(TObject)');
  7358. Add(' public');
  7359. Add(' constructor Create(const Par: longint = 1);');
  7360. Add(' end;');
  7361. Add('constructor tobject.create;');
  7362. Add('begin end;');
  7363. Add('constructor ttest.create(const par: longint);');
  7364. Add('begin end;');
  7365. Add('var t: ttest;');
  7366. Add('begin');
  7367. Add(' t:=ttest.create;');
  7368. Add(' t:=ttest.create(2);');
  7369. ConvertProgram;
  7370. CheckSource('TestClass_TObjectConstructorWithDefaultParam',
  7371. LinesToStr([ // statements
  7372. 'rtl.createClass($mod,"TObject",null,function(){',
  7373. ' this.$init = function () {',
  7374. ' };',
  7375. ' this.$final = function () {',
  7376. ' };',
  7377. ' this.Create = function(){',
  7378. ' };',
  7379. '});',
  7380. 'rtl.createClass($mod, "TTest", $mod.TObject, function () {',
  7381. ' this.Create$1 = function (Par) {',
  7382. ' };',
  7383. '});',
  7384. 'this.t = null;'
  7385. ]),
  7386. LinesToStr([ // $mod.$main
  7387. '$mod.t = $mod.TTest.$create("Create$1", [1]);',
  7388. '$mod.t = $mod.TTest.$create("Create$1", [2]);'
  7389. ]));
  7390. end;
  7391. procedure TTestModule.TestClass_Var;
  7392. begin
  7393. StartProgram(false);
  7394. Add('type');
  7395. Add(' TObject = class');
  7396. Add(' public');
  7397. Add(' vI: longint;');
  7398. Add(' constructor Create(Par: longint);');
  7399. Add(' end;');
  7400. Add('constructor tobject.create(par: longint);');
  7401. Add('begin');
  7402. Add(' vi:=par+3');
  7403. Add('end;');
  7404. Add('var Obj: tobject;');
  7405. Add('begin');
  7406. Add(' obj:=tobject.create(4);');
  7407. Add(' obj.vi:=obj.VI+5;');
  7408. ConvertProgram;
  7409. CheckSource('TestClass_Var',
  7410. LinesToStr([ // statements
  7411. 'rtl.createClass($mod,"TObject",null,function(){',
  7412. ' this.$init = function () {',
  7413. ' this.vI = 0;',
  7414. ' };',
  7415. ' this.$final = function () {',
  7416. ' };',
  7417. ' this.Create = function(Par){',
  7418. ' this.vI = Par+3;',
  7419. ' };',
  7420. '});',
  7421. 'this.Obj = null;'
  7422. ]),
  7423. LinesToStr([ // $mod.$main
  7424. '$mod.Obj = $mod.TObject.$create("Create",[4]);',
  7425. '$mod.Obj.vI = $mod.Obj.vI + 5;'
  7426. ]));
  7427. end;
  7428. procedure TTestModule.TestClass_Method;
  7429. begin
  7430. StartProgram(false);
  7431. Add('type');
  7432. Add(' TObject = class');
  7433. Add(' public');
  7434. Add(' vI: longint;');
  7435. Add(' Sub: TObject;');
  7436. Add(' constructor Create;');
  7437. Add(' function GetIt(Par: longint): tobject;');
  7438. Add(' end;');
  7439. Add('constructor tobject.create; begin end;');
  7440. Add('function tobject.getit(par: longint): tobject;');
  7441. Add('begin');
  7442. Add(' Self.vi:=par+3;');
  7443. Add(' Result:=self.sub;');
  7444. Add('end;');
  7445. Add('var Obj: tobject;');
  7446. Add('begin');
  7447. Add(' obj:=tobject.create;');
  7448. Add(' obj.getit(4);');
  7449. Add(' obj.sub.sub:=nil;');
  7450. Add(' obj.sub.getit(5);');
  7451. Add(' obj.sub.getit(6).SUB:=nil;');
  7452. Add(' obj.sub.getit(7).GETIT(8);');
  7453. Add(' obj.sub.getit(9).SuB.getit(10);');
  7454. ConvertProgram;
  7455. CheckSource('TestClass_Method',
  7456. LinesToStr([ // statements
  7457. 'rtl.createClass($mod,"TObject",null,function(){',
  7458. ' this.$init = function () {',
  7459. ' this.vI = 0;',
  7460. ' this.Sub = null;',
  7461. ' };',
  7462. ' this.$final = function () {',
  7463. ' this.Sub = undefined;',
  7464. ' };',
  7465. ' this.Create = function(){',
  7466. ' };',
  7467. ' this.GetIt = function(Par){',
  7468. ' var Result = null;',
  7469. ' this.vI = Par + 3;',
  7470. ' Result = this.Sub;',
  7471. ' return Result;',
  7472. ' };',
  7473. '});',
  7474. 'this.Obj = null;'
  7475. ]),
  7476. LinesToStr([ // $mod.$main
  7477. '$mod.Obj = $mod.TObject.$create("Create");',
  7478. '$mod.Obj.GetIt(4);',
  7479. '$mod.Obj.Sub.Sub=null;',
  7480. '$mod.Obj.Sub.GetIt(5);',
  7481. '$mod.Obj.Sub.GetIt(6).Sub=null;',
  7482. '$mod.Obj.Sub.GetIt(7).GetIt(8);',
  7483. '$mod.Obj.Sub.GetIt(9).Sub.GetIt(10);'
  7484. ]));
  7485. end;
  7486. procedure TTestModule.TestClass_Implementation;
  7487. begin
  7488. StartUnit(false);
  7489. Add([
  7490. 'interface',
  7491. 'type',
  7492. ' TObject = class',
  7493. ' constructor Create;',
  7494. ' end;',
  7495. 'implementation',
  7496. 'type',
  7497. ' TIntClass = class',
  7498. ' constructor Create; reintroduce;',
  7499. ' class procedure DoGlob;',
  7500. ' end;',
  7501. 'constructor tintclass.create;',
  7502. 'begin',
  7503. ' inherited;',
  7504. ' inherited create;',
  7505. ' doglob;',
  7506. 'end;',
  7507. 'class procedure tintclass.doglob;',
  7508. 'begin',
  7509. 'end;',
  7510. 'constructor tobject.create;',
  7511. 'var',
  7512. ' iC: tintclass;',
  7513. 'begin',
  7514. ' ic:=tintclass.create;',
  7515. ' tintclass.doglob;',
  7516. ' ic.doglob;',
  7517. 'end;',
  7518. 'initialization',
  7519. ' tintclass.doglob;',
  7520. '']);
  7521. ConvertUnit;
  7522. CheckSource('TestClass_Implementation',
  7523. LinesToStr([ // statements
  7524. 'var $impl = $mod.$impl;',
  7525. 'rtl.createClass($mod, "TObject", null, function () {',
  7526. ' this.$init = function () {',
  7527. ' };',
  7528. ' this.$final = function () {',
  7529. ' };',
  7530. ' this.Create = function () {',
  7531. ' var iC = null;',
  7532. ' iC = $impl.TIntClass.$create("Create$1");',
  7533. ' $impl.TIntClass.DoGlob();',
  7534. ' iC.$class.DoGlob();',
  7535. ' };',
  7536. '});',
  7537. '']),
  7538. LinesToStr([ // $mod.$main
  7539. '$impl.TIntClass.DoGlob();',
  7540. '']),
  7541. LinesToStr([
  7542. 'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
  7543. ' this.Create$1 = function () {',
  7544. ' $mod.TObject.Create.apply(this, arguments);',
  7545. ' $mod.TObject.Create.call(this);',
  7546. ' this.$class.DoGlob();',
  7547. ' };',
  7548. ' this.DoGlob = function () {',
  7549. ' };',
  7550. '});',
  7551. '']));
  7552. end;
  7553. procedure TTestModule.TestClass_Inheritance;
  7554. begin
  7555. StartProgram(false);
  7556. Add('type');
  7557. Add(' TObject = class');
  7558. Add(' public');
  7559. Add(' constructor Create;');
  7560. Add(' end;');
  7561. Add(' TClassA = class');
  7562. Add(' end;');
  7563. Add(' TClassB = class(TObject)');
  7564. Add(' procedure ProcB;');
  7565. Add(' end;');
  7566. Add('constructor tobject.create; begin end;');
  7567. Add('procedure tclassb.procb; begin end;');
  7568. Add('var');
  7569. Add(' oO: TObject;');
  7570. Add(' oA: TClassA;');
  7571. Add(' oB: TClassB;');
  7572. Add('begin');
  7573. Add(' oO:=tobject.Create;');
  7574. Add(' oA:=tclassa.Create;');
  7575. Add(' ob:=tclassb.Create;');
  7576. Add(' if oo is tclassa then ;');
  7577. Add(' ob:=oo as tclassb;');
  7578. Add(' (oo as tclassb).procb;');
  7579. ConvertProgram;
  7580. CheckSource('TestClass_Inheritance',
  7581. LinesToStr([ // statements
  7582. 'rtl.createClass($mod,"TObject",null,function(){',
  7583. ' this.$init = function () {',
  7584. ' };',
  7585. ' this.$final = function () {',
  7586. ' };',
  7587. ' this.Create = function () {',
  7588. ' };',
  7589. '});',
  7590. 'rtl.createClass($mod,"TClassA",$mod.TObject,function(){',
  7591. '});',
  7592. 'rtl.createClass($mod,"TClassB",$mod.TObject,function(){',
  7593. ' this.ProcB = function () {',
  7594. ' };',
  7595. '});',
  7596. 'this.oO = null;',
  7597. 'this.oA = null;',
  7598. 'this.oB = null;'
  7599. ]),
  7600. LinesToStr([ // $mod.$main
  7601. '$mod.oO = $mod.TObject.$create("Create");',
  7602. '$mod.oA = $mod.TClassA.$create("Create");',
  7603. '$mod.oB = $mod.TClassB.$create("Create");',
  7604. 'if ($mod.TClassA.isPrototypeOf($mod.oO));',
  7605. '$mod.oB = rtl.as($mod.oO, $mod.TClassB);',
  7606. 'rtl.as($mod.oO, $mod.TClassB).ProcB();'
  7607. ]));
  7608. end;
  7609. procedure TTestModule.TestClass_AbstractMethod;
  7610. begin
  7611. StartProgram(false);
  7612. Add('type');
  7613. Add(' TObject = class');
  7614. Add(' public');
  7615. Add(' procedure DoIt; virtual; abstract;');
  7616. Add(' end;');
  7617. Add('begin');
  7618. ConvertProgram;
  7619. CheckSource('TestClass_AbstractMethod',
  7620. LinesToStr([ // statements
  7621. 'rtl.createClass($mod,"TObject",null,function(){',
  7622. ' this.$init = function () {',
  7623. ' };',
  7624. ' this.$final = function () {',
  7625. ' };',
  7626. '});'
  7627. ]),
  7628. LinesToStr([ // this.$main
  7629. ''
  7630. ]));
  7631. end;
  7632. procedure TTestModule.TestClass_CallInherited_NoParams;
  7633. begin
  7634. StartProgram(false);
  7635. Add('type');
  7636. Add(' TObject = class');
  7637. Add(' procedure DoAbstract; virtual; abstract;');
  7638. Add(' procedure DoVirtual; virtual;');
  7639. Add(' procedure DoIt;');
  7640. Add(' end;');
  7641. Add(' TA = class');
  7642. Add(' procedure doabstract; override;');
  7643. Add(' procedure dovirtual; override;');
  7644. Add(' procedure DoSome;');
  7645. Add(' end;');
  7646. Add('procedure tobject.dovirtual;');
  7647. Add('begin');
  7648. Add(' inherited; // call non existing ancestor -> ignore silently');
  7649. Add('end;');
  7650. Add('procedure tobject.doit;');
  7651. Add('begin');
  7652. Add('end;');
  7653. Add('procedure ta.doabstract;');
  7654. Add('begin');
  7655. Add(' inherited dovirtual; // call TObject.DoVirtual');
  7656. Add('end;');
  7657. Add('procedure ta.dovirtual;');
  7658. Add('begin');
  7659. Add(' inherited; // call TObject.DoVirtual');
  7660. Add(' inherited dovirtual; // call TObject.DoVirtual');
  7661. Add(' inherited dovirtual(); // call TObject.DoVirtual');
  7662. Add(' doit;');
  7663. Add(' doit();');
  7664. Add('end;');
  7665. Add('procedure ta.dosome;');
  7666. Add('begin');
  7667. Add(' inherited; // call non existing ancestor method -> silently ignore');
  7668. Add('end;');
  7669. Add('begin');
  7670. ConvertProgram;
  7671. CheckSource('TestClass_CallInherited_NoParams',
  7672. LinesToStr([ // statements
  7673. 'rtl.createClass($mod,"TObject",null,function(){',
  7674. ' this.$init = function () {',
  7675. ' };',
  7676. ' this.$final = function () {',
  7677. ' };',
  7678. ' this.DoVirtual = function () {',
  7679. ' };',
  7680. ' this.DoIt = function () {',
  7681. ' };',
  7682. '});',
  7683. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  7684. ' this.DoAbstract = function () {',
  7685. ' $mod.TObject.DoVirtual.call(this);',
  7686. ' };',
  7687. ' this.DoVirtual = function () {',
  7688. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  7689. ' $mod.TObject.DoVirtual.call(this);',
  7690. ' $mod.TObject.DoVirtual.call(this);',
  7691. ' this.DoIt();',
  7692. ' this.DoIt();',
  7693. ' };',
  7694. ' this.DoSome = function () {',
  7695. ' };',
  7696. '});'
  7697. ]),
  7698. LinesToStr([ // this.$main
  7699. ''
  7700. ]));
  7701. end;
  7702. procedure TTestModule.TestClass_CallInherited_WithParams;
  7703. begin
  7704. StartProgram(false);
  7705. Add('type');
  7706. Add(' TObject = class');
  7707. Add(' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;');
  7708. Add(' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;');
  7709. Add(' procedure DoIt(pA: longint; pB: longint = 0);');
  7710. Add(' procedure DoIt2(pA: longint = 1; pB: longint = 2);');
  7711. Add(' end;');
  7712. Add(' TClassA = class');
  7713. Add(' procedure DoAbstract(pA: longint; pB: longint = 0); override;');
  7714. Add(' procedure DoVirtual(pA: longint; pB: longint = 0); override;');
  7715. Add(' end;');
  7716. Add('procedure tobject.dovirtual(pa: longint; pb: longint = 0);');
  7717. Add('begin');
  7718. Add('end;');
  7719. Add('procedure tobject.doit(pa: longint; pb: longint = 0);');
  7720. Add('begin');
  7721. Add('end;');
  7722. Add('procedure tobject.doit2(pa: longint; pb: longint = 0);');
  7723. Add('begin');
  7724. Add('end;');
  7725. Add('procedure tclassa.doabstract(pa: longint; pb: longint = 0);');
  7726. Add('begin');
  7727. Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
  7728. Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
  7729. Add('end;');
  7730. Add('procedure tclassa.dovirtual(pa: longint; pb: longint = 0);');
  7731. Add('begin');
  7732. Add(' inherited; // call TObject.DoVirtual(pA,pB)');
  7733. Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
  7734. Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
  7735. Add(' doit(pa,pb);');
  7736. Add(' doit(pa);');
  7737. Add(' doit2(pa);');
  7738. Add(' doit2;');
  7739. Add('end;');
  7740. Add('begin');
  7741. ConvertProgram;
  7742. CheckSource('TestClass_CallInherited_WithParams',
  7743. LinesToStr([ // statements
  7744. 'rtl.createClass($mod,"TObject",null,function(){',
  7745. ' this.$init = function () {',
  7746. ' };',
  7747. ' this.$final = function () {',
  7748. ' };',
  7749. ' this.DoVirtual = function (pA,pB) {',
  7750. ' };',
  7751. ' this.DoIt = function (pA,pB) {',
  7752. ' };',
  7753. ' this.DoIt2 = function (pA,pB) {',
  7754. ' };',
  7755. '});',
  7756. 'rtl.createClass($mod, "TClassA", $mod.TObject, function () {',
  7757. ' this.DoAbstract = function (pA,pB) {',
  7758. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  7759. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  7760. ' };',
  7761. ' this.DoVirtual = function (pA,pB) {',
  7762. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  7763. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  7764. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  7765. ' this.DoIt(pA,pB);',
  7766. ' this.DoIt(pA,0);',
  7767. ' this.DoIt2(pA,2);',
  7768. ' this.DoIt2(1,2);',
  7769. ' };',
  7770. '});'
  7771. ]),
  7772. LinesToStr([ // this.$main
  7773. ''
  7774. ]));
  7775. end;
  7776. procedure TTestModule.TestClasS_CallInheritedConstructor;
  7777. begin
  7778. StartProgram(false);
  7779. Add('type');
  7780. Add(' TObject = class');
  7781. Add(' constructor Create; virtual;');
  7782. Add(' constructor CreateWithB(b: boolean);');
  7783. Add(' end;');
  7784. Add(' TA = class');
  7785. Add(' constructor Create; override;');
  7786. Add(' constructor CreateWithC(c: char);');
  7787. Add(' procedure DoIt;');
  7788. Add(' class function DoSome: TObject;');
  7789. Add(' end;');
  7790. Add('constructor tobject.create;');
  7791. Add('begin');
  7792. Add(' inherited; // call non existing ancestor -> ignore silently');
  7793. Add('end;');
  7794. Add('constructor tobject.createwithb(b: boolean);');
  7795. Add('begin');
  7796. Add(' inherited; // call non existing ancestor -> ignore silently');
  7797. Add(' create; // normal call');
  7798. Add('end;');
  7799. Add('constructor ta.create;');
  7800. Add('begin');
  7801. Add(' inherited; // normal call TObject.Create');
  7802. Add(' inherited create; // normal call TObject.Create');
  7803. Add(' inherited createwithb(false); // normal call TObject.CreateWithB');
  7804. Add('end;');
  7805. Add('constructor ta.createwithc(c: char);');
  7806. Add('begin');
  7807. Add(' inherited create; // call TObject.Create');
  7808. Add(' inherited createwithb(true); // call TObject.CreateWithB');
  7809. Add(' doit;');
  7810. Add(' doit();');
  7811. Add(' dosome;');
  7812. Add('end;');
  7813. Add('procedure ta.doit;');
  7814. Add('begin');
  7815. Add(' create; // normal call');
  7816. Add(' createwithb(false); // normal call');
  7817. Add(' createwithc(''c''); // normal call');
  7818. Add('end;');
  7819. Add('class function ta.dosome: TObject;');
  7820. Add('begin');
  7821. Add(' Result:=create; // constructor');
  7822. Add(' Result:=createwithb(true); // constructor');
  7823. Add(' Result:=createwithc(''c''); // constructor');
  7824. Add('end;');
  7825. Add('begin');
  7826. ConvertProgram;
  7827. CheckSource('TestClass_CallInheritedConstructor',
  7828. LinesToStr([ // statements
  7829. 'rtl.createClass($mod,"TObject",null,function(){',
  7830. ' this.$init = function () {',
  7831. ' };',
  7832. ' this.$final = function () {',
  7833. ' };',
  7834. ' this.Create = function () {',
  7835. ' };',
  7836. ' this.CreateWithB = function (b) {',
  7837. ' this.Create();',
  7838. ' };',
  7839. '});',
  7840. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  7841. ' this.Create = function () {',
  7842. ' $mod.TObject.Create.apply(this, arguments);',
  7843. ' $mod.TObject.Create.call(this);',
  7844. ' $mod.TObject.CreateWithB.call(this, false);',
  7845. ' };',
  7846. ' this.CreateWithC = function (c) {',
  7847. ' $mod.TObject.Create.call(this);',
  7848. ' $mod.TObject.CreateWithB.call(this, true);',
  7849. ' this.DoIt();',
  7850. ' this.DoIt();',
  7851. ' this.$class.DoSome();',
  7852. ' };',
  7853. ' this.DoIt = function () {',
  7854. ' this.Create();',
  7855. ' this.CreateWithB(false);',
  7856. ' this.CreateWithC("c");',
  7857. ' };',
  7858. ' this.DoSome = function () {',
  7859. ' var Result = null;',
  7860. ' Result = this.$create("Create");',
  7861. ' Result = this.$create("CreateWithB", [true]);',
  7862. ' Result = this.$create("CreateWithC", ["c"]);',
  7863. ' return Result;',
  7864. ' };',
  7865. '});'
  7866. ]),
  7867. LinesToStr([ // this.$main
  7868. ''
  7869. ]));
  7870. end;
  7871. procedure TTestModule.TestClass_ClassVar;
  7872. begin
  7873. StartProgram(false);
  7874. Add('type');
  7875. Add(' TObject = class');
  7876. Add(' public');
  7877. Add(' class var vI: longint;');
  7878. Add(' class var Sub: TObject;');
  7879. Add(' constructor Create;');
  7880. Add(' class function GetIt(Par: longint): tobject;');
  7881. Add(' end;');
  7882. Add('constructor tobject.create;');
  7883. Add('begin');
  7884. Add(' vi:=vi+1;');
  7885. Add(' Self.vi:=Self.vi+1;');
  7886. Add('end;');
  7887. Add('class function tobject.getit(par: longint): tobject;');
  7888. Add('begin');
  7889. Add(' vi:=vi+par;');
  7890. Add(' Self.vi:=Self.vi+par;');
  7891. Add(' Result:=self.sub;');
  7892. Add('end;');
  7893. Add('var Obj: tobject;');
  7894. Add('begin');
  7895. Add(' obj:=tobject.create;');
  7896. Add(' tobject.vi:=3;');
  7897. Add(' if tobject.vi=4 then ;');
  7898. Add(' tobject.sub:=nil;');
  7899. Add(' obj.sub:=nil;');
  7900. Add(' obj.sub.sub:=nil;');
  7901. ConvertProgram;
  7902. CheckSource('TestClass_ClassVar',
  7903. LinesToStr([ // statements
  7904. 'rtl.createClass($mod,"TObject",null,function(){',
  7905. ' this.vI = 0;',
  7906. ' this.Sub = null;',
  7907. ' this.$init = function () {',
  7908. ' };',
  7909. ' this.$final = function () {',
  7910. ' };',
  7911. ' this.Create = function(){',
  7912. ' this.$class.vI = this.vI+1;',
  7913. ' this.$class.vI = this.vI+1;',
  7914. ' };',
  7915. ' this.GetIt = function(Par){',
  7916. ' var Result = null;',
  7917. ' this.vI = this.vI + Par;',
  7918. ' this.vI = this.vI + Par;',
  7919. ' Result = this.Sub;',
  7920. ' return Result;',
  7921. ' };',
  7922. '});',
  7923. 'this.Obj = null;'
  7924. ]),
  7925. LinesToStr([ // $mod.$main
  7926. '$mod.Obj = $mod.TObject.$create("Create");',
  7927. '$mod.TObject.vI = 3;',
  7928. 'if ($mod.TObject.vI === 4);',
  7929. '$mod.TObject.Sub=null;',
  7930. '$mod.Obj.$class.Sub=null;',
  7931. '$mod.Obj.Sub.$class.Sub=null;',
  7932. '']));
  7933. end;
  7934. procedure TTestModule.TestClass_CallClassMethod;
  7935. begin
  7936. StartProgram(false);
  7937. Add('type');
  7938. Add(' TObject = class');
  7939. Add(' public');
  7940. Add(' class var vI: longint;');
  7941. Add(' class var Sub: TObject;');
  7942. Add(' constructor Create;');
  7943. Add(' function GetMore(Par: longint): longint;');
  7944. Add(' class function GetIt(Par: longint): tobject;');
  7945. Add(' end;');
  7946. Add('constructor tobject.create;');
  7947. Add('begin');
  7948. Add(' sub:=getit(3);');
  7949. Add(' vi:=getmore(4);');
  7950. Add(' sub:=Self.getit(5);');
  7951. Add(' vi:=Self.getmore(6);');
  7952. Add('end;');
  7953. Add('function tobject.getmore(par: longint): longint;');
  7954. Add('begin');
  7955. Add(' sub:=getit(11);');
  7956. Add(' vi:=getmore(12);');
  7957. Add(' sub:=self.getit(13);');
  7958. Add(' vi:=self.getmore(14);');
  7959. Add('end;');
  7960. Add('class function tobject.getit(par: longint): tobject;');
  7961. Add('begin');
  7962. Add(' sub:=getit(21);');
  7963. Add(' vi:=sub.getmore(22);');
  7964. Add(' sub:=self.getit(23);');
  7965. Add(' vi:=self.sub.getmore(24);');
  7966. Add('end;');
  7967. Add('var Obj: tobject;');
  7968. Add('begin');
  7969. Add(' obj:=tobject.create;');
  7970. Add(' tobject.getit(5);');
  7971. Add(' obj.getit(6);');
  7972. Add(' obj.sub.getit(7);');
  7973. Add(' obj.sub.getit(8).SUB:=nil;');
  7974. Add(' obj.sub.getit(9).GETIT(10);');
  7975. Add(' obj.sub.getit(11).SuB.getit(12);');
  7976. ConvertProgram;
  7977. CheckSource('TestClass_CallClassMethod',
  7978. LinesToStr([ // statements
  7979. 'rtl.createClass($mod,"TObject",null,function(){',
  7980. ' this.vI = 0;',
  7981. ' this.Sub = null;',
  7982. ' this.$init = function () {',
  7983. ' };',
  7984. ' this.$final = function () {',
  7985. ' };',
  7986. ' this.Create = function(){',
  7987. ' this.$class.Sub = this.$class.GetIt(3);',
  7988. ' this.$class.vI = this.GetMore(4);',
  7989. ' this.$class.Sub = this.$class.GetIt(5);',
  7990. ' this.$class.vI = this.GetMore(6);',
  7991. ' };',
  7992. ' this.GetMore = function(Par){',
  7993. ' var Result = 0;',
  7994. ' this.$class.Sub = this.$class.GetIt(11);',
  7995. ' this.$class.vI = this.GetMore(12);',
  7996. ' this.$class.Sub = this.$class.GetIt(13);',
  7997. ' this.$class.vI = this.GetMore(14);',
  7998. ' return Result;',
  7999. ' };',
  8000. ' this.GetIt = function(Par){',
  8001. ' var Result = null;',
  8002. ' this.Sub = this.GetIt(21);',
  8003. ' this.vI = this.Sub.GetMore(22);',
  8004. ' this.Sub = this.GetIt(23);',
  8005. ' this.vI = this.Sub.GetMore(24);',
  8006. ' return Result;',
  8007. ' };',
  8008. '});',
  8009. 'this.Obj = null;'
  8010. ]),
  8011. LinesToStr([ // $mod.$main
  8012. '$mod.Obj = $mod.TObject.$create("Create");',
  8013. '$mod.TObject.GetIt(5);',
  8014. '$mod.Obj.$class.GetIt(6);',
  8015. '$mod.Obj.Sub.$class.GetIt(7);',
  8016. '$mod.Obj.Sub.$class.GetIt(8).$class.Sub=null;',
  8017. '$mod.Obj.Sub.$class.GetIt(9).$class.GetIt(10);',
  8018. '$mod.Obj.Sub.$class.GetIt(11).Sub.$class.GetIt(12);',
  8019. '']));
  8020. end;
  8021. procedure TTestModule.TestClass_Property;
  8022. begin
  8023. StartProgram(false);
  8024. Add('type');
  8025. Add(' TObject = class');
  8026. Add(' Fx: longint;');
  8027. Add(' Fy: longint;');
  8028. Add(' function GetInt: longint;');
  8029. Add(' procedure SetInt(Value: longint);');
  8030. Add(' procedure DoIt;');
  8031. Add(' property IntA: longint read Fx write Fy;');
  8032. Add(' property IntB: longint read GetInt write SetInt;');
  8033. Add(' end;');
  8034. Add('function tobject.getint: longint;');
  8035. Add('begin');
  8036. Add(' result:=fx;');
  8037. Add('end;');
  8038. Add('procedure tobject.setint(value: longint);');
  8039. Add('begin');
  8040. Add(' if value=fy then exit;');
  8041. Add(' fy:=value;');
  8042. Add('end;');
  8043. Add('procedure tobject.doit;');
  8044. Add('begin');
  8045. Add(' IntA:=IntA+1;');
  8046. Add(' Self.IntA:=Self.IntA+1;');
  8047. Add(' IntB:=IntB+1;');
  8048. Add(' Self.IntB:=Self.IntB+1;');
  8049. Add('end;');
  8050. Add('var Obj: tobject;');
  8051. Add('begin');
  8052. Add(' obj.inta:=obj.inta+1;');
  8053. Add(' if obj.intb=2 then;');
  8054. Add(' obj.intb:=obj.intb+2;');
  8055. Add(' obj.setint(obj.inta);');
  8056. ConvertProgram;
  8057. CheckSource('TestClass_Property',
  8058. LinesToStr([ // statements
  8059. 'rtl.createClass($mod, "TObject", null, function () {',
  8060. ' this.$init = function () {',
  8061. ' this.Fx = 0;',
  8062. ' this.Fy = 0;',
  8063. ' };',
  8064. ' this.$final = function () {',
  8065. ' };',
  8066. ' this.GetInt = function () {',
  8067. ' var Result = 0;',
  8068. ' Result = this.Fx;',
  8069. ' return Result;',
  8070. ' };',
  8071. ' this.SetInt = function (Value) {',
  8072. ' if (Value === this.Fy) return;',
  8073. ' this.Fy = Value;',
  8074. ' };',
  8075. ' this.DoIt = function () {',
  8076. ' this.Fy = this.Fx + 1;',
  8077. ' this.Fy = this.Fx + 1;',
  8078. ' this.SetInt(this.GetInt() + 1);',
  8079. ' this.SetInt(this.GetInt() + 1);',
  8080. ' };',
  8081. '});',
  8082. 'this.Obj = null;'
  8083. ]),
  8084. LinesToStr([ // $mod.$main
  8085. '$mod.Obj.Fy = $mod.Obj.Fx + 1;',
  8086. 'if ($mod.Obj.GetInt() === 2);',
  8087. '$mod.Obj.SetInt($mod.Obj.GetInt() + 2);',
  8088. '$mod.Obj.SetInt($mod.Obj.Fx);'
  8089. ]));
  8090. end;
  8091. procedure TTestModule.TestClass_Property_ClassMethod;
  8092. begin
  8093. StartProgram(false);
  8094. Add('type');
  8095. Add(' TObject = class');
  8096. Add(' class var Fx: longint;');
  8097. Add(' class var Fy: longint;');
  8098. Add(' class function GetInt: longint;');
  8099. Add(' class procedure SetInt(Value: longint);');
  8100. Add(' class procedure DoIt;');
  8101. Add(' class property IntA: longint read Fx write Fy;');
  8102. Add(' class property IntB: longint read GetInt write SetInt;');
  8103. Add(' end;');
  8104. Add('class function tobject.getint: longint;');
  8105. Add('begin');
  8106. Add(' result:=fx;');
  8107. Add('end;');
  8108. Add('class procedure tobject.setint(value: longint);');
  8109. Add('begin');
  8110. Add('end;');
  8111. Add('class procedure tobject.doit;');
  8112. Add('begin');
  8113. Add(' IntA:=IntA+1;');
  8114. Add(' Self.IntA:=Self.IntA+1;');
  8115. Add(' IntB:=IntB+1;');
  8116. Add(' Self.IntB:=Self.IntB+1;');
  8117. Add('end;');
  8118. Add('var Obj: tobject;');
  8119. Add('begin');
  8120. Add(' tobject.inta:=tobject.inta+1;');
  8121. Add(' if tobject.intb=2 then;');
  8122. Add(' tobject.intb:=tobject.intb+2;');
  8123. Add(' tobject.setint(tobject.inta);');
  8124. Add(' obj.inta:=obj.inta+1;');
  8125. Add(' if obj.intb=2 then;');
  8126. Add(' obj.intb:=obj.intb+2;');
  8127. Add(' obj.setint(obj.inta);');
  8128. ConvertProgram;
  8129. CheckSource('TestClass_Property_ClassMethod',
  8130. LinesToStr([ // statements
  8131. 'rtl.createClass($mod, "TObject", null, function () {',
  8132. ' this.Fx = 0;',
  8133. ' this.Fy = 0;',
  8134. ' this.$init = function () {',
  8135. ' };',
  8136. ' this.$final = function () {',
  8137. ' };',
  8138. ' this.GetInt = function () {',
  8139. ' var Result = 0;',
  8140. ' Result = this.Fx;',
  8141. ' return Result;',
  8142. ' };',
  8143. ' this.SetInt = function (Value) {',
  8144. ' };',
  8145. ' this.DoIt = function () {',
  8146. ' this.Fy = this.Fx + 1;',
  8147. ' this.Fy = this.Fx + 1;',
  8148. ' this.SetInt(this.GetInt() + 1);',
  8149. ' this.SetInt(this.GetInt() + 1);',
  8150. ' };',
  8151. '});',
  8152. 'this.Obj = null;'
  8153. ]),
  8154. LinesToStr([ // $mod.$main
  8155. '$mod.TObject.Fy = $mod.TObject.Fx + 1;',
  8156. 'if ($mod.TObject.GetInt() === 2);',
  8157. '$mod.TObject.SetInt($mod.TObject.GetInt() + 2);',
  8158. '$mod.TObject.SetInt($mod.TObject.Fx);',
  8159. '$mod.Obj.$class.Fy = $mod.Obj.Fx + 1;',
  8160. 'if ($mod.Obj.$class.GetInt() === 2);',
  8161. '$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
  8162. '$mod.Obj.$class.SetInt($mod.Obj.Fx);'
  8163. ]));
  8164. end;
  8165. procedure TTestModule.TestClass_Property_Indexed;
  8166. begin
  8167. StartProgram(false);
  8168. Add('type');
  8169. Add(' TObject = class');
  8170. Add(' FItems: array of longint;');
  8171. Add(' function GetItems(Index: longint): longint;');
  8172. Add(' procedure SetItems(Index: longint; Value: longint);');
  8173. Add(' procedure DoIt;');
  8174. Add(' property Items[Index: longint]: longint read getitems write setitems;');
  8175. Add(' end;');
  8176. Add('function tobject.getitems(index: longint): longint;');
  8177. Add('begin');
  8178. Add(' Result:=fitems[index];');
  8179. Add('end;');
  8180. Add('procedure tobject.setitems(index: longint; value: longint);');
  8181. Add('begin');
  8182. Add(' fitems[index]:=value;');
  8183. Add('end;');
  8184. Add('procedure tobject.doit;');
  8185. Add('begin');
  8186. Add(' items[1]:=2;');
  8187. Add(' items[3]:=items[4];');
  8188. Add(' self.items[5]:=self.items[6];');
  8189. Add(' items[items[7]]:=items[items[8]];');
  8190. Add('end;');
  8191. Add('var Obj: tobject;');
  8192. Add('begin');
  8193. Add(' obj.Items[11]:=obj.Items[12];');
  8194. ConvertProgram;
  8195. CheckSource('TestClass_Property_Indexed',
  8196. LinesToStr([ // statements
  8197. 'rtl.createClass($mod, "TObject", null, function () {',
  8198. ' this.$init = function () {',
  8199. ' this.FItems = [];',
  8200. ' };',
  8201. ' this.$final = function () {',
  8202. ' this.FItems = undefined;',
  8203. ' };',
  8204. ' this.GetItems = function (Index) {',
  8205. ' var Result = 0;',
  8206. ' Result = this.FItems[Index];',
  8207. ' return Result;',
  8208. ' };',
  8209. ' this.SetItems = function (Index, Value) {',
  8210. ' this.FItems[Index] = Value;',
  8211. ' };',
  8212. ' this.DoIt = function () {',
  8213. ' this.SetItems(1, 2);',
  8214. ' this.SetItems(3,this.GetItems(4));',
  8215. ' this.SetItems(5,this.GetItems(6));',
  8216. ' this.SetItems(this.GetItems(7), this.GetItems(this.GetItems(8)));',
  8217. ' };',
  8218. '});',
  8219. 'this.Obj = null;'
  8220. ]),
  8221. LinesToStr([ // $mod.$main
  8222. '$mod.Obj.SetItems(11,$mod.Obj.GetItems(12));'
  8223. ]));
  8224. end;
  8225. procedure TTestModule.TestClass_Property_IndexSpec;
  8226. begin
  8227. StartProgram(false);
  8228. Add([
  8229. 'type',
  8230. ' TEnum = (red, blue);',
  8231. ' TObject = class',
  8232. ' function GetIntBool(Index: longint): boolean; virtual; abstract;',
  8233. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  8234. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  8235. ' procedure SetEnumBool(Index: TEnum; b: boolean); virtual; abstract;',
  8236. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  8237. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  8238. ' property B1: boolean index 1 read GetIntBool write SetIntBool;',
  8239. ' property B2: boolean index TEnum.blue read GetEnumBool write SetEnumBool;',
  8240. ' property B3: boolean index ord(red) read GetIntBool write SetIntBool;',
  8241. ' property I1[A: String]: boolean index ord(blue) read GetStrIntBool write SetStrIntBool;',
  8242. ' end;',
  8243. 'procedure DoIt(b: boolean); begin end;',
  8244. 'var',
  8245. ' o: TObject;',
  8246. 'begin',
  8247. ' o.B1:=o.B1;',
  8248. ' o.B2:=o.B2;',
  8249. ' o.B3:=o.B3;',
  8250. ' o.I1[''a'']:=o.I1[''b''];',
  8251. ' doit(o.b1);',
  8252. ' doit(o.b2);',
  8253. ' doit(o.i1[''c'']);',
  8254. '']);
  8255. ConvertProgram;
  8256. CheckSource('TestClass_Property_IndexSpec',
  8257. LinesToStr([ // statements
  8258. 'this.TEnum = {',
  8259. ' "0": "red",',
  8260. ' red: 0,',
  8261. ' "1": "blue",',
  8262. ' blue: 1',
  8263. '};',
  8264. 'rtl.createClass($mod, "TObject", null, function () {',
  8265. ' this.$init = function () {',
  8266. ' };',
  8267. ' this.$final = function () {',
  8268. ' };',
  8269. '});',
  8270. 'this.DoIt = function (b) {',
  8271. '};',
  8272. 'this.o = null;',
  8273. '']),
  8274. LinesToStr([ // $mod.$main
  8275. '$mod.o.SetIntBool(1, $mod.o.GetIntBool(1));',
  8276. '$mod.o.SetEnumBool($mod.TEnum.blue, $mod.o.GetEnumBool($mod.TEnum.blue));',
  8277. '$mod.o.SetIntBool(0, $mod.o.GetIntBool(0));',
  8278. '$mod.o.SetStrIntBool("a", 1, $mod.o.GetStrIntBool("b", 1));',
  8279. '$mod.DoIt($mod.o.GetIntBool(1));',
  8280. '$mod.DoIt($mod.o.GetEnumBool($mod.TEnum.blue));',
  8281. '$mod.DoIt($mod.o.GetStrIntBool("c", 1));',
  8282. '']));
  8283. end;
  8284. procedure TTestModule.TestClass_PropertyOfTypeArray;
  8285. begin
  8286. StartProgram(false);
  8287. Add('type');
  8288. Add(' TArray = array of longint;');
  8289. Add(' TObject = class');
  8290. Add(' FItems: TArray;');
  8291. Add(' function GetItems: tarray;');
  8292. Add(' procedure SetItems(Value: tarray);');
  8293. Add(' property Items: tarray read getitems write setitems;');
  8294. Add(' end;');
  8295. Add('function tobject.getitems: tarray;');
  8296. Add('begin');
  8297. Add(' Result:=fitems;');
  8298. Add('end;');
  8299. Add('procedure tobject.setitems(value: tarray);');
  8300. Add('begin');
  8301. Add(' fitems:=value;');
  8302. Add(' fitems:=nil;');
  8303. Add(' Items:=nil;');
  8304. Add(' Items:=Items;');
  8305. Add(' Items[1]:=2;');
  8306. Add(' fitems[3]:=Items[4];');
  8307. Add(' Items[5]:=Items[6];');
  8308. Add(' Self.Items[7]:=8;');
  8309. Add(' Self.Items[9]:=Self.Items[10];');
  8310. Add(' Items[Items[11]]:=Items[Items[12]];');
  8311. Add('end;');
  8312. Add('var Obj: tobject;');
  8313. Add('begin');
  8314. Add(' obj.items:=nil;');
  8315. Add(' obj.items:=obj.items;');
  8316. Add(' obj.items[11]:=obj.items[12];');
  8317. ConvertProgram;
  8318. CheckSource('TestClass_PropertyOfTypeArray',
  8319. LinesToStr([ // statements
  8320. 'rtl.createClass($mod, "TObject", null, function () {',
  8321. ' this.$init = function () {',
  8322. ' this.FItems = [];',
  8323. ' };',
  8324. ' this.$final = function () {',
  8325. ' this.FItems = undefined;',
  8326. ' };',
  8327. ' this.GetItems = function () {',
  8328. ' var Result = [];',
  8329. ' Result = this.FItems;',
  8330. ' return Result;',
  8331. ' };',
  8332. ' this.SetItems = function (Value) {',
  8333. ' this.FItems = Value;',
  8334. ' this.FItems = [];',
  8335. ' this.SetItems([]);',
  8336. ' this.SetItems(this.GetItems());',
  8337. ' this.GetItems()[1] = 2;',
  8338. ' this.FItems[3] = this.GetItems()[4];',
  8339. ' this.GetItems()[5] = this.GetItems()[6];',
  8340. ' this.GetItems()[7] = 8;',
  8341. ' this.GetItems()[9] = this.GetItems()[10];',
  8342. ' this.GetItems()[this.GetItems()[11]] = this.GetItems()[this.GetItems()[12]];',
  8343. ' };',
  8344. '});',
  8345. 'this.Obj = null;'
  8346. ]),
  8347. LinesToStr([ // $mod.$main
  8348. '$mod.Obj.SetItems([]);',
  8349. '$mod.Obj.SetItems($mod.Obj.GetItems());',
  8350. '$mod.Obj.GetItems()[11] = $mod.Obj.GetItems()[12];'
  8351. ]));
  8352. end;
  8353. procedure TTestModule.TestClass_PropertyDefault;
  8354. begin
  8355. StartProgram(false);
  8356. Add('type');
  8357. Add(' TArray = array of longint;');
  8358. Add(' TObject = class');
  8359. Add(' FItems: TArray;');
  8360. Add(' function GetItems(Index: longint): longint;');
  8361. Add(' procedure SetItems(Index, Value: longint);');
  8362. Add(' property Items[Index: longint]: longint read getitems write setitems; default;');
  8363. Add(' end;');
  8364. Add('function tobject.getitems(index: longint): longint;');
  8365. Add('begin');
  8366. Add('end;');
  8367. Add('procedure tobject.setitems(index, value: longint);');
  8368. Add('begin');
  8369. Add(' Self[1]:=2;');
  8370. Add(' Self[3]:=Self[index];');
  8371. Add(' Self[index]:=Self[Self[value]];');
  8372. Add(' Self[Self[4]]:=value;');
  8373. Add('end;');
  8374. Add('var Obj: tobject;');
  8375. Add('begin');
  8376. Add(' obj[11]:=12;');
  8377. Add(' obj[13]:=obj[14];');
  8378. Add(' obj[obj[15]]:=obj[obj[15]];');
  8379. ConvertProgram;
  8380. CheckSource('TestClass_PropertyDefault',
  8381. LinesToStr([ // statements
  8382. 'rtl.createClass($mod, "TObject", null, function () {',
  8383. ' this.$init = function () {',
  8384. ' this.FItems = [];',
  8385. ' };',
  8386. ' this.$final = function () {',
  8387. ' this.FItems = undefined;',
  8388. ' };',
  8389. ' this.GetItems = function (Index) {',
  8390. ' var Result = 0;',
  8391. ' return Result;',
  8392. ' };',
  8393. ' this.SetItems = function (Index, Value) {',
  8394. ' this.SetItems(1, 2);',
  8395. ' this.SetItems(3, this.GetItems(Index));',
  8396. ' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
  8397. ' this.SetItems(this.GetItems(4), Value);',
  8398. ' };',
  8399. '});',
  8400. 'this.Obj = null;'
  8401. ]),
  8402. LinesToStr([ // $mod.$main
  8403. '$mod.Obj.SetItems(11, 12);',
  8404. '$mod.Obj.SetItems(13, $mod.Obj.GetItems(14));',
  8405. '$mod.Obj.SetItems($mod.Obj.GetItems(15), $mod.Obj.GetItems($mod.Obj.GetItems(15)));'
  8406. ]));
  8407. end;
  8408. procedure TTestModule.TestClass_PropertyOverride;
  8409. begin
  8410. StartProgram(false);
  8411. Add('type');
  8412. Add(' integer = longint;');
  8413. Add(' TObject = class');
  8414. Add(' FItem: integer;');
  8415. Add(' function GetItem: integer; external name ''GetItem'';');
  8416. Add(' procedure SetItem(Value: integer); external name ''SetItem'';');
  8417. Add(' property Item: integer read getitem write setitem;');
  8418. Add(' end;');
  8419. Add(' TCar = class');
  8420. Add(' FBag: integer;');
  8421. Add(' function GetBag: integer; external name ''GetBag'';');
  8422. Add(' property Item read getbag;');
  8423. Add(' end;');
  8424. Add('var');
  8425. Add(' Obj: tobject;');
  8426. Add(' Car: tcar;');
  8427. Add('begin');
  8428. Add(' Obj.Item:=Obj.Item;');
  8429. Add(' Car.Item:=Car.Item;');
  8430. ConvertProgram;
  8431. CheckSource('TestClass_PropertyOverride',
  8432. LinesToStr([ // statements
  8433. 'rtl.createClass($mod, "TObject", null, function () {',
  8434. ' this.$init = function () {',
  8435. ' this.FItem = 0;',
  8436. ' };',
  8437. ' this.$final = function () {',
  8438. ' };',
  8439. '});',
  8440. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  8441. ' this.$init = function () {',
  8442. ' $mod.TObject.$init.call(this);',
  8443. ' this.FBag = 0;',
  8444. ' };',
  8445. '});',
  8446. 'this.Obj = null;',
  8447. 'this.Car = null;',
  8448. '']),
  8449. LinesToStr([ // $mod.$main
  8450. '$mod.Obj.SetItem($mod.Obj.GetItem());',
  8451. '$mod.Car.SetItem($mod.Car.GetBag());',
  8452. '']));
  8453. end;
  8454. procedure TTestModule.TestClass_PropertyIncVisibility;
  8455. begin
  8456. AddModuleWithIntfImplSrc('unit1.pp',
  8457. LinesToStr([
  8458. 'type',
  8459. ' TNumber = longint;',
  8460. ' TInteger = longint;',
  8461. ' TObject = class',
  8462. ' private',
  8463. ' function GetItems(Index: TNumber): TInteger; virtual; abstract;',
  8464. ' procedure SetItems(Index: TInteger; Value: TNumber); virtual; abstract;',
  8465. ' protected',
  8466. ' property Items[Index: TNumber]: longint read GetItems write SetItems;',
  8467. ' end;']),
  8468. LinesToStr([
  8469. '']));
  8470. StartProgram(true);
  8471. Add([
  8472. 'uses unit1;',
  8473. 'type',
  8474. ' TBird = class',
  8475. ' public',
  8476. ' property Items;',
  8477. ' end;',
  8478. 'procedure DoIt(i: TInteger);',
  8479. 'begin',
  8480. 'end;',
  8481. 'var b: TBird;',
  8482. 'begin',
  8483. ' b.Items[1]:=2;',
  8484. ' b.Items[3]:=b.Items[4];',
  8485. ' DoIt(b.Items[5]);',
  8486. '']);
  8487. ConvertProgram;
  8488. CheckSource('TestClass_PropertyIncVisibility',
  8489. LinesToStr([ // statements
  8490. 'rtl.createClass($mod, "TBird", pas.unit1.TObject, function () {',
  8491. '});',
  8492. 'this.DoIt = function (i) {',
  8493. '};',
  8494. 'this.b = null;'
  8495. ]),
  8496. LinesToStr([ // $mod.$main
  8497. '$mod.b.SetItems(1, 2);',
  8498. '$mod.b.SetItems(3, $mod.b.GetItems(4));',
  8499. '$mod.DoIt($mod.b.GetItems(5));'
  8500. ]));
  8501. end;
  8502. procedure TTestModule.TestClass_Assigned;
  8503. begin
  8504. StartProgram(false);
  8505. Add('type');
  8506. Add(' TObject = class');
  8507. Add(' end;');
  8508. Add('var');
  8509. Add(' Obj: tobject;');
  8510. Add(' b: boolean;');
  8511. Add('begin');
  8512. Add(' if Assigned(obj) then ;');
  8513. Add(' b:=Assigned(obj) or false;');
  8514. ConvertProgram;
  8515. CheckSource('TestClass_Assigned',
  8516. LinesToStr([ // statements
  8517. 'rtl.createClass($mod, "TObject", null, function () {',
  8518. ' this.$init = function () {',
  8519. ' };',
  8520. ' this.$final = function () {',
  8521. ' };',
  8522. '});',
  8523. 'this.Obj = null;',
  8524. 'this.b = false;'
  8525. ]),
  8526. LinesToStr([ // $mod.$main
  8527. 'if ($mod.Obj != null);',
  8528. '$mod.b = ($mod.Obj != null) || false;'
  8529. ]));
  8530. end;
  8531. procedure TTestModule.TestClass_WithClassDoCreate;
  8532. begin
  8533. StartProgram(false);
  8534. Add('type');
  8535. Add(' TObject = class');
  8536. Add(' aBool: boolean;');
  8537. Add(' Arr: array of boolean;');
  8538. Add(' constructor Create;');
  8539. Add(' end;');
  8540. Add('constructor TObject.Create; begin end;');
  8541. Add('var');
  8542. Add(' Obj: tobject;');
  8543. Add(' b: boolean;');
  8544. Add('begin');
  8545. Add(' with tobject.create do begin');
  8546. Add(' b:=abool;');
  8547. Add(' abool:=b;');
  8548. Add(' b:=arr[1];');
  8549. Add(' arr[2]:=b;');
  8550. Add(' end;');
  8551. Add(' with tobject do');
  8552. Add(' obj:=create;');
  8553. Add(' with obj do begin');
  8554. Add(' create;');
  8555. Add(' b:=abool;');
  8556. Add(' abool:=b;');
  8557. Add(' b:=arr[3];');
  8558. Add(' arr[4]:=b;');
  8559. Add(' end;');
  8560. ConvertProgram;
  8561. CheckSource('TestClass_WithClassDoCreate',
  8562. LinesToStr([ // statements
  8563. 'rtl.createClass($mod, "TObject", null, function () {',
  8564. ' this.$init = function () {',
  8565. ' this.aBool = false;',
  8566. ' this.Arr = [];',
  8567. ' };',
  8568. ' this.$final = function () {',
  8569. ' this.Arr = undefined;',
  8570. ' };',
  8571. ' this.Create = function () {',
  8572. ' };',
  8573. '});',
  8574. 'this.Obj = null;',
  8575. 'this.b = false;'
  8576. ]),
  8577. LinesToStr([ // $mod.$main
  8578. 'var $with1 = $mod.TObject.$create("Create");',
  8579. '$mod.b = $with1.aBool;',
  8580. '$with1.aBool = $mod.b;',
  8581. '$mod.b = $with1.Arr[1];',
  8582. '$with1.Arr[2] = $mod.b;',
  8583. 'var $with2 = $mod.TObject;',
  8584. '$mod.Obj = $with2.$create("Create");',
  8585. 'var $with3 = $mod.Obj;',
  8586. '$with3.Create();',
  8587. '$mod.b = $with3.aBool;',
  8588. '$with3.aBool = $mod.b;',
  8589. '$mod.b = $with3.Arr[3];',
  8590. '$with3.Arr[4] = $mod.b;',
  8591. '']));
  8592. end;
  8593. procedure TTestModule.TestClass_WithClassInstDoProperty;
  8594. begin
  8595. StartProgram(false);
  8596. Add('type');
  8597. Add(' TObject = class');
  8598. Add(' FInt: longint;');
  8599. Add(' constructor Create;');
  8600. Add(' function GetSize: longint;');
  8601. Add(' procedure SetSize(Value: longint);');
  8602. Add(' property Int: longint read FInt write FInt;');
  8603. Add(' property Size: longint read GetSize write SetSize;');
  8604. Add(' end;');
  8605. Add('constructor TObject.Create; begin end;');
  8606. Add('function TObject.GetSize: longint; begin; end;');
  8607. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  8608. Add('var');
  8609. Add(' Obj: tobject;');
  8610. Add(' i: longint;');
  8611. Add('begin');
  8612. Add(' with TObject.Create do begin');
  8613. Add(' i:=int;');
  8614. Add(' int:=i;');
  8615. Add(' i:=size;');
  8616. Add(' size:=i;');
  8617. Add(' end;');
  8618. Add(' with obj do begin');
  8619. Add(' i:=int;');
  8620. Add(' int:=i;');
  8621. Add(' i:=size;');
  8622. Add(' size:=i;');
  8623. Add(' end;');
  8624. ConvertProgram;
  8625. CheckSource('TestClass_WithClassInstDoProperty',
  8626. LinesToStr([ // statements
  8627. 'rtl.createClass($mod, "TObject", null, function () {',
  8628. ' this.$init = function () {',
  8629. ' this.FInt = 0;',
  8630. ' };',
  8631. ' this.$final = function () {',
  8632. ' };',
  8633. ' this.Create = function () {',
  8634. ' };',
  8635. ' this.GetSize = function () {',
  8636. ' var Result = 0;',
  8637. ' return Result;',
  8638. ' };',
  8639. ' this.SetSize = function (Value) {',
  8640. ' };',
  8641. '});',
  8642. 'this.Obj = null;',
  8643. 'this.i = 0;'
  8644. ]),
  8645. LinesToStr([ // $mod.$main
  8646. 'var $with1 = $mod.TObject.$create("Create");',
  8647. '$mod.i = $with1.FInt;',
  8648. '$with1.FInt = $mod.i;',
  8649. '$mod.i = $with1.GetSize();',
  8650. '$with1.SetSize($mod.i);',
  8651. 'var $with2 = $mod.Obj;',
  8652. '$mod.i = $with2.FInt;',
  8653. '$with2.FInt = $mod.i;',
  8654. '$mod.i = $with2.GetSize();',
  8655. '$with2.SetSize($mod.i);',
  8656. '']));
  8657. end;
  8658. procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
  8659. begin
  8660. StartProgram(false);
  8661. Add('type');
  8662. Add(' TObject = class');
  8663. Add(' constructor Create;');
  8664. Add(' function GetItems(Index: longint): longint;');
  8665. Add(' procedure SetItems(Index, Value: longint);');
  8666. Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
  8667. Add(' end;');
  8668. Add('constructor TObject.Create; begin end;');
  8669. Add('function tobject.getitems(index: longint): longint; begin; end;');
  8670. Add('procedure tobject.setitems(index, value: longint); begin; end;');
  8671. Add('var');
  8672. Add(' Obj: tobject;');
  8673. Add(' i: longint;');
  8674. Add('begin');
  8675. Add(' with TObject.Create do begin');
  8676. Add(' i:=Items[1];');
  8677. Add(' Items[2]:=i;');
  8678. Add(' end;');
  8679. Add(' with obj do begin');
  8680. Add(' i:=Items[3];');
  8681. Add(' Items[4]:=i;');
  8682. Add(' end;');
  8683. ConvertProgram;
  8684. CheckSource('TestClass_WithClassInstDoPropertyWithParams',
  8685. LinesToStr([ // statements
  8686. 'rtl.createClass($mod, "TObject", null, function () {',
  8687. ' this.$init = function () {',
  8688. ' };',
  8689. ' this.$final = function () {',
  8690. ' };',
  8691. ' this.Create = function () {',
  8692. ' };',
  8693. ' this.GetItems = function (Index) {',
  8694. ' var Result = 0;',
  8695. ' return Result;',
  8696. ' };',
  8697. ' this.SetItems = function (Index, Value) {',
  8698. ' };',
  8699. '});',
  8700. 'this.Obj = null;',
  8701. 'this.i = 0;'
  8702. ]),
  8703. LinesToStr([ // $mod.$main
  8704. 'var $with1 = $mod.TObject.$create("Create");',
  8705. '$mod.i = $with1.GetItems(1);',
  8706. '$with1.SetItems(2, $mod.i);',
  8707. 'var $with2 = $mod.Obj;',
  8708. '$mod.i = $with2.GetItems(3);',
  8709. '$with2.SetItems(4, $mod.i);',
  8710. '']));
  8711. end;
  8712. procedure TTestModule.TestClass_WithClassInstDoFunc;
  8713. begin
  8714. StartProgram(false);
  8715. Add('type');
  8716. Add(' TObject = class');
  8717. Add(' constructor Create;');
  8718. Add(' function GetSize: longint;');
  8719. Add(' procedure SetSize(Value: longint);');
  8720. Add(' end;');
  8721. Add('constructor TObject.Create; begin end;');
  8722. Add('function TObject.GetSize: longint; begin; end;');
  8723. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  8724. Add('var');
  8725. Add(' Obj: tobject;');
  8726. Add(' i: longint;');
  8727. Add('begin');
  8728. Add(' with TObject.Create do begin');
  8729. Add(' i:=GetSize;');
  8730. Add(' i:=GetSize();');
  8731. Add(' SetSize(i);');
  8732. Add(' end;');
  8733. Add(' with obj do begin');
  8734. Add(' i:=GetSize;');
  8735. Add(' i:=GetSize();');
  8736. Add(' SetSize(i);');
  8737. Add(' end;');
  8738. ConvertProgram;
  8739. CheckSource('TestClass_WithClassInstDoFunc',
  8740. LinesToStr([ // statements
  8741. 'rtl.createClass($mod, "TObject", null, function () {',
  8742. ' this.$init = function () {',
  8743. ' };',
  8744. ' this.$final = function () {',
  8745. ' };',
  8746. ' this.Create = function () {',
  8747. ' };',
  8748. ' this.GetSize = function () {',
  8749. ' var Result = 0;',
  8750. ' return Result;',
  8751. ' };',
  8752. ' this.SetSize = function (Value) {',
  8753. ' };',
  8754. '});',
  8755. 'this.Obj = null;',
  8756. 'this.i = 0;'
  8757. ]),
  8758. LinesToStr([ // $mod.$main
  8759. 'var $with1 = $mod.TObject.$create("Create");',
  8760. '$mod.i = $with1.GetSize();',
  8761. '$mod.i = $with1.GetSize();',
  8762. '$with1.SetSize($mod.i);',
  8763. 'var $with2 = $mod.Obj;',
  8764. '$mod.i = $with2.GetSize();',
  8765. '$mod.i = $with2.GetSize();',
  8766. '$with2.SetSize($mod.i);',
  8767. '']));
  8768. end;
  8769. procedure TTestModule.TestClass_TypeCast;
  8770. begin
  8771. StartProgram(false);
  8772. Add('type');
  8773. Add(' TObject = class');
  8774. Add(' Next: TObject;');
  8775. Add(' constructor Create;');
  8776. Add(' end;');
  8777. Add(' TControl = class(TObject)');
  8778. Add(' Arr: array of TObject;');
  8779. Add(' function GetIt(vI: longint = 0): TObject;');
  8780. Add(' end;');
  8781. Add('constructor tobject.create; begin end;');
  8782. Add('function tcontrol.getit(vi: longint = 0): tobject; begin end;');
  8783. Add('var');
  8784. Add(' Obj: tobject;');
  8785. Add('begin');
  8786. Add(' obj:=tcontrol(obj).next;');
  8787. Add(' tcontrol(obj):=nil;');
  8788. Add(' obj:=tcontrol(obj);');
  8789. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
  8790. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
  8791. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
  8792. Add(' tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
  8793. ConvertProgram;
  8794. CheckSource('TestClass_TypeCast',
  8795. LinesToStr([ // statements
  8796. 'rtl.createClass($mod, "TObject", null, function () {',
  8797. ' this.$init = function () {',
  8798. ' this.Next = null;',
  8799. ' };',
  8800. ' this.$final = function () {',
  8801. ' this.Next = undefined;',
  8802. ' };',
  8803. ' this.Create = function () {',
  8804. ' };',
  8805. '});',
  8806. 'rtl.createClass($mod, "TControl", $mod.TObject, function () {',
  8807. ' this.$init = function () {',
  8808. ' $mod.TObject.$init.call(this);',
  8809. ' this.Arr = [];',
  8810. ' };',
  8811. ' this.$final = function () {',
  8812. ' this.Arr = undefined;',
  8813. ' $mod.TObject.$final.call(this);',
  8814. ' };',
  8815. ' this.GetIt = function (vI) {',
  8816. ' var Result = null;',
  8817. ' return Result;',
  8818. ' };',
  8819. '});',
  8820. 'this.Obj = null;'
  8821. ]),
  8822. LinesToStr([ // $mod.$main
  8823. '$mod.Obj = $mod.Obj.Next;',
  8824. '$mod.Obj = null;',
  8825. '$mod.Obj = $mod.Obj;',
  8826. '$mod.Obj = $mod.Obj.GetIt(0);',
  8827. '$mod.Obj = $mod.Obj.GetIt(0);',
  8828. '$mod.Obj = $mod.Obj.GetIt(1);',
  8829. '$mod.Obj = $mod.Obj.GetIt(0).Arr[2];',
  8830. '']));
  8831. end;
  8832. procedure TTestModule.TestClass_TypeCastUntypedParam;
  8833. begin
  8834. StartProgram(false);
  8835. Add('type');
  8836. Add(' TObject = class end;');
  8837. Add('procedure ProcA(var A);');
  8838. Add('begin');
  8839. Add(' TObject(A):=nil;');
  8840. Add(' TObject(A):=TObject(A);');
  8841. Add(' if TObject(A)=nil then ;');
  8842. Add(' if nil=TObject(A) then ;');
  8843. Add('end;');
  8844. Add('procedure ProcB(out A);');
  8845. Add('begin');
  8846. Add(' TObject(A):=nil;');
  8847. Add(' TObject(A):=TObject(A);');
  8848. Add(' if TObject(A)=nil then ;');
  8849. Add(' if nil=TObject(A) then ;');
  8850. Add('end;');
  8851. Add('procedure ProcC(const A);');
  8852. Add('begin');
  8853. Add(' if TObject(A)=nil then ;');
  8854. Add(' if nil=TObject(A) then ;');
  8855. Add('end;');
  8856. Add('var o: TObject;');
  8857. Add('begin');
  8858. Add(' ProcA(o);');
  8859. Add(' ProcB(o);');
  8860. Add(' ProcC(o);');
  8861. ConvertProgram;
  8862. CheckSource('TestClass_TypeCastUntypedParam',
  8863. LinesToStr([ // statements
  8864. 'rtl.createClass($mod, "TObject", null, function () {',
  8865. ' this.$init = function () {',
  8866. ' };',
  8867. ' this.$final = function () {',
  8868. ' };',
  8869. '});',
  8870. 'this.ProcA = function (A) {',
  8871. ' A.set(null);',
  8872. ' A.set(A.get());',
  8873. ' if (A.get() === null);',
  8874. ' if (null === A.get());',
  8875. '};',
  8876. 'this.ProcB = function (A) {',
  8877. ' A.set(null);',
  8878. ' A.set(A.get());',
  8879. ' if (A.get() === null);',
  8880. ' if (null === A.get());',
  8881. '};',
  8882. 'this.ProcC = function (A) {',
  8883. ' if (A === null);',
  8884. ' if (null === A);',
  8885. '};',
  8886. 'this.o = null;',
  8887. '']),
  8888. LinesToStr([ // $mod.$main
  8889. '$mod.ProcA({',
  8890. ' p: $mod,',
  8891. ' get: function () {',
  8892. ' return this.p.o;',
  8893. ' },',
  8894. ' set: function (v) {',
  8895. ' this.p.o = v;',
  8896. ' }',
  8897. '});',
  8898. '$mod.ProcB({',
  8899. ' p: $mod,',
  8900. ' get: function () {',
  8901. ' return this.p.o;',
  8902. ' },',
  8903. ' set: function (v) {',
  8904. ' this.p.o = v;',
  8905. ' }',
  8906. '});',
  8907. '$mod.ProcC($mod.o);',
  8908. '']));
  8909. end;
  8910. procedure TTestModule.TestClass_Overloads;
  8911. begin
  8912. StartProgram(false);
  8913. Add('type');
  8914. Add(' TObject = class');
  8915. Add(' procedure DoIt;');
  8916. Add(' procedure DoIt(vI: longint);');
  8917. Add(' end;');
  8918. Add('procedure TObject.DoIt;');
  8919. Add('begin');
  8920. Add(' DoIt;');
  8921. Add(' DoIt(1);');
  8922. Add('end;');
  8923. Add('procedure TObject.DoIt(vI: longint); begin end;');
  8924. Add('begin');
  8925. ConvertProgram;
  8926. CheckSource('TestClass_Overloads',
  8927. LinesToStr([ // statements
  8928. 'rtl.createClass($mod, "TObject", null, function () {',
  8929. ' this.$init = function () {',
  8930. ' };',
  8931. ' this.$final = function () {',
  8932. ' };',
  8933. ' this.DoIt = function () {',
  8934. ' this.DoIt();',
  8935. ' this.DoIt$1(1);',
  8936. ' };',
  8937. ' this.DoIt$1 = function (vI) {',
  8938. ' };',
  8939. '});',
  8940. '']),
  8941. LinesToStr([ // $mod.$main
  8942. '']));
  8943. end;
  8944. procedure TTestModule.TestClass_OverloadsAncestor;
  8945. begin
  8946. StartProgram(false);
  8947. Add('type');
  8948. Add(' TObject = class;');
  8949. Add(' TObject = class');
  8950. Add(' procedure DoIt(vA: longint);');
  8951. Add(' procedure DoIt(vA, vB: longint);');
  8952. Add(' end;');
  8953. Add(' TCar = class;');
  8954. Add(' TCar = class');
  8955. Add(' procedure DoIt(vA: longint);');
  8956. Add(' procedure DoIt(vA, vB: longint);');
  8957. Add(' end;');
  8958. Add('procedure tobject.doit(va: longint);');
  8959. Add('begin');
  8960. Add(' doit(1);');
  8961. Add(' doit(1,2);');
  8962. Add('end;');
  8963. Add('procedure tobject.doit(va, vb: longint); begin end;');
  8964. Add('procedure tcar.doit(va: longint);');
  8965. Add('begin');
  8966. Add(' doit(1);');
  8967. Add(' doit(1,2);');
  8968. Add(' inherited doit(1);');
  8969. Add(' inherited doit(1,2);');
  8970. Add('end;');
  8971. Add('procedure tcar.doit(va, vb: longint); begin end;');
  8972. Add('begin');
  8973. ConvertProgram;
  8974. CheckSource('TestClass_OverloadsAncestor',
  8975. LinesToStr([ // statements
  8976. 'rtl.createClass($mod, "TObject", null, function () {',
  8977. ' this.$init = function () {',
  8978. ' };',
  8979. ' this.$final = function () {',
  8980. ' };',
  8981. ' this.DoIt = function (vA) {',
  8982. ' this.DoIt(1);',
  8983. ' this.DoIt$1(1,2);',
  8984. ' };',
  8985. ' this.DoIt$1 = function (vA, vB) {',
  8986. ' };',
  8987. '});',
  8988. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  8989. ' this.DoIt$2 = function (vA) {',
  8990. ' this.DoIt$2(1);',
  8991. ' this.DoIt$3(1, 2);',
  8992. ' $mod.TObject.DoIt.call(this, 1);',
  8993. ' $mod.TObject.DoIt$1.call(this, 1, 2);',
  8994. ' };',
  8995. ' this.DoIt$3 = function (vA, vB) {',
  8996. ' };',
  8997. '});',
  8998. '']),
  8999. LinesToStr([ // $mod.$main
  9000. '']));
  9001. end;
  9002. procedure TTestModule.TestClass_OverloadConstructor;
  9003. begin
  9004. StartProgram(false);
  9005. Add('type');
  9006. Add(' TObject = class');
  9007. Add(' constructor Create(vA: longint);');
  9008. Add(' constructor Create(vA, vB: longint);');
  9009. Add(' end;');
  9010. Add(' TCar = class');
  9011. Add(' constructor Create(vA: longint);');
  9012. Add(' constructor Create(vA, vB: longint);');
  9013. Add(' end;');
  9014. Add('constructor tobject.create(va: longint);');
  9015. Add('begin');
  9016. Add(' create(1);');
  9017. Add(' create(1,2);');
  9018. Add('end;');
  9019. Add('constructor tobject.create(va, vb: longint); begin end;');
  9020. Add('constructor tcar.create(va: longint);');
  9021. Add('begin');
  9022. Add(' create(1);');
  9023. Add(' create(1,2);');
  9024. Add(' inherited create(1);');
  9025. Add(' inherited create(1,2);');
  9026. Add('end;');
  9027. Add('constructor tcar.create(va, vb: longint); begin end;');
  9028. Add('begin');
  9029. Add(' tobject.create(1);');
  9030. Add(' tobject.create(1,2);');
  9031. Add(' tcar.create(1);');
  9032. Add(' tcar.create(1,2);');
  9033. ConvertProgram;
  9034. CheckSource('TestClass_OverloadConstructor',
  9035. LinesToStr([ // statements
  9036. 'rtl.createClass($mod, "TObject", null, function () {',
  9037. ' this.$init = function () {',
  9038. ' };',
  9039. ' this.$final = function () {',
  9040. ' };',
  9041. ' this.Create = function (vA) {',
  9042. ' this.Create(1);',
  9043. ' this.Create$1(1,2);',
  9044. ' };',
  9045. ' this.Create$1 = function (vA, vB) {',
  9046. ' };',
  9047. '});',
  9048. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  9049. ' this.Create$2 = function (vA) {',
  9050. ' this.Create$2(1);',
  9051. ' this.Create$3(1, 2);',
  9052. ' $mod.TObject.Create.call(this, 1);',
  9053. ' $mod.TObject.Create$1.call(this, 1, 2);',
  9054. ' };',
  9055. ' this.Create$3 = function (vA, vB) {',
  9056. ' };',
  9057. '});',
  9058. '']),
  9059. LinesToStr([ // $mod.$main
  9060. '$mod.TObject.$create("Create", [1]);',
  9061. '$mod.TObject.$create("Create$1", [1, 2]);',
  9062. '$mod.TCar.$create("Create$2", [1]);',
  9063. '$mod.TCar.$create("Create$3", [1, 2]);',
  9064. '']));
  9065. end;
  9066. procedure TTestModule.TestClass_OverloadDelphiOverride;
  9067. begin
  9068. StartProgram(false);
  9069. Add([
  9070. '{$mode delphi}',
  9071. 'type',
  9072. ' TObject = class end;',
  9073. ' TBird = class',
  9074. ' function {#a}GetValue: longint; overload; virtual;',
  9075. ' function {#b}GetValue(AValue: longint): longint; overload; virtual;',
  9076. ' end;',
  9077. ' TEagle = class(TBird)',
  9078. ' function {#c}GetValue: longint; overload; override;',
  9079. ' function {#d}GetValue(AValue: longint): longint; overload; override;',
  9080. ' end;',
  9081. 'function TBird.GetValue: longint;',
  9082. 'begin',
  9083. ' if 3={@a}GetValue then ;',
  9084. ' if 4={@b}GetValue(5) then ;',
  9085. 'end;',
  9086. 'function TBird.GetValue(AValue: longint): longint;',
  9087. 'begin',
  9088. 'end;',
  9089. 'function TEagle.GetValue: longint;',
  9090. 'begin',
  9091. ' if 13={@c}GetValue then ;',
  9092. ' if 14={@d}GetValue(15) then ;',
  9093. ' if 15=inherited {@a}GetValue then ;',
  9094. ' if 16=inherited {@b}GetValue(17) then ;',
  9095. 'end;',
  9096. 'function TEagle.GetValue(AValue: longint): longint;',
  9097. 'begin',
  9098. 'end;',
  9099. 'var',
  9100. ' e: TEagle;',
  9101. 'begin',
  9102. ' if 23=e.{@c}GetValue then ;',
  9103. ' if 24=e.{@d}GetValue(25) then ;']);
  9104. ConvertProgram;
  9105. CheckSource('TestClass_OverloadDelphiOverride',
  9106. LinesToStr([ // statements
  9107. 'rtl.createClass($mod, "TObject", null, function () {',
  9108. ' this.$init = function () {',
  9109. ' };',
  9110. ' this.$final = function () {',
  9111. ' };',
  9112. '});',
  9113. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  9114. ' this.GetValue = function () {',
  9115. ' var Result = 0;',
  9116. ' if (3 === this.GetValue()) ;',
  9117. ' if (4 === this.GetValue$1(5)) ;',
  9118. ' return Result;',
  9119. ' };',
  9120. ' this.GetValue$1 = function (AValue) {',
  9121. ' var Result = 0;',
  9122. ' return Result;',
  9123. ' };',
  9124. '});',
  9125. 'rtl.createClass($mod, "TEagle", $mod.TBird, function () {',
  9126. ' this.GetValue = function () {',
  9127. ' var Result = 0;',
  9128. ' if (13 === this.GetValue()) ;',
  9129. ' if (14 === this.GetValue$1(15)) ;',
  9130. ' if (15 === $mod.TBird.GetValue.call(this)) ;',
  9131. ' if (16 === $mod.TBird.GetValue$1.call(this, 17)) ;',
  9132. ' return Result;',
  9133. ' };',
  9134. ' this.GetValue$1 = function (AValue) {',
  9135. ' var Result = 0;',
  9136. ' return Result;',
  9137. ' };',
  9138. '});',
  9139. 'this.e = null;',
  9140. '']),
  9141. LinesToStr([ // $mod.$main
  9142. 'if (23 === $mod.e.GetValue()) ;',
  9143. 'if (24 === $mod.e.GetValue$1(25)) ;',
  9144. '']));
  9145. end;
  9146. procedure TTestModule.TestClass_ReintroducedVar;
  9147. begin
  9148. StartProgram(false);
  9149. Add('type');
  9150. Add(' TObject = class');
  9151. Add(' strict private');
  9152. Add(' Some: longint;');
  9153. Add(' end;');
  9154. Add(' TMobile = class');
  9155. Add(' strict private');
  9156. Add(' Some: string;');
  9157. Add(' end;');
  9158. Add(' TCar = class(tmobile)');
  9159. Add(' procedure Some;');
  9160. Add(' procedure Some(vA: longint);');
  9161. Add(' end;');
  9162. Add('procedure tcar.some;');
  9163. Add('begin');
  9164. Add(' Some;');
  9165. Add(' Some(1);');
  9166. Add('end;');
  9167. Add('procedure tcar.some(va: longint); begin end;');
  9168. Add('begin');
  9169. ConvertProgram;
  9170. CheckSource('TestClass_ReintroducedVar',
  9171. LinesToStr([ // statements
  9172. 'rtl.createClass($mod, "TObject", null, function () {',
  9173. ' this.$init = function () {',
  9174. ' this.Some = 0;',
  9175. ' };',
  9176. ' this.$final = function () {',
  9177. ' };',
  9178. '});',
  9179. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  9180. ' this.$init = function () {',
  9181. ' $mod.TObject.$init.call(this);',
  9182. ' this.Some$1 = "";',
  9183. ' };',
  9184. '});',
  9185. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  9186. ' this.Some$2 = function () {',
  9187. ' this.Some$2();',
  9188. ' this.Some$3(1);',
  9189. ' };',
  9190. ' this.Some$3 = function (vA) {',
  9191. ' };',
  9192. '});',
  9193. '']),
  9194. LinesToStr([ // $mod.$main
  9195. '']));
  9196. end;
  9197. procedure TTestModule.TestClass_RaiseDescendant;
  9198. begin
  9199. StartProgram(false);
  9200. Add([
  9201. 'type',
  9202. ' TObject = class',
  9203. ' constructor Create(Msg: string);',
  9204. ' end;',
  9205. ' Exception = class',
  9206. ' end;',
  9207. ' EConvertError = class(Exception)',
  9208. ' end;',
  9209. 'constructor TObject.Create(Msg: string); begin end;',
  9210. 'function AssertConv(Msg: string = ''def''): EConvertError; begin end;',
  9211. 'begin',
  9212. ' raise Exception.Create(''Bar1'');',
  9213. ' raise EConvertError.Create(''Bar2'');',
  9214. ' raise AssertConv(''Bar2'');',
  9215. ' raise AssertConv;',
  9216. '']);
  9217. ConvertProgram;
  9218. CheckSource('TestClass_RaiseDescendant',
  9219. LinesToStr([ // statements
  9220. 'rtl.createClass($mod, "TObject", null, function () {',
  9221. ' this.$init = function () {',
  9222. ' };',
  9223. ' this.$final = function () {',
  9224. ' };',
  9225. ' this.Create = function (Msg) {',
  9226. ' };',
  9227. '});',
  9228. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  9229. '});',
  9230. 'rtl.createClass($mod, "EConvertError", $mod.Exception, function () {',
  9231. '});',
  9232. 'this.AssertConv = function (Msg) {',
  9233. ' var Result = null;',
  9234. ' return Result;',
  9235. '};',
  9236. '']),
  9237. LinesToStr([ // $mod.$main
  9238. 'throw $mod.Exception.$create("Create",["Bar1"]);',
  9239. 'throw $mod.EConvertError.$create("Create",["Bar2"]);',
  9240. 'throw $mod.AssertConv("Bar2");',
  9241. 'throw $mod.AssertConv("def");',
  9242. '']));
  9243. end;
  9244. procedure TTestModule.TestClass_ExternalMethod;
  9245. begin
  9246. AddModuleWithIntfImplSrc('unit2.pas',
  9247. LinesToStr([
  9248. 'type',
  9249. ' TObject = class',
  9250. ' public',
  9251. ' procedure Intern; external name ''$DoIntern'';',
  9252. ' end;',
  9253. '']),
  9254. LinesToStr([
  9255. '']));
  9256. StartUnit(true);
  9257. Add('interface');
  9258. Add('uses unit2;');
  9259. Add('type');
  9260. Add(' TCar = class(TObject)');
  9261. Add(' public');
  9262. Add(' procedure Intern2; external name ''$DoIntern2'';');
  9263. Add(' procedure DoIt;');
  9264. Add(' end;');
  9265. Add('implementation');
  9266. Add('procedure tcar.doit;');
  9267. Add('begin');
  9268. Add(' Intern;');
  9269. Add(' Intern();');
  9270. Add(' Intern2;');
  9271. Add(' Intern2();');
  9272. Add('end;');
  9273. Add('var Obj: TCar;');
  9274. Add('begin');
  9275. Add(' obj.intern;');
  9276. Add(' obj.intern();');
  9277. Add(' obj.intern2;');
  9278. Add(' obj.intern2();');
  9279. Add(' obj.doit;');
  9280. Add(' obj.doit();');
  9281. Add(' with obj do begin');
  9282. Add(' Intern;');
  9283. Add(' Intern();');
  9284. Add(' Intern2;');
  9285. Add(' Intern2();');
  9286. Add(' end;');
  9287. ConvertUnit;
  9288. CheckSource('TestClass_ExternalMethod',
  9289. LinesToStr([
  9290. 'var $impl = $mod.$impl;',
  9291. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  9292. ' this.DoIt = function () {',
  9293. ' this.$DoIntern();',
  9294. ' this.$DoIntern();',
  9295. ' this.$DoIntern2();',
  9296. ' this.$DoIntern2();',
  9297. ' };',
  9298. ' });',
  9299. '']),
  9300. LinesToStr([ // this.$init
  9301. '$impl.Obj.$DoIntern();',
  9302. '$impl.Obj.$DoIntern();',
  9303. '$impl.Obj.$DoIntern2();',
  9304. '$impl.Obj.$DoIntern2();',
  9305. '$impl.Obj.DoIt();',
  9306. '$impl.Obj.DoIt();',
  9307. 'var $with1 = $impl.Obj;',
  9308. '$with1.$DoIntern();',
  9309. '$with1.$DoIntern();',
  9310. '$with1.$DoIntern2();',
  9311. '$with1.$DoIntern2();',
  9312. '']),
  9313. LinesToStr([ // implementation
  9314. '$impl.Obj = null;',
  9315. '']) );
  9316. end;
  9317. procedure TTestModule.TestClass_ExternalVirtualNameMismatchFail;
  9318. begin
  9319. StartProgram(false);
  9320. Add('type');
  9321. Add(' TObject = class');
  9322. Add(' procedure DoIt; virtual; external name ''Foo'';');
  9323. Add(' end;');
  9324. Add('begin');
  9325. SetExpectedPasResolverError('Virtual method name must match external',
  9326. nVirtualMethodNameMustMatchExternal);
  9327. ConvertProgram;
  9328. end;
  9329. procedure TTestModule.TestClass_ExternalOverrideFail;
  9330. begin
  9331. StartProgram(false);
  9332. Add('type');
  9333. Add(' TObject = class');
  9334. Add(' procedure DoIt; virtual; external name ''DoIt'';');
  9335. Add(' end;');
  9336. Add(' TCar = class');
  9337. Add(' procedure DoIt; override; external name ''DoIt'';');
  9338. Add(' end;');
  9339. Add('begin');
  9340. SetExpectedPasResolverError('Invalid procedure modifier override,external',
  9341. nInvalidXModifierY);
  9342. ConvertProgram;
  9343. end;
  9344. procedure TTestModule.TestClass_ExternalVar;
  9345. begin
  9346. AddModuleWithIntfImplSrc('unit2.pas',
  9347. LinesToStr([
  9348. '{$modeswitch externalclass}',
  9349. 'type',
  9350. ' TObject = class',
  9351. ' public',
  9352. ' Intern: longint external name ''$Intern'';',
  9353. ' end;',
  9354. '']),
  9355. LinesToStr([
  9356. '']));
  9357. StartUnit(true);
  9358. Add('interface');
  9359. Add('uses unit2;');
  9360. Add('{$modeswitch externalclass}');
  9361. Add('type');
  9362. Add(' TCar = class(tobject)');
  9363. Add(' public');
  9364. Add(' Intern2: longint external name ''$Intern2'';');
  9365. Add(' procedure DoIt;');
  9366. Add(' end;');
  9367. Add('implementation');
  9368. Add('procedure tcar.doit;');
  9369. Add('begin');
  9370. Add(' Intern:=Intern+1;');
  9371. Add(' Intern2:=Intern2+2;');
  9372. Add('end;');
  9373. Add('var Obj: TCar;');
  9374. Add('begin');
  9375. Add(' obj.intern:=obj.intern+1;');
  9376. Add(' obj.intern2:=obj.intern2+2;');
  9377. Add(' with obj do begin');
  9378. Add(' intern:=intern+1;');
  9379. Add(' intern2:=intern2+2;');
  9380. Add(' end;');
  9381. ConvertUnit;
  9382. CheckSource('TestClass_ExternalVar',
  9383. LinesToStr([
  9384. 'var $impl = $mod.$impl;',
  9385. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  9386. ' this.DoIt = function () {',
  9387. ' this.$Intern = this.$Intern + 1;',
  9388. ' this.$Intern2 = this.$Intern2 + 2;',
  9389. ' };',
  9390. ' });',
  9391. '']),
  9392. LinesToStr([
  9393. '$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
  9394. '$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
  9395. 'var $with1 = $impl.Obj;',
  9396. '$with1.$Intern = $with1.$Intern + 1;',
  9397. '$with1.$Intern2 = $with1.$Intern2 + 2;',
  9398. '']),
  9399. LinesToStr([ // implementation
  9400. '$impl.Obj = null;',
  9401. '']));
  9402. end;
  9403. procedure TTestModule.TestClass_Const;
  9404. begin
  9405. StartProgram(false);
  9406. Add('type');
  9407. Add(' integer = longint;');
  9408. Add(' TClass = class of TObject;');
  9409. Add(' TObject = class');
  9410. Add(' public');
  9411. Add(' const cI: integer = 3;');
  9412. Add(' procedure DoIt;');
  9413. Add(' class procedure DoMore;');
  9414. Add(' end;');
  9415. Add('implementation');
  9416. Add('procedure tobject.doit;');
  9417. Add('begin');
  9418. Add(' if cI=4 then;');
  9419. Add(' if 5=cI then;');
  9420. Add(' if Self.cI=6 then;');
  9421. Add(' if 7=Self.cI then;');
  9422. Add(' with Self do begin');
  9423. Add(' if cI=11 then;');
  9424. Add(' if 12=cI then;');
  9425. Add(' end;');
  9426. Add('end;');
  9427. Add('class procedure tobject.domore;');
  9428. Add('begin');
  9429. Add(' if cI=8 then;');
  9430. Add(' if Self.cI=9 then;');
  9431. Add(' if 10=cI then;');
  9432. Add(' if 11=Self.cI then;');
  9433. Add(' with Self do begin');
  9434. Add(' if cI=13 then;');
  9435. Add(' if 14=cI then;');
  9436. Add(' end;');
  9437. Add('end;');
  9438. Add('var');
  9439. Add(' Obj: TObject;');
  9440. Add(' Cla: TClass;');
  9441. Add('begin');
  9442. Add(' if TObject.cI=21 then ;');
  9443. Add(' if Obj.cI=22 then ;');
  9444. Add(' if Cla.cI=23 then ;');
  9445. Add(' with obj do if ci=24 then;');
  9446. Add(' with TObject do if ci=25 then;');
  9447. Add(' with Cla do if ci=26 then;');
  9448. ConvertProgram;
  9449. CheckSource('TestClass_Const',
  9450. LinesToStr([
  9451. 'rtl.createClass($mod, "TObject", null, function () {',
  9452. ' this.cI = 3;',
  9453. ' this.$init = function () {',
  9454. ' };',
  9455. ' this.$final = function () {',
  9456. ' };',
  9457. ' this.DoIt = function () {',
  9458. ' if (this.cI === 4) ;',
  9459. ' if (5 === this.cI) ;',
  9460. ' if (this.cI === 6) ;',
  9461. ' if (7 === this.cI) ;',
  9462. ' if (this.cI === 11) ;',
  9463. ' if (12 === this.cI) ;',
  9464. ' };',
  9465. ' this.DoMore = function () {',
  9466. ' if (this.cI === 8) ;',
  9467. ' if (this.cI === 9) ;',
  9468. ' if (10 === this.cI) ;',
  9469. ' if (11 === this.cI) ;',
  9470. ' if (this.cI === 13) ;',
  9471. ' if (14 === this.cI) ;',
  9472. ' };',
  9473. '});',
  9474. 'this.Obj = null;',
  9475. 'this.Cla = null;',
  9476. '']),
  9477. LinesToStr([
  9478. 'if ($mod.TObject.cI === 21) ;',
  9479. 'if ($mod.Obj.cI === 22) ;',
  9480. 'if ($mod.Cla.cI === 23) ;',
  9481. 'var $with1 = $mod.Obj;',
  9482. 'if ($with1.cI === 24) ;',
  9483. 'var $with2 = $mod.TObject;',
  9484. 'if ($with2.cI === 25) ;',
  9485. 'var $with3 = $mod.Cla;',
  9486. 'if ($with3.cI === 26) ;',
  9487. '']));
  9488. end;
  9489. procedure TTestModule.TestClass_LocalVarSelfFail;
  9490. begin
  9491. StartProgram(false);
  9492. Add([
  9493. 'type',
  9494. ' TObject = class',
  9495. ' constructor Create;',
  9496. ' end;',
  9497. 'constructor tobject.create;',
  9498. 'var self: longint;',
  9499. 'begin',
  9500. 'end',
  9501. 'begin',
  9502. '']);
  9503. SetExpectedPasResolverError('Duplicate identifier "self" at (0)',nDuplicateIdentifier);
  9504. ConvertProgram;
  9505. end;
  9506. procedure TTestModule.TestClass_ArgSelfFail;
  9507. begin
  9508. StartProgram(false);
  9509. Add([
  9510. 'type',
  9511. ' TObject = class',
  9512. ' procedure DoIt(Self: longint);',
  9513. ' end;',
  9514. 'procedure tobject.doit(self: longint);',
  9515. 'begin',
  9516. 'end',
  9517. 'begin',
  9518. '']);
  9519. SetExpectedPasResolverError('Duplicate identifier "Self" at test1.pp(5,24)',nDuplicateIdentifier);
  9520. ConvertProgram;
  9521. end;
  9522. procedure TTestModule.TestClass_NestedProcSelf;
  9523. begin
  9524. StartProgram(false);
  9525. Add([
  9526. 'type',
  9527. ' TObject = class',
  9528. ' Key: longint;',
  9529. ' class var State: longint;',
  9530. ' procedure DoIt;',
  9531. ' function GetSize: longint; virtual; abstract;',
  9532. ' procedure SetSize(Value: longint); virtual; abstract;',
  9533. ' property Size: longint read GetSize write SetSize;',
  9534. ' end;',
  9535. 'procedure tobject.doit;',
  9536. ' procedure Sub;',
  9537. ' begin',
  9538. ' key:=key+2;',
  9539. ' self.key:=self.key+3;',
  9540. ' state:=state+4;',
  9541. ' self.state:=self.state+5;',
  9542. ' tobject.state:=tobject.state+6;',
  9543. ' size:=size+7;',
  9544. ' self.size:=self.size+8;',
  9545. ' end;',
  9546. 'begin',
  9547. ' sub;',
  9548. ' key:=key+12;',
  9549. ' self.key:=self.key+13;',
  9550. ' state:=state+14;',
  9551. ' self.state:=self.state+15;',
  9552. ' tobject.state:=tobject.state+16;',
  9553. ' size:=size+17;',
  9554. ' self.size:=self.size+18;',
  9555. 'end;',
  9556. 'begin',
  9557. '']);
  9558. ConvertProgram;
  9559. CheckSource('TestClass_NestedProcSelf',
  9560. LinesToStr([ // statements
  9561. 'rtl.createClass($mod, "TObject", null, function () {',
  9562. ' this.State = 0;',
  9563. ' this.$init = function () {',
  9564. ' this.Key = 0;',
  9565. ' };',
  9566. ' this.$final = function () {',
  9567. ' };',
  9568. ' this.DoIt = function () {',
  9569. ' var Self = this;',
  9570. ' function Sub() {',
  9571. ' Self.Key = Self.Key + 2;',
  9572. ' Self.Key = Self.Key + 3;',
  9573. ' Self.$class.State = Self.State + 4;',
  9574. ' Self.$class.State = Self.State + 5;',
  9575. ' $mod.TObject.State = $mod.TObject.State + 6;',
  9576. ' Self.SetSize(Self.GetSize() + 7);',
  9577. ' Self.SetSize(Self.GetSize() + 8);',
  9578. ' };',
  9579. ' Sub();',
  9580. ' Self.Key = Self.Key + 12;',
  9581. ' Self.Key = Self.Key + 13;',
  9582. ' Self.$class.State = Self.State + 14;',
  9583. ' Self.$class.State = Self.State + 15;',
  9584. ' $mod.TObject.State = $mod.TObject.State + 16;',
  9585. ' Self.SetSize(Self.GetSize() + 17);',
  9586. ' Self.SetSize(Self.GetSize() + 18);',
  9587. ' };',
  9588. '});',
  9589. '']),
  9590. LinesToStr([ // $mod.$main
  9591. '']));
  9592. end;
  9593. procedure TTestModule.TestClass_NestedProcSelf2;
  9594. begin
  9595. StartProgram(false);
  9596. Add([
  9597. 'type',
  9598. ' TObject = class',
  9599. ' Key: longint;',
  9600. ' class var State: longint;',
  9601. ' function GetSize: longint; virtual; abstract;',
  9602. ' procedure SetSize(Value: longint); virtual; abstract;',
  9603. ' property Size: longint read GetSize write SetSize;',
  9604. ' end;',
  9605. ' TBird = class',
  9606. ' procedure DoIt;',
  9607. ' end;',
  9608. 'procedure tbird.doit;',
  9609. ' procedure Sub;',
  9610. ' begin',
  9611. ' key:=key+2;',
  9612. ' self.key:=self.key+3;',
  9613. ' state:=state+4;',
  9614. ' self.state:=self.state+5;',
  9615. ' tobject.state:=tobject.state+6;',
  9616. ' size:=size+7;',
  9617. ' self.size:=self.size+8;',
  9618. ' end;',
  9619. 'begin',
  9620. ' sub;',
  9621. ' key:=key+12;',
  9622. ' self.key:=self.key+13;',
  9623. ' state:=state+14;',
  9624. ' self.state:=self.state+15;',
  9625. ' tobject.state:=tobject.state+16;',
  9626. ' size:=size+17;',
  9627. ' self.size:=self.size+18;',
  9628. 'end;',
  9629. 'begin',
  9630. '']);
  9631. ConvertProgram;
  9632. CheckSource('TestClass_NestedProcSelf2',
  9633. LinesToStr([ // statements
  9634. 'rtl.createClass($mod, "TObject", null, function () {',
  9635. ' this.State = 0;',
  9636. ' this.$init = function () {',
  9637. ' this.Key = 0;',
  9638. ' };',
  9639. ' this.$final = function () {',
  9640. ' };',
  9641. '});',
  9642. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  9643. ' this.DoIt = function () {',
  9644. ' var Self = this;',
  9645. ' function Sub() {',
  9646. ' Self.Key = Self.Key + 2;',
  9647. ' Self.Key = Self.Key + 3;',
  9648. ' Self.$class.State = Self.State + 4;',
  9649. ' Self.$class.State = Self.State + 5;',
  9650. ' $mod.TObject.State = $mod.TObject.State + 6;',
  9651. ' Self.SetSize(Self.GetSize() + 7);',
  9652. ' Self.SetSize(Self.GetSize() + 8);',
  9653. ' };',
  9654. ' Sub();',
  9655. ' this.Key = this.Key + 12;',
  9656. ' Self.Key = Self.Key + 13;',
  9657. ' this.$class.State = this.State + 14;',
  9658. ' Self.$class.State = Self.State + 15;',
  9659. ' $mod.TObject.State = $mod.TObject.State + 16;',
  9660. ' this.SetSize(this.GetSize() + 17);',
  9661. ' Self.SetSize(Self.GetSize() + 18);',
  9662. ' };',
  9663. '});',
  9664. '']),
  9665. LinesToStr([ // $mod.$main
  9666. '']));
  9667. end;
  9668. procedure TTestModule.TestClass_NestedProcClassSelf;
  9669. begin
  9670. StartProgram(false);
  9671. Add([
  9672. 'type',
  9673. ' TObject = class',
  9674. ' class var State: longint;',
  9675. ' class procedure DoIt;',
  9676. ' class function GetSize: longint; virtual; abstract;',
  9677. ' class procedure SetSize(Value: longint); virtual; abstract;',
  9678. ' class property Size: longint read GetSize write SetSize;',
  9679. ' end;',
  9680. 'class procedure tobject.doit;',
  9681. ' procedure Sub;',
  9682. ' begin',
  9683. ' state:=state+2;',
  9684. ' self.state:=self.state+3;',
  9685. ' tobject.state:=tobject.state+4;',
  9686. ' size:=size+5;',
  9687. ' self.size:=self.size+6;',
  9688. ' tobject.size:=tobject.size+7;',
  9689. ' end;',
  9690. 'begin',
  9691. ' sub;',
  9692. ' state:=state+12;',
  9693. ' self.state:=self.state+13;',
  9694. ' tobject.state:=tobject.state+14;',
  9695. ' size:=size+15;',
  9696. ' self.size:=self.size+16;',
  9697. ' tobject.size:=tobject.size+17;',
  9698. 'end;',
  9699. 'begin',
  9700. '']);
  9701. ConvertProgram;
  9702. CheckSource('TestClass_NestedProcClassSelf',
  9703. LinesToStr([ // statements
  9704. 'rtl.createClass($mod, "TObject", null, function () {',
  9705. ' this.State = 0;',
  9706. ' this.$init = function () {',
  9707. ' };',
  9708. ' this.$final = function () {',
  9709. ' };',
  9710. ' this.DoIt = function () {',
  9711. ' var Self = this;',
  9712. ' function Sub() {',
  9713. ' Self.State = Self.State + 2;',
  9714. ' Self.State = Self.State + 3;',
  9715. ' $mod.TObject.State = $mod.TObject.State + 4;',
  9716. ' Self.SetSize(Self.GetSize() + 5);',
  9717. ' Self.SetSize(Self.GetSize() + 6);',
  9718. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 7);',
  9719. ' };',
  9720. ' Sub();',
  9721. ' Self.State = Self.State + 12;',
  9722. ' Self.State = Self.State + 13;',
  9723. ' $mod.TObject.State = $mod.TObject.State + 14;',
  9724. ' Self.SetSize(Self.GetSize() + 15);',
  9725. ' Self.SetSize(Self.GetSize() + 16);',
  9726. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
  9727. ' };',
  9728. '});',
  9729. '']),
  9730. LinesToStr([ // $mod.$main
  9731. '']));
  9732. end;
  9733. procedure TTestModule.TestClass_NestedProcCallInherited;
  9734. begin
  9735. StartProgram(false);
  9736. Add([
  9737. 'type',
  9738. ' TObject = class',
  9739. ' function DoIt(k: boolean): longint; virtual;',
  9740. ' end;',
  9741. ' TBird = class',
  9742. ' function DoIt(k: boolean): longint; override;',
  9743. ' end;',
  9744. 'function tobject.doit(k: boolean): longint;',
  9745. 'begin',
  9746. 'end;',
  9747. 'function tbird.doit(k: boolean): longint;',
  9748. ' procedure Sub;',
  9749. ' begin',
  9750. ' inherited DoIt(true);',
  9751. //' if inherited DoIt(false)=4 then ;',
  9752. ' end;',
  9753. 'begin',
  9754. ' Sub;',
  9755. ' inherited;',
  9756. ' inherited DoIt(true);',
  9757. //' if inherited DoIt(false)=14 then ;',
  9758. 'end;',
  9759. 'begin',
  9760. '']);
  9761. ConvertProgram;
  9762. CheckSource('TestClass_NestedProcCallInherited',
  9763. LinesToStr([ // statements
  9764. 'rtl.createClass($mod, "TObject", null, function () {',
  9765. ' this.$init = function () {',
  9766. ' };',
  9767. ' this.$final = function () {',
  9768. ' };',
  9769. ' this.DoIt = function (k) {',
  9770. ' var Result = 0;',
  9771. ' return Result;',
  9772. ' };',
  9773. '});',
  9774. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  9775. ' this.DoIt = function (k) {',
  9776. ' var Self = this;',
  9777. ' var Result = 0;',
  9778. ' function Sub() {',
  9779. ' $mod.TObject.DoIt.call(Self, true);',
  9780. ' };',
  9781. ' Sub();',
  9782. ' $mod.TObject.DoIt.apply(Self, arguments);',
  9783. ' $mod.TObject.DoIt.call(Self, true);',
  9784. ' return Result;',
  9785. ' };',
  9786. '});',
  9787. '']),
  9788. LinesToStr([ // $mod.$main
  9789. '']));
  9790. end;
  9791. procedure TTestModule.TestClass_TObjectFree;
  9792. begin
  9793. StartProgram(false);
  9794. Add([
  9795. 'type',
  9796. ' TObject = class',
  9797. ' Obj: tobject;',
  9798. ' procedure Free;',
  9799. ' end;',
  9800. 'procedure tobject.free;',
  9801. 'begin',
  9802. 'end;',
  9803. 'function DoIt(o: tobject): tobject;',
  9804. 'var l: tobject;',
  9805. 'begin',
  9806. ' o.free;',
  9807. ' o.free();',
  9808. ' l.free;',
  9809. ' l.free();',
  9810. ' o.obj.free;',
  9811. ' o.obj.free();',
  9812. ' with o do obj.free;',
  9813. ' with o do obj.free();',
  9814. ' result.Free;',
  9815. ' result.Free();',
  9816. 'end;',
  9817. 'var o: tobject;',
  9818. ' a: array of tobject;',
  9819. 'begin',
  9820. ' o.free;',
  9821. ' o.obj.free;',
  9822. ' a[1+2].free;',
  9823. '']);
  9824. ConvertProgram;
  9825. CheckSource('TestClass_TObjectFree',
  9826. LinesToStr([ // statements
  9827. 'rtl.createClass($mod, "TObject", null, function () {',
  9828. ' this.$init = function () {',
  9829. ' this.Obj = null;',
  9830. ' };',
  9831. ' this.$final = function () {',
  9832. ' this.Obj = undefined;',
  9833. ' };',
  9834. ' this.Free = function () {',
  9835. ' };',
  9836. '});',
  9837. 'this.DoIt = function (o) {',
  9838. ' var Result = null;',
  9839. ' var l = null;',
  9840. ' o = rtl.freeLoc(o);',
  9841. ' o = rtl.freeLoc(o);',
  9842. ' l = rtl.freeLoc(l);',
  9843. ' l = rtl.freeLoc(l);',
  9844. ' rtl.free(o, "Obj");',
  9845. ' rtl.free(o, "Obj");',
  9846. ' rtl.free(o, "Obj");',
  9847. ' rtl.free(o, "Obj");',
  9848. ' Result = rtl.freeLoc(Result);',
  9849. ' Result = rtl.freeLoc(Result);',
  9850. ' return Result;',
  9851. '};',
  9852. 'this.o = null;',
  9853. 'this.a = [];',
  9854. '']),
  9855. LinesToStr([ // $mod.$main
  9856. 'rtl.free($mod, "o");',
  9857. 'rtl.free($mod.o, "Obj");',
  9858. 'rtl.free($mod.a, 1 + 2);',
  9859. '']));
  9860. end;
  9861. procedure TTestModule.TestClass_TObjectFreeNewInstance;
  9862. begin
  9863. StartProgram(false);
  9864. Add([
  9865. 'type',
  9866. ' TObject = class',
  9867. ' constructor Create;',
  9868. ' procedure Free;',
  9869. ' end;',
  9870. 'constructor TObject.Create; begin end;',
  9871. 'procedure tobject.free; begin end;',
  9872. 'begin',
  9873. ' with tobject.create do free;',
  9874. '']);
  9875. ConvertProgram;
  9876. CheckSource('TestClass_TObjectFreeNewInstance',
  9877. LinesToStr([ // statements
  9878. 'rtl.createClass($mod, "TObject", null, function () {',
  9879. ' this.$init = function () {',
  9880. ' };',
  9881. ' this.$final = function () {',
  9882. ' };',
  9883. ' this.Create = function () {',
  9884. ' };',
  9885. ' this.Free = function () {',
  9886. ' };',
  9887. '});',
  9888. '']),
  9889. LinesToStr([ // $mod.$main
  9890. 'var $with1 = $mod.TObject.$create("Create");',
  9891. '$with1=rtl.freeLoc($with1);',
  9892. '']));
  9893. end;
  9894. procedure TTestModule.TestClass_TObjectFreeLowerCase;
  9895. begin
  9896. StartProgram(false);
  9897. Add([
  9898. 'type',
  9899. ' TObject = class',
  9900. ' destructor Destroy;',
  9901. ' procedure Free;',
  9902. ' end;',
  9903. 'destructor TObject.Destroy; begin end;',
  9904. 'procedure tobject.free; begin end;',
  9905. 'var o: tobject;',
  9906. 'begin',
  9907. ' o.free;',
  9908. '']);
  9909. Converter.UseLowerCase:=true;
  9910. ConvertProgram;
  9911. CheckSource('TestClass_TObjectFreeLowerCase',
  9912. LinesToStr([ // statements
  9913. 'rtl.createClass($mod, "tobject", null, function () {',
  9914. ' this.$init = function () {',
  9915. ' };',
  9916. ' this.$final = function () {',
  9917. ' };',
  9918. ' rtl.tObjectDestroy = "destroy";',
  9919. ' this.destroy = function () {',
  9920. ' };',
  9921. ' this.free = function () {',
  9922. ' };',
  9923. '});',
  9924. 'this.o = null;',
  9925. '']),
  9926. LinesToStr([ // $mod.$main
  9927. 'rtl.free($mod, "o");',
  9928. '']));
  9929. end;
  9930. procedure TTestModule.TestClass_TObjectFreeFunctionFail;
  9931. begin
  9932. StartProgram(false);
  9933. Add([
  9934. 'type',
  9935. ' TObject = class',
  9936. ' procedure Free;',
  9937. ' function GetObj: tobject; virtual; abstract;',
  9938. ' end;',
  9939. 'procedure tobject.free;',
  9940. 'begin',
  9941. 'end;',
  9942. 'var o: tobject;',
  9943. 'begin',
  9944. ' o.getobj.free;',
  9945. '']);
  9946. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  9947. ConvertProgram;
  9948. end;
  9949. procedure TTestModule.TestClass_TObjectFreePropertyFail;
  9950. begin
  9951. StartProgram(false);
  9952. Add([
  9953. 'type',
  9954. ' TObject = class',
  9955. ' procedure Free;',
  9956. ' FObj: TObject;',
  9957. ' property Obj: tobject read FObj write FObj;',
  9958. ' end;',
  9959. 'procedure tobject.free;',
  9960. 'begin',
  9961. 'end;',
  9962. 'var o: tobject;',
  9963. 'begin',
  9964. ' o.obj.free;',
  9965. '']);
  9966. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  9967. ConvertProgram;
  9968. end;
  9969. procedure TTestModule.TestClass_ForIn;
  9970. begin
  9971. StartProgram(false);
  9972. Add([
  9973. 'type',
  9974. ' TObject = class end;',
  9975. ' TItem = TObject;',
  9976. ' TEnumerator = class',
  9977. ' FCurrent: TItem;',
  9978. ' property Current: TItem read FCurrent;',
  9979. ' function MoveNext: boolean;',
  9980. ' end;',
  9981. ' TBird = class',
  9982. ' function GetEnumerator: TEnumerator;',
  9983. ' end;',
  9984. 'function TEnumerator.MoveNext: boolean;',
  9985. 'begin',
  9986. 'end;',
  9987. 'function TBird.GetEnumerator: TEnumerator;',
  9988. 'begin',
  9989. 'end;',
  9990. 'var',
  9991. ' b: TBird;',
  9992. ' i, i2: TItem;',
  9993. 'begin',
  9994. ' for i in b do i2:=i;']);
  9995. ConvertProgram;
  9996. CheckSource('TestClass_ForIn',
  9997. LinesToStr([ // statements
  9998. 'rtl.createClass($mod, "TObject", null, function () {',
  9999. ' this.$init = function () {',
  10000. ' };',
  10001. ' this.$final = function () {',
  10002. ' };',
  10003. '});',
  10004. 'rtl.createClass($mod, "TEnumerator", $mod.TObject, function () {',
  10005. ' this.$init = function () {',
  10006. ' $mod.TObject.$init.call(this);',
  10007. ' this.FCurrent = null;',
  10008. ' };',
  10009. ' this.$final = function () {',
  10010. ' this.FCurrent = undefined;',
  10011. ' $mod.TObject.$final.call(this);',
  10012. ' };',
  10013. ' this.MoveNext = function () {',
  10014. ' var Result = false;',
  10015. ' return Result;',
  10016. ' };',
  10017. '});',
  10018. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  10019. ' this.GetEnumerator = function () {',
  10020. ' var Result = null;',
  10021. ' return Result;',
  10022. ' };',
  10023. '});',
  10024. 'this.b = null;',
  10025. 'this.i = null;',
  10026. 'this.i2 = null;'
  10027. ]),
  10028. LinesToStr([ // $mod.$main
  10029. 'var $in1 = $mod.b.GetEnumerator();',
  10030. 'try {',
  10031. ' while ($in1.MoveNext()){',
  10032. ' $mod.i = $in1.FCurrent;',
  10033. ' $mod.i2 = $mod.i;',
  10034. ' }',
  10035. '} finally {',
  10036. ' $in1 = rtl.freeLoc($in1)',
  10037. '};',
  10038. '']));
  10039. end;
  10040. procedure TTestModule.TestClassOf_Create;
  10041. begin
  10042. StartProgram(false);
  10043. Add('type');
  10044. Add(' TObject = class');
  10045. Add(' constructor Create;');
  10046. Add(' end;');
  10047. Add(' TClass = class of TObject;');
  10048. Add('constructor tobject.create; begin end;');
  10049. Add('var');
  10050. Add(' Obj: tobject;');
  10051. Add(' C: tclass;');
  10052. Add('begin');
  10053. Add(' obj:=C.create;');
  10054. Add(' with c do obj:=create;');
  10055. ConvertProgram;
  10056. CheckSource('TestClassOf_Create',
  10057. LinesToStr([ // statements
  10058. 'rtl.createClass($mod, "TObject", null, function () {',
  10059. ' this.$init = function () {',
  10060. ' };',
  10061. ' this.$final = function () {',
  10062. ' };',
  10063. ' this.Create = function () {',
  10064. ' };',
  10065. '});',
  10066. 'this.Obj = null;',
  10067. 'this.C = null;'
  10068. ]),
  10069. LinesToStr([ // $mod.$main
  10070. '$mod.Obj = $mod.C.$create("Create");',
  10071. 'var $with1 = $mod.C;',
  10072. '$mod.Obj = $with1.$create("Create");',
  10073. '']));
  10074. end;
  10075. procedure TTestModule.TestClassOf_Call;
  10076. begin
  10077. StartProgram(false);
  10078. Add('type');
  10079. Add(' TObject = class');
  10080. Add(' class procedure DoIt;');
  10081. Add(' end;');
  10082. Add(' TClass = class of TObject;');
  10083. Add('class procedure tobject.doit; begin end;');
  10084. Add('var');
  10085. Add(' C: tclass;');
  10086. Add('begin');
  10087. Add(' c.doit;');
  10088. Add(' with c do doit;');
  10089. ConvertProgram;
  10090. CheckSource('TestClassOf_Call',
  10091. LinesToStr([ // statements
  10092. 'rtl.createClass($mod, "TObject", null, function () {',
  10093. ' this.$init = function () {',
  10094. ' };',
  10095. ' this.$final = function () {',
  10096. ' };',
  10097. ' this.DoIt = function () {',
  10098. ' };',
  10099. '});',
  10100. 'this.C = null;'
  10101. ]),
  10102. LinesToStr([ // $mod.$main
  10103. '$mod.C.DoIt();',
  10104. 'var $with1 = $mod.C;',
  10105. '$with1.DoIt();',
  10106. '']));
  10107. end;
  10108. procedure TTestModule.TestClassOf_Assign;
  10109. begin
  10110. StartProgram(false);
  10111. Add('type');
  10112. Add(' TClass = class of TObject;');
  10113. Add(' TObject = class');
  10114. Add(' ClassType: TClass; ');
  10115. Add(' end;');
  10116. Add('var');
  10117. Add(' Obj: tobject;');
  10118. Add(' C: tclass;');
  10119. Add('begin');
  10120. Add(' c:=nil;');
  10121. Add(' c:=obj.classtype;');
  10122. ConvertProgram;
  10123. CheckSource('TestClassOf_Assign',
  10124. LinesToStr([ // statements
  10125. 'rtl.createClass($mod, "TObject", null, function () {',
  10126. ' this.$init = function () {',
  10127. ' this.ClassType = null;',
  10128. ' };',
  10129. ' this.$final = function () {',
  10130. ' this.ClassType = undefined;',
  10131. ' };',
  10132. '});',
  10133. 'this.Obj = null;',
  10134. 'this.C = null;'
  10135. ]),
  10136. LinesToStr([ // $mod.$main
  10137. '$mod.C = null;',
  10138. '$mod.C = $mod.Obj.ClassType;',
  10139. '']));
  10140. end;
  10141. procedure TTestModule.TestClassOf_Is;
  10142. begin
  10143. StartProgram(false);
  10144. Add('type');
  10145. Add(' TClass = class of TObject;');
  10146. Add(' TObject = class');
  10147. Add(' end;');
  10148. Add(' TCar = class');
  10149. Add(' end;');
  10150. Add(' TCars = class of TCar;');
  10151. Add('var');
  10152. Add(' Obj: tobject;');
  10153. Add(' C: tclass;');
  10154. Add(' Cars: tcars;');
  10155. Add('begin');
  10156. Add(' if c is tcar then ;');
  10157. Add(' if c is tcars then ;');
  10158. ConvertProgram;
  10159. CheckSource('TestClassOf_Is',
  10160. LinesToStr([ // statements
  10161. 'rtl.createClass($mod, "TObject", null, function () {',
  10162. ' this.$init = function () {',
  10163. ' };',
  10164. ' this.$final = function () {',
  10165. ' };',
  10166. '});',
  10167. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  10168. '});',
  10169. 'this.Obj = null;',
  10170. 'this.C = null;',
  10171. 'this.Cars = null;'
  10172. ]),
  10173. LinesToStr([ // $mod.$main
  10174. 'if(rtl.is($mod.C,$mod.TCar));',
  10175. 'if(rtl.is($mod.C,$mod.TCar));',
  10176. '']));
  10177. end;
  10178. procedure TTestModule.TestClassOf_Compare;
  10179. begin
  10180. StartProgram(false);
  10181. Add('type');
  10182. Add(' TClass = class of TObject;');
  10183. Add(' TObject = class');
  10184. Add(' ClassType: TClass; ');
  10185. Add(' end;');
  10186. Add('var');
  10187. Add(' b: boolean;');
  10188. Add(' Obj: tobject;');
  10189. Add(' C: tclass;');
  10190. Add('begin');
  10191. Add(' b:=c=nil;');
  10192. Add(' b:=nil=c;');
  10193. Add(' b:=c=obj.classtype;');
  10194. Add(' b:=obj.classtype=c;');
  10195. Add(' b:=c=TObject;');
  10196. Add(' b:=TObject=c;');
  10197. Add(' b:=c<>nil;');
  10198. Add(' b:=nil<>c;');
  10199. Add(' b:=c<>obj.classtype;');
  10200. Add(' b:=obj.classtype<>c;');
  10201. Add(' b:=c<>TObject;');
  10202. Add(' b:=TObject<>c;');
  10203. ConvertProgram;
  10204. CheckSource('TestClassOf_Compare',
  10205. LinesToStr([ // statements
  10206. 'rtl.createClass($mod, "TObject", null, function () {',
  10207. ' this.$init = function () {',
  10208. ' this.ClassType = null;',
  10209. ' };',
  10210. ' this.$final = function () {',
  10211. ' this.ClassType = undefined;',
  10212. ' };',
  10213. '});',
  10214. 'this.b = false;',
  10215. 'this.Obj = null;',
  10216. 'this.C = null;'
  10217. ]),
  10218. LinesToStr([ // $mod.$main
  10219. '$mod.b = $mod.C === null;',
  10220. '$mod.b = null === $mod.C;',
  10221. '$mod.b = $mod.C === $mod.Obj.ClassType;',
  10222. '$mod.b = $mod.Obj.ClassType === $mod.C;',
  10223. '$mod.b = $mod.C === $mod.TObject;',
  10224. '$mod.b = $mod.TObject === $mod.C;',
  10225. '$mod.b = $mod.C !== null;',
  10226. '$mod.b = null !== $mod.C;',
  10227. '$mod.b = $mod.C !== $mod.Obj.ClassType;',
  10228. '$mod.b = $mod.Obj.ClassType !== $mod.C;',
  10229. '$mod.b = $mod.C !== $mod.TObject;',
  10230. '$mod.b = $mod.TObject !== $mod.C;',
  10231. '']));
  10232. end;
  10233. procedure TTestModule.TestClassOf_ClassVar;
  10234. begin
  10235. StartProgram(false);
  10236. Add('type');
  10237. Add(' TObject = class');
  10238. Add(' class var id: longint;');
  10239. Add(' end;');
  10240. Add(' TClass = class of TObject;');
  10241. Add('var');
  10242. Add(' C: tclass;');
  10243. Add('begin');
  10244. Add(' C.id:=C.id;');
  10245. ConvertProgram;
  10246. CheckSource('TestClassOf_ClassVar',
  10247. LinesToStr([ // statements
  10248. 'rtl.createClass($mod, "TObject", null, function () {',
  10249. ' this.id = 0;',
  10250. ' this.$init = function () {',
  10251. ' };',
  10252. ' this.$final = function () {',
  10253. ' };',
  10254. '});',
  10255. 'this.C = null;'
  10256. ]),
  10257. LinesToStr([ // $mod.$main
  10258. '$mod.C.id = $mod.C.id;',
  10259. '']));
  10260. end;
  10261. procedure TTestModule.TestClassOf_ClassMethod;
  10262. begin
  10263. StartProgram(false);
  10264. Add('type');
  10265. Add(' TObject = class');
  10266. Add(' class function DoIt(i: longint = 0): longint;');
  10267. Add(' end;');
  10268. Add(' TClass = class of TObject;');
  10269. Add('class function tobject.doit(i: longint = 0): longint; begin end;');
  10270. Add('var');
  10271. Add(' i: longint;');
  10272. Add(' C: tclass;');
  10273. Add('begin');
  10274. Add(' C.DoIt;');
  10275. Add(' C.DoIt();');
  10276. Add(' i:=C.DoIt;');
  10277. Add(' i:=C.DoIt();');
  10278. ConvertProgram;
  10279. CheckSource('TestClassOf_ClassMethod',
  10280. LinesToStr([ // statements
  10281. 'rtl.createClass($mod, "TObject", null, function () {',
  10282. ' this.$init = function () {',
  10283. ' };',
  10284. ' this.$final = function () {',
  10285. ' };',
  10286. ' this.DoIt = function (i) {',
  10287. ' var Result = 0;',
  10288. ' return Result;',
  10289. ' };',
  10290. '});',
  10291. 'this.i = 0;',
  10292. 'this.C = null;'
  10293. ]),
  10294. LinesToStr([ // $mod.$main
  10295. '$mod.C.DoIt(0);',
  10296. '$mod.C.DoIt(0);',
  10297. '$mod.i = $mod.C.DoIt(0);',
  10298. '$mod.i = $mod.C.DoIt(0);',
  10299. '']));
  10300. end;
  10301. procedure TTestModule.TestClassOf_ClassProperty;
  10302. begin
  10303. StartProgram(false);
  10304. Add('type');
  10305. Add(' TObject = class');
  10306. Add(' class var FA: longint;');
  10307. Add(' class function GetA: longint;');
  10308. Add(' class procedure SetA(Value: longint);');
  10309. Add(' class property pA: longint read fa write fa;');
  10310. Add(' class property pB: longint read geta write seta;');
  10311. Add(' end;');
  10312. Add(' TObjectClass = class of tobject;');
  10313. Add('class function tobject.geta: longint; begin end;');
  10314. Add('class procedure tobject.seta(value: longint); begin end;');
  10315. Add('var');
  10316. Add(' b: boolean;');
  10317. Add(' Obj: tobject;');
  10318. Add(' Cla: tobjectclass;');
  10319. Add('begin');
  10320. Add(' obj.pa:=obj.pa;');
  10321. Add(' obj.pb:=obj.pb;');
  10322. Add(' b:=obj.pa=4;');
  10323. Add(' b:=obj.pb=obj.pb;');
  10324. Add(' b:=5=obj.pa;');
  10325. Add(' cla.pa:=6;');
  10326. Add(' cla.pa:=cla.pa;');
  10327. Add(' cla.pb:=cla.pb;');
  10328. Add(' b:=cla.pa=7;');
  10329. Add(' b:=cla.pb=cla.pb;');
  10330. Add(' b:=8=cla.pa;');
  10331. Add(' tobject.pa:=9;');
  10332. Add(' tobject.pb:=tobject.pb;');
  10333. Add(' b:=tobject.pa=10;');
  10334. Add(' b:=11=tobject.pa;');
  10335. ConvertProgram;
  10336. CheckSource('TestClassOf_ClassProperty',
  10337. LinesToStr([ // statements
  10338. 'rtl.createClass($mod, "TObject", null, function () {',
  10339. ' this.FA = 0;',
  10340. ' this.$init = function () {',
  10341. ' };',
  10342. ' this.$final = function () {',
  10343. ' };',
  10344. ' this.GetA = function () {',
  10345. ' var Result = 0;',
  10346. ' return Result;',
  10347. ' };',
  10348. ' this.SetA = function (Value) {',
  10349. ' };',
  10350. '});',
  10351. 'this.b = false;',
  10352. 'this.Obj = null;',
  10353. 'this.Cla = null;'
  10354. ]),
  10355. LinesToStr([ // $mod.$main
  10356. '$mod.Obj.$class.FA = $mod.Obj.FA;',
  10357. '$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
  10358. '$mod.b = $mod.Obj.FA === 4;',
  10359. '$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
  10360. '$mod.b = 5 === $mod.Obj.FA;',
  10361. '$mod.Cla.FA = 6;',
  10362. '$mod.Cla.FA = $mod.Cla.FA;',
  10363. '$mod.Cla.SetA($mod.Cla.GetA());',
  10364. '$mod.b = $mod.Cla.FA === 7;',
  10365. '$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
  10366. '$mod.b = 8 === $mod.Cla.FA;',
  10367. '$mod.TObject.FA = 9;',
  10368. '$mod.TObject.SetA($mod.TObject.GetA());',
  10369. '$mod.b = $mod.TObject.FA === 10;',
  10370. '$mod.b = 11 === $mod.TObject.FA;',
  10371. '']));
  10372. end;
  10373. procedure TTestModule.TestClassOf_ClassMethodSelf;
  10374. begin
  10375. StartProgram(false);
  10376. Add('type');
  10377. Add(' TObject = class');
  10378. Add(' class var GlobalId: longint;');
  10379. Add(' class procedure ProcA;');
  10380. Add(' end;');
  10381. Add('class procedure tobject.proca;');
  10382. Add('var b: boolean;');
  10383. Add('begin');
  10384. Add(' b:=self=nil;');
  10385. Add(' b:=self.globalid=3;');
  10386. Add(' b:=4=self.globalid;');
  10387. Add(' self.globalid:=5;');
  10388. Add(' self.proca;');
  10389. Add('end;');
  10390. Add('begin');
  10391. ConvertProgram;
  10392. CheckSource('TestClassOf_ClassMethodSelf',
  10393. LinesToStr([ // statements
  10394. 'rtl.createClass($mod, "TObject", null, function () {',
  10395. ' this.GlobalId = 0;',
  10396. ' this.$init = function () {',
  10397. ' };',
  10398. ' this.$final = function () {',
  10399. ' };',
  10400. ' this.ProcA = function () {',
  10401. ' var b = false;',
  10402. ' b = this === null;',
  10403. ' b = this.GlobalId === 3;',
  10404. ' b = 4 === this.GlobalId;',
  10405. ' this.GlobalId = 5;',
  10406. ' this.ProcA();',
  10407. ' };',
  10408. '});'
  10409. ]),
  10410. LinesToStr([ // $mod.$main
  10411. '']));
  10412. end;
  10413. procedure TTestModule.TestClassOf_TypeCast;
  10414. begin
  10415. StartProgram(false);
  10416. Add('type');
  10417. Add(' TObject = class');
  10418. Add(' class procedure {#TObject_DoIt}DoIt;');
  10419. Add(' end;');
  10420. Add(' TClass = class of TObject;');
  10421. Add(' TMobile = class');
  10422. Add(' class procedure {#TMobile_DoIt}DoIt;');
  10423. Add(' end;');
  10424. Add(' TMobileClass = class of TMobile;');
  10425. Add(' TCar = class(TMobile)');
  10426. Add(' class procedure {#TCar_DoIt}DoIt;');
  10427. Add(' end;');
  10428. Add(' TCarClass = class of TCar;');
  10429. Add('class procedure TObject.DoIt;');
  10430. Add('begin');
  10431. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  10432. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  10433. Add('end;');
  10434. Add('class procedure TMobile.DoIt;');
  10435. Add('begin');
  10436. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  10437. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  10438. Add(' TCarClass(Self).{@TCar_DoIt}DoIt;');
  10439. Add('end;');
  10440. Add('class procedure TCar.DoIt; begin end;');
  10441. Add('var');
  10442. Add(' ObjC: TClass;');
  10443. Add(' MobileC: TMobileClass;');
  10444. Add(' CarC: TCarClass;');
  10445. Add('begin');
  10446. Add(' ObjC.{@TObject_DoIt}DoIt;');
  10447. Add(' MobileC.{@TMobile_DoIt}DoIt;');
  10448. Add(' CarC.{@TCar_DoIt}DoIt;');
  10449. Add(' TClass(ObjC).{@TObject_DoIt}DoIt;');
  10450. Add(' TMobileClass(ObjC).{@TMobile_DoIt}DoIt;');
  10451. Add(' TCarClass(ObjC).{@TCar_DoIt}DoIt;');
  10452. Add(' TClass(MobileC).{@TObject_DoIt}DoIt;');
  10453. Add(' TMobileClass(MobileC).{@TMobile_DoIt}DoIt;');
  10454. Add(' TCarClass(MobileC).{@TCar_DoIt}DoIt;');
  10455. Add(' TClass(CarC).{@TObject_DoIt}DoIt;');
  10456. Add(' TMobileClass(CarC).{@TMobile_DoIt}DoIt;');
  10457. Add(' TCarClass(CarC).{@TCar_DoIt}DoIt;');
  10458. ConvertProgram;
  10459. CheckSource('TestClassOf_TypeCast',
  10460. LinesToStr([ // statements
  10461. 'rtl.createClass($mod, "TObject", null, function () {',
  10462. ' this.$init = function () {',
  10463. ' };',
  10464. ' this.$final = function () {',
  10465. ' };',
  10466. ' this.DoIt = function () {',
  10467. ' this.DoIt();',
  10468. ' this.DoIt$1();',
  10469. ' };',
  10470. '});',
  10471. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  10472. ' this.DoIt$1 = function () {',
  10473. ' this.DoIt();',
  10474. ' this.DoIt$1();',
  10475. ' this.DoIt$2();',
  10476. ' };',
  10477. '});',
  10478. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  10479. ' this.DoIt$2 = function () {',
  10480. ' };',
  10481. '});',
  10482. 'this.ObjC = null;',
  10483. 'this.MobileC = null;',
  10484. 'this.CarC = null;',
  10485. '']),
  10486. LinesToStr([ // $mod.$main
  10487. '$mod.ObjC.DoIt();',
  10488. '$mod.MobileC.DoIt$1();',
  10489. '$mod.CarC.DoIt$2();',
  10490. '$mod.ObjC.DoIt();',
  10491. '$mod.ObjC.DoIt$1();',
  10492. '$mod.ObjC.DoIt$2();',
  10493. '$mod.MobileC.DoIt();',
  10494. '$mod.MobileC.DoIt$1();',
  10495. '$mod.MobileC.DoIt$2();',
  10496. '$mod.CarC.DoIt();',
  10497. '$mod.CarC.DoIt$1();',
  10498. '$mod.CarC.DoIt$2();',
  10499. '']));
  10500. end;
  10501. procedure TTestModule.TestClassOf_ImplicitFunctionCall;
  10502. begin
  10503. StartProgram(false);
  10504. Add('type');
  10505. Add(' TObject = class');
  10506. Add(' function CurNow: longint; ');
  10507. Add(' class function Now: longint; ');
  10508. Add(' end;');
  10509. Add('function TObject.CurNow: longint; begin end;');
  10510. Add('class function TObject.Now: longint; begin end;');
  10511. Add('var');
  10512. Add(' Obj: tobject;');
  10513. Add(' vI: longint;');
  10514. Add('begin');
  10515. Add(' obj.curnow;');
  10516. Add(' vi:=obj.curnow;');
  10517. Add(' tobject.now;');
  10518. Add(' vi:=tobject.now;');
  10519. ConvertProgram;
  10520. CheckSource('TestClassOf_ImplicitFunctionCall',
  10521. LinesToStr([ // statements
  10522. 'rtl.createClass($mod, "TObject", null, function () {',
  10523. ' this.$init = function () {',
  10524. ' };',
  10525. ' this.$final = function () {',
  10526. ' };',
  10527. ' this.CurNow = function () {',
  10528. ' var Result = 0;',
  10529. ' return Result;',
  10530. ' };',
  10531. ' this.Now = function () {',
  10532. ' var Result = 0;',
  10533. ' return Result;',
  10534. ' };',
  10535. '});',
  10536. 'this.Obj = null;',
  10537. 'this.vI = 0;',
  10538. '']),
  10539. LinesToStr([ // $mod.$main
  10540. '$mod.Obj.CurNow();',
  10541. '$mod.vI = $mod.Obj.CurNow();',
  10542. '$mod.TObject.Now();',
  10543. '$mod.vI = $mod.TObject.Now();',
  10544. '']));
  10545. end;
  10546. procedure TTestModule.TestClassOf_Const;
  10547. begin
  10548. StartProgram(false);
  10549. Add([
  10550. 'type',
  10551. ' TObject = class',
  10552. ' end;',
  10553. ' TBird = TObject;',
  10554. ' TBirds = class of TBird;',
  10555. ' TEagles = TBirds;',
  10556. ' THawk = class(TBird);',
  10557. 'const',
  10558. ' Hawk: TEagles = THawk;',
  10559. ' DefaultBirdClasses : Array [1..2] of TEagles = (',
  10560. ' TBird,',
  10561. ' THawk',
  10562. ' );',
  10563. 'begin']);
  10564. ConvertProgram;
  10565. CheckSource('TestClassOf_Const',
  10566. LinesToStr([ // statements
  10567. 'rtl.createClass($mod, "TObject", null, function () {',
  10568. ' this.$init = function () {',
  10569. ' };',
  10570. ' this.$final = function () {',
  10571. ' };',
  10572. '});',
  10573. 'rtl.createClass($mod, "THawk", $mod.TObject, function () {',
  10574. '});',
  10575. 'this.Hawk = $mod.THawk;',
  10576. 'this.DefaultBirdClasses = [$mod.TObject, $mod.THawk];',
  10577. '']),
  10578. LinesToStr([ // $mod.$main
  10579. '']));
  10580. end;
  10581. procedure TTestModule.TestNestedClass_Fail;
  10582. begin
  10583. StartProgram(false);
  10584. Add([
  10585. 'type',
  10586. ' TObject = class',
  10587. ' type TNested = longint;',
  10588. ' end;',
  10589. 'begin']);
  10590. SetExpectedPasResolverError('not yet implemented: TNested:TPasAliasType [20170608232534] nested types',
  10591. nNotYetImplemented);
  10592. ConvertProgram;
  10593. end;
  10594. procedure TTestModule.TestExternalClass_Var;
  10595. begin
  10596. StartProgram(false);
  10597. Add([
  10598. '{$modeswitch externalclass}',
  10599. 'type',
  10600. ' TExtA = class external name ''ExtObj''',
  10601. ' Id: longint external name ''$Id'';',
  10602. ' B: longint;',
  10603. ' end;',
  10604. 'var Obj: TExtA;',
  10605. 'begin',
  10606. ' obj.id:=obj.id+1;',
  10607. ' obj.B:=obj.B+1;']);
  10608. ConvertProgram;
  10609. CheckSource('TestExternalClass_Var',
  10610. LinesToStr([ // statements
  10611. 'this.Obj = null;',
  10612. '']),
  10613. LinesToStr([ // $mod.$main
  10614. '$mod.Obj.$Id = $mod.Obj.$Id + 1;',
  10615. '$mod.Obj.B = $mod.Obj.B + 1;',
  10616. '']));
  10617. end;
  10618. procedure TTestModule.TestExternalClass_Const;
  10619. begin
  10620. StartProgram(false);
  10621. Add([
  10622. '{$modeswitch externalclass}',
  10623. 'type',
  10624. ' TExtA = class external name ''ExtObj''',
  10625. ' const Two: longint = 2;',
  10626. ' const Three = 3;',
  10627. ' const Id: longint;',
  10628. ' end;',
  10629. ' TExtB = class external name ''ExtB''',
  10630. ' A: TExtA;',
  10631. ' end;',
  10632. 'var',
  10633. ' A: texta;',
  10634. ' B: textb;',
  10635. ' i: longint;',
  10636. 'begin',
  10637. ' i:=a.two;',
  10638. ' i:=texta.two;',
  10639. ' i:=a.three;',
  10640. ' i:=texta.three;',
  10641. ' i:=a.id;',
  10642. ' i:=texta.id;',
  10643. '']);
  10644. ConvertProgram;
  10645. CheckSource('TestExternalClass_Const',
  10646. LinesToStr([ // statements
  10647. 'this.A = null;',
  10648. 'this.B = null;',
  10649. 'this.i = 0;',
  10650. '']),
  10651. LinesToStr([ // $mod.$main
  10652. '$mod.i = 2;',
  10653. '$mod.i = 2;',
  10654. '$mod.i = 3;',
  10655. '$mod.i = 3;',
  10656. '$mod.i = $mod.A.Id;',
  10657. '$mod.i = ExtObj.Id;',
  10658. '']));
  10659. end;
  10660. procedure TTestModule.TestExternalClass_Dollar;
  10661. begin
  10662. StartProgram(false);
  10663. Add([
  10664. '{$modeswitch externalclass}',
  10665. 'type',
  10666. ' TExtA = class external name ''$''',
  10667. ' Id: longint external name ''$'';',
  10668. ' function Bla(i: longint): longint; external name ''$'';',
  10669. ' end;',
  10670. 'function dollar(k: longint): longint; external name ''$'';',
  10671. 'var Obj: TExtA;',
  10672. 'begin',
  10673. ' dollar(1);',
  10674. ' obj.id:=obj.id+2;',
  10675. ' obj.Bla(3);',
  10676. '']);
  10677. ConvertProgram;
  10678. CheckSource('TestExternalClass_Dollar',
  10679. LinesToStr([ // statements
  10680. 'this.Obj = null;',
  10681. '']),
  10682. LinesToStr([ // $mod.$main
  10683. '$(1);',
  10684. '$mod.Obj.$ = $mod.Obj.$ + 2;',
  10685. '$mod.Obj.$(3);',
  10686. '']));
  10687. end;
  10688. procedure TTestModule.TestExternalClass_DuplicateVarFail;
  10689. begin
  10690. StartProgram(false);
  10691. Add('{$modeswitch externalclass}');
  10692. Add('type');
  10693. Add(' TExtA = class external name ''ExtA''');
  10694. Add(' Id: longint external name ''$Id'';');
  10695. Add(' end;');
  10696. Add(' TExtB = class external ''lib'' name ''ExtB''(TExtA)');
  10697. Add(' Id: longint;');
  10698. Add(' end;');
  10699. Add('begin');
  10700. SetExpectedPasResolverError('Duplicate identifier "Id" at test1.pp(6,5)',nDuplicateIdentifier);
  10701. ConvertProgram;
  10702. end;
  10703. procedure TTestModule.TestExternalClass_Method;
  10704. begin
  10705. StartProgram(false);
  10706. Add('{$modeswitch externalclass}');
  10707. Add('type');
  10708. Add(' TExtA = class external name ''ExtObj''');
  10709. Add(' procedure DoIt(Id: longint = 1); external name ''$Execute'';');
  10710. Add(' procedure DoSome(Id: longint = 1);');
  10711. Add(' end;');
  10712. Add('var Obj: texta;');
  10713. Add('begin');
  10714. Add(' obj.doit;');
  10715. Add(' obj.doit();');
  10716. Add(' obj.doit(2);');
  10717. Add(' with obj do begin');
  10718. Add(' doit;');
  10719. Add(' doit();');
  10720. Add(' doit(3);');
  10721. Add(' end;');
  10722. ConvertProgram;
  10723. CheckSource('TestExternalClass_Method',
  10724. LinesToStr([ // statements
  10725. 'this.Obj = null;',
  10726. '']),
  10727. LinesToStr([ // $mod.$main
  10728. '$mod.Obj.$Execute(1);',
  10729. '$mod.Obj.$Execute(1);',
  10730. '$mod.Obj.$Execute(2);',
  10731. 'var $with1 = $mod.Obj;',
  10732. '$with1.$Execute(1);',
  10733. '$with1.$Execute(1);',
  10734. '$with1.$Execute(3);',
  10735. '']));
  10736. end;
  10737. procedure TTestModule.TestExternalClass_ClassMethod;
  10738. begin
  10739. StartProgram(false);
  10740. Add([
  10741. '{$modeswitch externalclass}',
  10742. 'type',
  10743. ' TExtA = class external name ''ExtObj''',
  10744. ' class procedure DoIt(Id: longint = 1); external name ''$Execute'';',
  10745. ' end;',
  10746. ' TExtB = TExtA;',
  10747. 'begin',
  10748. ' texta.doit;',
  10749. ' texta.doit();',
  10750. ' texta.doit(2);',
  10751. ' with texta do begin',
  10752. ' doit;',
  10753. ' doit();',
  10754. ' doit(3);',
  10755. ' end;',
  10756. ' textb.doit;',
  10757. ' textb.doit();',
  10758. ' textb.doit(4);',
  10759. ' with textb do begin',
  10760. ' doit;',
  10761. ' doit();',
  10762. ' doit(5);',
  10763. ' end;',
  10764. '']);
  10765. ConvertProgram;
  10766. CheckSource('TestExternalClass_ClassMethod',
  10767. LinesToStr([ // statements
  10768. '']),
  10769. LinesToStr([ // $mod.$main
  10770. 'ExtObj.$Execute(1);',
  10771. 'ExtObj.$Execute(1);',
  10772. 'ExtObj.$Execute(2);',
  10773. 'ExtObj.$Execute(1);',
  10774. 'ExtObj.$Execute(1);',
  10775. 'ExtObj.$Execute(3);',
  10776. 'ExtObj.$Execute(1);',
  10777. 'ExtObj.$Execute(1);',
  10778. 'ExtObj.$Execute(4);',
  10779. 'ExtObj.$Execute(1);',
  10780. 'ExtObj.$Execute(1);',
  10781. 'ExtObj.$Execute(5);',
  10782. '']));
  10783. end;
  10784. procedure TTestModule.TestExternalClass_NonExternalOverride;
  10785. begin
  10786. StartProgram(false);
  10787. Add('{$modeswitch externalclass}');
  10788. Add('type');
  10789. Add(' TExtA = class external name ''ExtObjA''');
  10790. Add(' procedure ProcA; virtual;');
  10791. Add(' procedure ProcB; virtual;');
  10792. Add(' end;');
  10793. Add(' TExtB = class external name ''ExtObjB'' (TExtA)');
  10794. Add(' end;');
  10795. Add(' TExtC = class (TExtB)');
  10796. Add(' procedure ProcA; override;');
  10797. Add(' end;');
  10798. Add('procedure TExtC.ProcA;');
  10799. Add('begin');
  10800. Add(' ProcA;');
  10801. Add(' Self.ProcA;');
  10802. Add(' ProcB;');
  10803. Add(' Self.ProcB;');
  10804. Add('end;');
  10805. Add('var');
  10806. Add(' A: texta;');
  10807. Add(' B: textb;');
  10808. Add(' C: textc;');
  10809. Add('begin');
  10810. Add(' a.proca;');
  10811. Add(' b.proca;');
  10812. Add(' c.proca;');
  10813. ConvertProgram;
  10814. CheckSource('TestExternalClass_NonExternalOverride',
  10815. LinesToStr([ // statements
  10816. 'rtl.createClassExt($mod, "TExtC", ExtObjB, "", function () {',
  10817. ' this.$init = function () {',
  10818. ' };',
  10819. ' this.$final = function () {',
  10820. ' };',
  10821. ' this.ProcA = function () {',
  10822. ' this.ProcA();',
  10823. ' this.ProcA();',
  10824. ' this.ProcB();',
  10825. ' this.ProcB();',
  10826. ' };',
  10827. '});',
  10828. 'this.A = null;',
  10829. 'this.B = null;',
  10830. 'this.C = null;',
  10831. '']),
  10832. LinesToStr([ // $mod.$main
  10833. '$mod.A.ProcA();',
  10834. '$mod.B.ProcA();',
  10835. '$mod.C.ProcA();',
  10836. '']));
  10837. end;
  10838. procedure TTestModule.TestExternalClass_Property;
  10839. begin
  10840. StartProgram(false);
  10841. Add('{$modeswitch externalclass}');
  10842. Add('type');
  10843. Add(' TExtA = class external name ''ExtA''');
  10844. Add(' function getYear: longint;');
  10845. Add(' procedure setYear(Value: longint);');
  10846. Add(' property Year: longint read getyear write setyear;');
  10847. Add(' end;');
  10848. Add(' TExtB = class (TExtA)');
  10849. Add(' procedure OtherSetYear(Value: longint);');
  10850. Add(' property year write othersetyear;');
  10851. Add(' end;');
  10852. Add('procedure textb.othersetyear(value: longint);');
  10853. Add('begin');
  10854. Add(' setYear(Value+4);');
  10855. Add('end;');
  10856. Add('var');
  10857. Add(' A: texta;');
  10858. Add(' B: textb;');
  10859. Add('begin');
  10860. Add(' a.year:=a.year+1;');
  10861. Add(' b.year:=b.year+2;');
  10862. ConvertProgram;
  10863. CheckSource('TestExternalClass_NonExternalOverride',
  10864. LinesToStr([ // statements
  10865. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  10866. ' this.$init = function () {',
  10867. ' };',
  10868. ' this.$final = function () {',
  10869. ' };',
  10870. ' this.OtherSetYear = function (Value) {',
  10871. ' this.setYear(Value+4);',
  10872. ' };',
  10873. '});',
  10874. 'this.A = null;',
  10875. 'this.B = null;',
  10876. '']),
  10877. LinesToStr([ // $mod.$main
  10878. '$mod.A.setYear($mod.A.getYear()+1);',
  10879. '$mod.B.OtherSetYear($mod.B.getYear()+2);',
  10880. '']));
  10881. end;
  10882. procedure TTestModule.TestExternalClass_ClassProperty;
  10883. begin
  10884. StartProgram(false);
  10885. Add('{$modeswitch externalclass}');
  10886. Add('type');
  10887. Add(' TExtA = class external name ''ExtA''');
  10888. Add(' class function getYear: longint;');
  10889. Add(' class procedure setYear(Value: longint);');
  10890. Add(' class property Year: longint read getyear write setyear;');
  10891. Add(' end;');
  10892. Add(' TExtB = class (TExtA)');
  10893. Add(' class function GetCentury: longint;');
  10894. Add(' class procedure SetCentury(Value: longint);');
  10895. Add(' class property Century: longint read getcentury write setcentury;');
  10896. Add(' end;');
  10897. Add('class function textb.getcentury: longint;');
  10898. Add('begin');
  10899. Add('end;');
  10900. Add('class procedure textb.setcentury(value: longint);');
  10901. Add('begin');
  10902. Add(' setyear(value+11);');
  10903. Add(' texta.year:=texta.year+12;');
  10904. Add(' year:=year+13;');
  10905. Add(' textb.century:=textb.century+14;');
  10906. Add(' century:=century+15;');
  10907. Add('end;');
  10908. Add('var');
  10909. Add(' A: texta;');
  10910. Add(' B: textb;');
  10911. Add('begin');
  10912. Add(' texta.year:=texta.year+1;');
  10913. Add(' textb.year:=textb.year+2;');
  10914. Add(' TextA.year:=TextA.year+3;');
  10915. Add(' b.year:=b.year+4;');
  10916. Add(' textb.century:=textb.century+5;');
  10917. Add(' b.century:=b.century+6;');
  10918. ConvertProgram;
  10919. CheckSource('TestExternalClass_ClassProperty',
  10920. LinesToStr([ // statements
  10921. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  10922. ' this.$init = function () {',
  10923. ' };',
  10924. ' this.$final = function () {',
  10925. ' };',
  10926. ' this.GetCentury = function () {',
  10927. ' var Result = 0;',
  10928. ' return Result;',
  10929. ' };',
  10930. ' this.SetCentury = function (Value) {',
  10931. ' this.setYear(Value + 11);',
  10932. ' ExtA.setYear(ExtA.getYear() + 12);',
  10933. ' this.setYear(this.getYear() + 13);',
  10934. ' $mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 14);',
  10935. ' this.SetCentury(this.GetCentury() + 15);',
  10936. ' };',
  10937. '});',
  10938. 'this.A = null;',
  10939. 'this.B = null;',
  10940. '']),
  10941. LinesToStr([ // $mod.$main
  10942. 'ExtA.setYear(ExtA.getYear() + 1);',
  10943. '$mod.TExtB.setYear($mod.TExtB.getYear() + 2);',
  10944. 'ExtA.setYear(ExtA.getYear() + 3);',
  10945. '$mod.B.setYear($mod.B.getYear() + 4);',
  10946. '$mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 5);',
  10947. '$mod.B.$class.SetCentury($mod.B.$class.GetCentury() + 6);',
  10948. '']));
  10949. end;
  10950. procedure TTestModule.TestExternalClass_ClassOf;
  10951. begin
  10952. StartProgram(false);
  10953. Add('{$modeswitch externalclass}');
  10954. Add('type');
  10955. Add(' TExtA = class external name ''ExtA''');
  10956. Add(' procedure ProcA; virtual;');
  10957. Add(' procedure ProcB; virtual;');
  10958. Add(' end;');
  10959. Add(' TExtAClass = class of TExtA;');
  10960. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  10961. Add(' end;');
  10962. Add(' TExtBClass = class of TExtB;');
  10963. Add(' TExtC = class (TExtB)');
  10964. Add(' procedure ProcA; override;');
  10965. Add(' end;');
  10966. Add(' TExtCClass = class of TExtC;');
  10967. Add('procedure TExtC.ProcA; begin end;');
  10968. Add('var');
  10969. Add(' A: texta; ClA: TExtAClass;');
  10970. Add(' B: textb; ClB: TExtBClass;');
  10971. Add(' C: textc; ClC: TExtCClass;');
  10972. Add('begin');
  10973. Add(' ClA:=texta;');
  10974. Add(' ClA:=textb;');
  10975. Add(' ClA:=textc;');
  10976. Add(' ClB:=textb;');
  10977. Add(' ClB:=textc;');
  10978. Add(' ClC:=textc;');
  10979. ConvertProgram;
  10980. CheckSource('TestExternalClass_ClassOf',
  10981. LinesToStr([ // statements
  10982. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  10983. ' this.$init = function () {',
  10984. ' };',
  10985. ' this.$final = function () {',
  10986. ' };',
  10987. ' this.ProcA = function () {',
  10988. ' };',
  10989. '});',
  10990. 'this.A = null;',
  10991. 'this.ClA = null;',
  10992. 'this.B = null;',
  10993. 'this.ClB = null;',
  10994. 'this.C = null;',
  10995. 'this.ClC = null;',
  10996. '']),
  10997. LinesToStr([ // $mod.$main
  10998. '$mod.ClA = ExtA;',
  10999. '$mod.ClA = ExtB;',
  11000. '$mod.ClA = $mod.TExtC;',
  11001. '$mod.ClB = ExtB;',
  11002. '$mod.ClB = $mod.TExtC;',
  11003. '$mod.ClC = $mod.TExtC;',
  11004. '']));
  11005. end;
  11006. procedure TTestModule.TestExternalClass_ClassOtherUnit;
  11007. begin
  11008. AddModuleWithIntfImplSrc('unit2.pas',
  11009. LinesToStr([
  11010. '{$modeswitch externalclass}',
  11011. 'type',
  11012. ' TExtA = class external name ''ExtA''',
  11013. ' class var Id: longint;',
  11014. ' end;',
  11015. '']),
  11016. '');
  11017. StartUnit(true);
  11018. Add('interface');
  11019. Add('uses unit2;');
  11020. Add('implementation');
  11021. Add('begin');
  11022. Add(' unit2.texta.id:=unit2.texta.id+1;');
  11023. ConvertUnit;
  11024. CheckSource('TestExternalClass_ClassOtherUnit',
  11025. LinesToStr([
  11026. '']),
  11027. LinesToStr([
  11028. 'ExtA.Id = ExtA.Id + 1;',
  11029. '']));
  11030. end;
  11031. procedure TTestModule.TestExternalClass_Is;
  11032. begin
  11033. StartProgram(false);
  11034. Add('{$modeswitch externalclass}');
  11035. Add('type');
  11036. Add(' TExtA = class external name ''ExtA''');
  11037. Add(' end;');
  11038. Add(' TExtAClass = class of TExtA;');
  11039. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  11040. Add(' end;');
  11041. Add(' TExtBClass = class of TExtB;');
  11042. Add(' TExtC = class (TExtB)');
  11043. Add(' end;');
  11044. Add(' TExtCClass = class of TExtC;');
  11045. Add('var');
  11046. Add(' A: texta; ClA: TExtAClass;');
  11047. Add(' B: textb; ClB: TExtBClass;');
  11048. Add(' C: textc; ClC: TExtCClass;');
  11049. Add('begin');
  11050. Add(' if a is textb then ;');
  11051. Add(' if a is textc then ;');
  11052. Add(' if b is textc then ;');
  11053. Add(' if cla is textb then ;');
  11054. Add(' if cla is textc then ;');
  11055. Add(' if clb is textc then ;');
  11056. ConvertProgram;
  11057. CheckSource('TestExternalClass_Is',
  11058. LinesToStr([ // statements
  11059. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  11060. ' this.$init = function () {',
  11061. ' };',
  11062. ' this.$final = function () {',
  11063. ' };',
  11064. '});',
  11065. 'this.A = null;',
  11066. 'this.ClA = null;',
  11067. 'this.B = null;',
  11068. 'this.ClB = null;',
  11069. 'this.C = null;',
  11070. 'this.ClC = null;',
  11071. '']),
  11072. LinesToStr([ // $mod.$main
  11073. 'if (rtl.isExt($mod.A, ExtB)) ;',
  11074. 'if ($mod.TExtC.isPrototypeOf($mod.A)) ;',
  11075. 'if ($mod.TExtC.isPrototypeOf($mod.B)) ;',
  11076. 'if (rtl.isExt($mod.ClA, ExtB)) ;',
  11077. 'if (rtl.is($mod.ClA, $mod.TExtC)) ;',
  11078. 'if (rtl.is($mod.ClB, $mod.TExtC)) ;',
  11079. '']));
  11080. end;
  11081. procedure TTestModule.TestExternalClass_As;
  11082. begin
  11083. StartProgram(false);
  11084. Add('{$modeswitch externalclass}');
  11085. Add('type');
  11086. Add(' TExtA = class external name ''ExtA''');
  11087. Add(' end;');
  11088. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  11089. Add(' end;');
  11090. Add(' TExtC = class (TExtB)');
  11091. Add(' end;');
  11092. Add('var');
  11093. Add(' A: texta;');
  11094. Add(' B: textb;');
  11095. Add(' C: textc;');
  11096. Add('begin');
  11097. Add(' b:=a as textb;');
  11098. Add(' c:=a as textc;');
  11099. Add(' c:=b as textc;');
  11100. ConvertProgram;
  11101. CheckSource('TestExternalClass_Is',
  11102. LinesToStr([ // statements
  11103. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  11104. ' this.$init = function () {',
  11105. ' };',
  11106. ' this.$final = function () {',
  11107. ' };',
  11108. '});',
  11109. 'this.A = null;',
  11110. 'this.B = null;',
  11111. 'this.C = null;',
  11112. '']),
  11113. LinesToStr([ // $mod.$main
  11114. '$mod.B = rtl.asExt($mod.A, ExtB);',
  11115. '$mod.C = rtl.as($mod.A, $mod.TExtC);',
  11116. '$mod.C = rtl.as($mod.B, $mod.TExtC);',
  11117. '']));
  11118. end;
  11119. procedure TTestModule.TestExternalClass_DestructorFail;
  11120. begin
  11121. StartProgram(false);
  11122. Add('{$modeswitch externalclass}');
  11123. Add('type');
  11124. Add(' TExtA = class external name ''ExtA''');
  11125. Add(' destructor Free;');
  11126. Add(' end;');
  11127. SetExpectedPasResolverError('Pascal element not supported: destructor',
  11128. nPasElementNotSupported);
  11129. ConvertProgram;
  11130. end;
  11131. procedure TTestModule.TestExternalClass_New;
  11132. begin
  11133. StartProgram(false);
  11134. Add('{$modeswitch externalclass}');
  11135. Add('type');
  11136. Add(' TExtA = class external name ''ExtA''');
  11137. Add(' constructor New;');
  11138. Add(' constructor New(i: longint; j: longint = 2);');
  11139. Add(' end;');
  11140. Add('var');
  11141. Add(' A: texta;');
  11142. Add('begin');
  11143. Add(' a:=texta.new;');
  11144. Add(' a:=texta.new();');
  11145. Add(' a:=texta.new(1);');
  11146. Add(' with texta do begin');
  11147. Add(' a:=new;');
  11148. Add(' a:=new();');
  11149. Add(' a:=new(2);');
  11150. Add(' end;');
  11151. Add(' a:=test1.texta.new;');
  11152. Add(' a:=test1.texta.new();');
  11153. Add(' a:=test1.texta.new(3);');
  11154. ConvertProgram;
  11155. CheckSource('TestExternalClass_New',
  11156. LinesToStr([ // statements
  11157. 'this.A = null;',
  11158. '']),
  11159. LinesToStr([ // $mod.$main
  11160. '$mod.A = new ExtA();',
  11161. '$mod.A = new ExtA();',
  11162. '$mod.A = new ExtA(1,2);',
  11163. '$mod.A = new ExtA();',
  11164. '$mod.A = new ExtA();',
  11165. '$mod.A = new ExtA(2,2);',
  11166. '$mod.A = new ExtA();',
  11167. '$mod.A = new ExtA();',
  11168. '$mod.A = new ExtA(3,2);',
  11169. '']));
  11170. end;
  11171. procedure TTestModule.TestExternalClass_ClassOf_New;
  11172. begin
  11173. StartProgram(false);
  11174. Add('{$modeswitch externalclass}');
  11175. Add('type');
  11176. Add(' TExtAClass = class of TExtA;');
  11177. Add(' TExtA = class external name ''ExtA''');
  11178. Add(' constructor New;');
  11179. Add(' end;');
  11180. Add('var');
  11181. Add(' A: texta;');
  11182. Add(' C: textaclass;');
  11183. Add('begin');
  11184. Add(' a:=c.new;');
  11185. Add(' a:=c.new();');
  11186. Add(' with C do begin');
  11187. Add(' a:=new;');
  11188. Add(' a:=new();');
  11189. Add(' end;');
  11190. Add(' a:=test1.c.new;');
  11191. Add(' a:=test1.c.new();');
  11192. ConvertProgram;
  11193. CheckSource('TestExternalClass_ClassOf_New',
  11194. LinesToStr([ // statements
  11195. 'this.A = null;',
  11196. 'this.C = null;',
  11197. '']),
  11198. LinesToStr([ // $mod.$main
  11199. '$mod.A = new $mod.C();',
  11200. '$mod.A = new $mod.C();',
  11201. 'var $with1 = $mod.C;',
  11202. '$mod.A = new $with1();',
  11203. '$mod.A = new $with1();',
  11204. '$mod.A = new $mod.C();',
  11205. '$mod.A = new $mod.C();',
  11206. '']));
  11207. end;
  11208. procedure TTestModule.TestExternalClass_FuncClassOf_New;
  11209. begin
  11210. StartProgram(false);
  11211. Add('{$modeswitch externalclass}');
  11212. Add('type');
  11213. Add(' TExtAClass = class of TExtA;');
  11214. Add(' TExtA = class external name ''ExtA''');
  11215. Add(' constructor New;');
  11216. Add(' end;');
  11217. Add('function GetCreator: TExtAClass;');
  11218. Add('begin');
  11219. Add(' Result:=TExtA;');
  11220. Add('end;');
  11221. Add('var');
  11222. Add(' A: texta;');
  11223. Add('begin');
  11224. Add(' a:=getcreator.new;');
  11225. Add(' a:=getcreator().new;');
  11226. Add(' a:=getcreator().new();');
  11227. Add(' a:=getcreator.new();');
  11228. Add(' with getcreator do begin');
  11229. Add(' a:=new;');
  11230. Add(' a:=new();');
  11231. Add(' end;');
  11232. ConvertProgram;
  11233. CheckSource('TestExternalClass_FuncClassOf_New',
  11234. LinesToStr([ // statements
  11235. 'this.GetCreator = function () {',
  11236. ' var Result = null;',
  11237. ' Result = ExtA;',
  11238. ' return Result;',
  11239. '};',
  11240. 'this.A = null;',
  11241. '']),
  11242. LinesToStr([ // $mod.$main
  11243. '$mod.A = new ($mod.GetCreator())();',
  11244. '$mod.A = new ($mod.GetCreator())();',
  11245. '$mod.A = new ($mod.GetCreator())();',
  11246. '$mod.A = new ($mod.GetCreator())();',
  11247. 'var $with1 = $mod.GetCreator();',
  11248. '$mod.A = new $with1();',
  11249. '$mod.A = new $with1();',
  11250. '']));
  11251. end;
  11252. procedure TTestModule.TestExternalClass_LocalConstSameName;
  11253. begin
  11254. StartProgram(false);
  11255. Add('{$modeswitch externalclass}');
  11256. Add('type');
  11257. Add(' TExtA = class external name ''ExtA''');
  11258. Add(' constructor New;');
  11259. Add(' end;');
  11260. Add('function DoIt: longint;');
  11261. Add('const ExtA: longint = 3;');
  11262. Add('begin');
  11263. Add(' Result:=ExtA;');
  11264. Add('end;');
  11265. Add('var');
  11266. Add(' A: texta;');
  11267. Add('begin');
  11268. Add(' a:=texta.new;');
  11269. ConvertProgram;
  11270. CheckSource('TestExternalClass_LocalConstSameName',
  11271. LinesToStr([ // statements
  11272. 'var ExtA$1 = 3;',
  11273. 'this.DoIt = function () {',
  11274. ' var Result = 0;',
  11275. ' Result = ExtA$1;',
  11276. ' return Result;',
  11277. '};',
  11278. 'this.A = null;',
  11279. '']),
  11280. LinesToStr([ // $mod.$main
  11281. '$mod.A = new ExtA();',
  11282. '']));
  11283. end;
  11284. procedure TTestModule.TestExternalClass_ReintroduceOverload;
  11285. begin
  11286. StartProgram(false);
  11287. Add('{$modeswitch externalclass}');
  11288. Add('type');
  11289. Add(' TExtA = class external name ''ExtA''');
  11290. Add(' procedure DoIt;');
  11291. Add(' end;');
  11292. Add(' TMyA = class(TExtA)');
  11293. Add(' procedure DoIt;');
  11294. Add(' end;');
  11295. Add('procedure TMyA.DoIt; begin end;');
  11296. Add('begin');
  11297. ConvertProgram;
  11298. CheckSource('TestExternalClass_ReintroduceOverload',
  11299. LinesToStr([ // statements
  11300. 'rtl.createClassExt($mod, "TMyA", ExtA, "", function () {',
  11301. ' this.$init = function () {',
  11302. ' };',
  11303. ' this.$final = function () {',
  11304. ' };',
  11305. ' this.DoIt$1 = function () {',
  11306. ' };',
  11307. '});',
  11308. '']),
  11309. LinesToStr([ // $mod.$main
  11310. '']));
  11311. end;
  11312. procedure TTestModule.TestExternalClass_Inherited;
  11313. begin
  11314. StartProgram(false);
  11315. Add('{$modeswitch externalclass}');
  11316. Add('type');
  11317. Add(' TExtA = class external name ''ExtA''');
  11318. Add(' procedure DoIt(i: longint = 1); virtual;');
  11319. Add(' procedure DoSome(j: longint = 2);');
  11320. Add(' end;');
  11321. Add(' TExtB = class external name ''ExtB''(TExtA)');
  11322. Add(' end;');
  11323. Add(' TMyC = class(TExtB)');
  11324. Add(' procedure DoIt(i: longint = 1); override;');
  11325. Add(' procedure DoSome(j: longint = 2); reintroduce;');
  11326. Add(' end;');
  11327. Add('procedure TMyC.DoIt(i: longint);');
  11328. Add('begin');
  11329. Add(' inherited;');
  11330. Add(' inherited DoIt;');
  11331. Add(' inherited DoIt();');
  11332. Add(' inherited DoIt(3);');
  11333. Add(' inherited DoSome;');
  11334. Add(' inherited DoSome();');
  11335. Add(' inherited DoSome(4);');
  11336. Add('end;');
  11337. Add('procedure TMyC.DoSome(j: longint);');
  11338. Add('begin');
  11339. Add(' inherited;');
  11340. Add('end;');
  11341. Add('begin');
  11342. ConvertProgram;
  11343. CheckSource('TestExternalClass_ReintroduceOverload',
  11344. LinesToStr([ // statements
  11345. 'rtl.createClassExt($mod, "TMyC", ExtB, "", function () {',
  11346. ' this.$init = function () {',
  11347. ' };',
  11348. ' this.$final = function () {',
  11349. ' };',
  11350. ' this.DoIt = function (i) {',
  11351. ' ExtB.DoIt.apply(this, arguments);',
  11352. ' ExtB.DoIt.call(this, 1);',
  11353. ' ExtB.DoIt.call(this, 1);',
  11354. ' ExtB.DoIt.call(this, 3);',
  11355. ' ExtB.DoSome.call(this, 2);',
  11356. ' ExtB.DoSome.call(this, 2);',
  11357. ' ExtB.DoSome.call(this, 4);',
  11358. ' };',
  11359. ' this.DoSome$1 = function (j) {',
  11360. ' ExtB.DoSome.apply(this, arguments);',
  11361. ' };',
  11362. '});',
  11363. '']),
  11364. LinesToStr([ // $mod.$main
  11365. '']));
  11366. end;
  11367. procedure TTestModule.TestExternalClass_PascalAncestorFail;
  11368. begin
  11369. StartProgram(false);
  11370. Add('{$modeswitch externalclass}');
  11371. Add('type');
  11372. Add(' TObject = class');
  11373. Add(' end;');
  11374. Add(' TExtA = class external name ''ExtA''(TObject)');
  11375. Add(' end;');
  11376. Add('begin');
  11377. SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
  11378. ConvertProgram;
  11379. end;
  11380. procedure TTestModule.TestExternalClass_NewInstance;
  11381. begin
  11382. StartProgram(false);
  11383. Add('{$modeswitch externalclass}');
  11384. Add('type');
  11385. Add(' TExtA = class external name ''ExtA''');
  11386. Add(' end;');
  11387. Add(' TMyB = class(TExtA)');
  11388. Add(' protected');
  11389. Add(' class function NewInstance(fnname: string; const paramarray): TMyB; virtual;');
  11390. Add(' end;');
  11391. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  11392. Add('begin end;');
  11393. Add('begin');
  11394. ConvertProgram;
  11395. CheckSource('TestExternalClass_NewInstance',
  11396. LinesToStr([ // statements
  11397. 'rtl.createClassExt($mod, "TMyB", ExtA, "NewInstance", function () {',
  11398. ' this.$init = function () {',
  11399. ' };',
  11400. ' this.$final = function () {',
  11401. ' };',
  11402. ' this.NewInstance = function (fnname, paramarray) {',
  11403. ' var Result = null;',
  11404. ' return Result;',
  11405. ' };',
  11406. '});',
  11407. '']),
  11408. LinesToStr([ // $mod.$main
  11409. '']));
  11410. end;
  11411. procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
  11412. begin
  11413. StartProgram(false);
  11414. Add('{$modeswitch externalclass}');
  11415. Add('type');
  11416. Add(' TExtA = class external name ''ExtA''');
  11417. Add(' end;');
  11418. Add(' TMyB = class(TExtA)');
  11419. Add(' protected');
  11420. Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
  11421. Add(' end;');
  11422. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  11423. Add('begin end;');
  11424. Add('begin');
  11425. SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
  11426. ConvertProgram;
  11427. end;
  11428. procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
  11429. begin
  11430. StartProgram(false);
  11431. Add('{$modeswitch externalclass}');
  11432. Add('type');
  11433. Add(' TExtA = class external name ''ExtA''');
  11434. Add(' end;');
  11435. Add(' TMyB = class(TExtA)');
  11436. Add(' protected');
  11437. Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
  11438. Add(' end;');
  11439. Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
  11440. Add('begin end;');
  11441. Add('begin');
  11442. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
  11443. nIncompatibleTypeArgNo);
  11444. ConvertProgram;
  11445. end;
  11446. procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
  11447. begin
  11448. StartProgram(false);
  11449. Add('{$modeswitch externalclass}');
  11450. Add('type');
  11451. Add(' TExtA = class external name ''ExtA''');
  11452. Add(' end;');
  11453. Add(' TMyB = class(TExtA)');
  11454. Add(' protected');
  11455. Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
  11456. Add(' end;');
  11457. Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
  11458. Add('begin end;');
  11459. Add('begin');
  11460. SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
  11461. nIncompatibleTypeArgNo);
  11462. ConvertProgram;
  11463. end;
  11464. procedure TTestModule.TestExternalClass_PascalProperty;
  11465. begin
  11466. StartProgram(false);
  11467. Add('{$modeswitch externalclass}');
  11468. Add('type');
  11469. Add(' TJSElement = class;');
  11470. Add(' TJSNotifyEvent = procedure(Sender: TJSElement) of object;');
  11471. Add(' TJSElement = class external name ''ExtA''');
  11472. Add(' end;');
  11473. Add(' TControl = class(TJSElement)');
  11474. Add(' private');
  11475. Add(' FOnClick: TJSNotifyEvent;');
  11476. Add(' property OnClick: TJSNotifyEvent read FOnClick write FOnClick;');
  11477. Add(' procedure Click(Sender: TJSElement);');
  11478. Add(' end;');
  11479. Add('procedure TControl.Click(Sender: TJSElement);');
  11480. Add('begin');
  11481. Add(' OnClick(Self);');
  11482. Add('end;');
  11483. Add('var');
  11484. Add(' Ctrl: TControl;');
  11485. Add('begin');
  11486. Add(' Ctrl.OnClick:[email protected];');
  11487. Add(' Ctrl.OnClick(Ctrl);');
  11488. ConvertProgram;
  11489. CheckSource('TestExternalClass_PascalProperty',
  11490. LinesToStr([ // statements
  11491. 'rtl.createClassExt($mod, "TControl", ExtA, "", function () {',
  11492. ' this.$init = function () {',
  11493. ' this.FOnClick = null;',
  11494. ' };',
  11495. ' this.$final = function () {',
  11496. ' this.FOnClick = undefined;',
  11497. ' };',
  11498. ' this.Click = function (Sender) {',
  11499. ' this.FOnClick(this);',
  11500. ' };',
  11501. '});',
  11502. 'this.Ctrl = null;',
  11503. '']),
  11504. LinesToStr([ // $mod.$main
  11505. '$mod.Ctrl.FOnClick = rtl.createCallback($mod.Ctrl, "Click");',
  11506. '$mod.Ctrl.FOnClick($mod.Ctrl);',
  11507. '']));
  11508. end;
  11509. procedure TTestModule.TestExternalClass_TypeCastToRootClass;
  11510. begin
  11511. StartProgram(false);
  11512. Add('{$modeswitch externalclass}');
  11513. Add('type');
  11514. Add(' TObject = class');
  11515. Add(' end;');
  11516. Add(' TChild = class');
  11517. Add(' end;');
  11518. Add(' TExtRootA = class external name ''ExtRootA''');
  11519. Add(' end;');
  11520. Add(' TExtChildA = class external name ''ExtChildA''(TExtRootA)');
  11521. Add(' end;');
  11522. Add(' TExtRootB = class external name ''ExtRootB''');
  11523. Add(' end;');
  11524. Add(' TExtChildB = class external name ''ExtChildB''(TExtRootB)');
  11525. Add(' end;');
  11526. Add('var');
  11527. Add(' Obj: TObject;');
  11528. Add(' Child: TChild;');
  11529. Add(' RootA: TExtRootA;');
  11530. Add(' ChildA: TExtChildA;');
  11531. Add(' RootB: TExtRootB;');
  11532. Add(' ChildB: TExtChildB;');
  11533. Add('begin');
  11534. Add(' obj:=tobject(roota);');
  11535. Add(' obj:=tobject(childa);');
  11536. Add(' child:=tchild(tobject(roota));');
  11537. Add(' roota:=textroota(obj);');
  11538. Add(' roota:=textroota(child);');
  11539. Add(' roota:=textroota(rootb);');
  11540. Add(' roota:=textroota(childb);');
  11541. Add(' childa:=textchilda(textroota(obj));');
  11542. ConvertProgram;
  11543. CheckSource('TestExternalClass_TypeCastToRootClass',
  11544. LinesToStr([ // statements
  11545. 'rtl.createClass($mod, "TObject", null, function () {',
  11546. ' this.$init = function () {',
  11547. ' };',
  11548. ' this.$final = function () {',
  11549. ' };',
  11550. '});',
  11551. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  11552. '});',
  11553. 'this.Obj = null;',
  11554. 'this.Child = null;',
  11555. 'this.RootA = null;',
  11556. 'this.ChildA = null;',
  11557. 'this.RootB = null;',
  11558. 'this.ChildB = null;',
  11559. '']),
  11560. LinesToStr([ // $mod.$main
  11561. '$mod.Obj = $mod.RootA;',
  11562. '$mod.Obj = $mod.ChildA;',
  11563. '$mod.Child = $mod.RootA;',
  11564. '$mod.RootA = $mod.Obj;',
  11565. '$mod.RootA = $mod.Child;',
  11566. '$mod.RootA = $mod.RootB;',
  11567. '$mod.RootA = $mod.ChildB;',
  11568. '$mod.ChildA = $mod.Obj;',
  11569. '']));
  11570. end;
  11571. procedure TTestModule.TestExternalClass_TypeCastStringToExternalString;
  11572. begin
  11573. StartProgram(false);
  11574. Add('{$modeswitch externalclass}');
  11575. Add('type');
  11576. Add(' TJSString = class external name ''String''');
  11577. Add(' class function fromCharCode() : string; varargs;');
  11578. Add(' function anchor(const aName : string) : string;');
  11579. Add(' end;');
  11580. Add('var');
  11581. Add(' s: string;');
  11582. Add('begin');
  11583. Add(' s:=TJSString.fromCharCode(65,66);');
  11584. Add(' s:=TJSString(s).anchor(s);');
  11585. Add(' s:=TJSString(''foo'').anchor(s);');
  11586. ConvertProgram;
  11587. CheckSource('TestExternalClass_TypeCastStringToExternalString',
  11588. LinesToStr([ // statements
  11589. 'this.s = "";',
  11590. '']),
  11591. LinesToStr([ // $mod.$main
  11592. '$mod.s = String.fromCharCode(65, 66);',
  11593. '$mod.s = $mod.s.anchor($mod.s);',
  11594. '$mod.s = "foo".anchor($mod.s);',
  11595. '']));
  11596. end;
  11597. procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
  11598. begin
  11599. StartProgram(false);
  11600. Add('{$modeswitch externalclass}');
  11601. Add('type');
  11602. Add(' TJSString = class external name ''String''');
  11603. Add(' class function fromCharCode() : string; varargs;');
  11604. Add(' end;');
  11605. Add('var');
  11606. Add(' s: string;');
  11607. Add(' sObj: TJSString;');
  11608. Add('begin');
  11609. Add(' s:=sObj.fromCharCode(65,66);');
  11610. SetExpectedPasResolverError('External class instance cannot access static class function fromCharCode',
  11611. nExternalClassInstanceCannotAccessStaticX);
  11612. ConvertProgram;
  11613. end;
  11614. procedure TTestModule.TestExternalClass_BracketAccessor;
  11615. begin
  11616. StartProgram(false);
  11617. Add('{$modeswitch externalclass}');
  11618. Add('type');
  11619. Add(' TJSArray = class external name ''Array2''');
  11620. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  11621. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  11622. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  11623. Add(' end;');
  11624. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);');
  11625. Add('begin end;');
  11626. Add('var');
  11627. Add(' Arr: tjsarray;');
  11628. Add(' s: string;');
  11629. Add(' i: longint;');
  11630. Add(' v: jsvalue;');
  11631. Add('begin');
  11632. Add(' v:=arr[0];');
  11633. Add(' v:=arr.items[1];');
  11634. Add(' arr[2]:=s;');
  11635. Add(' arr.items[3]:=s;');
  11636. Add(' arr[4]:=i;');
  11637. Add(' arr[5]:=arr[6];');
  11638. Add(' arr.items[7]:=arr.items[8];');
  11639. Add(' with arr do items[9]:=items[10];');
  11640. Add(' doit(arr[7],arr[8],arr[9],arr[10]);');
  11641. ConvertProgram;
  11642. CheckSource('TestExternalClass_BracketAccessor',
  11643. LinesToStr([ // statements
  11644. 'this.DoIt = function (vI, vJ, vK, vL) {',
  11645. '};',
  11646. 'this.Arr = null;',
  11647. 'this.s = "";',
  11648. 'this.i = 0;',
  11649. 'this.v = undefined;',
  11650. '']),
  11651. LinesToStr([ // $mod.$main
  11652. '$mod.v = $mod.Arr[0];',
  11653. '$mod.v = $mod.Arr[1];',
  11654. '$mod.Arr[2] = $mod.s;',
  11655. '$mod.Arr[3] = $mod.s;',
  11656. '$mod.Arr[4] = $mod.i;',
  11657. '$mod.Arr[5] = $mod.Arr[6];',
  11658. '$mod.Arr[7] = $mod.Arr[8];',
  11659. 'var $with1 = $mod.Arr;',
  11660. '$with1[9] = $with1[10];',
  11661. '$mod.DoIt($mod.Arr[7], $mod.Arr[8], {',
  11662. ' a: 9,',
  11663. ' p: $mod.Arr,',
  11664. ' get: function () {',
  11665. ' return this.p[this.a];',
  11666. ' },',
  11667. ' set: function (v) {',
  11668. ' this.p[this.a] = v;',
  11669. ' }',
  11670. '}, {',
  11671. ' a: 10,',
  11672. ' p: $mod.Arr,',
  11673. ' get: function () {',
  11674. ' return this.p[this.a];',
  11675. ' },',
  11676. ' set: function (v) {',
  11677. ' this.p[this.a] = v;',
  11678. ' }',
  11679. '});',
  11680. '']));
  11681. end;
  11682. procedure TTestModule.TestExternalClass_BracketAccessor_2ParamsFail;
  11683. begin
  11684. StartProgram(false);
  11685. Add('{$modeswitch externalclass}');
  11686. Add('type');
  11687. Add(' TJSArray = class external name ''Array2''');
  11688. Add(' function GetItems(Index1, Index2: longint): jsvalue; external name ''[]'';');
  11689. Add(' procedure SetItems(Index1, Index2: longint; Value: jsvalue); external name ''[]'';');
  11690. Add(' property Items[Index1, Index2: longint]: jsvalue read GetItems write SetItems; default;');
  11691. Add(' end;');
  11692. Add('begin');
  11693. SetExpectedPasResolverError(sBracketAccessorOfExternalClassMustHaveOneParameter,
  11694. nBracketAccessorOfExternalClassMustHaveOneParameter);
  11695. ConvertProgram;
  11696. end;
  11697. procedure TTestModule.TestExternalClass_BracketAccessor_ReadOnly;
  11698. begin
  11699. StartProgram(false);
  11700. Add('{$modeswitch externalclass}');
  11701. Add('type');
  11702. Add(' TJSArray = class external name ''Array2''');
  11703. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  11704. Add(' property Items[Index: longint]: jsvalue read GetItems; default;');
  11705. Add(' end;');
  11706. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue);');
  11707. Add('begin end;');
  11708. Add('var');
  11709. Add(' Arr: tjsarray;');
  11710. Add(' v: jsvalue;');
  11711. Add('begin');
  11712. Add(' v:=arr[0];');
  11713. Add(' v:=arr.items[1];');
  11714. Add(' with arr do v:=items[2];');
  11715. Add(' doit(arr[3],arr[4]);');
  11716. ConvertProgram;
  11717. CheckSource('TestExternalClass_BracketAccessor_ReadOnly',
  11718. LinesToStr([ // statements
  11719. 'this.DoIt = function (vI, vJ) {',
  11720. '};',
  11721. 'this.Arr = null;',
  11722. 'this.v = undefined;',
  11723. '']),
  11724. LinesToStr([ // $mod.$main
  11725. '$mod.v = $mod.Arr[0];',
  11726. '$mod.v = $mod.Arr[1];',
  11727. 'var $with1 = $mod.Arr;',
  11728. '$mod.v = $with1[2];',
  11729. '$mod.DoIt($mod.Arr[3], $mod.Arr[4]);',
  11730. '']));
  11731. end;
  11732. procedure TTestModule.TestExternalClass_BracketAccessor_WriteOnly;
  11733. begin
  11734. StartProgram(false);
  11735. Add('{$modeswitch externalclass}');
  11736. Add('type');
  11737. Add(' TJSArray = class external name ''Array2''');
  11738. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  11739. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  11740. Add(' end;');
  11741. Add('var');
  11742. Add(' Arr: tjsarray;');
  11743. Add(' s: string;');
  11744. Add(' i: longint;');
  11745. Add(' v: jsvalue;');
  11746. Add('begin');
  11747. Add(' arr[2]:=s;');
  11748. Add(' arr.items[3]:=s;');
  11749. Add(' arr[4]:=i;');
  11750. Add(' with arr do items[5]:=i;');
  11751. ConvertProgram;
  11752. CheckSource('TestExternalClass_BracketAccessor_WriteOnly',
  11753. LinesToStr([ // statements
  11754. 'this.Arr = null;',
  11755. 'this.s = "";',
  11756. 'this.i = 0;',
  11757. 'this.v = undefined;',
  11758. '']),
  11759. LinesToStr([ // $mod.$main
  11760. '$mod.Arr[2] = $mod.s;',
  11761. '$mod.Arr[3] = $mod.s;',
  11762. '$mod.Arr[4] = $mod.i;',
  11763. 'var $with1 = $mod.Arr;',
  11764. '$with1[5] = $mod.i;',
  11765. '']));
  11766. end;
  11767. procedure TTestModule.TestExternalClass_BracketAccessor_MultiType;
  11768. begin
  11769. StartProgram(false);
  11770. Add('{$modeswitch externalclass}');
  11771. Add('type');
  11772. Add(' TJSArray = class external name ''Array2''');
  11773. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  11774. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  11775. Add(' procedure SetNumbers(Index: longint; Value: longint); external name ''[]'';');
  11776. Add(' property Numbers[Index: longint]: longint write SetNumbers;');
  11777. Add(' end;');
  11778. Add('var');
  11779. Add(' Arr: tjsarray;');
  11780. Add(' s: string;');
  11781. Add(' i: longint;');
  11782. Add(' v: jsvalue;');
  11783. Add('begin');
  11784. Add(' arr[2]:=s;');
  11785. Add(' arr.items[3]:=s;');
  11786. Add(' arr.numbers[4]:=i;');
  11787. Add(' with arr do items[5]:=i;');
  11788. Add(' with arr do numbers[6]:=i;');
  11789. ConvertProgram;
  11790. CheckSource('TestExternalClass_BracketAccessor_MultiType',
  11791. LinesToStr([ // statements
  11792. 'this.Arr = null;',
  11793. 'this.s = "";',
  11794. 'this.i = 0;',
  11795. 'this.v = undefined;',
  11796. '']),
  11797. LinesToStr([ // $mod.$main
  11798. '$mod.Arr[2] = $mod.s;',
  11799. '$mod.Arr[3] = $mod.s;',
  11800. '$mod.Arr[4] = $mod.i;',
  11801. 'var $with1 = $mod.Arr;',
  11802. '$with1[5] = $mod.i;',
  11803. 'var $with2 = $mod.Arr;',
  11804. '$with2[6] = $mod.i;',
  11805. '']));
  11806. end;
  11807. procedure TTestModule.TestExternalClass_BracketAccessor_Index;
  11808. begin
  11809. StartProgram(false);
  11810. Add('{$modeswitch externalclass}');
  11811. Add('type');
  11812. Add(' TJSArray = class external name ''Array2''');
  11813. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  11814. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  11815. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  11816. Add(' end;');
  11817. Add('var');
  11818. Add(' Arr: tjsarray;');
  11819. Add(' i: longint;');
  11820. Add(' IntArr: array of longint;');
  11821. Add(' v: jsvalue;');
  11822. Add('begin');
  11823. Add(' v:=arr.items[i];');
  11824. Add(' arr[longint(v)]:=arr.items[intarr[0]];');
  11825. Add(' arr.items[intarr[1]]:=arr[IntArr[2]];');
  11826. ConvertProgram;
  11827. CheckSource('TestExternalClass_BracketAccessor_Index',
  11828. LinesToStr([ // statements
  11829. 'this.Arr = null;',
  11830. 'this.i = 0;',
  11831. 'this.IntArr = [];',
  11832. 'this.v = undefined;',
  11833. '']),
  11834. LinesToStr([ // $mod.$main
  11835. '$mod.v = $mod.Arr[$mod.i];',
  11836. '$mod.Arr[Math.floor($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
  11837. '$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
  11838. '']));
  11839. end;
  11840. procedure TTestModule.TestClassInterface_Ignore;
  11841. begin
  11842. StartProgram(false);
  11843. Add([
  11844. '{$modeswitch ignoreinterfaces}',
  11845. 'type',
  11846. ' TGUID = record end;',
  11847. ' IUnknown = interface;',
  11848. ' IUnknown = interface',
  11849. ' [''{00000000-0000-0000-C000-000000000046}'']',
  11850. ' function QueryInterface(const iid : tguid;out obj) : longint;',
  11851. ' function _AddRef : longint; cdecl;',
  11852. ' function _Release : longint; stdcall;',
  11853. ' end;',
  11854. ' IInterface = IUnknown;',
  11855. ' TObject = class',
  11856. ' ClassName: string;',
  11857. ' end;',
  11858. ' TInterfacedObject = class(TObject,IUnknown)',
  11859. ' RefCount : longint;',
  11860. ' end;',
  11861. 'var i: TInterfacedObject;',
  11862. 'begin',
  11863. ' i.ClassName:=''a'';',
  11864. ' i.RefCount:=3;',
  11865. '']);
  11866. ConvertProgram;
  11867. CheckSource('TestClassInterface_Ignore',
  11868. LinesToStr([ // statements
  11869. 'this.TGUID = function (s) {',
  11870. ' this.$equal = function (b) {',
  11871. ' return true;',
  11872. ' };',
  11873. '};',
  11874. 'rtl.createClass($mod, "TObject", null, function () {',
  11875. ' this.$init = function () {',
  11876. ' this.ClassName = "";',
  11877. ' };',
  11878. ' this.$final = function () {',
  11879. ' };',
  11880. '});',
  11881. 'rtl.createClass($mod, "TInterfacedObject", $mod.TObject, function () {',
  11882. ' this.$init = function () {',
  11883. ' $mod.TObject.$init.call(this);',
  11884. ' this.RefCount = 0;',
  11885. ' };',
  11886. '});',
  11887. 'this.i = null;',
  11888. '']),
  11889. LinesToStr([ // $mod.$main
  11890. '$mod.i.ClassName = "a";',
  11891. '$mod.i.RefCount = 3;',
  11892. '']));
  11893. end;
  11894. procedure TTestModule.TestProcType;
  11895. begin
  11896. StartProgram(false);
  11897. Add([
  11898. 'type',
  11899. ' TProcInt = procedure(vI: longint = 1);',
  11900. 'procedure DoIt(vJ: longint);',
  11901. 'begin end;',
  11902. 'var',
  11903. ' b: boolean;',
  11904. ' vP, vQ: tprocint;',
  11905. 'begin',
  11906. ' vp:=nil;',
  11907. ' vp:=vp;',
  11908. ' vp:=@doit;',
  11909. ' vp;',
  11910. ' vp();',
  11911. ' vp(2);',
  11912. ' b:=vp=nil;',
  11913. ' b:=nil=vp;',
  11914. ' b:=vp=vq;',
  11915. ' b:=vp=@doit;',
  11916. ' b:=@doit=vp;',
  11917. ' b:=vp<>nil;',
  11918. ' b:=nil<>vp;',
  11919. ' b:=vp<>vq;',
  11920. ' b:=vp<>@doit;',
  11921. ' b:=@doit<>vp;',
  11922. ' b:=Assigned(vp);',
  11923. ' if Assigned(vp) then ;']);
  11924. ConvertProgram;
  11925. CheckSource('TestProcType',
  11926. LinesToStr([ // statements
  11927. 'this.DoIt = function(vJ) {',
  11928. '};',
  11929. 'this.b = false;',
  11930. 'this.vP = null;',
  11931. 'this.vQ = null;'
  11932. ]),
  11933. LinesToStr([ // $mod.$main
  11934. '$mod.vP = null;',
  11935. '$mod.vP = $mod.vP;',
  11936. '$mod.vP = $mod.DoIt;',
  11937. '$mod.vP(1);',
  11938. '$mod.vP(1);',
  11939. '$mod.vP(2);',
  11940. '$mod.b = $mod.vP === null;',
  11941. '$mod.b = null === $mod.vP;',
  11942. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  11943. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  11944. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  11945. '$mod.b = $mod.vP !== null;',
  11946. '$mod.b = null !== $mod.vP;',
  11947. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  11948. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  11949. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  11950. '$mod.b = $mod.vP != null;',
  11951. 'if ($mod.vP != null) ;',
  11952. '']));
  11953. end;
  11954. procedure TTestModule.TestProcType_Arg;
  11955. begin
  11956. StartProgram(false);
  11957. Add([
  11958. 'type',
  11959. ' TProcInt = procedure(vI: longint = 1);',
  11960. 'procedure DoIt(vJ: longint); begin end;',
  11961. 'procedure DoSome(vP, vQ: TProcInt);',
  11962. 'var',
  11963. ' b: boolean;',
  11964. 'begin',
  11965. ' vp:=nil;',
  11966. ' vp:=vp;',
  11967. ' vp:=@doit;',
  11968. ' vp;',
  11969. ' vp();',
  11970. ' vp(2);',
  11971. ' b:=vp=nil;',
  11972. ' b:=nil=vp;',
  11973. ' b:=vp=vq;',
  11974. ' b:=vp=@doit;',
  11975. ' b:=@doit=vp;',
  11976. ' b:=vp<>nil;',
  11977. ' b:=nil<>vp;',
  11978. ' b:=vp<>vq;',
  11979. ' b:=vp<>@doit;',
  11980. ' b:=@doit<>vp;',
  11981. ' b:=Assigned(vp);',
  11982. ' if Assigned(vp) then ;',
  11983. 'end;',
  11984. 'begin',
  11985. ' DoSome(@DoIt,nil);']);
  11986. ConvertProgram;
  11987. CheckSource('TestProcType_Arg',
  11988. LinesToStr([ // statements
  11989. 'this.DoIt = function(vJ) {',
  11990. '};',
  11991. 'this.DoSome = function(vP, vQ) {',
  11992. ' var b = false;',
  11993. ' vP = null;',
  11994. ' vP = vP;',
  11995. ' vP = $mod.DoIt;',
  11996. ' vP(1);',
  11997. ' vP(1);',
  11998. ' vP(2);',
  11999. ' b = vP === null;',
  12000. ' b = null === vP;',
  12001. ' b = rtl.eqCallback(vP,vQ);',
  12002. ' b = rtl.eqCallback(vP, $mod.DoIt);',
  12003. ' b = rtl.eqCallback($mod.DoIt, vP);',
  12004. ' b = vP !== null;',
  12005. ' b = null !== vP;',
  12006. ' b = !rtl.eqCallback(vP, vQ);',
  12007. ' b = !rtl.eqCallback(vP, $mod.DoIt);',
  12008. ' b = !rtl.eqCallback($mod.DoIt, vP);',
  12009. ' b = vP != null;',
  12010. ' if (vP != null) ;',
  12011. '};',
  12012. '']),
  12013. LinesToStr([ // $mod.$main
  12014. '$mod.DoSome($mod.DoIt,null);',
  12015. '']));
  12016. end;
  12017. procedure TTestModule.TestProcType_FunctionFPC;
  12018. begin
  12019. StartProgram(false);
  12020. Add('type');
  12021. Add(' TFuncInt = function(vA: longint = 1): longint;');
  12022. Add('function DoIt(vI: longint): longint;');
  12023. Add('begin end;');
  12024. Add('var');
  12025. Add(' b: boolean;');
  12026. Add(' vP, vQ: tfuncint;');
  12027. Add('begin');
  12028. Add(' vp:=nil;');
  12029. Add(' vp:=vp;');
  12030. Add(' vp:=@doit;'); // ok in fpc and delphi
  12031. //Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  12032. Add(' vp;'); // ok in fpc and delphi
  12033. Add(' vp();');
  12034. Add(' vp(2);');
  12035. Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  12036. Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  12037. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  12038. Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  12039. Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  12040. //Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  12041. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  12042. Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  12043. Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  12044. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  12045. Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  12046. Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  12047. //Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  12048. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  12049. Add(' b:=Assigned(vp);');
  12050. //Add(' doit(vp);'); // illegal in fpc, ok in delphi
  12051. Add(' doit(vp());'); // ok in fpc and delphi
  12052. Add(' doit(vp(2));'); // ok in fpc and delphi
  12053. ConvertProgram;
  12054. CheckSource('TestProcType_FunctionFPC',
  12055. LinesToStr([ // statements
  12056. 'this.DoIt = function(vI) {',
  12057. ' var Result = 0;',
  12058. ' return Result;',
  12059. '};',
  12060. 'this.b = false;',
  12061. 'this.vP = null;',
  12062. 'this.vQ = null;'
  12063. ]),
  12064. LinesToStr([ // $mod.$main
  12065. '$mod.vP = null;',
  12066. '$mod.vP = $mod.vP;',
  12067. '$mod.vP = $mod.DoIt;',
  12068. '$mod.vP(1);',
  12069. '$mod.vP(1);',
  12070. '$mod.vP(2);',
  12071. '$mod.b = $mod.vP === null;',
  12072. '$mod.b = null === $mod.vP;',
  12073. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  12074. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  12075. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  12076. '$mod.b = 4 === $mod.vP(1);',
  12077. '$mod.b = $mod.vP !== null;',
  12078. '$mod.b = null !== $mod.vP;',
  12079. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  12080. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  12081. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  12082. '$mod.b = 6 !== $mod.vP(1);',
  12083. '$mod.b = $mod.vP != null;',
  12084. '$mod.DoIt($mod.vP(1));',
  12085. '$mod.DoIt($mod.vP(2));',
  12086. '']));
  12087. end;
  12088. procedure TTestModule.TestProcType_FunctionDelphi;
  12089. begin
  12090. StartProgram(false);
  12091. Add('{$mode Delphi}');
  12092. Add('type');
  12093. Add(' TFuncInt = function(vA: longint = 1): longint;');
  12094. Add('function DoIt(vI: longint): longint;');
  12095. Add('begin end;');
  12096. Add('var');
  12097. Add(' b: boolean;');
  12098. Add(' vP, vQ: tfuncint;');
  12099. Add('begin');
  12100. Add(' vp:=nil;');
  12101. Add(' vp:=vp;');
  12102. Add(' vp:=@doit;'); // ok in fpc and delphi
  12103. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  12104. Add(' vp;'); // ok in fpc and delphi
  12105. Add(' vp();');
  12106. Add(' vp(2);');
  12107. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  12108. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  12109. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  12110. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  12111. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  12112. Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  12113. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  12114. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  12115. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  12116. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  12117. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  12118. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  12119. Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  12120. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  12121. Add(' b:=Assigned(vp);');
  12122. Add(' doit(vp);'); // illegal in fpc, ok in delphi
  12123. Add(' doit(vp());'); // ok in fpc and delphi
  12124. Add(' doit(vp(2));'); // ok in fpc and delphi *)
  12125. ConvertProgram;
  12126. CheckSource('TestProcType_FunctionDelphi',
  12127. LinesToStr([ // statements
  12128. 'this.DoIt = function(vI) {',
  12129. ' var Result = 0;',
  12130. ' return Result;',
  12131. '};',
  12132. 'this.b = false;',
  12133. 'this.vP = null;',
  12134. 'this.vQ = null;'
  12135. ]),
  12136. LinesToStr([ // $mod.$main
  12137. '$mod.vP = null;',
  12138. '$mod.vP = $mod.vP;',
  12139. '$mod.vP = $mod.DoIt;',
  12140. '$mod.vP = $mod.DoIt;',
  12141. '$mod.vP(1);',
  12142. '$mod.vP(1);',
  12143. '$mod.vP(2);',
  12144. '$mod.b = $mod.vP(1) === $mod.vQ(1);',
  12145. '$mod.b = $mod.vP(1) === 3;',
  12146. '$mod.b = 4 === $mod.vP(1);',
  12147. '$mod.b = $mod.vP(1) !== $mod.vQ(1);',
  12148. '$mod.b = $mod.vP(1) !== 5;',
  12149. '$mod.b = 6 !== $mod.vP(1);',
  12150. '$mod.b = $mod.vP != null;',
  12151. '$mod.DoIt($mod.vP(1));',
  12152. '$mod.DoIt($mod.vP(1));',
  12153. '$mod.DoIt($mod.vP(2));',
  12154. '']));
  12155. end;
  12156. procedure TTestModule.TestProcType_ProcedureDelphi;
  12157. begin
  12158. StartProgram(false);
  12159. Add('{$mode Delphi}');
  12160. Add('type');
  12161. Add(' TProc = procedure;');
  12162. Add('procedure DoIt;');
  12163. Add('begin end;');
  12164. Add('var');
  12165. Add(' b: boolean;');
  12166. Add(' vP, vQ: tproc;');
  12167. Add('begin');
  12168. Add(' vp:=nil;');
  12169. Add(' vp:=vp;');
  12170. Add(' vp:=vq;');
  12171. Add(' vp:=@doit;'); // ok in fpc and delphi, Note that in Delphi type of @F is Pointer, while in FPC it is the proc type
  12172. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  12173. //Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
  12174. Add(' vp;'); // ok in fpc and delphi
  12175. Add(' vp();');
  12176. // equal
  12177. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  12178. Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
  12179. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  12180. Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
  12181. Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
  12182. //Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  12183. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  12184. Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
  12185. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  12186. Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
  12187. // unequal
  12188. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  12189. Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
  12190. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  12191. Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
  12192. //Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  12193. Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
  12194. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  12195. Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
  12196. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  12197. Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
  12198. Add(' b:=Assigned(vp);');
  12199. ConvertProgram;
  12200. CheckSource('TestProcType_ProcedureDelphi',
  12201. LinesToStr([ // statements
  12202. 'this.DoIt = function() {',
  12203. '};',
  12204. 'this.b = false;',
  12205. 'this.vP = null;',
  12206. 'this.vQ = null;'
  12207. ]),
  12208. LinesToStr([ // $mod.$main
  12209. '$mod.vP = null;',
  12210. '$mod.vP = $mod.vP;',
  12211. '$mod.vP = $mod.vQ;',
  12212. '$mod.vP = $mod.DoIt;',
  12213. '$mod.vP = $mod.DoIt;',
  12214. '$mod.vP();',
  12215. '$mod.vP();',
  12216. '$mod.b = $mod.vP === null;',
  12217. '$mod.b = null === $mod.vP;',
  12218. '$mod.b = rtl.eqCallback($mod.vP, $mod.vQ);',
  12219. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  12220. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  12221. '$mod.b = $mod.vP !== null;',
  12222. '$mod.b = null !== $mod.vP;',
  12223. '$mod.b = !rtl.eqCallback($mod.vP, $mod.vQ);',
  12224. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  12225. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  12226. '$mod.b = $mod.vP != null;',
  12227. '']));
  12228. end;
  12229. procedure TTestModule.TestProcType_AsParam;
  12230. begin
  12231. StartProgram(false);
  12232. Add('type');
  12233. Add(' TFuncInt = function(vA: longint = 1): longint;');
  12234. Add('procedure DoIt(vG: tfuncint; const vH: tfuncint; var vI: tfuncint);');
  12235. Add('var vJ: tfuncint;');
  12236. Add('begin');
  12237. Add(' vg:=vg;');
  12238. Add(' vj:=vh;');
  12239. Add(' vi:=vi;');
  12240. Add(' doit(vg,vg,vg);');
  12241. Add(' doit(vh,vh,vj);');
  12242. Add(' doit(vi,vi,vi);');
  12243. Add(' doit(vj,vj,vj);');
  12244. Add('end;');
  12245. Add('var i: tfuncint;');
  12246. Add('begin');
  12247. Add(' doit(i,i,i);');
  12248. ConvertProgram;
  12249. CheckSource('TestProcType_AsParam',
  12250. LinesToStr([ // statements
  12251. 'this.DoIt = function (vG,vH,vI) {',
  12252. ' var vJ = null;',
  12253. ' vG = vG;',
  12254. ' vJ = vH;',
  12255. ' vI.set(vI.get());',
  12256. ' $mod.DoIt(vG, vG, {',
  12257. ' get: function () {',
  12258. ' return vG;',
  12259. ' },',
  12260. ' set: function (v) {',
  12261. ' vG = v;',
  12262. ' }',
  12263. ' });',
  12264. ' $mod.DoIt(vH, vH, {',
  12265. ' get: function () {',
  12266. ' return vJ;',
  12267. ' },',
  12268. ' set: function (v) {',
  12269. ' vJ = v;',
  12270. ' }',
  12271. ' });',
  12272. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  12273. ' $mod.DoIt(vJ, vJ, {',
  12274. ' get: function () {',
  12275. ' return vJ;',
  12276. ' },',
  12277. ' set: function (v) {',
  12278. ' vJ = v;',
  12279. ' }',
  12280. ' });',
  12281. '};',
  12282. 'this.i = null;'
  12283. ]),
  12284. LinesToStr([
  12285. '$mod.DoIt($mod.i,$mod.i,{',
  12286. ' p: $mod,',
  12287. ' get: function () {',
  12288. ' return this.p.i;',
  12289. ' },',
  12290. ' set: function (v) {',
  12291. ' this.p.i = v;',
  12292. ' }',
  12293. '});'
  12294. ]));
  12295. end;
  12296. procedure TTestModule.TestProcType_MethodFPC;
  12297. begin
  12298. StartProgram(false);
  12299. Add('type');
  12300. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  12301. Add(' TObject = class');
  12302. Add(' function DoIt(vA: longint = 1): longint;');
  12303. Add(' end;');
  12304. Add('function TObject.DoIt(vA: longint = 1): longint;');
  12305. Add('begin');
  12306. Add('end;');
  12307. Add('var');
  12308. Add(' Obj: TObject;');
  12309. Add(' vP: tfuncint;');
  12310. Add(' b: boolean;');
  12311. Add('begin');
  12312. Add(' vp:[email protected];'); // ok in fpc and delphi
  12313. //Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  12314. Add(' vp;'); // ok in fpc and delphi
  12315. Add(' vp();');
  12316. Add(' vp(2);');
  12317. Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  12318. Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  12319. Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  12320. Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  12321. ConvertProgram;
  12322. CheckSource('TestProcType_MethodFPC',
  12323. LinesToStr([ // statements
  12324. 'rtl.createClass($mod, "TObject", null, function () {',
  12325. ' this.$init = function () {',
  12326. ' };',
  12327. ' this.$final = function () {',
  12328. ' };',
  12329. ' this.DoIt = function (vA) {',
  12330. ' var Result = 0;',
  12331. ' return Result;',
  12332. ' };',
  12333. '});',
  12334. 'this.Obj = null;',
  12335. 'this.vP = null;',
  12336. 'this.b = false;'
  12337. ]),
  12338. LinesToStr([
  12339. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  12340. '$mod.vP(1);',
  12341. '$mod.vP(1);',
  12342. '$mod.vP(2);',
  12343. '$mod.b = rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  12344. '$mod.b = rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  12345. '$mod.b = !rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  12346. '$mod.b = !rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  12347. '']));
  12348. end;
  12349. procedure TTestModule.TestProcType_MethodDelphi;
  12350. begin
  12351. StartProgram(false);
  12352. Add('{$mode delphi}');
  12353. Add('type');
  12354. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  12355. Add(' TObject = class');
  12356. Add(' function DoIt(vA: longint = 1): longint;');
  12357. Add(' end;');
  12358. Add('function TObject.DoIt(vA: longint = 1): longint;');
  12359. Add('begin');
  12360. Add('end;');
  12361. Add('var');
  12362. Add(' Obj: TObject;');
  12363. Add(' vP: tfuncint;');
  12364. Add(' b: boolean;');
  12365. Add('begin');
  12366. Add(' vp:[email protected];'); // ok in fpc and delphi
  12367. Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  12368. Add(' vp;'); // ok in fpc and delphi
  12369. Add(' vp();');
  12370. Add(' vp(2);');
  12371. //Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  12372. //Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  12373. //Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  12374. //Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  12375. ConvertProgram;
  12376. CheckSource('TestProcType_MethodDelphi',
  12377. LinesToStr([ // statements
  12378. 'rtl.createClass($mod, "TObject", null, function () {',
  12379. ' this.$init = function () {',
  12380. ' };',
  12381. ' this.$final = function () {',
  12382. ' };',
  12383. ' this.DoIt = function (vA) {',
  12384. ' var Result = 0;',
  12385. ' return Result;',
  12386. ' };',
  12387. '});',
  12388. 'this.Obj = null;',
  12389. 'this.vP = null;',
  12390. 'this.b = false;'
  12391. ]),
  12392. LinesToStr([
  12393. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  12394. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  12395. '$mod.vP(1);',
  12396. '$mod.vP(1);',
  12397. '$mod.vP(2);',
  12398. '']));
  12399. end;
  12400. procedure TTestModule.TestProcType_PropertyFPC;
  12401. begin
  12402. StartProgram(false);
  12403. Add('type');
  12404. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  12405. Add(' TObject = class');
  12406. Add(' FOnFoo: TFuncInt;');
  12407. Add(' function DoIt(vA: longint = 1): longint;');
  12408. Add(' function GetFoo: TFuncInt;');
  12409. Add(' procedure SetFoo(const Value: TFuncInt);');
  12410. Add(' function GetEvents(Index: longint): TFuncInt;');
  12411. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  12412. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  12413. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  12414. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  12415. Add(' end;');
  12416. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  12417. Add('function tobject.getfoo: tfuncint; begin end;');
  12418. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  12419. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  12420. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  12421. Add('var');
  12422. Add(' Obj: TObject;');
  12423. Add(' vP: tfuncint;');
  12424. Add(' b: boolean;');
  12425. Add('begin');
  12426. Add(' obj.onfoo:=nil;');
  12427. Add(' obj.onbar:=nil;');
  12428. Add(' obj.events[1]:=nil;');
  12429. Add(' obj.onfoo:=obj.onfoo;');
  12430. Add(' obj.onbar:=obj.onbar;');
  12431. Add(' obj.events[2]:=obj.events[3];');
  12432. Add(' obj.onfoo:[email protected];');
  12433. Add(' obj.onbar:[email protected];');
  12434. Add(' obj.events[4]:[email protected];');
  12435. //Add(' obj.onfoo:=obj.doit;'); // delphi
  12436. //Add(' obj.onbar:=obj.doit;'); // delphi
  12437. //Add(' obj.events[4]:=obj.doit;'); // delphi
  12438. Add(' obj.onfoo;');
  12439. Add(' obj.onbar;');
  12440. //Add(' obj.events[5];'); ToDo in pasresolver
  12441. Add(' obj.onfoo();');
  12442. Add(' obj.onbar();');
  12443. Add(' obj.events[6]();');
  12444. Add(' b:=obj.onfoo=nil;');
  12445. Add(' b:=obj.onbar=nil;');
  12446. Add(' b:=obj.events[7]=nil;');
  12447. Add(' b:=obj.onfoo<>nil;');
  12448. Add(' b:=obj.onbar<>nil;');
  12449. Add(' b:=obj.events[8]<>nil;');
  12450. Add(' b:=obj.onfoo=vp;');
  12451. Add(' b:=obj.onbar=vp;');
  12452. Add(' b:=obj.events[9]=vp;');
  12453. Add(' b:=obj.onfoo=obj.onfoo;');
  12454. Add(' b:=obj.onbar=obj.onfoo;');
  12455. Add(' b:=obj.events[10]=obj.onfoo;');
  12456. Add(' b:=obj.onfoo<>obj.onfoo;');
  12457. Add(' b:=obj.onbar<>obj.onfoo;');
  12458. Add(' b:=obj.events[11]<>obj.onfoo;');
  12459. Add(' b:[email protected];');
  12460. Add(' b:[email protected];');
  12461. Add(' b:=obj.events[12][email protected];');
  12462. Add(' b:=obj.onfoo<>@obj.doit;');
  12463. Add(' b:=obj.onbar<>@obj.doit;');
  12464. Add(' b:=obj.events[12]<>@obj.doit;');
  12465. Add(' b:=Assigned(obj.onfoo);');
  12466. Add(' b:=Assigned(obj.onbar);');
  12467. Add(' b:=Assigned(obj.events[13]);');
  12468. ConvertProgram;
  12469. CheckSource('TestProcType_PropertyFPC',
  12470. LinesToStr([ // statements
  12471. 'rtl.createClass($mod, "TObject", null, function () {',
  12472. ' this.$init = function () {',
  12473. ' this.FOnFoo = null;',
  12474. ' };',
  12475. ' this.$final = function () {',
  12476. ' this.FOnFoo = undefined;',
  12477. ' };',
  12478. ' this.DoIt = function (vA) {',
  12479. ' var Result = 0;',
  12480. ' return Result;',
  12481. ' };',
  12482. 'this.GetFoo = function () {',
  12483. ' var Result = null;',
  12484. ' return Result;',
  12485. '};',
  12486. 'this.SetFoo = function (Value) {',
  12487. '};',
  12488. 'this.GetEvents = function (Index) {',
  12489. ' var Result = null;',
  12490. ' return Result;',
  12491. '};',
  12492. 'this.SetEvents = function (Index, Value) {',
  12493. '};',
  12494. '});',
  12495. 'this.Obj = null;',
  12496. 'this.vP = null;',
  12497. 'this.b = false;'
  12498. ]),
  12499. LinesToStr([
  12500. '$mod.Obj.FOnFoo = null;',
  12501. '$mod.Obj.SetFoo(null);',
  12502. '$mod.Obj.SetEvents(1, null);',
  12503. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  12504. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  12505. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  12506. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  12507. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  12508. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  12509. '$mod.Obj.FOnFoo(1);',
  12510. '$mod.Obj.GetFoo();',
  12511. '$mod.Obj.FOnFoo(1);',
  12512. '$mod.Obj.GetFoo()(1);',
  12513. '$mod.Obj.GetEvents(6)(1);',
  12514. '$mod.b = $mod.Obj.FOnFoo === null;',
  12515. '$mod.b = $mod.Obj.GetFoo() === null;',
  12516. '$mod.b = $mod.Obj.GetEvents(7) === null;',
  12517. '$mod.b = $mod.Obj.FOnFoo !== null;',
  12518. '$mod.b = $mod.Obj.GetFoo() !== null;',
  12519. '$mod.b = $mod.Obj.GetEvents(8) !== null;',
  12520. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.vP);',
  12521. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.vP);',
  12522. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(9), $mod.vP);',
  12523. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  12524. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  12525. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(10), $mod.Obj.FOnFoo);',
  12526. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  12527. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  12528. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(11), $mod.Obj.FOnFoo);',
  12529. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  12530. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  12531. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  12532. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  12533. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  12534. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  12535. '$mod.b = $mod.Obj.FOnFoo != null;',
  12536. '$mod.b = $mod.Obj.GetFoo() != null;',
  12537. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  12538. '']));
  12539. end;
  12540. procedure TTestModule.TestProcType_PropertyDelphi;
  12541. begin
  12542. StartProgram(false);
  12543. Add('{$mode delphi}');
  12544. Add('type');
  12545. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  12546. Add(' TObject = class');
  12547. Add(' FOnFoo: TFuncInt;');
  12548. Add(' function DoIt(vA: longint = 1): longint;');
  12549. Add(' function GetFoo: TFuncInt;');
  12550. Add(' procedure SetFoo(const Value: TFuncInt);');
  12551. Add(' function GetEvents(Index: longint): TFuncInt;');
  12552. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  12553. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  12554. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  12555. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  12556. Add(' end;');
  12557. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  12558. Add('function tobject.getfoo: tfuncint; begin end;');
  12559. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  12560. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  12561. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  12562. Add('var');
  12563. Add(' Obj: TObject;');
  12564. Add(' vP: tfuncint;');
  12565. Add(' b: boolean;');
  12566. Add('begin');
  12567. Add(' obj.onfoo:=nil;');
  12568. Add(' obj.onbar:=nil;');
  12569. Add(' obj.events[1]:=nil;');
  12570. Add(' obj.onfoo:=obj.onfoo;');
  12571. Add(' obj.onbar:=obj.onbar;');
  12572. Add(' obj.events[2]:=obj.events[3];');
  12573. Add(' obj.onfoo:[email protected];');
  12574. Add(' obj.onbar:[email protected];');
  12575. Add(' obj.events[4]:[email protected];');
  12576. Add(' obj.onfoo:=obj.doit;'); // delphi
  12577. Add(' obj.onbar:=obj.doit;'); // delphi
  12578. Add(' obj.events[4]:=obj.doit;'); // delphi
  12579. Add(' obj.onfoo;');
  12580. Add(' obj.onbar;');
  12581. //Add(' obj.events[5];'); ToDo in pasresolver
  12582. Add(' obj.onfoo();');
  12583. Add(' obj.onbar();');
  12584. Add(' obj.events[6]();');
  12585. //Add(' b:=obj.onfoo=nil;'); // fpc
  12586. //Add(' b:=obj.onbar=nil;'); // fpc
  12587. //Add(' b:=obj.events[7]=nil;'); // fpc
  12588. //Add(' b:=obj.onfoo<>nil;'); // fpc
  12589. //Add(' b:=obj.onbar<>nil;'); // fpc
  12590. //Add(' b:=obj.events[8]<>nil;'); // fpc
  12591. Add(' b:=obj.onfoo=vp;');
  12592. Add(' b:=obj.onbar=vp;');
  12593. //Add(' b:=obj.events[9]=vp;'); ToDo in pasresolver
  12594. Add(' b:=obj.onfoo=obj.onfoo;');
  12595. Add(' b:=obj.onbar=obj.onfoo;');
  12596. //Add(' b:=obj.events[10]=obj.onfoo;'); // ToDo in pasresolver
  12597. Add(' b:=obj.onfoo<>obj.onfoo;');
  12598. Add(' b:=obj.onbar<>obj.onfoo;');
  12599. //Add(' b:=obj.events[11]<>obj.onfoo;'); // ToDo in pasresolver
  12600. //Add(' b:[email protected];'); // fpc
  12601. //Add(' b:[email protected];'); // fpc
  12602. //Add(' b:=obj.events[12][email protected];'); // fpc
  12603. //Add(' b:=obj.onfoo<>@obj.doit;'); // fpc
  12604. //Add(' b:=obj.onbar<>@obj.doit;'); // fpc
  12605. //Add(' b:=obj.events[12]<>@obj.doit;'); // fpc
  12606. Add(' b:=Assigned(obj.onfoo);');
  12607. Add(' b:=Assigned(obj.onbar);');
  12608. Add(' b:=Assigned(obj.events[13]);');
  12609. ConvertProgram;
  12610. CheckSource('TestProcType_PropertyDelphi',
  12611. LinesToStr([ // statements
  12612. 'rtl.createClass($mod, "TObject", null, function () {',
  12613. ' this.$init = function () {',
  12614. ' this.FOnFoo = null;',
  12615. ' };',
  12616. ' this.$final = function () {',
  12617. ' this.FOnFoo = undefined;',
  12618. ' };',
  12619. ' this.DoIt = function (vA) {',
  12620. ' var Result = 0;',
  12621. ' return Result;',
  12622. ' };',
  12623. 'this.GetFoo = function () {',
  12624. ' var Result = null;',
  12625. ' return Result;',
  12626. '};',
  12627. 'this.SetFoo = function (Value) {',
  12628. '};',
  12629. 'this.GetEvents = function (Index) {',
  12630. ' var Result = null;',
  12631. ' return Result;',
  12632. '};',
  12633. 'this.SetEvents = function (Index, Value) {',
  12634. '};',
  12635. '});',
  12636. 'this.Obj = null;',
  12637. 'this.vP = null;',
  12638. 'this.b = false;'
  12639. ]),
  12640. LinesToStr([
  12641. '$mod.Obj.FOnFoo = null;',
  12642. '$mod.Obj.SetFoo(null);',
  12643. '$mod.Obj.SetEvents(1, null);',
  12644. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  12645. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  12646. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  12647. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  12648. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  12649. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  12650. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  12651. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  12652. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  12653. '$mod.Obj.FOnFoo(1);',
  12654. '$mod.Obj.GetFoo();',
  12655. '$mod.Obj.FOnFoo(1);',
  12656. '$mod.Obj.GetFoo()(1);',
  12657. '$mod.Obj.GetEvents(6)(1);',
  12658. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.vP(1);',
  12659. '$mod.b = $mod.Obj.GetFoo() === $mod.vP(1);',
  12660. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.Obj.FOnFoo(1);',
  12661. '$mod.b = $mod.Obj.GetFoo() === $mod.Obj.FOnFoo(1);',
  12662. '$mod.b = $mod.Obj.FOnFoo(1) !== $mod.Obj.FOnFoo(1);',
  12663. '$mod.b = $mod.Obj.GetFoo() !== $mod.Obj.FOnFoo(1);',
  12664. '$mod.b = $mod.Obj.FOnFoo != null;',
  12665. '$mod.b = $mod.Obj.GetFoo() != null;',
  12666. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  12667. '']));
  12668. end;
  12669. procedure TTestModule.TestProcType_WithClassInstDoPropertyFPC;
  12670. begin
  12671. StartProgram(false);
  12672. Add('type');
  12673. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  12674. Add(' TObject = class');
  12675. Add(' FOnFoo: TFuncInt;');
  12676. Add(' function DoIt(vA: longint = 1): longint;');
  12677. Add(' function GetFoo: TFuncInt;');
  12678. Add(' procedure SetFoo(const Value: TFuncInt);');
  12679. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  12680. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  12681. Add(' end;');
  12682. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  12683. Add('function tobject.getfoo: tfuncint; begin end;');
  12684. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  12685. Add('var');
  12686. Add(' Obj: TObject;');
  12687. Add(' vP: tfuncint;');
  12688. Add(' b: boolean;');
  12689. Add('begin');
  12690. Add('with obj do begin');
  12691. Add(' fonfoo:=nil;');
  12692. Add(' onfoo:=nil;');
  12693. Add(' onbar:=nil;');
  12694. Add(' fonfoo:=fonfoo;');
  12695. Add(' onfoo:=onfoo;');
  12696. Add(' onbar:=onbar;');
  12697. Add(' fonfoo:=@doit;');
  12698. Add(' onfoo:=@doit;');
  12699. Add(' onbar:=@doit;');
  12700. //Add(' fonfoo:=doit;'); // delphi
  12701. //Add(' onfoo:=doit;'); // delphi
  12702. //Add(' onbar:=doit;'); // delphi
  12703. Add(' fonfoo;');
  12704. Add(' onfoo;');
  12705. Add(' onbar;');
  12706. Add(' fonfoo();');
  12707. Add(' onfoo();');
  12708. Add(' onbar();');
  12709. Add(' b:=fonfoo=nil;');
  12710. Add(' b:=onfoo=nil;');
  12711. Add(' b:=onbar=nil;');
  12712. Add(' b:=fonfoo<>nil;');
  12713. Add(' b:=onfoo<>nil;');
  12714. Add(' b:=onbar<>nil;');
  12715. Add(' b:=fonfoo=vp;');
  12716. Add(' b:=onfoo=vp;');
  12717. Add(' b:=onbar=vp;');
  12718. Add(' b:=fonfoo=fonfoo;');
  12719. Add(' b:=onfoo=onfoo;');
  12720. Add(' b:=onbar=onfoo;');
  12721. Add(' b:=fonfoo<>fonfoo;');
  12722. Add(' b:=onfoo<>onfoo;');
  12723. Add(' b:=onbar<>onfoo;');
  12724. Add(' b:=fonfoo=@doit;');
  12725. Add(' b:=onfoo=@doit;');
  12726. Add(' b:=onbar=@doit;');
  12727. Add(' b:=fonfoo<>@doit;');
  12728. Add(' b:=onfoo<>@doit;');
  12729. Add(' b:=onbar<>@doit;');
  12730. Add(' b:=Assigned(fonfoo);');
  12731. Add(' b:=Assigned(onfoo);');
  12732. Add(' b:=Assigned(onbar);');
  12733. Add('end;');
  12734. ConvertProgram;
  12735. CheckSource('TestProcType_WithClassInstDoPropertyFPC',
  12736. LinesToStr([ // statements
  12737. 'rtl.createClass($mod, "TObject", null, function () {',
  12738. ' this.$init = function () {',
  12739. ' this.FOnFoo = null;',
  12740. ' };',
  12741. ' this.$final = function () {',
  12742. ' this.FOnFoo = undefined;',
  12743. ' };',
  12744. ' this.DoIt = function (vA) {',
  12745. ' var Result = 0;',
  12746. ' return Result;',
  12747. ' };',
  12748. ' this.GetFoo = function () {',
  12749. ' var Result = null;',
  12750. ' return Result;',
  12751. ' };',
  12752. ' this.SetFoo = function (Value) {',
  12753. ' };',
  12754. '});',
  12755. 'this.Obj = null;',
  12756. 'this.vP = null;',
  12757. 'this.b = false;'
  12758. ]),
  12759. LinesToStr([
  12760. 'var $with1 = $mod.Obj;',
  12761. '$with1.FOnFoo = null;',
  12762. '$with1.FOnFoo = null;',
  12763. '$with1.SetFoo(null);',
  12764. '$with1.FOnFoo = $with1.FOnFoo;',
  12765. '$with1.FOnFoo = $with1.FOnFoo;',
  12766. '$with1.SetFoo($with1.GetFoo());',
  12767. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  12768. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  12769. '$with1.SetFoo(rtl.createCallback($with1, "DoIt"));',
  12770. '$with1.FOnFoo(1);',
  12771. '$with1.FOnFoo(1);',
  12772. '$with1.GetFoo();',
  12773. '$with1.FOnFoo(1);',
  12774. '$with1.FOnFoo(1);',
  12775. '$with1.GetFoo()(1);',
  12776. '$mod.b = $with1.FOnFoo === null;',
  12777. '$mod.b = $with1.FOnFoo === null;',
  12778. '$mod.b = $with1.GetFoo() === null;',
  12779. '$mod.b = $with1.FOnFoo !== null;',
  12780. '$mod.b = $with1.FOnFoo !== null;',
  12781. '$mod.b = $with1.GetFoo() !== null;',
  12782. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  12783. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  12784. '$mod.b = rtl.eqCallback($with1.GetFoo(), $mod.vP);',
  12785. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  12786. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  12787. '$mod.b = rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  12788. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  12789. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  12790. '$mod.b = !rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  12791. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  12792. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  12793. '$mod.b = rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  12794. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  12795. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  12796. '$mod.b = !rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  12797. '$mod.b = $with1.FOnFoo != null;',
  12798. '$mod.b = $with1.FOnFoo != null;',
  12799. '$mod.b = $with1.GetFoo() != null;',
  12800. '']));
  12801. end;
  12802. procedure TTestModule.TestProcType_Nested;
  12803. begin
  12804. StartProgram(false);
  12805. Add([
  12806. 'type',
  12807. ' TProcInt = procedure(vI: longint = 1);',
  12808. 'procedure DoIt(vJ: longint);',
  12809. 'var aProc: TProcInt;',
  12810. ' b: boolean;',
  12811. ' procedure Sub(vK: longint);',
  12812. ' var aSub: TProcInt;',
  12813. ' procedure SubSub(vK: longint);',
  12814. ' var aSubSub: TProcInt;',
  12815. ' begin;',
  12816. ' aProc:=@DoIt;',
  12817. ' aSub:=@DoIt;',
  12818. ' aSubSub:=@DoIt;',
  12819. ' aProc:=@Sub;',
  12820. ' aSub:=@Sub;',
  12821. ' aSubSub:=@Sub;',
  12822. ' aProc:=@SubSub;',
  12823. ' aSub:=@SubSub;',
  12824. ' aSubSub:=@SubSub;',
  12825. ' end;',
  12826. ' begin;',
  12827. ' end;',
  12828. 'begin;',
  12829. ' aProc:=@Sub;',
  12830. ' b:=aProc=@Sub;',
  12831. ' b:=@Sub=aProc;',
  12832. 'end;',
  12833. 'begin',
  12834. '']);
  12835. ConvertProgram;
  12836. CheckSource('TestProcType_Nested',
  12837. LinesToStr([ // statements
  12838. 'this.DoIt = function (vJ) {',
  12839. ' var aProc = null;',
  12840. ' var b = false;',
  12841. ' function Sub(vK) {',
  12842. ' var aSub = null;',
  12843. ' function SubSub(vK) {',
  12844. ' var aSubSub = null;',
  12845. ' aProc = $mod.DoIt;',
  12846. ' aSub = $mod.DoIt;',
  12847. ' aSubSub = $mod.DoIt;',
  12848. ' aProc = Sub;',
  12849. ' aSub = Sub;',
  12850. ' aSubSub = Sub;',
  12851. ' aProc = SubSub;',
  12852. ' aSub = SubSub;',
  12853. ' aSubSub = SubSub;',
  12854. ' };',
  12855. ' };',
  12856. ' aProc = Sub;',
  12857. ' b = rtl.eqCallback(aProc, Sub);',
  12858. ' b = rtl.eqCallback(Sub, aProc);',
  12859. '};',
  12860. '']),
  12861. LinesToStr([ // $mod.$main
  12862. '']));
  12863. end;
  12864. procedure TTestModule.TestProcType_NestedOfObject;
  12865. begin
  12866. StartProgram(false);
  12867. Add([
  12868. 'type',
  12869. ' TProcInt = procedure(vI: longint = 1) of object;',
  12870. ' TObject = class',
  12871. ' procedure DoIt(vJ: longint);',
  12872. ' end;',
  12873. 'procedure TObject.DoIt(vJ: longint);',
  12874. 'var aProc: TProcInt;',
  12875. ' b: boolean;',
  12876. ' procedure Sub(vK: longint);',
  12877. ' var aSub: TProcInt;',
  12878. ' procedure SubSub(vK: longint);',
  12879. ' var aSubSub: TProcInt;',
  12880. ' begin;',
  12881. ' aProc:=@DoIt;',
  12882. ' aSub:=@DoIt;',
  12883. ' aSubSub:=@DoIt;',
  12884. ' aProc:=@Sub;',
  12885. ' aSub:=@Sub;',
  12886. ' aSubSub:=@Sub;',
  12887. ' aProc:=@SubSub;',
  12888. ' aSub:=@SubSub;',
  12889. ' aSubSub:=@SubSub;',
  12890. ' end;',
  12891. ' begin;',
  12892. ' end;',
  12893. 'begin;',
  12894. ' aProc:=@Sub;',
  12895. ' b:=aProc=@Sub;',
  12896. ' b:=@Sub=aProc;',
  12897. 'end;',
  12898. 'begin',
  12899. '']);
  12900. ConvertProgram;
  12901. CheckSource('TestProcType_Nested',
  12902. LinesToStr([ // statements
  12903. 'rtl.createClass($mod, "TObject", null, function () {',
  12904. ' this.$init = function () {',
  12905. ' };',
  12906. ' this.$final = function () {',
  12907. ' };',
  12908. ' this.DoIt = function (vJ) {',
  12909. ' var Self = this;',
  12910. ' var aProc = null;',
  12911. ' var b = false;',
  12912. ' function Sub(vK) {',
  12913. ' var aSub = null;',
  12914. ' function SubSub(vK) {',
  12915. ' var aSubSub = null;',
  12916. ' aProc = rtl.createCallback(Self, "DoIt");',
  12917. ' aSub = rtl.createCallback(Self, "DoIt");',
  12918. ' aSubSub = rtl.createCallback(Self, "DoIt");',
  12919. ' aProc = Sub;',
  12920. ' aSub = Sub;',
  12921. ' aSubSub = Sub;',
  12922. ' aProc = SubSub;',
  12923. ' aSub = SubSub;',
  12924. ' aSubSub = SubSub;',
  12925. ' };',
  12926. ' };',
  12927. ' aProc = Sub;',
  12928. ' b = rtl.eqCallback(aProc, Sub);',
  12929. ' b = rtl.eqCallback(Sub, aProc);',
  12930. ' };',
  12931. '});',
  12932. '']),
  12933. LinesToStr([ // $mod.$main
  12934. '']));
  12935. end;
  12936. procedure TTestModule.TestProcType_ReferenceToProc;
  12937. begin
  12938. StartProgram(false);
  12939. Add([
  12940. 'type',
  12941. ' TProcRef = reference to procedure(i: longint = 0);',
  12942. ' TFuncRef = reference to function(i: longint = 0): longint;',
  12943. 'var',
  12944. ' p: TProcRef;',
  12945. ' f: TFuncRef;',
  12946. 'procedure DoIt(i: longint);',
  12947. 'begin',
  12948. 'end;',
  12949. 'function GetIt(i: longint): longint;',
  12950. 'begin',
  12951. ' p:=@DoIt;',
  12952. ' f:=@GetIt;',
  12953. ' f;',
  12954. ' f();',
  12955. ' f(1);',
  12956. 'end;',
  12957. 'begin',
  12958. ' p:=@DoIt;',
  12959. ' f:=@GetIt;',
  12960. ' f;',
  12961. ' f();',
  12962. ' f(1);',
  12963. ' p:=TProcRef(f);',
  12964. '']);
  12965. ConvertProgram;
  12966. CheckSource('TestProcType_ReferenceToProc',
  12967. LinesToStr([ // statements
  12968. 'this.p = null;',
  12969. 'this.f = null;',
  12970. 'this.DoIt = function (i) {',
  12971. '};',
  12972. 'this.GetIt = function (i) {',
  12973. ' var Result = 0;',
  12974. ' $mod.p = $mod.DoIt;',
  12975. ' $mod.f = $mod.GetIt;',
  12976. ' $mod.f(0);',
  12977. ' $mod.f(0);',
  12978. ' $mod.f(1);',
  12979. ' return Result;',
  12980. '};',
  12981. '']),
  12982. LinesToStr([ // $mod.$main
  12983. '$mod.p = $mod.DoIt;',
  12984. '$mod.f = $mod.GetIt;',
  12985. '$mod.f(0);',
  12986. '$mod.f(0);',
  12987. '$mod.f(1);',
  12988. '$mod.p = $mod.f;',
  12989. '']));
  12990. end;
  12991. procedure TTestModule.TestProcType_ReferenceToMethod;
  12992. begin
  12993. StartProgram(false);
  12994. Add([
  12995. 'type',
  12996. ' TFuncRef = reference to function(i: longint = 5): longint;',
  12997. ' TObject = class',
  12998. ' function Grow(s: longint): longint;',
  12999. ' end;',
  13000. 'var',
  13001. ' f: tfuncref;',
  13002. 'function tobject.grow(s: longint): longint;',
  13003. ' function GrowSub(i: longint): longint;',
  13004. ' begin',
  13005. ' f:=@grow;',
  13006. ' f:=@growsub;',
  13007. ' end;',
  13008. 'begin',
  13009. ' f:=@grow;',
  13010. ' f:=@growsub;',
  13011. 'end;',
  13012. 'begin',
  13013. '']);
  13014. ConvertProgram;
  13015. CheckSource('TestProcType_ReferenceToMethod',
  13016. LinesToStr([ // statements
  13017. 'rtl.createClass($mod, "TObject", null, function () {',
  13018. ' this.$init = function () {',
  13019. ' };',
  13020. ' this.$final = function () {',
  13021. ' };',
  13022. ' this.Grow = function (s) {',
  13023. ' var Self = this;',
  13024. ' var Result = 0;',
  13025. ' function GrowSub(i) {',
  13026. ' var Result = 0;',
  13027. ' $mod.f = rtl.createCallback(Self, "Grow");',
  13028. ' $mod.f = GrowSub;',
  13029. ' return Result;',
  13030. ' };',
  13031. ' $mod.f = rtl.createCallback(Self, "Grow");',
  13032. ' $mod.f = GrowSub;',
  13033. ' return Result;',
  13034. ' };',
  13035. '});',
  13036. 'this.f = null;',
  13037. '']),
  13038. LinesToStr([ // $mod.$main
  13039. '']));
  13040. end;
  13041. procedure TTestModule.TestProcType_Typecast;
  13042. begin
  13043. StartProgram(false);
  13044. Add([
  13045. 'type',
  13046. ' TNotifyEvent = procedure(Sender: Pointer) of object;',
  13047. ' TEvent = procedure of object;',
  13048. ' TGetter = function:longint of object;',
  13049. ' TProcA = procedure(i: longint);',
  13050. ' TFuncB = function(i, j: longint): longint;',
  13051. 'procedure DoIt(); varargs; begin end;',
  13052. 'var',
  13053. ' Notify: tnotifyevent;',
  13054. ' Event: tevent;',
  13055. ' Getter: tgetter;',
  13056. ' ProcA: tproca;',
  13057. ' FuncB: tfuncb;',
  13058. ' p: pointer;',
  13059. 'begin',
  13060. ' notify:=tnotifyevent(event);',
  13061. ' event:=tevent(event);',
  13062. ' event:=tevent(notify);',
  13063. ' event:=tevent(getter);',
  13064. ' event:=tevent(proca);',
  13065. ' proca:=tproca(funcb);',
  13066. ' funcb:=tfuncb(funcb);',
  13067. ' funcb:=tfuncb(proca);',
  13068. ' funcb:=tfuncb(getter);',
  13069. ' proca:=tproca(p);',
  13070. ' funcb:=tfuncb(p);',
  13071. ' getter:=tgetter(p);',
  13072. ' p:=pointer(notify);',
  13073. ' p:=notify;',
  13074. ' p:=pointer(proca);',
  13075. ' p:=proca;',
  13076. ' p:=pointer(funcb);',
  13077. ' p:=funcb;',
  13078. ' doit(Pointer(notify),pointer(event),pointer(proca));',
  13079. '']);
  13080. ConvertProgram;
  13081. CheckSource('TestProcType_Typecast',
  13082. LinesToStr([ // statements
  13083. 'this.DoIt = function () {',
  13084. '};',
  13085. 'this.Notify = null;',
  13086. 'this.Event = null;',
  13087. 'this.Getter = null;',
  13088. 'this.ProcA = null;',
  13089. 'this.FuncB = null;',
  13090. 'this.p = null;',
  13091. '']),
  13092. LinesToStr([ // $mod.$main
  13093. '$mod.Notify = $mod.Event;',
  13094. '$mod.Event = $mod.Event;',
  13095. '$mod.Event = $mod.Notify;',
  13096. '$mod.Event = $mod.Getter;',
  13097. '$mod.Event = $mod.ProcA;',
  13098. '$mod.ProcA = $mod.FuncB;',
  13099. '$mod.FuncB = $mod.FuncB;',
  13100. '$mod.FuncB = $mod.ProcA;',
  13101. '$mod.FuncB = $mod.Getter;',
  13102. '$mod.ProcA = $mod.p;',
  13103. '$mod.FuncB = $mod.p;',
  13104. '$mod.Getter = $mod.p;',
  13105. '$mod.p = $mod.Notify;',
  13106. '$mod.p = $mod.Notify;',
  13107. '$mod.p = $mod.ProcA;',
  13108. '$mod.p = $mod.ProcA;',
  13109. '$mod.p = $mod.FuncB;',
  13110. '$mod.p = $mod.FuncB;',
  13111. '$mod.DoIt($mod.Notify, $mod.Event, $mod.ProcA);',
  13112. '']));
  13113. end;
  13114. procedure TTestModule.TestProcType_PassProcToUntyped;
  13115. begin
  13116. StartProgram(false);
  13117. Add([
  13118. 'type',
  13119. ' TEvent = procedure of object;',
  13120. ' TFunc = function: longint;',
  13121. 'procedure DoIt(); varargs; begin end;',
  13122. 'procedure DoSome(const a; var b; p: pointer); begin end;',
  13123. 'var',
  13124. ' Event: tevent;',
  13125. ' Func: TFunc;',
  13126. 'begin',
  13127. ' doit(event,func);',
  13128. ' dosome(event,event,event);',
  13129. ' dosome(func,func,func);',
  13130. '']);
  13131. ConvertProgram;
  13132. CheckSource('TestProcType_PassProcToUntyped',
  13133. LinesToStr([ // statements
  13134. 'this.DoIt = function () {',
  13135. '};',
  13136. 'this.DoSome = function (a, b, p) {',
  13137. '};',
  13138. 'this.Event = null;',
  13139. 'this.Func = null;',
  13140. '']),
  13141. LinesToStr([ // $mod.$main
  13142. '$mod.DoIt($mod.Event, $mod.Func);',
  13143. '$mod.DoSome($mod.Event, {',
  13144. ' p: $mod,',
  13145. ' get: function () {',
  13146. ' return this.p.Event;',
  13147. ' },',
  13148. ' set: function (v) {',
  13149. ' this.p.Event = v;',
  13150. ' }',
  13151. '}, $mod.Event);',
  13152. '$mod.DoSome($mod.Func, {',
  13153. ' p: $mod,',
  13154. ' get: function () {',
  13155. ' return this.p.Func;',
  13156. ' },',
  13157. ' set: function (v) {',
  13158. ' this.p.Func = v;',
  13159. ' }',
  13160. '}, $mod.Func);',
  13161. '']));
  13162. end;
  13163. procedure TTestModule.TestProcType_PassProcToArray;
  13164. begin
  13165. StartProgram(false);
  13166. Add([
  13167. 'type',
  13168. ' TFunc = function: longint;',
  13169. ' TArrFunc = array of TFunc;',
  13170. 'procedure DoIt(Arr: TArrFunc); begin end;',
  13171. 'function GetIt: longint; begin end;',
  13172. 'var',
  13173. ' Func: tfunc;',
  13174. 'begin',
  13175. ' doit([]);',
  13176. ' doit([@GetIt]);',
  13177. ' doit([Func]);',
  13178. '']);
  13179. ConvertProgram;
  13180. CheckSource('TestProcType_PassProcToArray',
  13181. LinesToStr([ // statements
  13182. 'this.DoIt = function (Arr) {',
  13183. '};',
  13184. 'this.GetIt = function () {',
  13185. ' var Result = 0;',
  13186. ' return Result;',
  13187. '};',
  13188. 'this.Func = null;',
  13189. '']),
  13190. LinesToStr([ // $mod.$main
  13191. '$mod.DoIt([]);',
  13192. '$mod.DoIt([$mod.GetIt]);',
  13193. '$mod.DoIt([$mod.Func]);',
  13194. '']));
  13195. end;
  13196. procedure TTestModule.TestPointer;
  13197. begin
  13198. StartProgram(false);
  13199. Add('type');
  13200. Add(' TObject = class end;');
  13201. Add(' TClass = class of TObject;');
  13202. Add(' TArrInt = array of longint;');
  13203. Add('var');
  13204. Add(' v: jsvalue;');
  13205. Add(' Obj: tobject;');
  13206. Add(' C: tclass;');
  13207. Add(' a: tarrint;');
  13208. Add(' p: Pointer;');
  13209. Add('begin');
  13210. Add(' p:=p;');
  13211. Add(' p:=nil;');
  13212. Add(' if p=nil then;');
  13213. Add(' if nil=p then;');
  13214. Add(' if Assigned(p) then;');
  13215. Add(' p:=Pointer(v);');
  13216. Add(' p:=obj;');
  13217. Add(' p:=c;');
  13218. Add(' p:=a;');
  13219. Add(' p:=tobject;');
  13220. Add(' obj:=TObject(p);');
  13221. Add(' c:=TClass(p);');
  13222. Add(' a:=TArrInt(p);');
  13223. ConvertProgram;
  13224. CheckSource('TestPointer',
  13225. LinesToStr([ // statements
  13226. 'rtl.createClass($mod, "TObject", null, function () {',
  13227. ' this.$init = function () {',
  13228. ' };',
  13229. ' this.$final = function () {',
  13230. ' };',
  13231. '});',
  13232. 'this.v = undefined;',
  13233. 'this.Obj = null;',
  13234. 'this.C = null;',
  13235. 'this.a = [];',
  13236. 'this.p = null;',
  13237. '']),
  13238. LinesToStr([ // $mod.$main
  13239. '$mod.p = $mod.p;',
  13240. '$mod.p = null;',
  13241. 'if ($mod.p === null) ;',
  13242. 'if (null === $mod.p) ;',
  13243. 'if ($mod.p != null) ;',
  13244. '$mod.p = $mod.v;',
  13245. '$mod.p = $mod.Obj;',
  13246. '$mod.p = $mod.C;',
  13247. '$mod.p = $mod.a;',
  13248. '$mod.p = $mod.TObject;',
  13249. '$mod.Obj = $mod.p;',
  13250. '$mod.C = $mod.p;',
  13251. '$mod.a = $mod.p;',
  13252. '']));
  13253. end;
  13254. procedure TTestModule.TestPointer_Proc;
  13255. begin
  13256. StartProgram(false);
  13257. Add('type');
  13258. Add(' TObject = class');
  13259. Add(' procedure DoIt; virtual; abstract;');
  13260. Add(' end;');
  13261. Add('procedure DoSome; begin end;');
  13262. Add('var');
  13263. Add(' o: TObject;');
  13264. Add(' p: Pointer;');
  13265. Add('begin');
  13266. Add(' p:=@DoSome;');
  13267. Add(' p:[email protected];');
  13268. ConvertProgram;
  13269. CheckSource('TestPointer_Proc',
  13270. LinesToStr([ // statements
  13271. 'rtl.createClass($mod, "TObject", null, function () {',
  13272. ' this.$init = function () {',
  13273. ' };',
  13274. ' this.$final = function () {',
  13275. ' };',
  13276. '});',
  13277. 'this.DoSome = function () {',
  13278. '};',
  13279. 'this.o = null;',
  13280. 'this.p = null;',
  13281. '']),
  13282. LinesToStr([ // $mod.$main
  13283. '$mod.p = $mod.DoSome;',
  13284. '$mod.p = rtl.createCallback($mod.o, "DoIt");',
  13285. '']));
  13286. end;
  13287. procedure TTestModule.TestPointer_AssignRecordFail;
  13288. begin
  13289. StartProgram(false);
  13290. Add('type');
  13291. Add(' TRec = record end;');
  13292. Add('var');
  13293. Add(' p: Pointer;');
  13294. Add(' r: TRec;');
  13295. Add('begin');
  13296. Add(' p:=r;');
  13297. SetExpectedPasResolverError('Incompatible types: got "TRec" expected "Pointer"',
  13298. nIncompatibleTypesGotExpected);
  13299. ConvertProgram;
  13300. end;
  13301. procedure TTestModule.TestPointer_AssignStaticArrayFail;
  13302. begin
  13303. StartProgram(false);
  13304. Add('type');
  13305. Add(' TArr = array[boolean] of longint;');
  13306. Add('var');
  13307. Add(' p: Pointer;');
  13308. Add(' a: TArr;');
  13309. Add('begin');
  13310. Add(' p:=a;');
  13311. SetExpectedPasResolverError('Incompatible types: got "TArr" expected "Pointer"',
  13312. nIncompatibleTypesGotExpected);
  13313. ConvertProgram;
  13314. end;
  13315. procedure TTestModule.TestPointer_ArrayParamsFail;
  13316. begin
  13317. StartProgram(false);
  13318. Add('var');
  13319. Add(' p: Pointer;');
  13320. Add('begin');
  13321. Add(' p:=p[1];');
  13322. SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter);
  13323. ConvertProgram;
  13324. end;
  13325. procedure TTestModule.TestPointer_TypeCastJSValueToPointer;
  13326. begin
  13327. StartProgram(false);
  13328. Add([
  13329. 'procedure DoIt(args: array of jsvalue); begin end;',
  13330. 'procedure DoAll; varargs; begin end;',
  13331. 'var',
  13332. ' v: jsvalue;',
  13333. 'begin',
  13334. ' DoIt([pointer(v)]);',
  13335. ' DoAll(pointer(v));',
  13336. '']);
  13337. ConvertProgram;
  13338. CheckSource('TestPointer_TypeCastJSValueToPointer',
  13339. LinesToStr([ // statements
  13340. 'this.DoIt = function (args) {',
  13341. '};',
  13342. 'this.DoAll = function () {',
  13343. '};',
  13344. 'this.v = undefined;',
  13345. '']),
  13346. LinesToStr([ // $mod.$main
  13347. '$mod.DoIt([$mod.v]);',
  13348. '$mod.DoAll($mod.v);',
  13349. '']));
  13350. end;
  13351. procedure TTestModule.TestJSValue_AssignToJSValue;
  13352. begin
  13353. StartProgram(false);
  13354. Add('var');
  13355. Add(' v: jsvalue;');
  13356. Add(' i: longint;');
  13357. Add(' s: string;');
  13358. Add(' b: boolean;');
  13359. Add(' d: double;');
  13360. Add(' p: pointer;');
  13361. Add('begin');
  13362. Add(' v:=v;');
  13363. Add(' v:=1;');
  13364. Add(' v:=i;');
  13365. Add(' v:='''';');
  13366. Add(' v:=''c'';');
  13367. Add(' v:=''foo'';');
  13368. Add(' v:=s;');
  13369. Add(' v:=false;');
  13370. Add(' v:=true;');
  13371. Add(' v:=b;');
  13372. Add(' v:=0.1;');
  13373. Add(' v:=d;');
  13374. Add(' v:=nil;');
  13375. Add(' v:=p;');
  13376. ConvertProgram;
  13377. CheckSource('TestJSValue_AssignToJSValue',
  13378. LinesToStr([ // statements
  13379. 'this.v = undefined;',
  13380. 'this.i = 0;',
  13381. 'this.s = "";',
  13382. 'this.b = false;',
  13383. 'this.d = 0.0;',
  13384. 'this.p = null;',
  13385. '']),
  13386. LinesToStr([ // $mod.$main
  13387. '$mod.v = $mod.v;',
  13388. '$mod.v = 1;',
  13389. '$mod.v = $mod.i;',
  13390. '$mod.v = "";',
  13391. '$mod.v = "c";',
  13392. '$mod.v = "foo";',
  13393. '$mod.v = $mod.s;',
  13394. '$mod.v = false;',
  13395. '$mod.v = true;',
  13396. '$mod.v = $mod.b;',
  13397. '$mod.v = 0.1;',
  13398. '$mod.v = $mod.d;',
  13399. '$mod.v = null;',
  13400. '$mod.v = $mod.p;',
  13401. '']));
  13402. end;
  13403. procedure TTestModule.TestJSValue_TypeCastToBaseType;
  13404. begin
  13405. StartProgram(false);
  13406. Add('type');
  13407. Add(' integer = longint;');
  13408. Add(' TYesNo = boolean;');
  13409. Add(' TFloat = double;');
  13410. Add(' TCaption = string;');
  13411. Add(' TChar = char;');
  13412. Add('var');
  13413. Add(' v: jsvalue;');
  13414. Add(' i: integer;');
  13415. Add(' s: TCaption;');
  13416. Add(' b: TYesNo;');
  13417. Add(' d: TFloat;');
  13418. Add(' c: char;');
  13419. Add('begin');
  13420. Add(' i:=longint(v);');
  13421. Add(' i:=integer(v);');
  13422. Add(' s:=string(v);');
  13423. Add(' s:=TCaption(v);');
  13424. Add(' b:=boolean(v);');
  13425. Add(' b:=TYesNo(v);');
  13426. Add(' d:=double(v);');
  13427. Add(' d:=TFloat(v);');
  13428. Add(' c:=char(v);');
  13429. Add(' c:=TChar(v);');
  13430. ConvertProgram;
  13431. CheckSource('TestJSValue_TypeCastToBaseType',
  13432. LinesToStr([ // statements
  13433. 'this.v = undefined;',
  13434. 'this.i = 0;',
  13435. 'this.s = "";',
  13436. 'this.b = false;',
  13437. 'this.d = 0.0;',
  13438. 'this.c = "";',
  13439. '']),
  13440. LinesToStr([ // $mod.$main
  13441. '$mod.i = Math.floor($mod.v);',
  13442. '$mod.i = Math.floor($mod.v);',
  13443. '$mod.s = "" + $mod.v;',
  13444. '$mod.s = "" + $mod.v;',
  13445. '$mod.b = !($mod.v == false);',
  13446. '$mod.b = !($mod.v == false);',
  13447. '$mod.d = rtl.getNumber($mod.v);',
  13448. '$mod.d = rtl.getNumber($mod.v);',
  13449. '$mod.c = rtl.getChar($mod.v);',
  13450. '$mod.c = rtl.getChar($mod.v);',
  13451. '']));
  13452. end;
  13453. procedure TTestModule.TestJSValue_Equal;
  13454. begin
  13455. StartProgram(false);
  13456. Add('type');
  13457. Add(' integer = longint;');
  13458. Add(' TYesNo = boolean;');
  13459. Add(' TFloat = double;');
  13460. Add(' TCaption = string;');
  13461. Add(' TChar = char;');
  13462. Add(' TMulti = JSValue;');
  13463. Add('var');
  13464. Add(' v: jsvalue;');
  13465. Add(' i: integer;');
  13466. Add(' s: TCaption;');
  13467. Add(' b: TYesNo;');
  13468. Add(' d: TFloat;');
  13469. Add(' c: char;');
  13470. Add(' m: TMulti;');
  13471. Add('begin');
  13472. Add(' b:=v=v;');
  13473. Add(' b:=v<>v;');
  13474. Add(' b:=v=1;');
  13475. Add(' b:=v<>1;');
  13476. Add(' b:=2=v;');
  13477. Add(' b:=2<>v;');
  13478. Add(' b:=v=i;');
  13479. Add(' b:=i=v;');
  13480. Add(' b:=v=nil;');
  13481. Add(' b:=nil=v;');
  13482. Add(' b:=v=false;');
  13483. Add(' b:=true=v;');
  13484. Add(' b:=v=b;');
  13485. Add(' b:=b=v;');
  13486. Add(' b:=v=s;');
  13487. Add(' b:=s=v;');
  13488. Add(' b:=v=''foo'';');
  13489. Add(' b:=''''=v;');
  13490. Add(' b:=v=d;');
  13491. Add(' b:=d=v;');
  13492. Add(' b:=v=3.4;');
  13493. Add(' b:=5.6=v;');
  13494. Add(' b:=v=c;');
  13495. Add(' b:=c=v;');
  13496. Add(' b:=m=m;');
  13497. Add(' b:=v=m;');
  13498. Add(' b:=m=v;');
  13499. ConvertProgram;
  13500. CheckSource('TestJSValue_Equal',
  13501. LinesToStr([ // statements
  13502. 'this.v = undefined;',
  13503. 'this.i = 0;',
  13504. 'this.s = "";',
  13505. 'this.b = false;',
  13506. 'this.d = 0.0;',
  13507. 'this.c = "";',
  13508. 'this.m = undefined;',
  13509. '']),
  13510. LinesToStr([ // $mod.$main
  13511. '$mod.b = $mod.v == $mod.v;',
  13512. '$mod.b = $mod.v != $mod.v;',
  13513. '$mod.b = $mod.v == 1;',
  13514. '$mod.b = $mod.v != 1;',
  13515. '$mod.b = 2 == $mod.v;',
  13516. '$mod.b = 2 != $mod.v;',
  13517. '$mod.b = $mod.v == $mod.i;',
  13518. '$mod.b = $mod.i == $mod.v;',
  13519. '$mod.b = $mod.v == null;',
  13520. '$mod.b = null == $mod.v;',
  13521. '$mod.b = $mod.v == false;',
  13522. '$mod.b = true == $mod.v;',
  13523. '$mod.b = $mod.v == $mod.b;',
  13524. '$mod.b = $mod.b == $mod.v;',
  13525. '$mod.b = $mod.v == $mod.s;',
  13526. '$mod.b = $mod.s == $mod.v;',
  13527. '$mod.b = $mod.v == "foo";',
  13528. '$mod.b = "" == $mod.v;',
  13529. '$mod.b = $mod.v == $mod.d;',
  13530. '$mod.b = $mod.d == $mod.v;',
  13531. '$mod.b = $mod.v == 3.4;',
  13532. '$mod.b = 5.6 == $mod.v;',
  13533. '$mod.b = $mod.v == $mod.c;',
  13534. '$mod.b = $mod.c == $mod.v;',
  13535. '$mod.b = $mod.m == $mod.m;',
  13536. '$mod.b = $mod.v == $mod.m;',
  13537. '$mod.b = $mod.m == $mod.v;',
  13538. '']));
  13539. end;
  13540. procedure TTestModule.TestJSValue_If;
  13541. begin
  13542. StartProgram(false);
  13543. Add([
  13544. 'var',
  13545. ' v: jsvalue;',
  13546. 'begin',
  13547. ' if v then ;',
  13548. ' while v do ;',
  13549. ' repeat until v;',
  13550. '']);
  13551. ConvertProgram;
  13552. CheckSource('TestJSValue_If',
  13553. LinesToStr([ // statements
  13554. 'this.v = undefined;',
  13555. '']),
  13556. LinesToStr([ // $mod.$main
  13557. 'if ($mod.v) ;',
  13558. 'while($mod.v){',
  13559. '};',
  13560. 'do{',
  13561. '} while(!$mod.v);',
  13562. '']));
  13563. end;
  13564. procedure TTestModule.TestJSValue_Enum;
  13565. begin
  13566. StartProgram(false);
  13567. Add('type');
  13568. Add(' TColor = (red, blue);');
  13569. Add(' TRedBlue = TColor;');
  13570. Add('var');
  13571. Add(' v: jsvalue;');
  13572. Add(' e: TColor;');
  13573. Add('begin');
  13574. Add(' v:=e;');
  13575. Add(' v:=TColor(e);');
  13576. Add(' v:=TRedBlue(e);');
  13577. Add(' e:=TColor(v);');
  13578. Add(' e:=TRedBlue(v);');
  13579. ConvertProgram;
  13580. CheckSource('TestJSValue_Enum',
  13581. LinesToStr([ // statements
  13582. 'this.TColor = {',
  13583. ' "0": "red",',
  13584. ' red: 0,',
  13585. ' "1": "blue",',
  13586. ' blue: 1',
  13587. '};',
  13588. 'this.v = undefined;',
  13589. 'this.e = 0;',
  13590. '']),
  13591. LinesToStr([ // $mod.$main
  13592. '$mod.v = $mod.e;',
  13593. '$mod.v = $mod.e;',
  13594. '$mod.v = $mod.e;',
  13595. '$mod.e = $mod.v;',
  13596. '$mod.e = $mod.v;',
  13597. '']));
  13598. end;
  13599. procedure TTestModule.TestJSValue_ClassInstance;
  13600. begin
  13601. StartProgram(false);
  13602. Add([
  13603. 'type',
  13604. ' TObject = class',
  13605. ' end;',
  13606. ' TBirdObject = TObject;',
  13607. 'var',
  13608. ' v: jsvalue;',
  13609. ' o: TObject;',
  13610. 'begin',
  13611. ' v:=o;',
  13612. ' v:=TObject(o);',
  13613. ' v:=TBirdObject(o);',
  13614. ' o:=TObject(v);',
  13615. ' o:=TBirdObject(v);',
  13616. ' if v is TObject then ;',
  13617. '']);
  13618. ConvertProgram;
  13619. CheckSource('TestJSValue_ClassInstance',
  13620. LinesToStr([ // statements
  13621. 'rtl.createClass($mod, "TObject", null, function () {',
  13622. ' this.$init = function () {',
  13623. ' };',
  13624. ' this.$final = function () {',
  13625. ' };',
  13626. '});',
  13627. 'this.v = undefined;',
  13628. 'this.o = null;',
  13629. '']),
  13630. LinesToStr([ // $mod.$main
  13631. '$mod.v = $mod.o;',
  13632. '$mod.v = $mod.o;',
  13633. '$mod.v = $mod.o;',
  13634. '$mod.o = rtl.getObject($mod.v);',
  13635. '$mod.o = rtl.getObject($mod.v);',
  13636. 'if (rtl.isExt($mod.v, $mod.TObject, 1)) ;',
  13637. '']));
  13638. end;
  13639. procedure TTestModule.TestJSValue_ClassOf;
  13640. begin
  13641. StartProgram(false);
  13642. Add([
  13643. 'type',
  13644. ' TClass = class of TObject;',
  13645. ' TObject = class',
  13646. ' end;',
  13647. ' TBirds = class of TBird;',
  13648. ' TBird = class(TObject) end;',
  13649. 'var',
  13650. ' v: jsvalue;',
  13651. ' c: TClass;',
  13652. 'begin',
  13653. ' v:=c;',
  13654. ' v:=TObject;',
  13655. ' v:=TClass(c);',
  13656. ' v:=TBirds(c);',
  13657. ' c:=TClass(v);',
  13658. ' c:=TBirds(v);',
  13659. ' if v is TClass then ;',
  13660. '']);
  13661. ConvertProgram;
  13662. CheckSource('TestJSValue_ClassOf',
  13663. LinesToStr([ // statements
  13664. 'rtl.createClass($mod, "TObject", null, function () {',
  13665. ' this.$init = function () {',
  13666. ' };',
  13667. ' this.$final = function () {',
  13668. ' };',
  13669. '});',
  13670. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13671. '});',
  13672. 'this.v = undefined;',
  13673. 'this.c = null;',
  13674. '']),
  13675. LinesToStr([ // $mod.$main
  13676. '$mod.v = $mod.c;',
  13677. '$mod.v = $mod.TObject;',
  13678. '$mod.v = $mod.c;',
  13679. '$mod.v = $mod.c;',
  13680. '$mod.c = rtl.getObject($mod.v);',
  13681. '$mod.c = rtl.getObject($mod.v);',
  13682. 'if (rtl.isExt($mod.v, $mod.TObject, 2)) ;',
  13683. '']));
  13684. end;
  13685. procedure TTestModule.TestJSValue_ArrayOfJSValue;
  13686. begin
  13687. StartProgram(false);
  13688. Add([
  13689. 'type',
  13690. ' integer = longint;',
  13691. ' TArray = array of JSValue;',
  13692. ' TArrgh = tarray;',
  13693. ' TArrInt = array of integer;',
  13694. 'var',
  13695. ' v: jsvalue;',
  13696. ' TheArray: tarray = (1,''2'');',
  13697. ' Arr: tarrgh;',
  13698. ' i: integer;',
  13699. ' ArrInt: tarrint;',
  13700. 'begin',
  13701. ' arr:=thearray;',
  13702. ' thearray:=arr;',
  13703. ' setlength(arr,2);',
  13704. ' setlength(thearray,3);',
  13705. ' arr[4]:=v;',
  13706. ' arr[5]:=length(thearray);',
  13707. ' arr[6]:=nil;',
  13708. ' arr[7]:=thearray[8];',
  13709. ' arr[low(arr)]:=high(thearray);',
  13710. ' arr:=arrint;',
  13711. ' arrInt:=tarrint(arr);',
  13712. ' if TheArray = nil then ;',
  13713. ' if nil = TheArray then ;',
  13714. ' if TheArray <> nil then ;',
  13715. ' if nil <> TheArray then ;',
  13716. '']);
  13717. ConvertProgram;
  13718. CheckSource('TestJSValue_ArrayOfJSValue',
  13719. LinesToStr([ // statements
  13720. 'this.v = undefined;',
  13721. 'this.TheArray = [1, "2"];',
  13722. 'this.Arr = [];',
  13723. 'this.i = 0;',
  13724. 'this.ArrInt = [];',
  13725. '']),
  13726. LinesToStr([ // $mod.$main
  13727. '$mod.Arr = $mod.TheArray;',
  13728. '$mod.TheArray = $mod.Arr;',
  13729. '$mod.Arr = rtl.arraySetLength($mod.Arr,undefined,2);',
  13730. '$mod.TheArray = rtl.arraySetLength($mod.TheArray,undefined,3);',
  13731. '$mod.Arr[4] = $mod.v;',
  13732. '$mod.Arr[5] = rtl.length($mod.TheArray);',
  13733. '$mod.Arr[6] = null;',
  13734. '$mod.Arr[7] = $mod.TheArray[8];',
  13735. '$mod.Arr[0] = rtl.length($mod.TheArray) - 1;',
  13736. '$mod.Arr = $mod.ArrInt;',
  13737. '$mod.ArrInt = $mod.Arr;',
  13738. 'if (rtl.length($mod.TheArray) === 0) ;',
  13739. 'if (rtl.length($mod.TheArray) === 0) ;',
  13740. 'if (rtl.length($mod.TheArray) > 0) ;',
  13741. 'if (rtl.length($mod.TheArray) > 0) ;',
  13742. '']));
  13743. end;
  13744. procedure TTestModule.TestJSValue_Params;
  13745. begin
  13746. StartProgram(false);
  13747. Add('type');
  13748. Add(' integer = longint;');
  13749. Add(' TYesNo = boolean;');
  13750. Add(' TFloat = double;');
  13751. Add(' TCaption = string;');
  13752. Add(' TChar = char;');
  13753. Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
  13754. Add('var');
  13755. Add(' l: jsvalue;');
  13756. Add('begin');
  13757. Add(' a:=a;');
  13758. Add(' l:=b;');
  13759. Add(' c:=c;');
  13760. Add(' d:=d;');
  13761. Add(' Result:=l;');
  13762. Add('end;');
  13763. Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
  13764. Add('var');
  13765. Add(' v: jsvalue;');
  13766. Add(' i: integer;');
  13767. Add(' b: TYesNo;');
  13768. Add(' d: TFloat;');
  13769. Add(' s: TCaption;');
  13770. Add(' c: TChar;');
  13771. Add('begin');
  13772. Add(' v:=doit(v,v,v,v);');
  13773. Add(' i:=integer(dosome(i,i));');
  13774. Add(' b:=TYesNo(dosome(b,b));');
  13775. Add(' d:=TFloat(dosome(d,d));');
  13776. Add(' s:=TCaption(dosome(s,s));');
  13777. Add(' c:=TChar(dosome(c,c));');
  13778. ConvertProgram;
  13779. CheckSource('TestJSValue_Params',
  13780. LinesToStr([ // statements
  13781. 'this.DoIt = function (a, b, c, d) {',
  13782. ' var Result = undefined;',
  13783. ' var l = undefined;',
  13784. ' a = a;',
  13785. ' l = b;',
  13786. ' c.set(c.get());',
  13787. ' d.set(d.get());',
  13788. ' Result = l;',
  13789. ' return Result;',
  13790. '};',
  13791. 'this.DoSome = function (a, b) {',
  13792. ' var Result = undefined;',
  13793. ' return Result;',
  13794. '};',
  13795. 'this.v = undefined;',
  13796. 'this.i = 0;',
  13797. 'this.b = false;',
  13798. 'this.d = 0.0;',
  13799. 'this.s = "";',
  13800. 'this.c = "";',
  13801. '']),
  13802. LinesToStr([ // $mod.$main
  13803. '$mod.v = $mod.DoIt($mod.v, $mod.v, {',
  13804. ' p: $mod,',
  13805. ' get: function () {',
  13806. ' return this.p.v;',
  13807. ' },',
  13808. ' set: function (v) {',
  13809. ' this.p.v = v;',
  13810. ' }',
  13811. '}, {',
  13812. ' p: $mod,',
  13813. ' get: function () {',
  13814. ' return this.p.v;',
  13815. ' },',
  13816. ' set: function (v) {',
  13817. ' this.p.v = v;',
  13818. ' }',
  13819. '});',
  13820. '$mod.i = Math.floor($mod.DoSome($mod.i, $mod.i));',
  13821. '$mod.b = !($mod.DoSome($mod.b, $mod.b) == false);',
  13822. '$mod.d = rtl.getNumber($mod.DoSome($mod.d, $mod.d));',
  13823. '$mod.s = "" + $mod.DoSome($mod.s, $mod.s);',
  13824. '$mod.c = rtl.getChar($mod.DoSome($mod.c, $mod.c));',
  13825. '']));
  13826. end;
  13827. procedure TTestModule.TestJSValue_UntypedParam;
  13828. begin
  13829. StartProgram(false);
  13830. Add('function DoIt(const a; var b; out c): jsvalue;');
  13831. Add('begin');
  13832. Add(' Result:=a;');
  13833. Add(' Result:=b;');
  13834. Add(' Result:=c;');
  13835. Add(' b:=Result;');
  13836. Add(' c:=Result;');
  13837. Add('end;');
  13838. Add('var i: longint;');
  13839. Add('begin');
  13840. Add(' doit(i,i,i);');
  13841. ConvertProgram;
  13842. CheckSource('TestJSValue_UntypedParam',
  13843. LinesToStr([ // statements
  13844. 'this.DoIt = function (a, b, c) {',
  13845. ' var Result = undefined;',
  13846. ' Result = a;',
  13847. ' Result = b.get();',
  13848. ' Result = c.get();',
  13849. ' b.set(Result);',
  13850. ' c.set(Result);',
  13851. ' return Result;',
  13852. '};',
  13853. 'this.i = 0;',
  13854. '']),
  13855. LinesToStr([ // $mod.$main
  13856. '$mod.DoIt($mod.i, {',
  13857. ' p: $mod,',
  13858. ' get: function () {',
  13859. ' return this.p.i;',
  13860. ' },',
  13861. ' set: function (v) {',
  13862. ' this.p.i = v;',
  13863. ' }',
  13864. '}, {',
  13865. ' p: $mod,',
  13866. ' get: function () {',
  13867. ' return this.p.i;',
  13868. ' },',
  13869. ' set: function (v) {',
  13870. ' this.p.i = v;',
  13871. ' }',
  13872. '});',
  13873. '']));
  13874. end;
  13875. procedure TTestModule.TestJSValue_FuncResultType;
  13876. begin
  13877. StartProgram(false);
  13878. Add('type');
  13879. Add(' integer = longint;');
  13880. Add(' TJSValueArray = array of JSValue;');
  13881. Add(' TListSortCompare = function(Item1, Item2: JSValue): Integer;');
  13882. Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
  13883. Add('begin');
  13884. Add(' while Compare(P,aList[0])>0 do ;');
  13885. Add('end;');
  13886. Add('var');
  13887. Add(' Compare: TListSortCompare;');
  13888. Add(' V: JSValue;');
  13889. Add(' i: integer;');
  13890. Add('begin');
  13891. Add(' if Compare(V,V)>0 then ;');
  13892. Add(' if Compare(i,i)>1 then ;');
  13893. Add(' if Compare(nil,false)>2 then ;');
  13894. Add(' if Compare(1,true)>3 then ;');
  13895. ConvertProgram;
  13896. CheckSource('TestJSValue_UntypedParam',
  13897. LinesToStr([ // statements
  13898. 'this.Sort = function (P, aList, Compare) {',
  13899. ' while (Compare(P, aList[0]) > 0) {',
  13900. ' };',
  13901. '};',
  13902. 'this.Compare = null;',
  13903. 'this.V = undefined;',
  13904. 'this.i = 0;',
  13905. '']),
  13906. LinesToStr([ // $mod.$main
  13907. 'if ($mod.Compare($mod.V, $mod.V) > 0) ;',
  13908. 'if ($mod.Compare($mod.i, $mod.i) > 1) ;',
  13909. 'if ($mod.Compare(null, false) > 2) ;',
  13910. 'if ($mod.Compare(1, true) > 3) ;',
  13911. '']));
  13912. end;
  13913. procedure TTestModule.TestJSValue_ProcType_Assign;
  13914. begin
  13915. StartProgram(false);
  13916. Add('type');
  13917. Add(' integer = longint;');
  13918. Add(' TObject = class');
  13919. Add(' class function GetGlob: integer;');
  13920. Add(' function Getter: integer;');
  13921. Add(' end;');
  13922. Add('class function TObject.GetGlob: integer;');
  13923. Add('var v1: jsvalue;');
  13924. Add('begin');
  13925. Add(' v1:=@GetGlob;');
  13926. Add(' v1:[email protected];');
  13927. Add('end;');
  13928. Add('function TObject.Getter: integer;');
  13929. Add('var v2: jsvalue;');
  13930. Add('begin');
  13931. Add(' v2:=@Getter;');
  13932. Add(' v2:[email protected];');
  13933. Add(' v2:=@GetGlob;');
  13934. Add(' v2:[email protected];');
  13935. Add('end;');
  13936. Add('function GetIt(i: integer): integer;');
  13937. Add('var v3: jsvalue;');
  13938. Add('begin');
  13939. Add(' v3:=@GetIt;');
  13940. Add('end;');
  13941. Add('var');
  13942. Add(' V: JSValue;');
  13943. Add(' o: TObject;');
  13944. Add('begin');
  13945. Add(' v:=@GetIt;');
  13946. Add(' v:[email protected];');
  13947. Add(' v:[email protected];');
  13948. ConvertProgram;
  13949. CheckSource('TestJSValue_ProcType_Assign',
  13950. LinesToStr([ // statements
  13951. 'rtl.createClass($mod, "TObject", null, function () {',
  13952. ' this.$init = function () {',
  13953. ' };',
  13954. ' this.$final = function () {',
  13955. ' };',
  13956. ' this.GetGlob = function () {',
  13957. ' var Result = 0;',
  13958. ' var v1 = undefined;',
  13959. ' v1 = rtl.createCallback(this, "GetGlob");',
  13960. ' v1 = rtl.createCallback(this, "GetGlob");',
  13961. ' return Result;',
  13962. ' };',
  13963. ' this.Getter = function () {',
  13964. ' var Result = 0;',
  13965. ' var v2 = undefined;',
  13966. ' v2 = rtl.createCallback(this, "Getter");',
  13967. ' v2 = rtl.createCallback(this, "Getter");',
  13968. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  13969. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  13970. ' return Result;',
  13971. ' };',
  13972. '});',
  13973. 'this.GetIt = function (i) {',
  13974. ' var Result = 0;',
  13975. ' var v3 = undefined;',
  13976. ' v3 = $mod.GetIt;',
  13977. ' return Result;',
  13978. '};',
  13979. 'this.V = undefined;',
  13980. 'this.o = null;',
  13981. '']),
  13982. LinesToStr([ // $mod.$main
  13983. '$mod.V = $mod.GetIt;',
  13984. '$mod.V = rtl.createCallback($mod.o, "Getter");',
  13985. '$mod.V = rtl.createCallback($mod.o.$class, "GetGlob");',
  13986. '']));
  13987. end;
  13988. procedure TTestModule.TestJSValue_ProcType_Equal;
  13989. begin
  13990. StartProgram(false);
  13991. Add('type');
  13992. Add(' integer = longint;');
  13993. Add(' TObject = class');
  13994. Add(' class function GetGlob: integer;');
  13995. Add(' function Getter: integer;');
  13996. Add(' end;');
  13997. Add('class function TObject.GetGlob: integer;');
  13998. Add('var v1: jsvalue;');
  13999. Add('begin');
  14000. Add(' if v1=@GetGlob then;');
  14001. Add(' if [email protected] then ;');
  14002. Add('end;');
  14003. Add('function TObject.Getter: integer;');
  14004. Add('var v2: jsvalue;');
  14005. Add('begin');
  14006. Add(' if v2=@Getter then;');
  14007. Add(' if [email protected] then ;');
  14008. Add(' if v2=@GetGlob then;');
  14009. Add(' if [email protected] then;');
  14010. Add('end;');
  14011. Add('function GetIt(i: integer): integer;');
  14012. Add('var v3: jsvalue;');
  14013. Add('begin');
  14014. Add(' if v3=@GetIt then;');
  14015. Add('end;');
  14016. Add('var');
  14017. Add(' V: JSValue;');
  14018. Add(' o: TObject;');
  14019. Add('begin');
  14020. Add(' if v=@GetIt then;');
  14021. Add(' if [email protected] then;');
  14022. Add(' if [email protected] then;');
  14023. Add(' if @GetIt=v then;');
  14024. Add(' if @o.Getter=v then;');
  14025. Add(' if @o.GetGlob=v then;');
  14026. ConvertProgram;
  14027. CheckSource('TestJSValue_ProcType_Equal',
  14028. LinesToStr([ // statements
  14029. 'rtl.createClass($mod, "TObject", null, function () {',
  14030. ' this.$init = function () {',
  14031. ' };',
  14032. ' this.$final = function () {',
  14033. ' };',
  14034. ' this.GetGlob = function () {',
  14035. ' var Result = 0;',
  14036. ' var v1 = undefined;',
  14037. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  14038. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  14039. ' return Result;',
  14040. ' };',
  14041. ' this.Getter = function () {',
  14042. ' var Result = 0;',
  14043. ' var v2 = undefined;',
  14044. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  14045. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  14046. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  14047. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  14048. ' return Result;',
  14049. ' };',
  14050. '});',
  14051. 'this.GetIt = function (i) {',
  14052. ' var Result = 0;',
  14053. ' var v3 = undefined;',
  14054. ' if (rtl.eqCallback(v3, $mod.GetIt)) ;',
  14055. ' return Result;',
  14056. '};',
  14057. 'this.V = undefined;',
  14058. 'this.o = null;',
  14059. '']),
  14060. LinesToStr([ // $mod.$main
  14061. 'if (rtl.eqCallback($mod.V, $mod.GetIt)) ;',
  14062. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o, "Getter"))) ;',
  14063. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o.$class, "GetGlob"))) ;',
  14064. 'if (rtl.eqCallback($mod.GetIt, $mod.V)) ;',
  14065. 'if (rtl.eqCallback(rtl.createCallback($mod.o, "Getter"), $mod.V)) ;',
  14066. 'if (rtl.eqCallback(rtl.createCallback($mod.o.$class, "GetGlob"), $mod.V)) ;',
  14067. '']));
  14068. end;
  14069. procedure TTestModule.TestJSValue_ProcType_Param;
  14070. begin
  14071. StartProgram(false);
  14072. Add([
  14073. 'type',
  14074. ' variant = jsvalue;',
  14075. ' TArrVariant = array of variant;',
  14076. ' TArrVar2 = TArrVariant;',
  14077. ' TFuncInt = function: longint;',
  14078. 'function GetIt: longint;',
  14079. 'begin',
  14080. 'end;',
  14081. 'procedure DoIt(p: jsvalue; Arr: TArrVar2);',
  14082. 'var v: variant;',
  14083. 'begin',
  14084. ' v:=arr[1];',
  14085. 'end;',
  14086. 'var s: string;',
  14087. 'begin',
  14088. ' DoIt(GetIt,[]);',
  14089. ' DoIt(@GetIt,[]);',
  14090. ' DoIt(1,[s,GetIt]);',
  14091. ' DoIt(1,[s,@GetIt]);',
  14092. '']);
  14093. ConvertProgram;
  14094. CheckSource('TestJSValue_ProcType_Param',
  14095. LinesToStr([ // statements
  14096. 'this.GetIt = function () {',
  14097. ' var Result = 0;',
  14098. ' return Result;',
  14099. '};',
  14100. 'this.DoIt = function (p, Arr) {',
  14101. ' var v = undefined;',
  14102. ' v = Arr[1];',
  14103. '};',
  14104. 'this.s = "";',
  14105. '']),
  14106. LinesToStr([ // $mod.$main
  14107. '$mod.DoIt($mod.GetIt(), []);',
  14108. '$mod.DoIt($mod.GetIt, []);',
  14109. '$mod.DoIt(1, [$mod.s, $mod.GetIt()]);',
  14110. '$mod.DoIt(1, [$mod.s, $mod.GetIt]);',
  14111. '']));
  14112. end;
  14113. procedure TTestModule.TestJSValue_AssignToPointerFail;
  14114. begin
  14115. StartProgram(false);
  14116. Add([
  14117. 'var',
  14118. ' v: JSValue;',
  14119. ' p: Pointer;',
  14120. 'begin',
  14121. ' p:=v;',
  14122. '']);
  14123. SetExpectedPasResolverError('Incompatible types: got "JSValue" expected "Pointer"',
  14124. nIncompatibleTypesGotExpected);
  14125. ConvertProgram;
  14126. end;
  14127. procedure TTestModule.TestJSValue_OverloadDouble;
  14128. begin
  14129. StartProgram(false);
  14130. Add([
  14131. 'type',
  14132. ' integer = longint;',
  14133. ' tdatetime = double;',
  14134. 'procedure DoIt(d: double); begin end;',
  14135. 'procedure DoIt(v: jsvalue); begin end;',
  14136. 'var',
  14137. ' d: double;',
  14138. ' dt: tdatetime;',
  14139. ' i: integer;',
  14140. ' b: byte;',
  14141. ' shi: shortint;',
  14142. ' w: word;',
  14143. ' smi: smallint;',
  14144. ' lw: longword;',
  14145. ' li: longint;',
  14146. ' ni: nativeint;',
  14147. ' nu: nativeuint;',
  14148. 'begin',
  14149. ' DoIt(d);',
  14150. ' DoIt(dt);',
  14151. ' DoIt(i);',
  14152. ' DoIt(b);',
  14153. ' DoIt(shi);',
  14154. ' DoIt(w);',
  14155. ' DoIt(smi);',
  14156. ' DoIt(lw);',
  14157. ' DoIt(li);',
  14158. ' DoIt(ni);',
  14159. ' DoIt(nu);',
  14160. '']);
  14161. ConvertProgram;
  14162. CheckSource('TestJSValue_OverloadDouble',
  14163. LinesToStr([ // statements
  14164. 'this.DoIt = function (d) {',
  14165. '};',
  14166. 'this.DoIt$1 = function (v) {',
  14167. '};',
  14168. 'this.d = 0.0;',
  14169. 'this.dt = 0.0;',
  14170. 'this.i = 0;',
  14171. 'this.b = 0;',
  14172. 'this.shi = 0;',
  14173. 'this.w = 0;',
  14174. 'this.smi = 0;',
  14175. 'this.lw = 0;',
  14176. 'this.li = 0;',
  14177. 'this.ni = 0;',
  14178. 'this.nu = 0;',
  14179. '']),
  14180. LinesToStr([ // $mod.$main
  14181. '$mod.DoIt($mod.d);',
  14182. '$mod.DoIt($mod.dt);',
  14183. '$mod.DoIt($mod.i);',
  14184. '$mod.DoIt($mod.b);',
  14185. '$mod.DoIt($mod.shi);',
  14186. '$mod.DoIt($mod.w);',
  14187. '$mod.DoIt($mod.smi);',
  14188. '$mod.DoIt($mod.lw);',
  14189. '$mod.DoIt($mod.li);',
  14190. '$mod.DoIt($mod.ni);',
  14191. '$mod.DoIt($mod.nu);',
  14192. '']));
  14193. end;
  14194. procedure TTestModule.TestJSValue_OverloadNativeInt;
  14195. begin
  14196. StartProgram(false);
  14197. Add([
  14198. 'type',
  14199. ' integer = longint;',
  14200. ' int53 = nativeint;',
  14201. ' tdatetime = double;',
  14202. 'procedure DoIt(n: nativeint); begin end;',
  14203. 'procedure DoIt(v: jsvalue); begin end;',
  14204. 'var',
  14205. ' d: double;',
  14206. ' dt: tdatetime;',
  14207. ' i: integer;',
  14208. ' b: byte;',
  14209. ' shi: shortint;',
  14210. ' w: word;',
  14211. ' smi: smallint;',
  14212. ' lw: longword;',
  14213. ' li: longint;',
  14214. ' ni: nativeint;',
  14215. ' nu: nativeuint;',
  14216. 'begin',
  14217. ' DoIt(d);',
  14218. ' DoIt(dt);',
  14219. ' DoIt(i);',
  14220. ' DoIt(b);',
  14221. ' DoIt(shi);',
  14222. ' DoIt(w);',
  14223. ' DoIt(smi);',
  14224. ' DoIt(lw);',
  14225. ' DoIt(li);',
  14226. ' DoIt(ni);',
  14227. ' DoIt(nu);',
  14228. '']);
  14229. ConvertProgram;
  14230. CheckSource('TestJSValue_OverloadNativeInt',
  14231. LinesToStr([ // statements
  14232. 'this.DoIt = function (n) {',
  14233. '};',
  14234. 'this.DoIt$1 = function (v) {',
  14235. '};',
  14236. 'this.d = 0.0;',
  14237. 'this.dt = 0.0;',
  14238. 'this.i = 0;',
  14239. 'this.b = 0;',
  14240. 'this.shi = 0;',
  14241. 'this.w = 0;',
  14242. 'this.smi = 0;',
  14243. 'this.lw = 0;',
  14244. 'this.li = 0;',
  14245. 'this.ni = 0;',
  14246. 'this.nu = 0;',
  14247. '']),
  14248. LinesToStr([ // $mod.$main
  14249. '$mod.DoIt$1($mod.d);',
  14250. '$mod.DoIt$1($mod.dt);',
  14251. '$mod.DoIt($mod.i);',
  14252. '$mod.DoIt($mod.b);',
  14253. '$mod.DoIt($mod.shi);',
  14254. '$mod.DoIt($mod.w);',
  14255. '$mod.DoIt($mod.smi);',
  14256. '$mod.DoIt($mod.lw);',
  14257. '$mod.DoIt($mod.li);',
  14258. '$mod.DoIt($mod.ni);',
  14259. '$mod.DoIt($mod.nu);',
  14260. '']));
  14261. end;
  14262. procedure TTestModule.TestJSValue_OverloadWord;
  14263. begin
  14264. StartProgram(false);
  14265. Add([
  14266. 'type',
  14267. ' integer = longint;',
  14268. ' int53 = nativeint;',
  14269. ' tdatetime = double;',
  14270. 'procedure DoIt(w: word); begin end;',
  14271. 'procedure DoIt(v: jsvalue); begin end;',
  14272. 'var',
  14273. ' d: double;',
  14274. ' dt: tdatetime;',
  14275. ' i: integer;',
  14276. ' b: byte;',
  14277. ' shi: shortint;',
  14278. ' w: word;',
  14279. ' smi: smallint;',
  14280. ' lw: longword;',
  14281. ' li: longint;',
  14282. ' ni: nativeint;',
  14283. ' nu: nativeuint;',
  14284. 'begin',
  14285. ' DoIt(d);',
  14286. ' DoIt(dt);',
  14287. ' DoIt(i);',
  14288. ' DoIt(b);',
  14289. ' DoIt(shi);',
  14290. ' DoIt(w);',
  14291. ' DoIt(smi);',
  14292. ' DoIt(lw);',
  14293. ' DoIt(li);',
  14294. ' DoIt(ni);',
  14295. ' DoIt(nu);',
  14296. '']);
  14297. ConvertProgram;
  14298. CheckSource('TestJSValue_OverloadWord',
  14299. LinesToStr([ // statements
  14300. 'this.DoIt = function (w) {',
  14301. '};',
  14302. 'this.DoIt$1 = function (v) {',
  14303. '};',
  14304. 'this.d = 0.0;',
  14305. 'this.dt = 0.0;',
  14306. 'this.i = 0;',
  14307. 'this.b = 0;',
  14308. 'this.shi = 0;',
  14309. 'this.w = 0;',
  14310. 'this.smi = 0;',
  14311. 'this.lw = 0;',
  14312. 'this.li = 0;',
  14313. 'this.ni = 0;',
  14314. 'this.nu = 0;',
  14315. '']),
  14316. LinesToStr([ // $mod.$main
  14317. '$mod.DoIt$1($mod.d);',
  14318. '$mod.DoIt$1($mod.dt);',
  14319. '$mod.DoIt$1($mod.i);',
  14320. '$mod.DoIt($mod.b);',
  14321. '$mod.DoIt($mod.shi);',
  14322. '$mod.DoIt($mod.w);',
  14323. '$mod.DoIt$1($mod.smi);',
  14324. '$mod.DoIt$1($mod.lw);',
  14325. '$mod.DoIt$1($mod.li);',
  14326. '$mod.DoIt$1($mod.ni);',
  14327. '$mod.DoIt$1($mod.nu);',
  14328. '']));
  14329. end;
  14330. procedure TTestModule.TestJSValue_OverloadString;
  14331. begin
  14332. StartProgram(false);
  14333. Add([
  14334. 'type',
  14335. ' uni = string;',
  14336. ' WChar = char;',
  14337. 'procedure DoIt(s: string); begin end;',
  14338. 'procedure DoIt(v: jsvalue); begin end;',
  14339. 'var',
  14340. ' s: string;',
  14341. ' c: char;',
  14342. ' u: uni;',
  14343. 'begin',
  14344. ' DoIt(s);',
  14345. ' DoIt(c);',
  14346. ' DoIt(u);',
  14347. '']);
  14348. ConvertProgram;
  14349. CheckSource('TestJSValue_OverloadString',
  14350. LinesToStr([ // statements
  14351. 'this.DoIt = function (s) {',
  14352. '};',
  14353. 'this.DoIt$1 = function (v) {',
  14354. '};',
  14355. 'this.s = "";',
  14356. 'this.c = "";',
  14357. 'this.u = "";',
  14358. '']),
  14359. LinesToStr([ // $mod.$main
  14360. '$mod.DoIt($mod.s);',
  14361. '$mod.DoIt($mod.c);',
  14362. '$mod.DoIt($mod.u);',
  14363. '']));
  14364. end;
  14365. procedure TTestModule.TestJSValue_OverloadChar;
  14366. begin
  14367. StartProgram(false);
  14368. Add([
  14369. 'type',
  14370. ' uni = string;',
  14371. ' WChar = char;',
  14372. 'procedure DoIt(c: char); begin end;',
  14373. 'procedure DoIt(v: jsvalue); begin end;',
  14374. 'var',
  14375. ' s: string;',
  14376. ' c: char;',
  14377. ' u: uni;',
  14378. 'begin',
  14379. ' DoIt(s);',
  14380. ' DoIt(c);',
  14381. ' DoIt(u);',
  14382. '']);
  14383. ConvertProgram;
  14384. CheckSource('TestJSValue_OverloadChar',
  14385. LinesToStr([ // statements
  14386. 'this.DoIt = function (c) {',
  14387. '};',
  14388. 'this.DoIt$1 = function (v) {',
  14389. '};',
  14390. 'this.s = "";',
  14391. 'this.c = "";',
  14392. 'this.u = "";',
  14393. '']),
  14394. LinesToStr([ // $mod.$main
  14395. '$mod.DoIt$1($mod.s);',
  14396. '$mod.DoIt($mod.c);',
  14397. '$mod.DoIt$1($mod.u);',
  14398. '']));
  14399. end;
  14400. procedure TTestModule.TestJSValue_OverloadPointer;
  14401. begin
  14402. StartProgram(false);
  14403. Add([
  14404. 'type',
  14405. ' TObject = class end;',
  14406. 'procedure DoIt(p: pointer); begin end;',
  14407. 'procedure DoIt(v: jsvalue); begin end;',
  14408. 'var',
  14409. ' o: TObject;',
  14410. 'begin',
  14411. ' DoIt(o);',
  14412. '']);
  14413. ConvertProgram;
  14414. CheckSource('TestJSValue_OverloadPointer',
  14415. LinesToStr([ // statements
  14416. 'rtl.createClass($mod, "TObject", null, function () {',
  14417. ' this.$init = function () {',
  14418. ' };',
  14419. ' this.$final = function () {',
  14420. ' };',
  14421. '});',
  14422. 'this.DoIt = function (p) {',
  14423. '};',
  14424. 'this.DoIt$1 = function (v) {',
  14425. '};',
  14426. 'this.o = null;',
  14427. '']),
  14428. LinesToStr([ // $mod.$main
  14429. '$mod.DoIt($mod.o);',
  14430. '']));
  14431. end;
  14432. procedure TTestModule.TestRTTI_ProcType;
  14433. begin
  14434. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14435. StartProgram(false);
  14436. Add('type');
  14437. Add(' TProcA = procedure;');
  14438. Add(' TMethodB = procedure of object;');
  14439. Add(' TProcC = procedure; varargs;');
  14440. Add(' TProcD = procedure(i: longint; const j: string; var c: char; out d: double);');
  14441. Add(' TProcE = function: nativeint;');
  14442. Add(' TProcF = function(const p: TProcA): nativeuint;');
  14443. Add('var p: pointer;');
  14444. Add('begin');
  14445. Add(' p:=typeinfo(tproca);');
  14446. ConvertProgram;
  14447. CheckSource('TestRTTI_ProcType',
  14448. LinesToStr([ // statements
  14449. '$mod.$rtti.$ProcVar("TProcA", {',
  14450. ' procsig: rtl.newTIProcSig(null)',
  14451. '});',
  14452. '$mod.$rtti.$MethodVar("TMethodB", {',
  14453. ' procsig: rtl.newTIProcSig(null),',
  14454. ' methodkind: 0',
  14455. '});',
  14456. '$mod.$rtti.$ProcVar("TProcC", {',
  14457. ' procsig: rtl.newTIProcSig(null, 2)',
  14458. '});',
  14459. '$mod.$rtti.$ProcVar("TProcD", {',
  14460. ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
  14461. '});',
  14462. '$mod.$rtti.$ProcVar("TProcE", {',
  14463. ' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
  14464. '});',
  14465. '$mod.$rtti.$ProcVar("TProcF", {',
  14466. ' procsig: rtl.newTIProcSig([["p", $mod.$rtti["TProcA"], 2]], rtl.nativeuint)',
  14467. '});',
  14468. 'this.p = null;',
  14469. '']),
  14470. LinesToStr([ // $mod.$main
  14471. '$mod.p = $mod.$rtti["TProcA"];',
  14472. '']));
  14473. end;
  14474. procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
  14475. begin
  14476. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14477. AddModuleWithIntfImplSrc('unit2.pas',
  14478. LinesToStr([
  14479. 'type',
  14480. ' TObject = class end;'
  14481. ]),
  14482. '');
  14483. StartUnit(true);
  14484. Add('interface');
  14485. Add('uses unit2;');
  14486. Add('type');
  14487. Add(' TProcA = function(o: tobject): tobject;');
  14488. Add('implementation');
  14489. Add('type');
  14490. Add(' TProcB = function(o: tobject): tobject;');
  14491. Add('var p: Pointer;');
  14492. Add('initialization');
  14493. Add(' p:=typeinfo(tproca);');
  14494. Add(' p:=typeinfo(tprocb);');
  14495. ConvertUnit;
  14496. CheckSource('TestRTTI_ProcType_ArgFromOtherUnit',
  14497. LinesToStr([ // statements
  14498. 'var $impl = $mod.$impl;',
  14499. '$mod.$rtti.$ProcVar("TProcA", {',
  14500. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  14501. '});',
  14502. '']),
  14503. LinesToStr([ // this.$init
  14504. '$impl.p = $mod.$rtti["TProcA"];',
  14505. '$impl.p = $mod.$rtti["TProcB"];',
  14506. '']),
  14507. LinesToStr([ // implementation
  14508. '$mod.$rtti.$ProcVar("TProcB", {',
  14509. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  14510. '});',
  14511. '$impl.p = null;',
  14512. '']) );
  14513. end;
  14514. procedure TTestModule.TestRTTI_EnumAndSetType;
  14515. begin
  14516. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14517. StartProgram(false);
  14518. Add('type');
  14519. Add(' TFlag = (light,dark);');
  14520. Add(' TFlags = set of TFlag;');
  14521. Add(' TProc = function(f: TFlags): TFlag;');
  14522. Add('var p: pointer;');
  14523. Add('begin');
  14524. Add(' p:=typeinfo(tflag);');
  14525. Add(' p:=typeinfo(tflags);');
  14526. ConvertProgram;
  14527. CheckSource('TestRTTI_EnumAndType',
  14528. LinesToStr([ // statements
  14529. 'this.TFlag = {',
  14530. ' "0": "light",',
  14531. ' light: 0,',
  14532. ' "1": "dark",',
  14533. ' dark: 1',
  14534. '};',
  14535. '$mod.$rtti.$Enum("TFlag", {',
  14536. ' minvalue: 0,',
  14537. ' maxvalue: 1,',
  14538. ' ordtype: 1,',
  14539. ' enumtype: this.TFlag',
  14540. '});',
  14541. '$mod.$rtti.$Set("TFlags", {',
  14542. ' comptype: $mod.$rtti["TFlag"]',
  14543. '});',
  14544. '$mod.$rtti.$ProcVar("TProc", {',
  14545. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TFlags"]]], $mod.$rtti["TFlag"])',
  14546. '});',
  14547. 'this.p = null;',
  14548. '']),
  14549. LinesToStr([ // $mod.$main
  14550. '$mod.p = $mod.$rtti["TFlag"];',
  14551. '$mod.p = $mod.$rtti["TFlags"];',
  14552. '']));
  14553. end;
  14554. procedure TTestModule.TestRTTI_EnumRange;
  14555. begin
  14556. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14557. StartProgram(false);
  14558. Add([
  14559. 'type',
  14560. ' TCol = (red,green,blue);',
  14561. ' TColRg = green..blue;',
  14562. ' TSetOfColRg = set of TColRg;',
  14563. 'var p: pointer;',
  14564. 'begin',
  14565. ' p:=typeinfo(tcolrg);',
  14566. ' p:=typeinfo(tsetofcolrg);',
  14567. '']);
  14568. ConvertProgram;
  14569. end;
  14570. procedure TTestModule.TestRTTI_AnonymousEnumType;
  14571. begin
  14572. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14573. StartProgram(false);
  14574. Add('type');
  14575. Add(' TFlags = set of (red, green);');
  14576. Add('var');
  14577. Add(' f: TFlags;');
  14578. Add('begin');
  14579. Add(' Include(f,red);');
  14580. ConvertProgram;
  14581. CheckSource('TestRTTI_AnonymousEnumType',
  14582. LinesToStr([ // statements
  14583. 'this.TFlags$a = {',
  14584. ' "0": "red",',
  14585. ' red: 0,',
  14586. ' "1": "green",',
  14587. ' green: 1',
  14588. '};',
  14589. '$mod.$rtti.$Enum("TFlags$a", {',
  14590. ' minvalue: 0,',
  14591. ' maxvalue: 1,',
  14592. ' ordtype: 1,',
  14593. ' enumtype: this.TFlags$a',
  14594. '});',
  14595. '$mod.$rtti.$Set("TFlags", {',
  14596. ' comptype: $mod.$rtti["TFlags$a"]',
  14597. '});',
  14598. 'this.f = {};',
  14599. '']),
  14600. LinesToStr([
  14601. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  14602. '']));
  14603. end;
  14604. procedure TTestModule.TestRTTI_StaticArray;
  14605. begin
  14606. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14607. StartProgram(false);
  14608. Add('type');
  14609. Add(' TFlag = (light,dark);');
  14610. Add(' TFlagNames = array[TFlag] of string;');
  14611. Add(' TBoolNames = array[boolean] of string;');
  14612. Add(' TByteArray = array[1..32768] of byte;');
  14613. Add(' TProc = function(f: TBoolNames): TFlagNames;');
  14614. Add('var p: pointer;');
  14615. Add('begin');
  14616. Add(' p:=typeinfo(TFlagNames);');
  14617. Add(' p:=typeinfo(TBoolNames);');
  14618. ConvertProgram;
  14619. CheckSource('TestRTTI_StaticArray',
  14620. LinesToStr([ // statements
  14621. 'this.TFlag = {',
  14622. ' "0": "light",',
  14623. ' light: 0,',
  14624. ' "1": "dark",',
  14625. ' dark: 1',
  14626. '};',
  14627. '$mod.$rtti.$Enum("TFlag", {',
  14628. ' minvalue: 0,',
  14629. ' maxvalue: 1,',
  14630. ' ordtype: 1,',
  14631. ' enumtype: this.TFlag',
  14632. '});',
  14633. '$mod.$rtti.$StaticArray("TFlagNames", {',
  14634. ' dims: [2],',
  14635. ' eltype: rtl.string',
  14636. '});',
  14637. '$mod.$rtti.$StaticArray("TBoolNames", {',
  14638. ' dims: [2],',
  14639. ' eltype: rtl.string',
  14640. '});',
  14641. '$mod.$rtti.$StaticArray("TByteArray", {',
  14642. ' dims: [32768],',
  14643. ' eltype: rtl.byte',
  14644. '});',
  14645. '$mod.$rtti.$ProcVar("TProc", {',
  14646. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TBoolNames"]]], $mod.$rtti["TFlagNames"])',
  14647. '});',
  14648. 'this.p = null;',
  14649. '']),
  14650. LinesToStr([ // $mod.$main
  14651. '$mod.p = $mod.$rtti["TFlagNames"];',
  14652. '$mod.p = $mod.$rtti["TBoolNames"];',
  14653. '']));
  14654. end;
  14655. procedure TTestModule.TestRTTI_DynArray;
  14656. begin
  14657. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14658. StartProgram(false);
  14659. Add('type');
  14660. Add(' TArrStr = array of string;');
  14661. Add(' TArr2Dim = array of tarrstr;');
  14662. Add(' TProc = function(f: TArrStr): TArr2Dim;');
  14663. Add('var p: pointer;');
  14664. Add('begin');
  14665. Add(' p:=typeinfo(tarrstr);');
  14666. Add(' p:=typeinfo(tarr2dim);');
  14667. ConvertProgram;
  14668. CheckSource('TestRTTI_DynArray',
  14669. LinesToStr([ // statements
  14670. '$mod.$rtti.$DynArray("TArrStr", {',
  14671. ' eltype: rtl.string',
  14672. '});',
  14673. '$mod.$rtti.$DynArray("TArr2Dim", {',
  14674. ' eltype: $mod.$rtti["TArrStr"]',
  14675. '});',
  14676. '$mod.$rtti.$ProcVar("TProc", {',
  14677. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TArrStr"]]], $mod.$rtti["TArr2Dim"])',
  14678. '});',
  14679. 'this.p = null;',
  14680. '']),
  14681. LinesToStr([ // $mod.$main
  14682. '$mod.p = $mod.$rtti["TArrStr"];',
  14683. '$mod.p = $mod.$rtti["TArr2Dim"];',
  14684. '']));
  14685. end;
  14686. procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
  14687. begin
  14688. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14689. StartProgram(false);
  14690. Add('type');
  14691. Add(' TArr = array of array of longint;');
  14692. Add('var a: TArr;');
  14693. Add('begin');
  14694. ConvertProgram;
  14695. CheckSource('TestRTTI_ArrayNestedAnonymous',
  14696. LinesToStr([ // statements
  14697. '$mod.$rtti.$DynArray("TArr$a", {',
  14698. ' eltype: rtl.longint',
  14699. '});',
  14700. '$mod.$rtti.$DynArray("TArr", {',
  14701. ' eltype: $mod.$rtti["TArr$a"]',
  14702. '});',
  14703. 'this.a = [];',
  14704. '']),
  14705. LinesToStr([ // $mod.$main
  14706. ]));
  14707. end;
  14708. procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
  14709. begin
  14710. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14711. StartProgram(false);
  14712. Add('type');
  14713. Add(' TObject = class');
  14714. Add(' published');
  14715. Add(' procedure Proc; virtual; abstract;');
  14716. Add(' procedure Proc(Sender: tobject); virtual; abstract;');
  14717. Add(' end;');
  14718. Add('begin');
  14719. SetExpectedPasResolverError('Duplicate identifier "Proc" at test1.pp(6,19)',
  14720. nDuplicateIdentifier);
  14721. ConvertProgram;
  14722. end;
  14723. procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
  14724. begin
  14725. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14726. StartProgram(false);
  14727. Add('type');
  14728. Add(' TObject = class');
  14729. Add(' published');
  14730. Add(' procedure Proc; external name ''foo'';');
  14731. Add(' end;');
  14732. Add('begin');
  14733. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  14734. nPublishedNameMustMatchExternal);
  14735. ConvertProgram;
  14736. end;
  14737. procedure TTestModule.TestRTTI_PublishedClassPropertyFail;
  14738. begin
  14739. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14740. StartProgram(false);
  14741. Add('type');
  14742. Add(' TObject = class');
  14743. Add(' class var FA: longint;');
  14744. Add(' published');
  14745. Add(' class property A: longint read FA;');
  14746. Add(' end;');
  14747. Add('begin');
  14748. SetExpectedPasResolverError('Invalid published property modifier "class"',
  14749. nInvalidXModifierY);
  14750. ConvertProgram;
  14751. end;
  14752. procedure TTestModule.TestRTTI_PublishedClassFieldFail;
  14753. begin
  14754. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14755. StartProgram(false);
  14756. Add('type');
  14757. Add(' TObject = class');
  14758. Add(' published');
  14759. Add(' class var FA: longint;');
  14760. Add(' end;');
  14761. Add('begin');
  14762. SetExpectedPasResolverError(sSymbolCannotBePublished,
  14763. nSymbolCannotBePublished);
  14764. ConvertProgram;
  14765. end;
  14766. procedure TTestModule.TestRTTI_PublishedFieldExternalFail;
  14767. begin
  14768. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14769. StartProgram(false);
  14770. Add('{$modeswitch externalclass}');
  14771. Add('type');
  14772. Add(' TObject = class');
  14773. Add(' published');
  14774. Add(' V: longint; external name ''foo'';');
  14775. Add(' end;');
  14776. Add('begin');
  14777. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  14778. nPublishedNameMustMatchExternal);
  14779. ConvertProgram;
  14780. end;
  14781. procedure TTestModule.TestRTTI_IndexModifier;
  14782. begin
  14783. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14784. StartProgram(false);
  14785. Add([
  14786. 'type',
  14787. ' TEnum = (red, blue);',
  14788. ' TObject = class',
  14789. ' FB: boolean;',
  14790. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  14791. ' function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
  14792. ' procedure SetBoolBool(Index: boolean; b: boolean); virtual; abstract;',
  14793. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  14794. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  14795. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  14796. ' published',
  14797. ' property B1: boolean index 1 read FB write SetIntBool;',
  14798. ' property B2: boolean index TEnum.blue read GetEnumBool write FB;',
  14799. ' property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
  14800. ' end;',
  14801. 'begin']);
  14802. ConvertProgram;
  14803. CheckSource('TestRTTI_IndexModifier',
  14804. LinesToStr([ // statements
  14805. 'this.TEnum = {',
  14806. ' "0": "red",',
  14807. ' red: 0,',
  14808. ' "1": "blue",',
  14809. ' blue: 1',
  14810. '};',
  14811. '$mod.$rtti.$Enum("TEnum", {',
  14812. ' minvalue: 0,',
  14813. ' maxvalue: 1,',
  14814. ' ordtype: 1,',
  14815. ' enumtype: this.TEnum',
  14816. '});',
  14817. 'rtl.createClass($mod, "TObject", null, function () {',
  14818. ' this.$init = function () {',
  14819. ' this.FB = false;',
  14820. ' };',
  14821. ' this.$final = function () {',
  14822. ' };',
  14823. ' var $r = this.$rtti;',
  14824. ' $r.addProperty(',
  14825. ' "B1",',
  14826. ' 18,',
  14827. ' rtl.boolean,',
  14828. ' "FB",',
  14829. ' "SetIntBool",',
  14830. ' {',
  14831. ' index: 1',
  14832. ' }',
  14833. ' );',
  14834. ' $r.addProperty(',
  14835. ' "B2",',
  14836. ' 17,',
  14837. ' rtl.boolean,',
  14838. ' "GetEnumBool",',
  14839. ' "FB",',
  14840. ' {',
  14841. ' index: $mod.TEnum.blue',
  14842. ' }',
  14843. ' );',
  14844. ' $r.addProperty(',
  14845. ' "I1",',
  14846. ' 19,',
  14847. ' rtl.boolean,',
  14848. ' "GetStrIntBool",',
  14849. ' "SetStrIntBool",',
  14850. ' {',
  14851. ' index: 2',
  14852. ' }',
  14853. ' );',
  14854. '});',
  14855. '']),
  14856. LinesToStr([ // $mod.$main
  14857. '']));
  14858. end;
  14859. procedure TTestModule.TestRTTI_StoredModifier;
  14860. begin
  14861. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14862. StartProgram(false);
  14863. Add([
  14864. 'const',
  14865. ' ConstB = true;',
  14866. 'type',
  14867. ' TObject = class',
  14868. ' private',
  14869. ' FB: boolean;',
  14870. ' function IsBStored: boolean; virtual; abstract;',
  14871. ' published',
  14872. ' property BoolA: boolean read FB stored true;',
  14873. ' property BoolB: boolean read FB stored false;',
  14874. ' property BoolC: boolean read FB stored FB;',
  14875. ' property BoolD: boolean read FB stored ConstB;',
  14876. ' property BoolE: boolean read FB stored IsBStored;',
  14877. ' end;',
  14878. 'begin']);
  14879. ConvertProgram;
  14880. CheckSource('TestRTTI_StoredModifier',
  14881. LinesToStr([ // statements
  14882. 'this.ConstB = true;',
  14883. 'rtl.createClass($mod, "TObject", null, function () {',
  14884. ' this.$init = function () {',
  14885. ' this.FB = false;',
  14886. ' };',
  14887. ' this.$final = function () {',
  14888. ' };',
  14889. ' var $r = this.$rtti;',
  14890. ' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
  14891. ' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
  14892. ' $r.addProperty(',
  14893. ' "BoolC",',
  14894. ' 8,',
  14895. ' rtl.boolean,',
  14896. ' "FB",',
  14897. ' "",',
  14898. ' {',
  14899. ' stored: "FB"',
  14900. ' }',
  14901. ' );',
  14902. ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
  14903. ' $r.addProperty(',
  14904. ' "BoolE",',
  14905. ' 12,',
  14906. ' rtl.boolean,',
  14907. ' "FB",',
  14908. ' "",',
  14909. ' {',
  14910. ' stored: "IsBStored"',
  14911. ' }',
  14912. ' );',
  14913. '});',
  14914. '']),
  14915. LinesToStr([ // $mod.$main
  14916. '']));
  14917. end;
  14918. procedure TTestModule.TestRTTI_DefaultValue;
  14919. begin
  14920. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14921. StartProgram(false);
  14922. Add([
  14923. 'type',
  14924. ' TEnum = (red, blue);',
  14925. 'const',
  14926. ' CB = true or false;',
  14927. ' CI = 1+2;',
  14928. 'type',
  14929. ' TObject = class',
  14930. ' FB: boolean;',
  14931. ' FI: longint;',
  14932. ' FE: TEnum;',
  14933. ' published',
  14934. ' property B1: boolean read FB default true;',
  14935. ' property B2: boolean read FB default CB;',
  14936. ' property B3: boolean read FB default test1.cb;',
  14937. ' property I1: longint read FI default 2;',
  14938. ' property I2: longint read FI default CI;',
  14939. ' property E1: TEnum read FE default red;',
  14940. ' property E2: TEnum read FE default TEnum.blue;',
  14941. ' end;',
  14942. 'begin']);
  14943. ConvertProgram;
  14944. CheckSource('TestRTTI_DefaultValue',
  14945. LinesToStr([ // statements
  14946. 'this.TEnum = {',
  14947. ' "0": "red",',
  14948. ' red: 0,',
  14949. ' "1": "blue",',
  14950. ' blue: 1',
  14951. '};',
  14952. '$mod.$rtti.$Enum("TEnum", {',
  14953. ' minvalue: 0,',
  14954. ' maxvalue: 1,',
  14955. ' ordtype: 1,',
  14956. ' enumtype: this.TEnum',
  14957. '});',
  14958. 'this.CB = true || false;',
  14959. 'this.CI = 1 + 2;',
  14960. 'rtl.createClass($mod, "TObject", null, function () {',
  14961. ' this.$init = function () {',
  14962. ' this.FB = false;',
  14963. ' this.FI = 0;',
  14964. ' this.FE = 0;',
  14965. ' };',
  14966. ' this.$final = function () {',
  14967. ' };',
  14968. ' var $r = this.$rtti;',
  14969. ' $r.addProperty(',
  14970. ' "B1",',
  14971. ' 0,',
  14972. ' rtl.boolean,',
  14973. ' "FB",',
  14974. ' "",',
  14975. ' {',
  14976. ' Default: true',
  14977. ' }',
  14978. ' );',
  14979. ' $r.addProperty(',
  14980. ' "B2",',
  14981. ' 0,',
  14982. ' rtl.boolean,',
  14983. ' "FB",',
  14984. ' "",',
  14985. ' {',
  14986. ' Default: true',
  14987. ' }',
  14988. ' );',
  14989. ' $r.addProperty(',
  14990. ' "B3",',
  14991. ' 0,',
  14992. ' rtl.boolean,',
  14993. ' "FB",',
  14994. ' "",',
  14995. ' {',
  14996. ' Default: true',
  14997. ' }',
  14998. ' );',
  14999. ' $r.addProperty(',
  15000. ' "I1",',
  15001. ' 0,',
  15002. ' rtl.longint,',
  15003. ' "FI",',
  15004. ' "",',
  15005. ' {',
  15006. ' Default: 2',
  15007. ' }',
  15008. ' );',
  15009. ' $r.addProperty(',
  15010. ' "I2",',
  15011. ' 0,',
  15012. ' rtl.longint,',
  15013. ' "FI",',
  15014. ' "",',
  15015. ' {',
  15016. ' Default: 3',
  15017. ' }',
  15018. ' );',
  15019. ' $r.addProperty(',
  15020. ' "E1",',
  15021. ' 0,',
  15022. ' $mod.$rtti["TEnum"],',
  15023. ' "FE",',
  15024. ' "",',
  15025. ' {',
  15026. ' Default: $mod.TEnum.red',
  15027. ' }',
  15028. ' );',
  15029. ' $r.addProperty(',
  15030. ' "E2",',
  15031. ' 0,',
  15032. ' $mod.$rtti["TEnum"],',
  15033. ' "FE",',
  15034. ' "",',
  15035. ' {',
  15036. ' Default: $mod.TEnum.blue',
  15037. ' }',
  15038. ' );',
  15039. '});',
  15040. '']),
  15041. LinesToStr([ // $mod.$main
  15042. '']));
  15043. end;
  15044. procedure TTestModule.TestRTTI_DefaultValueSet;
  15045. begin
  15046. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15047. StartProgram(false);
  15048. Add([
  15049. 'type',
  15050. ' TEnum = (red, blue);',
  15051. ' TSet = set of TEnum;',
  15052. 'const',
  15053. ' CSet = [red,blue];',
  15054. 'type',
  15055. ' TObject = class',
  15056. ' FSet: TSet;',
  15057. ' published',
  15058. ' property Set1: TSet read FSet default [];',
  15059. ' property Set2: TSet read FSet default [red];',
  15060. ' property Set3: TSet read FSet default [red,blue];',
  15061. ' property Set4: TSet read FSet default CSet;',
  15062. ' end;',
  15063. 'begin']);
  15064. ConvertProgram;
  15065. CheckSource('TestRTTI_DefaultValueSet',
  15066. LinesToStr([ // statements
  15067. 'this.TEnum = {',
  15068. ' "0": "red",',
  15069. ' red: 0,',
  15070. ' "1": "blue",',
  15071. ' blue: 1',
  15072. '};',
  15073. '$mod.$rtti.$Enum("TEnum", {',
  15074. ' minvalue: 0,',
  15075. ' maxvalue: 1,',
  15076. ' ordtype: 1,',
  15077. ' enumtype: this.TEnum',
  15078. '});',
  15079. '$mod.$rtti.$Set("TSet", {',
  15080. ' comptype: $mod.$rtti["TEnum"]',
  15081. '});',
  15082. 'this.CSet = rtl.createSet($mod.TEnum.red, $mod.TEnum.blue);',
  15083. 'rtl.createClass($mod, "TObject", null, function () {',
  15084. ' this.$init = function () {',
  15085. ' this.FSet = {};',
  15086. ' };',
  15087. ' this.$final = function () {',
  15088. ' this.FSet = undefined;',
  15089. ' };',
  15090. ' var $r = this.$rtti;',
  15091. ' $r.addProperty(',
  15092. ' "Set1",',
  15093. ' 0,',
  15094. ' $mod.$rtti["TSet"],',
  15095. ' "FSet",',
  15096. ' "",',
  15097. ' {',
  15098. ' Default: {}',
  15099. ' }',
  15100. ' );',
  15101. ' $r.addProperty(',
  15102. ' "Set2",',
  15103. ' 0,',
  15104. ' $mod.$rtti["TSet"],',
  15105. ' "FSet",',
  15106. ' "",',
  15107. ' {',
  15108. ' Default: rtl.createSet($mod.TEnum.red)',
  15109. ' }',
  15110. ' );',
  15111. ' $r.addProperty(',
  15112. ' "Set3",',
  15113. ' 0,',
  15114. ' $mod.$rtti["TSet"],',
  15115. ' "FSet",',
  15116. ' "",',
  15117. ' {',
  15118. ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
  15119. ' }',
  15120. ' );',
  15121. ' $r.addProperty(',
  15122. ' "Set4",',
  15123. ' 0,',
  15124. ' $mod.$rtti["TSet"],',
  15125. ' "FSet",',
  15126. ' "",',
  15127. ' {',
  15128. ' Default: $mod.CSet',
  15129. ' }',
  15130. ' );',
  15131. '});',
  15132. '']),
  15133. LinesToStr([ // $mod.$main
  15134. '']));
  15135. end;
  15136. procedure TTestModule.TestRTTI_DefaultValueRangeType;
  15137. begin
  15138. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15139. StartProgram(false);
  15140. Add([
  15141. 'type',
  15142. ' TRg = -1..1;',
  15143. 'const',
  15144. ' l = low(TRg);',
  15145. ' h = high(TRg);',
  15146. 'type',
  15147. ' TObject = class',
  15148. ' FV: TRg;',
  15149. ' published',
  15150. ' property V1: TRg read FV default -1;',
  15151. ' end;',
  15152. 'begin']);
  15153. ConvertProgram;
  15154. CheckSource('TestRTTI_DefaultValueRangeType',
  15155. LinesToStr([ // statements
  15156. '$mod.$rtti.$Int("TRg", {',
  15157. ' minvalue: -1,',
  15158. ' maxvalue: 1,',
  15159. ' ordtype: 0',
  15160. '});',
  15161. 'this.l = -1;',
  15162. 'this.h = 1;',
  15163. 'rtl.createClass($mod, "TObject", null, function () {',
  15164. ' this.$init = function () {',
  15165. ' this.FV = -1;',
  15166. ' };',
  15167. ' this.$final = function () {',
  15168. ' };',
  15169. ' var $r = this.$rtti;',
  15170. ' $r.addProperty(',
  15171. ' "V1",',
  15172. ' 0,',
  15173. ' $mod.$rtti["TRg"],',
  15174. ' "FV",',
  15175. ' "",',
  15176. ' {',
  15177. ' Default: -1',
  15178. ' }',
  15179. ' );',
  15180. '});',
  15181. '']),
  15182. LinesToStr([ // $mod.$main
  15183. '']));
  15184. end;
  15185. procedure TTestModule.TestRTTI_Class_Field;
  15186. begin
  15187. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15188. StartProgram(false);
  15189. Add('{$modeswitch externalclass}');
  15190. Add('type');
  15191. Add(' TObject = class');
  15192. Add(' private');
  15193. Add(' FPropA: string;');
  15194. Add(' published');
  15195. Add(' VarLI: longint;');
  15196. Add(' VarC: char;');
  15197. Add(' VarS: string;');
  15198. Add(' VarD: double;');
  15199. Add(' VarB: boolean;');
  15200. Add(' VarLW: longword;');
  15201. Add(' VarSmI: smallint;');
  15202. Add(' VarW: word;');
  15203. Add(' VarShI: shortint;');
  15204. Add(' VarBy: byte;');
  15205. Add(' VarExt: longint external name ''VarExt'';');
  15206. Add(' end;');
  15207. Add('var p: pointer;');
  15208. Add(' Obj: tobject;');
  15209. Add('begin');
  15210. Add(' p:=typeinfo(tobject);');
  15211. Add(' p:=typeinfo(p);');
  15212. Add(' p:=typeinfo(obj);');
  15213. ConvertProgram;
  15214. CheckSource('TestRTTI_Class_Field',
  15215. LinesToStr([ // statements
  15216. 'rtl.createClass($mod, "TObject", null, function () {',
  15217. ' this.$init = function () {',
  15218. ' this.FPropA = "";',
  15219. ' this.VarLI = 0;',
  15220. ' this.VarC = "";',
  15221. ' this.VarS = "";',
  15222. ' this.VarD = 0.0;',
  15223. ' this.VarB = false;',
  15224. ' this.VarLW = 0;',
  15225. ' this.VarSmI = 0;',
  15226. ' this.VarW = 0;',
  15227. ' this.VarShI = 0;',
  15228. ' this.VarBy = 0;',
  15229. ' };',
  15230. ' this.$final = function () {',
  15231. ' };',
  15232. ' var $r = this.$rtti;',
  15233. ' $r.addField("VarLI", rtl.longint);',
  15234. ' $r.addField("VarC", rtl.char);',
  15235. ' $r.addField("VarS", rtl.string);',
  15236. ' $r.addField("VarD", rtl.double);',
  15237. ' $r.addField("VarB", rtl.boolean);',
  15238. ' $r.addField("VarLW", rtl.longword);',
  15239. ' $r.addField("VarSmI", rtl.smallint);',
  15240. ' $r.addField("VarW", rtl.word);',
  15241. ' $r.addField("VarShI", rtl.shortint);',
  15242. ' $r.addField("VarBy", rtl.byte);',
  15243. ' $r.addField("VarExt", rtl.longint);',
  15244. '});',
  15245. 'this.p = null;',
  15246. 'this.Obj = null;',
  15247. '']),
  15248. LinesToStr([ // $mod.$main
  15249. '$mod.p = $mod.$rtti["TObject"];',
  15250. '$mod.p = rtl.pointer;',
  15251. '$mod.p = $mod.Obj.$rtti;',
  15252. '']));
  15253. end;
  15254. procedure TTestModule.TestRTTI_Class_Method;
  15255. begin
  15256. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15257. StartProgram(false);
  15258. Add('type');
  15259. Add(' TObject = class');
  15260. Add(' private');
  15261. Add(' procedure Internal; external name ''$intern'';');
  15262. Add(' published');
  15263. Add(' procedure Click; virtual; abstract;');
  15264. Add(' procedure Notify(Sender: TObject); virtual; abstract;');
  15265. Add(' function GetNotify: boolean; external name ''GetNotify'';');
  15266. Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
  15267. Add(' end;');
  15268. Add('begin');
  15269. ConvertProgram;
  15270. CheckSource('TestRTTI_Class_Method',
  15271. LinesToStr([ // statements
  15272. 'rtl.createClass($mod, "TObject", null, function () {',
  15273. ' this.$init = function () {',
  15274. ' };',
  15275. ' this.$final = function () {',
  15276. ' };',
  15277. ' var $r = this.$rtti;',
  15278. ' $r.addMethod("Click", 0, null);',
  15279. ' $r.addMethod("Notify", 0, [["Sender", $r]]);',
  15280. ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
  15281. ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
  15282. ' flags: 2',
  15283. ' });',
  15284. '});',
  15285. '']),
  15286. LinesToStr([ // $mod.$main
  15287. '']));
  15288. end;
  15289. procedure TTestModule.TestRTTI_Class_MethodArgFlags;
  15290. begin
  15291. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15292. StartProgram(false);
  15293. Add('type');
  15294. Add(' TObject = class');
  15295. Add(' published');
  15296. Add(' procedure OpenArray(const Args: array of string); virtual; abstract;');
  15297. Add(' procedure ByRef(var Value: longint; out Item: longint); virtual; abstract;');
  15298. Add(' procedure Untyped(var Value; out Item); virtual; abstract;');
  15299. Add(' end;');
  15300. Add('begin');
  15301. ConvertProgram;
  15302. CheckSource('TestRTTI_Class_MethodOpenArray',
  15303. LinesToStr([ // statements
  15304. 'rtl.createClass($mod, "TObject", null, function () {',
  15305. ' this.$init = function () {',
  15306. ' };',
  15307. ' this.$final = function () {',
  15308. ' };',
  15309. ' var $r = this.$rtti;',
  15310. '$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
  15311. '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
  15312. '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
  15313. '});',
  15314. '']),
  15315. LinesToStr([ // $mod.$main
  15316. '']));
  15317. end;
  15318. procedure TTestModule.TestRTTI_Class_Property;
  15319. begin
  15320. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15321. StartProgram(false);
  15322. Add('{$modeswitch externalclass}');
  15323. Add('type');
  15324. Add(' TObject = class');
  15325. Add(' private');
  15326. Add(' FColor: longint;');
  15327. Add(' FColorStored: boolean;');
  15328. Add(' procedure SetColor(Value: longint); virtual; abstract;');
  15329. Add(' function GetColor: longint; virtual; abstract;');
  15330. Add(' function GetColorStored: boolean; virtual; abstract;');
  15331. Add(' FExtSize: longint external name ''$extSize'';');
  15332. Add(' FExtSizeStored: boolean external name ''$extSizeStored'';');
  15333. Add(' procedure SetExtSize(Value: longint); external name ''$setSize'';');
  15334. Add(' function GetExtSize: longint; external name ''$getSize'';');
  15335. Add(' function GetExtSizeStored: boolean; external name ''$getExtSizeStored'';');
  15336. Add(' published');
  15337. Add(' property ColorA: longint read FColor;');
  15338. Add(' property ColorB: longint write FColor;');
  15339. Add(' property ColorC: longint read GetColor write SetColor;');
  15340. Add(' property ColorD: longint read FColor write FColor stored FColorStored;');
  15341. Add(' property ExtSizeA: longint read FExtSize write FExtSize;');
  15342. Add(' property ExtSizeB: longint read GetExtSize write SetExtSize stored FExtSizeStored;');
  15343. Add(' property ExtSizeC: longint read FExtSize write FExtSize stored GetExtSizeStored;');
  15344. Add(' end;');
  15345. Add('begin');
  15346. ConvertProgram;
  15347. CheckSource('TestRTTI_Class_Property',
  15348. LinesToStr([ // statements
  15349. 'rtl.createClass($mod, "TObject", null, function () {',
  15350. ' this.$init = function () {',
  15351. ' this.FColor = 0;',
  15352. ' this.FColorStored = false;',
  15353. ' };',
  15354. ' this.$final = function () {',
  15355. ' };',
  15356. ' var $r = this.$rtti;',
  15357. ' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
  15358. ' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
  15359. ' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
  15360. ' $r.addProperty(',
  15361. ' "ColorD",',
  15362. ' 8,',
  15363. ' rtl.longint,',
  15364. ' "FColor",',
  15365. ' "FColor",',
  15366. ' {',
  15367. ' stored: "FColorStored"',
  15368. ' }',
  15369. ' );',
  15370. ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
  15371. ' $r.addProperty(',
  15372. ' "ExtSizeB",',
  15373. ' 11,',
  15374. ' rtl.longint,',
  15375. ' "$getSize",',
  15376. ' "$setSize",',
  15377. ' {',
  15378. ' stored: "$extSizeStored"',
  15379. ' }',
  15380. ' );',
  15381. ' $r.addProperty(',
  15382. ' "ExtSizeC",',
  15383. ' 12,',
  15384. ' rtl.longint,',
  15385. ' "$extSize",',
  15386. ' "$extSize",',
  15387. ' {',
  15388. ' stored: "$getExtSizeStored"',
  15389. ' }',
  15390. ' );',
  15391. '});',
  15392. '']),
  15393. LinesToStr([ // $mod.$main
  15394. '']));
  15395. end;
  15396. procedure TTestModule.TestRTTI_Class_PropertyParams;
  15397. begin
  15398. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15399. StartProgram(false);
  15400. Add('{$modeswitch externalclass}');
  15401. Add('type');
  15402. Add(' integer = longint;');
  15403. Add(' TObject = class');
  15404. Add(' private');
  15405. Add(' function GetItems(i: integer): tobject; virtual; abstract;');
  15406. Add(' procedure SetItems(i: integer; value: tobject); virtual; abstract;');
  15407. Add(' function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
  15408. Add(' procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
  15409. Add(' published');
  15410. Add(' property Items[Index: integer]: tobject read getitems write setitems;');
  15411. Add(' property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
  15412. Add(' end;');
  15413. Add('begin');
  15414. ConvertProgram;
  15415. CheckSource('TestRTTI_Class_PropertyParams',
  15416. LinesToStr([ // statements
  15417. 'rtl.createClass($mod, "TObject", null, function () {',
  15418. ' this.$init = function () {',
  15419. ' };',
  15420. ' this.$final = function () {',
  15421. ' };',
  15422. ' var $r = this.$rtti;',
  15423. ' $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
  15424. ' $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
  15425. '});',
  15426. '']),
  15427. LinesToStr([ // $mod.$main
  15428. '']));
  15429. end;
  15430. procedure TTestModule.TestRTTI_OverrideMethod;
  15431. begin
  15432. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15433. StartProgram(false);
  15434. Add('type');
  15435. Add(' TObject = class');
  15436. Add(' published');
  15437. Add(' procedure DoIt; virtual; abstract;');
  15438. Add(' end;');
  15439. Add(' TSky = class');
  15440. Add(' published');
  15441. Add(' procedure DoIt; override;');
  15442. Add(' end;');
  15443. Add('procedure TSky.DoIt; begin end;');
  15444. Add('begin');
  15445. ConvertProgram;
  15446. CheckSource('TestRTTI_OverrideMethod',
  15447. LinesToStr([ // statements
  15448. 'rtl.createClass($mod, "TObject", null, function () {',
  15449. ' this.$init = function () {',
  15450. ' };',
  15451. ' this.$final = function () {',
  15452. ' };',
  15453. ' var $r = this.$rtti;',
  15454. ' $r.addMethod("DoIt", 0, null);',
  15455. '});',
  15456. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  15457. ' this.DoIt = function () {',
  15458. ' };',
  15459. '});',
  15460. '']),
  15461. LinesToStr([ // $mod.$main
  15462. '']));
  15463. end;
  15464. procedure TTestModule.TestRTTI_OverloadProperty;
  15465. begin
  15466. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15467. StartProgram(false);
  15468. Add('type');
  15469. Add(' TObject = class');
  15470. Add(' protected');
  15471. Add(' FFlag: longint;');
  15472. Add(' published');
  15473. Add(' property Flag: longint read fflag;');
  15474. Add(' end;');
  15475. Add(' TSky = class');
  15476. Add(' published');
  15477. Add(' property FLAG: longint write fflag;');
  15478. Add(' end;');
  15479. Add('begin');
  15480. ConvertProgram;
  15481. CheckSource('TestRTTI_OverrideMethod',
  15482. LinesToStr([ // statements
  15483. 'rtl.createClass($mod, "TObject", null, function () {',
  15484. ' this.$init = function () {',
  15485. ' this.FFlag = 0;',
  15486. ' };',
  15487. ' this.$final = function () {',
  15488. ' };',
  15489. ' var $r = this.$rtti;',
  15490. ' $r.addProperty("Flag", 0, rtl.longint, "FFlag", "");',
  15491. '});',
  15492. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  15493. ' var $r = this.$rtti;',
  15494. ' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
  15495. '});',
  15496. '']),
  15497. LinesToStr([ // $mod.$main
  15498. '']));
  15499. end;
  15500. procedure TTestModule.TestRTTI_ClassForward;
  15501. begin
  15502. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15503. StartProgram(false);
  15504. Add('type');
  15505. Add(' TObject = class end;');
  15506. Add(' tbridge = class;');
  15507. Add(' TProc = function: tbridge;');
  15508. Add(' TOger = class');
  15509. Add(' published');
  15510. Add(' FBridge: tbridge;');
  15511. Add(' procedure SetBridge(Value: tbridge); virtual; abstract;');
  15512. Add(' property Bridge: tbridge read fbridge write setbridge;');
  15513. Add(' end;');
  15514. Add(' TBridge = class');
  15515. Add(' FOger: toger;');
  15516. Add(' end;');
  15517. Add('var p: Pointer;');
  15518. Add(' b: tbridge;');
  15519. Add('begin');
  15520. Add(' p:=typeinfo(tbridge);');
  15521. Add(' p:=typeinfo(b);');
  15522. ConvertProgram;
  15523. CheckSource('TestRTTI_ClassForward',
  15524. LinesToStr([ // statements
  15525. 'rtl.createClass($mod, "TObject", null, function () {',
  15526. ' this.$init = function () {',
  15527. ' };',
  15528. ' this.$final = function () {',
  15529. ' };',
  15530. '});',
  15531. '$mod.$rtti.$Class("TBridge");',
  15532. '$mod.$rtti.$ProcVar("TProc", {',
  15533. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TBridge"])',
  15534. '});',
  15535. 'rtl.createClass($mod, "TOger", $mod.TObject, function () {',
  15536. ' this.$init = function () {',
  15537. ' $mod.TObject.$init.call(this);',
  15538. ' this.FBridge = null;',
  15539. ' };',
  15540. ' this.$final = function () {',
  15541. ' this.FBridge = undefined;',
  15542. ' $mod.TObject.$final.call(this);',
  15543. ' };',
  15544. ' var $r = this.$rtti;',
  15545. ' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
  15546. ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
  15547. ' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
  15548. '});',
  15549. 'rtl.createClass($mod, "TBridge", $mod.TObject, function () {',
  15550. ' this.$init = function () {',
  15551. ' $mod.TObject.$init.call(this);',
  15552. ' this.FOger = null;',
  15553. ' };',
  15554. ' this.$final = function () {',
  15555. ' this.FOger = undefined;',
  15556. ' $mod.TObject.$final.call(this);',
  15557. ' };',
  15558. '});',
  15559. 'this.p = null;',
  15560. 'this.b = null;',
  15561. '']),
  15562. LinesToStr([ // $mod.$main
  15563. '$mod.p = $mod.$rtti["TBridge"];',
  15564. '$mod.p = $mod.b.$rtti;',
  15565. '']));
  15566. end;
  15567. procedure TTestModule.TestRTTI_ClassOf;
  15568. begin
  15569. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15570. StartProgram(false);
  15571. Add('type');
  15572. Add(' TClass = class of tobject;');
  15573. Add(' TProcA = function: TClass;');
  15574. Add(' TObject = class');
  15575. Add(' published');
  15576. Add(' C: tclass;');
  15577. Add(' end;');
  15578. Add(' tfox = class;');
  15579. Add(' TBird = class end;');
  15580. Add(' TBirds = class of tbird;');
  15581. Add(' TFox = class end;');
  15582. Add(' TFoxes = class of tfox;');
  15583. Add(' TCows = class of TCow;');
  15584. Add(' TCow = class;');
  15585. Add(' TCow = class end;');
  15586. Add('begin');
  15587. ConvertProgram;
  15588. CheckSource('TestRTTI_ClassOf',
  15589. LinesToStr([ // statements
  15590. '$mod.$rtti.$Class("TObject");',
  15591. '$mod.$rtti.$ClassRef("TClass", {',
  15592. ' instancetype: $mod.$rtti["TObject"]',
  15593. '});',
  15594. '$mod.$rtti.$ProcVar("TProcA", {',
  15595. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TClass"])',
  15596. '});',
  15597. 'rtl.createClass($mod, "TObject", null, function () {',
  15598. ' this.$init = function () {',
  15599. ' this.C = null;',
  15600. ' };',
  15601. ' this.$final = function () {',
  15602. ' this.C = undefined;',
  15603. ' };',
  15604. ' var $r = this.$rtti;',
  15605. ' $r.addField("C", $mod.$rtti["TClass"]);',
  15606. '});',
  15607. '$mod.$rtti.$Class("TFox");',
  15608. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  15609. '});',
  15610. '$mod.$rtti.$ClassRef("TBirds", {',
  15611. ' instancetype: $mod.$rtti["TBird"]',
  15612. '});',
  15613. 'rtl.createClass($mod, "TFox", $mod.TObject, function () {',
  15614. '});',
  15615. '$mod.$rtti.$ClassRef("TFoxes", {',
  15616. ' instancetype: $mod.$rtti["TFox"]',
  15617. '});',
  15618. '$mod.$rtti.$Class("TCow");',
  15619. '$mod.$rtti.$ClassRef("TCows", {',
  15620. ' instancetype: $mod.$rtti["TCow"]',
  15621. '});',
  15622. 'rtl.createClass($mod, "TCow", $mod.TObject, function () {',
  15623. '});',
  15624. '']),
  15625. LinesToStr([ // $mod.$main
  15626. '']));
  15627. end;
  15628. procedure TTestModule.TestRTTI_Record;
  15629. begin
  15630. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15631. StartProgram(false);
  15632. Add('type');
  15633. Add(' integer = longint;');
  15634. Add(' TPoint = record');
  15635. Add(' x,y: integer;');
  15636. Add(' end;');
  15637. Add('var p: pointer;');
  15638. Add(' r: tpoint;');
  15639. Add('begin');
  15640. Add(' p:=typeinfo(tpoint);');
  15641. Add(' p:=typeinfo(r);');
  15642. Add(' p:=typeinfo(r.x);');
  15643. ConvertProgram;
  15644. CheckSource('TestRTTI_Record',
  15645. LinesToStr([ // statements
  15646. 'this.TPoint = function (s) {',
  15647. ' if (s) {',
  15648. ' this.x = s.x;',
  15649. ' this.y = s.y;',
  15650. ' } else {',
  15651. ' this.x = 0;',
  15652. ' this.y = 0;',
  15653. ' };',
  15654. ' this.$equal = function (b) {',
  15655. ' return (this.x === b.x) && (this.y === b.y);',
  15656. ' };',
  15657. '};',
  15658. '$mod.$rtti.$Record("TPoint", {}).addFields("x", rtl.longint, "y", rtl.longint);',
  15659. 'this.p = null;',
  15660. 'this.r = new $mod.TPoint();',
  15661. '']),
  15662. LinesToStr([ // $mod.$main
  15663. '$mod.p = $mod.$rtti["TPoint"];',
  15664. '$mod.p = $mod.$rtti["TPoint"];',
  15665. '$mod.p = rtl.longint;',
  15666. '']));
  15667. end;
  15668. procedure TTestModule.TestRTTI_RecordAnonymousArray;
  15669. begin
  15670. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15671. StartProgram(false);
  15672. Add('type');
  15673. Add(' TFloatRec = record');
  15674. Add(' d: array of char;');
  15675. // Add(' i: array of array of longint;');
  15676. Add(' end;');
  15677. Add('var p: pointer;');
  15678. Add(' r: tfloatrec;');
  15679. Add('begin');
  15680. Add(' p:=typeinfo(tfloatrec);');
  15681. Add(' p:=typeinfo(r);');
  15682. Add(' p:=typeinfo(r.d);');
  15683. ConvertProgram;
  15684. CheckSource('TestRTTI_Record',
  15685. LinesToStr([ // statements
  15686. 'this.TFloatRec = function (s) {',
  15687. ' if (s) {',
  15688. ' this.d = s.d;',
  15689. ' } else {',
  15690. ' this.d = [];',
  15691. ' };',
  15692. ' this.$equal = function (b) {',
  15693. ' return this.d === b.d;',
  15694. ' };',
  15695. '};',
  15696. '$mod.$rtti.$DynArray("TFloatRec.d$a", {',
  15697. ' eltype: rtl.char',
  15698. '});',
  15699. '$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);',
  15700. 'this.p = null;',
  15701. 'this.r = new $mod.TFloatRec();',
  15702. '']),
  15703. LinesToStr([ // $mod.$main
  15704. '$mod.p = $mod.$rtti["TFloatRec"];',
  15705. '$mod.p = $mod.$rtti["TFloatRec"];',
  15706. '$mod.p = $mod.$rtti["TFloatRec.d$a"];',
  15707. '']));
  15708. end;
  15709. procedure TTestModule.TestRTTI_LocalTypes;
  15710. begin
  15711. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15712. StartProgram(false);
  15713. Add('procedure DoIt;');
  15714. Add('type');
  15715. Add(' integer = longint;');
  15716. Add(' TPoint = record');
  15717. Add(' x,y: integer;');
  15718. Add(' end;');
  15719. Add('begin');
  15720. Add('end;');
  15721. Add('begin');
  15722. ConvertProgram;
  15723. CheckSource('TestRTTI_LocalTypes',
  15724. LinesToStr([ // statements
  15725. 'this.DoIt = function () {',
  15726. ' this.TPoint = function (s) {',
  15727. ' if (s) {',
  15728. ' this.x = s.x;',
  15729. ' this.y = s.y;',
  15730. ' } else {',
  15731. ' this.x = 0;',
  15732. ' this.y = 0;',
  15733. ' };',
  15734. ' this.$equal = function (b) {',
  15735. ' return (this.x === b.x) && (this.y === b.y);',
  15736. ' };',
  15737. ' };',
  15738. '};',
  15739. '']),
  15740. LinesToStr([ // $mod.$main
  15741. '']));
  15742. end;
  15743. procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
  15744. begin
  15745. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15746. StartProgram(false);
  15747. Add('type');
  15748. Add(' TCaption = string;');
  15749. Add(' TYesNo = boolean;');
  15750. Add(' TLetter = char;');
  15751. Add(' TFloat = double;');
  15752. Add(' TPtr = pointer;');
  15753. Add(' TShortInt = shortint;');
  15754. Add(' TByte = byte;');
  15755. Add(' TSmallInt = smallint;');
  15756. Add(' TWord = word;');
  15757. Add(' TInt32 = longint;');
  15758. Add(' TDWord = longword;');
  15759. Add(' TValue = jsvalue;');
  15760. Add('var p: TPtr;');
  15761. Add('begin');
  15762. Add(' p:=typeinfo(string);');
  15763. Add(' p:=typeinfo(tcaption);');
  15764. Add(' p:=typeinfo(boolean);');
  15765. Add(' p:=typeinfo(tyesno);');
  15766. Add(' p:=typeinfo(char);');
  15767. Add(' p:=typeinfo(tletter);');
  15768. Add(' p:=typeinfo(double);');
  15769. Add(' p:=typeinfo(tfloat);');
  15770. Add(' p:=typeinfo(pointer);');
  15771. Add(' p:=typeinfo(tptr);');
  15772. Add(' p:=typeinfo(shortint);');
  15773. Add(' p:=typeinfo(tshortint);');
  15774. Add(' p:=typeinfo(byte);');
  15775. Add(' p:=typeinfo(tbyte);');
  15776. Add(' p:=typeinfo(smallint);');
  15777. Add(' p:=typeinfo(tsmallint);');
  15778. Add(' p:=typeinfo(word);');
  15779. Add(' p:=typeinfo(tword);');
  15780. Add(' p:=typeinfo(longword);');
  15781. Add(' p:=typeinfo(tdword);');
  15782. Add(' p:=typeinfo(jsvalue);');
  15783. Add(' p:=typeinfo(tvalue);');
  15784. ConvertProgram;
  15785. CheckSource('TestRTTI_TypeInfo_BaseTypes',
  15786. LinesToStr([ // statements
  15787. 'this.p = null;',
  15788. '']),
  15789. LinesToStr([ // $mod.$main
  15790. '$mod.p = rtl.string;',
  15791. '$mod.p = rtl.string;',
  15792. '$mod.p = rtl.boolean;',
  15793. '$mod.p = rtl.boolean;',
  15794. '$mod.p = rtl.char;',
  15795. '$mod.p = rtl.char;',
  15796. '$mod.p = rtl.double;',
  15797. '$mod.p = rtl.double;',
  15798. '$mod.p = rtl.pointer;',
  15799. '$mod.p = rtl.pointer;',
  15800. '$mod.p = rtl.shortint;',
  15801. '$mod.p = rtl.shortint;',
  15802. '$mod.p = rtl.byte;',
  15803. '$mod.p = rtl.byte;',
  15804. '$mod.p = rtl.smallint;',
  15805. '$mod.p = rtl.smallint;',
  15806. '$mod.p = rtl.word;',
  15807. '$mod.p = rtl.word;',
  15808. '$mod.p = rtl.longword;',
  15809. '$mod.p = rtl.longword;',
  15810. '$mod.p = rtl.jsvalue;',
  15811. '$mod.p = rtl.jsvalue;',
  15812. '']));
  15813. end;
  15814. procedure TTestModule.TestRTTI_TypeInfo_LocalFail;
  15815. begin
  15816. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15817. StartProgram(false);
  15818. Add('procedure DoIt;');
  15819. Add('type');
  15820. Add(' integer = longint;');
  15821. Add(' TPoint = record');
  15822. Add(' x,y: integer;');
  15823. Add(' end;');
  15824. Add('var p: pointer;');
  15825. Add('begin');
  15826. Add(' p:=typeinfo(tpoint);');
  15827. Add('end;');
  15828. Add('begin');
  15829. SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
  15830. ConvertProgram;
  15831. end;
  15832. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  15833. begin
  15834. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15835. StartProgram(false);
  15836. Add('{$modeswitch externalclass}');
  15837. Add('type');
  15838. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  15839. Add(' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;');
  15840. Add(' TFlag = (up,down);');
  15841. Add(' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;');
  15842. Add(' TFlags = set of TFlag;');
  15843. Add(' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;');
  15844. Add('var');
  15845. Add(' ti: TTypeInfo;');
  15846. Add(' tiInt: TTypeInfoInteger;');
  15847. Add(' tiEnum: TTypeInfoEnum;');
  15848. Add(' tiSet: TTypeInfoSet;');
  15849. Add('begin');
  15850. Add(' ti:=typeinfo(string);');
  15851. Add(' ti:=typeinfo(boolean);');
  15852. Add(' ti:=typeinfo(char);');
  15853. Add(' ti:=typeinfo(double);');
  15854. Add(' tiInt:=typeinfo(shortint);');
  15855. Add(' tiInt:=typeinfo(byte);');
  15856. Add(' tiInt:=typeinfo(smallint);');
  15857. Add(' tiInt:=typeinfo(word);');
  15858. Add(' tiInt:=typeinfo(longint);');
  15859. Add(' tiInt:=typeinfo(longword);');
  15860. Add(' ti:=typeinfo(jsvalue);');
  15861. Add(' tiEnum:=typeinfo(tflag);');
  15862. Add(' tiSet:=typeinfo(tflags);');
  15863. ConvertProgram;
  15864. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
  15865. LinesToStr([ // statements
  15866. 'this.TFlag = {',
  15867. ' "0": "up",',
  15868. ' up: 0,',
  15869. ' "1": "down",',
  15870. ' down: 1',
  15871. '};',
  15872. '$mod.$rtti.$Enum("TFlag", {',
  15873. ' minvalue: 0,',
  15874. ' maxvalue: 1,',
  15875. ' ordtype: 1,',
  15876. ' enumtype: this.TFlag',
  15877. '});',
  15878. '$mod.$rtti.$Set("TFlags", {',
  15879. ' comptype: $mod.$rtti["TFlag"]',
  15880. '});',
  15881. 'this.ti = null;',
  15882. 'this.tiInt = null;',
  15883. 'this.tiEnum = null;',
  15884. 'this.tiSet = null;',
  15885. '']),
  15886. LinesToStr([ // $mod.$main
  15887. '$mod.ti = rtl.string;',
  15888. '$mod.ti = rtl.boolean;',
  15889. '$mod.ti = rtl.char;',
  15890. '$mod.ti = rtl.double;',
  15891. '$mod.tiInt = rtl.shortint;',
  15892. '$mod.tiInt = rtl.byte;',
  15893. '$mod.tiInt = rtl.smallint;',
  15894. '$mod.tiInt = rtl.word;',
  15895. '$mod.tiInt = rtl.longint;',
  15896. '$mod.tiInt = rtl.longword;',
  15897. '$mod.ti = rtl.jsvalue;',
  15898. '$mod.tiEnum = $mod.$rtti["TFlag"];',
  15899. '$mod.tiSet = $mod.$rtti["TFlags"];',
  15900. '']));
  15901. end;
  15902. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  15903. begin
  15904. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15905. StartProgram(false);
  15906. Add('{$modeswitch externalclass}');
  15907. Add('type');
  15908. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  15909. Add(' TStaticArr = array[boolean] of string;');
  15910. Add(' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
  15911. Add(' TDynArr = array of string;');
  15912. Add(' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
  15913. Add(' TProc = procedure;');
  15914. Add(' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
  15915. Add(' TMethod = procedure of object;');
  15916. Add(' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
  15917. Add('var');
  15918. Add(' StaticArray: TStaticArr;');
  15919. Add(' tiStaticArray: TTypeInfoStaticArray;');
  15920. Add(' DynArray: TDynArr;');
  15921. Add(' tiDynArray: TTypeInfoDynArray;');
  15922. Add(' ProcVar: TProc;');
  15923. Add(' tiProcVar: TTypeInfoProcVar;');
  15924. Add(' MethodVar: TMethod;');
  15925. Add(' tiMethodVar: TTypeInfoMethodVar;');
  15926. Add('begin');
  15927. Add(' tiStaticArray:=typeinfo(StaticArray);');
  15928. Add(' tiStaticArray:=typeinfo(TStaticArr);');
  15929. Add(' tiDynArray:=typeinfo(DynArray);');
  15930. Add(' tiDynArray:=typeinfo(TDynArr);');
  15931. Add(' tiProcVar:=typeinfo(ProcVar);');
  15932. Add(' tiProcVar:=typeinfo(TProc);');
  15933. Add(' tiMethodVar:=typeinfo(MethodVar);');
  15934. Add(' tiMethodVar:=typeinfo(TMethod);');
  15935. ConvertProgram;
  15936. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
  15937. LinesToStr([ // statements
  15938. ' $mod.$rtti.$StaticArray("TStaticArr", {',
  15939. ' dims: [2],',
  15940. ' eltype: rtl.string',
  15941. '});',
  15942. '$mod.$rtti.$DynArray("TDynArr", {',
  15943. ' eltype: rtl.string',
  15944. '});',
  15945. '$mod.$rtti.$ProcVar("TProc", {',
  15946. ' procsig: rtl.newTIProcSig(null)',
  15947. '});',
  15948. '$mod.$rtti.$MethodVar("TMethod", {',
  15949. ' procsig: rtl.newTIProcSig(null),',
  15950. ' methodkind: 0',
  15951. '});',
  15952. 'this.StaticArray = rtl.arraySetLength(null,"",2);',
  15953. 'this.tiStaticArray = null;',
  15954. 'this.DynArray = [];',
  15955. 'this.tiDynArray = null;',
  15956. 'this.ProcVar = null;',
  15957. 'this.tiProcVar = null;',
  15958. 'this.MethodVar = null;',
  15959. 'this.tiMethodVar = null;',
  15960. '']),
  15961. LinesToStr([ // $mod.$main
  15962. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  15963. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  15964. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  15965. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  15966. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  15967. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  15968. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  15969. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  15970. '']));
  15971. end;
  15972. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  15973. begin
  15974. Converter.Options:=Converter.Options-[coNoTypeInfo];
  15975. StartProgram(false);
  15976. Add('{$modeswitch externalclass}');
  15977. Add('type');
  15978. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  15979. Add(' TRec = record end;');
  15980. Add(' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
  15981. // ToDo: ^PRec
  15982. Add(' TObject = class end;');
  15983. Add(' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
  15984. Add(' TClass = class of tobject;');
  15985. Add(' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
  15986. Add(' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
  15987. Add('var');
  15988. Add(' Rec: trec;');
  15989. Add(' tiRecord: ttypeinforecord;');
  15990. Add(' Obj: tobject;');
  15991. Add(' tiClass: ttypeinfoclass;');
  15992. Add(' aClass: tclass;');
  15993. Add(' tiClassRef: ttypeinfoclassref;');
  15994. // ToDo: ^PRec
  15995. Add(' tiPointer: ttypeinfopointer;');
  15996. Add('begin');
  15997. Add(' tirecord:=typeinfo(trec);');
  15998. Add(' tirecord:=typeinfo(trec);');
  15999. Add(' ticlass:=typeinfo(obj);');
  16000. Add(' ticlass:=typeinfo(tobject);');
  16001. Add(' ticlass:=typeinfo(aclass);');
  16002. Add(' ticlassref:=typeinfo(tclass);');
  16003. ConvertProgram;
  16004. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
  16005. LinesToStr([ // statements
  16006. 'this.TRec = function (s) {',
  16007. ' this.$equal = function (b) {',
  16008. ' return true;',
  16009. ' };',
  16010. '};',
  16011. '$mod.$rtti.$Record("TRec", {});',
  16012. 'rtl.createClass($mod, "TObject", null, function () {',
  16013. ' this.$init = function () {',
  16014. ' };',
  16015. ' this.$final = function () {',
  16016. ' };',
  16017. '});',
  16018. '$mod.$rtti.$ClassRef("TClass", {',
  16019. ' instancetype: $mod.$rtti["TObject"]',
  16020. '});',
  16021. 'this.Rec = new $mod.TRec();',
  16022. 'this.tiRecord = null;',
  16023. 'this.Obj = null;',
  16024. 'this.tiClass = null;',
  16025. 'this.aClass = null;',
  16026. 'this.tiClassRef = null;',
  16027. 'this.tiPointer = null;',
  16028. '']),
  16029. LinesToStr([ // $mod.$main
  16030. '$mod.tiRecord = $mod.$rtti["TRec"];',
  16031. '$mod.tiRecord = $mod.$rtti["TRec"];',
  16032. '$mod.tiClass = $mod.Obj.$rtti;',
  16033. '$mod.tiClass = $mod.$rtti["TObject"];',
  16034. '$mod.tiClass = $mod.aClass.$rtti;',
  16035. '$mod.tiClassRef = $mod.$rtti["TClass"];',
  16036. '']));
  16037. end;
  16038. procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
  16039. begin
  16040. Converter.Options:=Converter.Options-[coNoTypeInfo];
  16041. StartProgram(false);
  16042. Add([
  16043. '{$modeswitch externalclass}',
  16044. 'type',
  16045. ' TClass = class of tobject;',
  16046. ' TObject = class',
  16047. ' function MyClass: TClass;',
  16048. ' class function ClassType: TClass;',
  16049. ' end;',
  16050. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  16051. ' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
  16052. 'function TObject.MyClass: TClass;',
  16053. 'var t: TTypeInfoClass;',
  16054. 'begin',
  16055. ' t:=TypeInfo(Self);',
  16056. ' t:=TypeInfo(Result);',
  16057. 'end;',
  16058. 'class function TObject.ClassType: TClass;',
  16059. 'var t: TTypeInfoClass;',
  16060. 'begin',
  16061. ' t:=TypeInfo(Self);',
  16062. ' t:=TypeInfo(Result);',
  16063. 'end;',
  16064. 'var',
  16065. ' Obj: TObject;',
  16066. ' t: TTypeInfoClass;',
  16067. 'begin',
  16068. ' t:=TypeInfo(TObject.ClassType);',
  16069. ' t:=TypeInfo(Obj.ClassType);',
  16070. ' t:=TypeInfo(Obj.MyClass);',
  16071. '']);
  16072. ConvertProgram;
  16073. CheckSource('TestRTTI_TypeInfo_FunctionClassType',
  16074. LinesToStr([ // statements
  16075. '$mod.$rtti.$Class("TObject");',
  16076. '$mod.$rtti.$ClassRef("TClass", {',
  16077. ' instancetype: $mod.$rtti["TObject"]',
  16078. '});',
  16079. 'rtl.createClass($mod, "TObject", null, function () {',
  16080. ' this.$init = function () {',
  16081. ' };',
  16082. ' this.$final = function () {',
  16083. ' };',
  16084. ' this.MyClass = function () {',
  16085. ' var Result = null;',
  16086. ' var t = null;',
  16087. ' t = this.$rtti;',
  16088. ' t = Result.$rtti;',
  16089. ' return Result;',
  16090. ' };',
  16091. ' this.ClassType = function () {',
  16092. ' var Result = null;',
  16093. ' var t = null;',
  16094. ' t = this.$rtti;',
  16095. ' t = Result.$rtti;',
  16096. ' return Result;',
  16097. ' };',
  16098. '});',
  16099. 'this.Obj = null;',
  16100. 'this.t = null;',
  16101. '']),
  16102. LinesToStr([ // $mod.$main
  16103. '$mod.t = $mod.TObject.ClassType().$rtti;',
  16104. '$mod.t = $mod.Obj.$class.ClassType().$rtti;',
  16105. '$mod.t = $mod.Obj.MyClass().$rtti;',
  16106. '']));
  16107. end;
  16108. procedure TTestModule.TestResourcestringProgram;
  16109. begin
  16110. StartProgram(false);
  16111. Add([
  16112. 'const Bar = ''bar'';',
  16113. 'resourcestring',
  16114. ' Red = ''red'';',
  16115. ' Foobar = ''fOo''+bar;',
  16116. 'var s: string;',
  16117. ' c: char;',
  16118. 'begin',
  16119. ' s:=red;',
  16120. ' s:=test1.red;',
  16121. ' c:=red[1];',
  16122. ' c:=test1.red[2];',
  16123. ' if red=foobar then ;',
  16124. ' if red[3]=red[4] then ;']);
  16125. ConvertProgram;
  16126. CheckSource('TestResourcestringProgram',
  16127. LinesToStr([ // statements
  16128. 'this.Bar = "bar";',
  16129. 'this.s = "";',
  16130. 'this.c = "";',
  16131. '$mod.$resourcestrings = {',
  16132. ' Red: {',
  16133. ' org: "red"',
  16134. ' },',
  16135. ' Foobar: {',
  16136. ' org: "fOobar"',
  16137. ' }',
  16138. '};',
  16139. '']),
  16140. LinesToStr([ // $mod.$main
  16141. '$mod.s = rtl.getResStr(pas.program, "Red");',
  16142. '$mod.s = rtl.getResStr(pas.program, "Red");',
  16143. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(0);',
  16144. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(1);',
  16145. 'if (rtl.getResStr(pas.program, "Red") === rtl.getResStr(pas.program, "Foobar")) ;',
  16146. 'if (rtl.getResStr(pas.program, "Red").charAt(2) === rtl.getResStr(pas.program, "Red").charAt(3)) ;',
  16147. '']));
  16148. end;
  16149. procedure TTestModule.TestResourcestringUnit;
  16150. begin
  16151. StartUnit(false);
  16152. Add([
  16153. 'interface',
  16154. 'const Red = ''rEd'';',
  16155. 'resourcestring',
  16156. ' Blue = ''blue'';',
  16157. ' NotRed = ''not''+Red;',
  16158. 'var s: string;',
  16159. 'implementation',
  16160. 'resourcestring',
  16161. ' ImplGreen = ''green'';',
  16162. 'initialization',
  16163. ' s:=blue+ImplGreen;',
  16164. ' s:=test1.blue+test1.implgreen;',
  16165. ' s:=blue[1]+implgreen[2];']);
  16166. ConvertUnit;
  16167. CheckSource('TestResourcestringUnit',
  16168. LinesToStr([ // statements
  16169. 'this.Red = "rEd";',
  16170. 'this.s = "";',
  16171. '$mod.$resourcestrings = {',
  16172. ' Blue: {',
  16173. ' org: "blue"',
  16174. ' },',
  16175. ' NotRed: {',
  16176. ' org: "notrEd"',
  16177. ' },',
  16178. ' ImplGreen: {',
  16179. ' org: "green"',
  16180. ' }',
  16181. '};',
  16182. '']),
  16183. LinesToStr([ // $mod.$main
  16184. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  16185. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  16186. '$mod.s = rtl.getResStr(pas.Test1, "Blue").charAt(0) + rtl.getResStr(pas.Test1, "ImplGreen").charAt(1);',
  16187. '']));
  16188. end;
  16189. procedure TTestModule.TestResourcestringImplementation;
  16190. begin
  16191. StartUnit(false);
  16192. Add([
  16193. 'interface',
  16194. 'implementation',
  16195. 'resourcestring',
  16196. ' ImplRed = ''red'';']);
  16197. ConvertUnit;
  16198. CheckSource('TestResourcestringImplementation',
  16199. LinesToStr([ // intf statements
  16200. 'var $impl = $mod.$impl;']),
  16201. LinesToStr([ // $mod.$init
  16202. '']),
  16203. LinesToStr([ // impl statements
  16204. '$mod.$resourcestrings = {',
  16205. ' ImplRed: {',
  16206. ' org: "red"',
  16207. ' }',
  16208. '};',
  16209. '']));
  16210. end;
  16211. procedure TTestModule.TestAtributes_Ignore;
  16212. begin
  16213. StartProgram(false);
  16214. Add([
  16215. '{$modeswitch ignoreattributes}',
  16216. 'type',
  16217. ' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
  16218. ' TObject = class',
  16219. ' [custom5()] FS: string;',
  16220. ' [customProp] property S: string read FS;',
  16221. ' end;',
  16222. 'var',
  16223. ' [custom6]',
  16224. ' o: TObject;',
  16225. 'begin',
  16226. '']);
  16227. ConvertProgram;
  16228. CheckSource('TestAtributes_Ignore',
  16229. LinesToStr([ // statements
  16230. 'rtl.createClass($mod, "TObject", null, function () {',
  16231. ' this.$init = function () {',
  16232. ' this.FS = "";',
  16233. ' };',
  16234. ' this.$final = function () {',
  16235. ' };',
  16236. '});',
  16237. 'this.o = null;',
  16238. '']),
  16239. LinesToStr([ // $mod.$main
  16240. '']));
  16241. end;
  16242. procedure TTestModule.TestAssert;
  16243. begin
  16244. StartProgram(false);
  16245. Add([
  16246. 'procedure DoIt;',
  16247. 'var',
  16248. ' b: boolean;',
  16249. ' s: string;',
  16250. 'begin',
  16251. ' {$Assertions on}',
  16252. ' Assert(b);',
  16253. 'end;',
  16254. 'begin',
  16255. ' DoIt;',
  16256. '']);
  16257. ConvertProgram;
  16258. CheckSource('TestAssert',
  16259. LinesToStr([ // statements
  16260. 'this.DoIt = function () {',
  16261. ' var b = false;',
  16262. ' var s = "";',
  16263. ' if (b) throw "assert failed";',
  16264. '};',
  16265. '']),
  16266. LinesToStr([ // $mod.$main
  16267. '$mod.DoIt();',
  16268. '']));
  16269. end;
  16270. procedure TTestModule.TestAssert_SysUtils;
  16271. begin
  16272. AddModuleWithIntfImplSrc('SysUtils.pas',
  16273. LinesToStr([
  16274. 'type',
  16275. ' TObject = class',
  16276. ' constructor Create;',
  16277. ' end;',
  16278. ' EAssertionFailed = class',
  16279. ' constructor Create(s: string);',
  16280. ' end;',
  16281. '']),
  16282. LinesToStr([
  16283. 'constructor TObject.Create;',
  16284. 'begin end;',
  16285. 'constructor EAssertionFailed.Create(s: string);',
  16286. 'begin end;',
  16287. '']) );
  16288. StartProgram(true);
  16289. Add([
  16290. 'uses sysutils;',
  16291. 'procedure DoIt;',
  16292. 'var',
  16293. ' b: boolean;',
  16294. ' s: string;',
  16295. 'begin',
  16296. ' {$Assertions on}',
  16297. ' Assert(b);',
  16298. ' Assert(b,''msg'');',
  16299. 'end;',
  16300. 'begin',
  16301. ' DoIt;',
  16302. '']);
  16303. ConvertProgram;
  16304. CheckSource('TestAssert_SysUtils',
  16305. LinesToStr([ // statements
  16306. 'this.DoIt = function () {',
  16307. ' var b = false;',
  16308. ' var s = "";',
  16309. ' if (b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
  16310. ' if (b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
  16311. '};',
  16312. '']),
  16313. LinesToStr([ // $mod.$main
  16314. '$mod.DoIt();',
  16315. '']));
  16316. end;
  16317. procedure TTestModule.TestObjectChecks;
  16318. begin
  16319. Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsObjectChecks];
  16320. StartProgram(false);
  16321. Add([
  16322. 'type',
  16323. ' TObject = class',
  16324. ' procedure DoIt;',
  16325. ' end;',
  16326. ' TClass = class of tobject;',
  16327. ' TBird = class',
  16328. ' end;',
  16329. ' TBirdClass = class of TBird;',
  16330. 'var',
  16331. ' o : TObject;',
  16332. ' c: TClass;',
  16333. ' b: TBird;',
  16334. ' bc: TBirdClass;',
  16335. 'procedure TObject.DoIt;',
  16336. 'begin',
  16337. ' b:=TBird(o);',
  16338. 'end;',
  16339. 'begin',
  16340. ' o.DoIt;',
  16341. ' b:=TBird(o);',
  16342. ' bc:=TBirdClass(c);',
  16343. '']);
  16344. ConvertProgram;
  16345. CheckSource('TestCheckMethodCall',
  16346. LinesToStr([ // statements
  16347. 'rtl.createClass($mod, "TObject", null, function () {',
  16348. ' this.$init = function () {',
  16349. ' };',
  16350. ' this.$final = function () {',
  16351. ' };',
  16352. ' this.DoIt = function () {',
  16353. ' rtl.checkMethodCall(this,$mod.TObject);',
  16354. ' $mod.b = rtl.asExt($mod.o, $mod.TBird, 1);',
  16355. ' };',
  16356. '});',
  16357. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16358. '});',
  16359. 'this.o = null;',
  16360. 'this.c = null;',
  16361. 'this.b = null;',
  16362. 'this.bc = null;',
  16363. '']),
  16364. LinesToStr([ // $mod.$main
  16365. '$mod.o.DoIt();',
  16366. '$mod.b = rtl.asExt($mod.o,$mod.TBird, 1);',
  16367. '$mod.bc = rtl.asExt($mod.c, $mod.TBird, 2);',
  16368. '']));
  16369. end;
  16370. procedure TTestModule.TestRangeChecks_Assign;
  16371. begin
  16372. Scanner.Options:=Scanner.Options+[po_CAssignments];
  16373. StartProgram(false);
  16374. Add([
  16375. '{$R+}',
  16376. 'var',
  16377. ' b: byte;',
  16378. ' w: word;',
  16379. 'procedure DoIt(p: byte);',
  16380. 'begin',
  16381. ' b:=w;',
  16382. ' b+=w;',
  16383. 'end;',
  16384. '{$R-}',
  16385. 'begin',
  16386. ' DoIt(w);',
  16387. ' b:=w;',
  16388. '{$R+}',
  16389. '']);
  16390. ConvertProgram;
  16391. CheckSource('TestRangeChecks_Assign',
  16392. LinesToStr([ // statements
  16393. 'this.b = 0;',
  16394. 'this.w = 0;',
  16395. 'this.DoIt = function (p) {',
  16396. ' rtl.rc(p, 0, 255);',
  16397. ' $mod.b = rtl.rc($mod.w,0,255);',
  16398. ' rtl.rc($mod.b += $mod.w, 0, 255);',
  16399. '};',
  16400. '']),
  16401. LinesToStr([ // $mod.$main
  16402. '$mod.DoIt($mod.w);',
  16403. '$mod.b = rtl.rc($mod.w,0,255);',
  16404. '']));
  16405. end;
  16406. Initialization
  16407. RegisterTests([TTestModule]);
  16408. end.