tcmodules.pas 667 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349635063516352635363546355635663576358635963606361636263636364636563666367636863696370637163726373637463756376637763786379638063816382638363846385638663876388638963906391639263936394639563966397639863996400640164026403640464056406640764086409641064116412641364146415641664176418641964206421642264236424642564266427642864296430643164326433643464356436643764386439644064416442644364446445644664476448644964506451645264536454645564566457645864596460646164626463646464656466646764686469647064716472647364746475647664776478647964806481648264836484648564866487648864896490649164926493649464956496649764986499650065016502650365046505650665076508650965106511651265136514651565166517651865196520652165226523652465256526652765286529653065316532653365346535653665376538653965406541654265436544654565466547654865496550655165526553655465556556655765586559656065616562656365646565656665676568656965706571657265736574657565766577657865796580658165826583658465856586658765886589659065916592659365946595659665976598659966006601660266036604660566066607660866096610661166126613661466156616661766186619662066216622662366246625662666276628662966306631663266336634663566366637663866396640664166426643664466456646664766486649665066516652665366546655665666576658665966606661666266636664666566666667666866696670667166726673667466756676667766786679668066816682668366846685668666876688668966906691669266936694669566966697669866996700670167026703670467056706670767086709671067116712671367146715671667176718671967206721672267236724672567266727672867296730673167326733673467356736673767386739674067416742674367446745674667476748674967506751675267536754675567566757675867596760676167626763676467656766676767686769677067716772677367746775677667776778677967806781678267836784678567866787678867896790679167926793679467956796679767986799680068016802680368046805680668076808680968106811681268136814681568166817681868196820682168226823682468256826682768286829683068316832683368346835683668376838683968406841684268436844684568466847684868496850685168526853685468556856685768586859686068616862686368646865686668676868686968706871687268736874687568766877687868796880688168826883688468856886688768886889689068916892689368946895689668976898689969006901690269036904690569066907690869096910691169126913691469156916691769186919692069216922692369246925692669276928692969306931693269336934693569366937693869396940694169426943694469456946694769486949695069516952695369546955695669576958695969606961696269636964696569666967696869696970697169726973697469756976697769786979698069816982698369846985698669876988698969906991699269936994699569966997699869997000700170027003700470057006700770087009701070117012701370147015701670177018701970207021702270237024702570267027702870297030703170327033703470357036703770387039704070417042704370447045704670477048704970507051705270537054705570567057705870597060706170627063706470657066706770687069707070717072707370747075707670777078707970807081708270837084708570867087708870897090709170927093709470957096709770987099710071017102710371047105710671077108710971107111711271137114711571167117711871197120712171227123712471257126712771287129713071317132713371347135713671377138713971407141714271437144714571467147714871497150715171527153715471557156715771587159716071617162716371647165716671677168716971707171717271737174717571767177717871797180718171827183718471857186718771887189719071917192719371947195719671977198719972007201720272037204720572067207720872097210721172127213721472157216721772187219722072217222722372247225722672277228722972307231723272337234723572367237723872397240724172427243724472457246724772487249725072517252725372547255725672577258725972607261726272637264726572667267726872697270727172727273727472757276727772787279728072817282728372847285728672877288728972907291729272937294729572967297729872997300730173027303730473057306730773087309731073117312731373147315731673177318731973207321732273237324732573267327732873297330733173327333733473357336733773387339734073417342734373447345734673477348734973507351735273537354735573567357735873597360736173627363736473657366736773687369737073717372737373747375737673777378737973807381738273837384738573867387738873897390739173927393739473957396739773987399740074017402740374047405740674077408740974107411741274137414741574167417741874197420742174227423742474257426742774287429743074317432743374347435743674377438743974407441744274437444744574467447744874497450745174527453745474557456745774587459746074617462746374647465746674677468746974707471747274737474747574767477747874797480748174827483748474857486748774887489749074917492749374947495749674977498749975007501750275037504750575067507750875097510751175127513751475157516751775187519752075217522752375247525752675277528752975307531753275337534753575367537753875397540754175427543754475457546754775487549755075517552755375547555755675577558755975607561756275637564756575667567756875697570757175727573757475757576757775787579758075817582758375847585758675877588758975907591759275937594759575967597759875997600760176027603760476057606760776087609761076117612761376147615761676177618761976207621762276237624762576267627762876297630763176327633763476357636763776387639764076417642764376447645764676477648764976507651765276537654765576567657765876597660766176627663766476657666766776687669767076717672767376747675767676777678767976807681768276837684768576867687768876897690769176927693769476957696769776987699770077017702770377047705770677077708770977107711771277137714771577167717771877197720772177227723772477257726772777287729773077317732773377347735773677377738773977407741774277437744774577467747774877497750775177527753775477557756775777587759776077617762776377647765776677677768776977707771777277737774777577767777777877797780778177827783778477857786778777887789779077917792779377947795779677977798779978007801780278037804780578067807780878097810781178127813781478157816781778187819782078217822782378247825782678277828782978307831783278337834783578367837783878397840784178427843784478457846784778487849785078517852785378547855785678577858785978607861786278637864786578667867786878697870787178727873787478757876787778787879788078817882788378847885788678877888788978907891789278937894789578967897789878997900790179027903790479057906790779087909791079117912791379147915791679177918791979207921792279237924792579267927792879297930793179327933793479357936793779387939794079417942794379447945794679477948794979507951795279537954795579567957795879597960796179627963796479657966796779687969797079717972797379747975797679777978797979807981798279837984798579867987798879897990799179927993799479957996799779987999800080018002800380048005800680078008800980108011801280138014801580168017801880198020802180228023802480258026802780288029803080318032803380348035803680378038803980408041804280438044804580468047804880498050805180528053805480558056805780588059806080618062806380648065806680678068806980708071807280738074807580768077807880798080808180828083808480858086808780888089809080918092809380948095809680978098809981008101810281038104810581068107810881098110811181128113811481158116811781188119812081218122812381248125812681278128812981308131813281338134813581368137813881398140814181428143814481458146814781488149815081518152815381548155815681578158815981608161816281638164816581668167816881698170817181728173817481758176817781788179818081818182818381848185818681878188818981908191819281938194819581968197819881998200820182028203820482058206820782088209821082118212821382148215821682178218821982208221822282238224822582268227822882298230823182328233823482358236823782388239824082418242824382448245824682478248824982508251825282538254825582568257825882598260826182628263826482658266826782688269827082718272827382748275827682778278827982808281828282838284828582868287828882898290829182928293829482958296829782988299830083018302830383048305830683078308830983108311831283138314831583168317831883198320832183228323832483258326832783288329833083318332833383348335833683378338833983408341834283438344834583468347834883498350835183528353835483558356835783588359836083618362836383648365836683678368836983708371837283738374837583768377837883798380838183828383838483858386838783888389839083918392839383948395839683978398839984008401840284038404840584068407840884098410841184128413841484158416841784188419842084218422842384248425842684278428842984308431843284338434843584368437843884398440844184428443844484458446844784488449845084518452845384548455845684578458845984608461846284638464846584668467846884698470847184728473847484758476847784788479848084818482848384848485848684878488848984908491849284938494849584968497849884998500850185028503850485058506850785088509851085118512851385148515851685178518851985208521852285238524852585268527852885298530853185328533853485358536853785388539854085418542854385448545854685478548854985508551855285538554855585568557855885598560856185628563856485658566856785688569857085718572857385748575857685778578857985808581858285838584858585868587858885898590859185928593859485958596859785988599860086018602860386048605860686078608860986108611861286138614861586168617861886198620862186228623862486258626862786288629863086318632863386348635863686378638863986408641864286438644864586468647864886498650865186528653865486558656865786588659866086618662866386648665866686678668866986708671867286738674867586768677867886798680868186828683868486858686868786888689869086918692869386948695869686978698869987008701870287038704870587068707870887098710871187128713871487158716871787188719872087218722872387248725872687278728872987308731873287338734873587368737873887398740874187428743874487458746874787488749875087518752875387548755875687578758875987608761876287638764876587668767876887698770877187728773877487758776877787788779878087818782878387848785878687878788878987908791879287938794879587968797879887998800880188028803880488058806880788088809881088118812881388148815881688178818881988208821882288238824882588268827882888298830883188328833883488358836883788388839884088418842884388448845884688478848884988508851885288538854885588568857885888598860886188628863886488658866886788688869887088718872887388748875887688778878887988808881888288838884888588868887888888898890889188928893889488958896889788988899890089018902890389048905890689078908890989108911891289138914891589168917891889198920892189228923892489258926892789288929893089318932893389348935893689378938893989408941894289438944894589468947894889498950895189528953895489558956895789588959896089618962896389648965896689678968896989708971897289738974897589768977897889798980898189828983898489858986898789888989899089918992899389948995899689978998899990009001900290039004900590069007900890099010901190129013901490159016901790189019902090219022902390249025902690279028902990309031903290339034903590369037903890399040904190429043904490459046904790489049905090519052905390549055905690579058905990609061906290639064906590669067906890699070907190729073907490759076907790789079908090819082908390849085908690879088908990909091909290939094909590969097909890999100910191029103910491059106910791089109911091119112911391149115911691179118911991209121912291239124912591269127912891299130913191329133913491359136913791389139914091419142914391449145914691479148914991509151915291539154915591569157915891599160916191629163916491659166916791689169917091719172917391749175917691779178917991809181918291839184918591869187918891899190919191929193919491959196919791989199920092019202920392049205920692079208920992109211921292139214921592169217921892199220922192229223922492259226922792289229923092319232923392349235923692379238923992409241924292439244924592469247924892499250925192529253925492559256925792589259926092619262926392649265926692679268926992709271927292739274927592769277927892799280928192829283928492859286928792889289929092919292929392949295929692979298929993009301930293039304930593069307930893099310931193129313931493159316931793189319932093219322932393249325932693279328932993309331933293339334933593369337933893399340934193429343934493459346934793489349935093519352935393549355935693579358935993609361936293639364936593669367936893699370937193729373937493759376937793789379938093819382938393849385938693879388938993909391939293939394939593969397939893999400940194029403940494059406940794089409941094119412941394149415941694179418941994209421942294239424942594269427942894299430943194329433943494359436943794389439944094419442944394449445944694479448944994509451945294539454945594569457945894599460946194629463946494659466946794689469947094719472947394749475947694779478947994809481948294839484948594869487948894899490949194929493949494959496949794989499950095019502950395049505950695079508950995109511951295139514951595169517951895199520952195229523952495259526952795289529953095319532953395349535953695379538953995409541954295439544954595469547954895499550955195529553955495559556955795589559956095619562956395649565956695679568956995709571957295739574957595769577957895799580958195829583958495859586958795889589959095919592959395949595959695979598959996009601960296039604960596069607960896099610961196129613961496159616961796189619962096219622962396249625962696279628962996309631963296339634963596369637963896399640964196429643964496459646964796489649965096519652965396549655965696579658965996609661966296639664966596669667966896699670967196729673967496759676967796789679968096819682968396849685968696879688968996909691969296939694969596969697969896999700970197029703970497059706970797089709971097119712971397149715971697179718971997209721972297239724972597269727972897299730973197329733973497359736973797389739974097419742974397449745974697479748974997509751975297539754975597569757975897599760976197629763976497659766976797689769977097719772977397749775977697779778977997809781978297839784978597869787978897899790979197929793979497959796979797989799980098019802980398049805980698079808980998109811981298139814981598169817981898199820982198229823982498259826982798289829983098319832983398349835983698379838983998409841984298439844984598469847984898499850985198529853985498559856985798589859986098619862986398649865986698679868986998709871987298739874987598769877987898799880988198829883988498859886988798889889989098919892989398949895989698979898989999009901990299039904990599069907990899099910991199129913991499159916991799189919992099219922992399249925992699279928992999309931993299339934993599369937993899399940994199429943994499459946994799489949995099519952995399549955995699579958995999609961996299639964996599669967996899699970997199729973997499759976997799789979998099819982998399849985998699879988998999909991999299939994999599969997999899991000010001100021000310004100051000610007100081000910010100111001210013100141001510016100171001810019100201002110022100231002410025100261002710028100291003010031100321003310034100351003610037100381003910040100411004210043100441004510046100471004810049100501005110052100531005410055100561005710058100591006010061100621006310064100651006610067100681006910070100711007210073100741007510076100771007810079100801008110082100831008410085100861008710088100891009010091100921009310094100951009610097100981009910100101011010210103101041010510106101071010810109101101011110112101131011410115101161011710118101191012010121101221012310124101251012610127101281012910130101311013210133101341013510136101371013810139101401014110142101431014410145101461014710148101491015010151101521015310154101551015610157101581015910160101611016210163101641016510166101671016810169101701017110172101731017410175101761017710178101791018010181101821018310184101851018610187101881018910190101911019210193101941019510196101971019810199102001020110202102031020410205102061020710208102091021010211102121021310214102151021610217102181021910220102211022210223102241022510226102271022810229102301023110232102331023410235102361023710238102391024010241102421024310244102451024610247102481024910250102511025210253102541025510256102571025810259102601026110262102631026410265102661026710268102691027010271102721027310274102751027610277102781027910280102811028210283102841028510286102871028810289102901029110292102931029410295102961029710298102991030010301103021030310304103051030610307103081030910310103111031210313103141031510316103171031810319103201032110322103231032410325103261032710328103291033010331103321033310334103351033610337103381033910340103411034210343103441034510346103471034810349103501035110352103531035410355103561035710358103591036010361103621036310364103651036610367103681036910370103711037210373103741037510376103771037810379103801038110382103831038410385103861038710388103891039010391103921039310394103951039610397103981039910400104011040210403104041040510406104071040810409104101041110412104131041410415104161041710418104191042010421104221042310424104251042610427104281042910430104311043210433104341043510436104371043810439104401044110442104431044410445104461044710448104491045010451104521045310454104551045610457104581045910460104611046210463104641046510466104671046810469104701047110472104731047410475104761047710478104791048010481104821048310484104851048610487104881048910490104911049210493104941049510496104971049810499105001050110502105031050410505105061050710508105091051010511105121051310514105151051610517105181051910520105211052210523105241052510526105271052810529105301053110532105331053410535105361053710538105391054010541105421054310544105451054610547105481054910550105511055210553105541055510556105571055810559105601056110562105631056410565105661056710568105691057010571105721057310574105751057610577105781057910580105811058210583105841058510586105871058810589105901059110592105931059410595105961059710598105991060010601106021060310604106051060610607106081060910610106111061210613106141061510616106171061810619106201062110622106231062410625106261062710628106291063010631106321063310634106351063610637106381063910640106411064210643106441064510646106471064810649106501065110652106531065410655106561065710658106591066010661106621066310664106651066610667106681066910670106711067210673106741067510676106771067810679106801068110682106831068410685106861068710688106891069010691106921069310694106951069610697106981069910700107011070210703107041070510706107071070810709107101071110712107131071410715107161071710718107191072010721107221072310724107251072610727107281072910730107311073210733107341073510736107371073810739107401074110742107431074410745107461074710748107491075010751107521075310754107551075610757107581075910760107611076210763107641076510766107671076810769107701077110772107731077410775107761077710778107791078010781107821078310784107851078610787107881078910790107911079210793107941079510796107971079810799108001080110802108031080410805108061080710808108091081010811108121081310814108151081610817108181081910820108211082210823108241082510826108271082810829108301083110832108331083410835108361083710838108391084010841108421084310844108451084610847108481084910850108511085210853108541085510856108571085810859108601086110862108631086410865108661086710868108691087010871108721087310874108751087610877108781087910880108811088210883108841088510886108871088810889108901089110892108931089410895108961089710898108991090010901109021090310904109051090610907109081090910910109111091210913109141091510916109171091810919109201092110922109231092410925109261092710928109291093010931109321093310934109351093610937109381093910940109411094210943109441094510946109471094810949109501095110952109531095410955109561095710958109591096010961109621096310964109651096610967109681096910970109711097210973109741097510976109771097810979109801098110982109831098410985109861098710988109891099010991109921099310994109951099610997109981099911000110011100211003110041100511006110071100811009110101101111012110131101411015110161101711018110191102011021110221102311024110251102611027110281102911030110311103211033110341103511036110371103811039110401104111042110431104411045110461104711048110491105011051110521105311054110551105611057110581105911060110611106211063110641106511066110671106811069110701107111072110731107411075110761107711078110791108011081110821108311084110851108611087110881108911090110911109211093110941109511096110971109811099111001110111102111031110411105111061110711108111091111011111111121111311114111151111611117111181111911120111211112211123111241112511126111271112811129111301113111132111331113411135111361113711138111391114011141111421114311144111451114611147111481114911150111511115211153111541115511156111571115811159111601116111162111631116411165111661116711168111691117011171111721117311174111751117611177111781117911180111811118211183111841118511186111871118811189111901119111192111931119411195111961119711198111991120011201112021120311204112051120611207112081120911210112111121211213112141121511216112171121811219112201122111222112231122411225112261122711228112291123011231112321123311234112351123611237112381123911240112411124211243112441124511246112471124811249112501125111252112531125411255112561125711258112591126011261112621126311264112651126611267112681126911270112711127211273112741127511276112771127811279112801128111282112831128411285112861128711288112891129011291112921129311294112951129611297112981129911300113011130211303113041130511306113071130811309113101131111312113131131411315113161131711318113191132011321113221132311324113251132611327113281132911330113311133211333113341133511336113371133811339113401134111342113431134411345113461134711348113491135011351113521135311354113551135611357113581135911360113611136211363113641136511366113671136811369113701137111372113731137411375113761137711378113791138011381113821138311384113851138611387113881138911390113911139211393113941139511396113971139811399114001140111402114031140411405114061140711408114091141011411114121141311414114151141611417114181141911420114211142211423114241142511426114271142811429114301143111432114331143411435114361143711438114391144011441114421144311444114451144611447114481144911450114511145211453114541145511456114571145811459114601146111462114631146411465114661146711468114691147011471114721147311474114751147611477114781147911480114811148211483114841148511486114871148811489114901149111492114931149411495114961149711498114991150011501115021150311504115051150611507115081150911510115111151211513115141151511516115171151811519115201152111522115231152411525115261152711528115291153011531115321153311534115351153611537115381153911540115411154211543115441154511546115471154811549115501155111552115531155411555115561155711558115591156011561115621156311564115651156611567115681156911570115711157211573115741157511576115771157811579115801158111582115831158411585115861158711588115891159011591115921159311594115951159611597115981159911600116011160211603116041160511606116071160811609116101161111612116131161411615116161161711618116191162011621116221162311624116251162611627116281162911630116311163211633116341163511636116371163811639116401164111642116431164411645116461164711648116491165011651116521165311654116551165611657116581165911660116611166211663116641166511666116671166811669116701167111672116731167411675116761167711678116791168011681116821168311684116851168611687116881168911690116911169211693116941169511696116971169811699117001170111702117031170411705117061170711708117091171011711117121171311714117151171611717117181171911720117211172211723117241172511726117271172811729117301173111732117331173411735117361173711738117391174011741117421174311744117451174611747117481174911750117511175211753117541175511756117571175811759117601176111762117631176411765117661176711768117691177011771117721177311774117751177611777117781177911780117811178211783117841178511786117871178811789117901179111792117931179411795117961179711798117991180011801118021180311804118051180611807118081180911810118111181211813118141181511816118171181811819118201182111822118231182411825118261182711828118291183011831118321183311834118351183611837118381183911840118411184211843118441184511846118471184811849118501185111852118531185411855118561185711858118591186011861118621186311864118651186611867118681186911870118711187211873118741187511876118771187811879118801188111882118831188411885118861188711888118891189011891118921189311894118951189611897118981189911900119011190211903119041190511906119071190811909119101191111912119131191411915119161191711918119191192011921119221192311924119251192611927119281192911930119311193211933119341193511936119371193811939119401194111942119431194411945119461194711948119491195011951119521195311954119551195611957119581195911960119611196211963119641196511966119671196811969119701197111972119731197411975119761197711978119791198011981119821198311984119851198611987119881198911990119911199211993119941199511996119971199811999120001200112002120031200412005120061200712008120091201012011120121201312014120151201612017120181201912020120211202212023120241202512026120271202812029120301203112032120331203412035120361203712038120391204012041120421204312044120451204612047120481204912050120511205212053120541205512056120571205812059120601206112062120631206412065120661206712068120691207012071120721207312074120751207612077120781207912080120811208212083120841208512086120871208812089120901209112092120931209412095120961209712098120991210012101121021210312104121051210612107121081210912110121111211212113121141211512116121171211812119121201212112122121231212412125121261212712128121291213012131121321213312134121351213612137121381213912140121411214212143121441214512146121471214812149121501215112152121531215412155121561215712158121591216012161121621216312164121651216612167121681216912170121711217212173121741217512176121771217812179121801218112182121831218412185121861218712188121891219012191121921219312194121951219612197121981219912200122011220212203122041220512206122071220812209122101221112212122131221412215122161221712218122191222012221122221222312224122251222612227122281222912230122311223212233122341223512236122371223812239122401224112242122431224412245122461224712248122491225012251122521225312254122551225612257122581225912260122611226212263122641226512266122671226812269122701227112272122731227412275122761227712278122791228012281122821228312284122851228612287122881228912290122911229212293122941229512296122971229812299123001230112302123031230412305123061230712308123091231012311123121231312314123151231612317123181231912320123211232212323123241232512326123271232812329123301233112332123331233412335123361233712338123391234012341123421234312344123451234612347123481234912350123511235212353123541235512356123571235812359123601236112362123631236412365123661236712368123691237012371123721237312374123751237612377123781237912380123811238212383123841238512386123871238812389123901239112392123931239412395123961239712398123991240012401124021240312404124051240612407124081240912410124111241212413124141241512416124171241812419124201242112422124231242412425124261242712428124291243012431124321243312434124351243612437124381243912440124411244212443124441244512446124471244812449124501245112452124531245412455124561245712458124591246012461124621246312464124651246612467124681246912470124711247212473124741247512476124771247812479124801248112482124831248412485124861248712488124891249012491124921249312494124951249612497124981249912500125011250212503125041250512506125071250812509125101251112512125131251412515125161251712518125191252012521125221252312524125251252612527125281252912530125311253212533125341253512536125371253812539125401254112542125431254412545125461254712548125491255012551125521255312554125551255612557125581255912560125611256212563125641256512566125671256812569125701257112572125731257412575125761257712578125791258012581125821258312584125851258612587125881258912590125911259212593125941259512596125971259812599126001260112602126031260412605126061260712608126091261012611126121261312614126151261612617126181261912620126211262212623126241262512626126271262812629126301263112632126331263412635126361263712638126391264012641126421264312644126451264612647126481264912650126511265212653126541265512656126571265812659126601266112662126631266412665126661266712668126691267012671126721267312674126751267612677126781267912680126811268212683126841268512686126871268812689126901269112692126931269412695126961269712698126991270012701127021270312704127051270612707127081270912710127111271212713127141271512716127171271812719127201272112722127231272412725127261272712728127291273012731127321273312734127351273612737127381273912740127411274212743127441274512746127471274812749127501275112752127531275412755127561275712758127591276012761127621276312764127651276612767127681276912770127711277212773127741277512776127771277812779127801278112782127831278412785127861278712788127891279012791127921279312794127951279612797127981279912800128011280212803128041280512806128071280812809128101281112812128131281412815128161281712818128191282012821128221282312824128251282612827128281282912830128311283212833128341283512836128371283812839128401284112842128431284412845128461284712848128491285012851128521285312854128551285612857128581285912860128611286212863128641286512866128671286812869128701287112872128731287412875128761287712878128791288012881128821288312884128851288612887128881288912890128911289212893128941289512896128971289812899129001290112902129031290412905129061290712908129091291012911129121291312914129151291612917129181291912920129211292212923129241292512926129271292812929129301293112932129331293412935129361293712938129391294012941129421294312944129451294612947129481294912950129511295212953129541295512956129571295812959129601296112962129631296412965129661296712968129691297012971129721297312974129751297612977129781297912980129811298212983129841298512986129871298812989129901299112992129931299412995129961299712998129991300013001130021300313004130051300613007130081300913010130111301213013130141301513016130171301813019130201302113022130231302413025130261302713028130291303013031130321303313034130351303613037130381303913040130411304213043130441304513046130471304813049130501305113052130531305413055130561305713058130591306013061130621306313064130651306613067130681306913070130711307213073130741307513076130771307813079130801308113082130831308413085130861308713088130891309013091130921309313094130951309613097130981309913100131011310213103131041310513106131071310813109131101311113112131131311413115131161311713118131191312013121131221312313124131251312613127131281312913130131311313213133131341313513136131371313813139131401314113142131431314413145131461314713148131491315013151131521315313154131551315613157131581315913160131611316213163131641316513166131671316813169131701317113172131731317413175131761317713178131791318013181131821318313184131851318613187131881318913190131911319213193131941319513196131971319813199132001320113202132031320413205132061320713208132091321013211132121321313214132151321613217132181321913220132211322213223132241322513226132271322813229132301323113232132331323413235132361323713238132391324013241132421324313244132451324613247132481324913250132511325213253132541325513256132571325813259132601326113262132631326413265132661326713268132691327013271132721327313274132751327613277132781327913280132811328213283132841328513286132871328813289132901329113292132931329413295132961329713298132991330013301133021330313304133051330613307133081330913310133111331213313133141331513316133171331813319133201332113322133231332413325133261332713328133291333013331133321333313334133351333613337133381333913340133411334213343133441334513346133471334813349133501335113352133531335413355133561335713358133591336013361133621336313364133651336613367133681336913370133711337213373133741337513376133771337813379133801338113382133831338413385133861338713388133891339013391133921339313394133951339613397133981339913400134011340213403134041340513406134071340813409134101341113412134131341413415134161341713418134191342013421134221342313424134251342613427134281342913430134311343213433134341343513436134371343813439134401344113442134431344413445134461344713448134491345013451134521345313454134551345613457134581345913460134611346213463134641346513466134671346813469134701347113472134731347413475134761347713478134791348013481134821348313484134851348613487134881348913490134911349213493134941349513496134971349813499135001350113502135031350413505135061350713508135091351013511135121351313514135151351613517135181351913520135211352213523135241352513526135271352813529135301353113532135331353413535135361353713538135391354013541135421354313544135451354613547135481354913550135511355213553135541355513556135571355813559135601356113562135631356413565135661356713568135691357013571135721357313574135751357613577135781357913580135811358213583135841358513586135871358813589135901359113592135931359413595135961359713598135991360013601136021360313604136051360613607136081360913610136111361213613136141361513616136171361813619136201362113622136231362413625136261362713628136291363013631136321363313634136351363613637136381363913640136411364213643136441364513646136471364813649136501365113652136531365413655136561365713658136591366013661136621366313664136651366613667136681366913670136711367213673136741367513676136771367813679136801368113682136831368413685136861368713688136891369013691136921369313694136951369613697136981369913700137011370213703137041370513706137071370813709137101371113712137131371413715137161371713718137191372013721137221372313724137251372613727137281372913730137311373213733137341373513736137371373813739137401374113742137431374413745137461374713748137491375013751137521375313754137551375613757137581375913760137611376213763137641376513766137671376813769137701377113772137731377413775137761377713778137791378013781137821378313784137851378613787137881378913790137911379213793137941379513796137971379813799138001380113802138031380413805138061380713808138091381013811138121381313814138151381613817138181381913820138211382213823138241382513826138271382813829138301383113832138331383413835138361383713838138391384013841138421384313844138451384613847138481384913850138511385213853138541385513856138571385813859138601386113862138631386413865138661386713868138691387013871138721387313874138751387613877138781387913880138811388213883138841388513886138871388813889138901389113892138931389413895138961389713898138991390013901139021390313904139051390613907139081390913910139111391213913139141391513916139171391813919139201392113922139231392413925139261392713928139291393013931139321393313934139351393613937139381393913940139411394213943139441394513946139471394813949139501395113952139531395413955139561395713958139591396013961139621396313964139651396613967139681396913970139711397213973139741397513976139771397813979139801398113982139831398413985139861398713988139891399013991139921399313994139951399613997139981399914000140011400214003140041400514006140071400814009140101401114012140131401414015140161401714018140191402014021140221402314024140251402614027140281402914030140311403214033140341403514036140371403814039140401404114042140431404414045140461404714048140491405014051140521405314054140551405614057140581405914060140611406214063140641406514066140671406814069140701407114072140731407414075140761407714078140791408014081140821408314084140851408614087140881408914090140911409214093140941409514096140971409814099141001410114102141031410414105141061410714108141091411014111141121411314114141151411614117141181411914120141211412214123141241412514126141271412814129141301413114132141331413414135141361413714138141391414014141141421414314144141451414614147141481414914150141511415214153141541415514156141571415814159141601416114162141631416414165141661416714168141691417014171141721417314174141751417614177141781417914180141811418214183141841418514186141871418814189141901419114192141931419414195141961419714198141991420014201142021420314204142051420614207142081420914210142111421214213142141421514216142171421814219142201422114222142231422414225142261422714228142291423014231142321423314234142351423614237142381423914240142411424214243142441424514246142471424814249142501425114252142531425414255142561425714258142591426014261142621426314264142651426614267142681426914270142711427214273142741427514276142771427814279142801428114282142831428414285142861428714288142891429014291142921429314294142951429614297142981429914300143011430214303143041430514306143071430814309143101431114312143131431414315143161431714318143191432014321143221432314324143251432614327143281432914330143311433214333143341433514336143371433814339143401434114342143431434414345143461434714348143491435014351143521435314354143551435614357143581435914360143611436214363143641436514366143671436814369143701437114372143731437414375143761437714378143791438014381143821438314384143851438614387143881438914390143911439214393143941439514396143971439814399144001440114402144031440414405144061440714408144091441014411144121441314414144151441614417144181441914420144211442214423144241442514426144271442814429144301443114432144331443414435144361443714438144391444014441144421444314444144451444614447144481444914450144511445214453144541445514456144571445814459144601446114462144631446414465144661446714468144691447014471144721447314474144751447614477144781447914480144811448214483144841448514486144871448814489144901449114492144931449414495144961449714498144991450014501145021450314504145051450614507145081450914510145111451214513145141451514516145171451814519145201452114522145231452414525145261452714528145291453014531145321453314534145351453614537145381453914540145411454214543145441454514546145471454814549145501455114552145531455414555145561455714558145591456014561145621456314564145651456614567145681456914570145711457214573145741457514576145771457814579145801458114582145831458414585145861458714588145891459014591145921459314594145951459614597145981459914600146011460214603146041460514606146071460814609146101461114612146131461414615146161461714618146191462014621146221462314624146251462614627146281462914630146311463214633146341463514636146371463814639146401464114642146431464414645146461464714648146491465014651146521465314654146551465614657146581465914660146611466214663146641466514666146671466814669146701467114672146731467414675146761467714678146791468014681146821468314684146851468614687146881468914690146911469214693146941469514696146971469814699147001470114702147031470414705147061470714708147091471014711147121471314714147151471614717147181471914720147211472214723147241472514726147271472814729147301473114732147331473414735147361473714738147391474014741147421474314744147451474614747147481474914750147511475214753147541475514756147571475814759147601476114762147631476414765147661476714768147691477014771147721477314774147751477614777147781477914780147811478214783147841478514786147871478814789147901479114792147931479414795147961479714798147991480014801148021480314804148051480614807148081480914810148111481214813148141481514816148171481814819148201482114822148231482414825148261482714828148291483014831148321483314834148351483614837148381483914840148411484214843148441484514846148471484814849148501485114852148531485414855148561485714858148591486014861148621486314864148651486614867148681486914870148711487214873148741487514876148771487814879148801488114882148831488414885148861488714888148891489014891148921489314894148951489614897148981489914900149011490214903149041490514906149071490814909149101491114912149131491414915149161491714918149191492014921149221492314924149251492614927149281492914930149311493214933149341493514936149371493814939149401494114942149431494414945149461494714948149491495014951149521495314954149551495614957149581495914960149611496214963149641496514966149671496814969149701497114972149731497414975149761497714978149791498014981149821498314984149851498614987149881498914990149911499214993149941499514996149971499814999150001500115002150031500415005150061500715008150091501015011150121501315014150151501615017150181501915020150211502215023150241502515026150271502815029150301503115032150331503415035150361503715038150391504015041150421504315044150451504615047150481504915050150511505215053150541505515056150571505815059150601506115062150631506415065150661506715068150691507015071150721507315074150751507615077150781507915080150811508215083150841508515086150871508815089150901509115092150931509415095150961509715098150991510015101151021510315104151051510615107151081510915110151111511215113151141511515116151171511815119151201512115122151231512415125151261512715128151291513015131151321513315134151351513615137151381513915140151411514215143151441514515146151471514815149151501515115152151531515415155151561515715158151591516015161151621516315164151651516615167151681516915170151711517215173151741517515176151771517815179151801518115182151831518415185151861518715188151891519015191151921519315194151951519615197151981519915200152011520215203152041520515206152071520815209152101521115212152131521415215152161521715218152191522015221152221522315224152251522615227152281522915230152311523215233152341523515236152371523815239152401524115242152431524415245152461524715248152491525015251152521525315254152551525615257152581525915260152611526215263152641526515266152671526815269152701527115272152731527415275152761527715278152791528015281152821528315284152851528615287152881528915290152911529215293152941529515296152971529815299153001530115302153031530415305153061530715308153091531015311153121531315314153151531615317153181531915320153211532215323153241532515326153271532815329153301533115332153331533415335153361533715338153391534015341153421534315344153451534615347153481534915350153511535215353153541535515356153571535815359153601536115362153631536415365153661536715368153691537015371153721537315374153751537615377153781537915380153811538215383153841538515386153871538815389153901539115392153931539415395153961539715398153991540015401154021540315404154051540615407154081540915410154111541215413154141541515416154171541815419154201542115422154231542415425154261542715428154291543015431154321543315434154351543615437154381543915440154411544215443154441544515446154471544815449154501545115452154531545415455154561545715458154591546015461154621546315464154651546615467154681546915470154711547215473154741547515476154771547815479154801548115482154831548415485154861548715488154891549015491154921549315494154951549615497154981549915500155011550215503155041550515506155071550815509155101551115512155131551415515155161551715518155191552015521155221552315524155251552615527155281552915530155311553215533155341553515536155371553815539155401554115542155431554415545155461554715548155491555015551155521555315554155551555615557155581555915560155611556215563155641556515566155671556815569155701557115572155731557415575155761557715578155791558015581155821558315584155851558615587155881558915590155911559215593155941559515596155971559815599156001560115602156031560415605156061560715608156091561015611156121561315614156151561615617156181561915620156211562215623156241562515626156271562815629156301563115632156331563415635156361563715638156391564015641156421564315644156451564615647156481564915650156511565215653156541565515656156571565815659156601566115662156631566415665156661566715668156691567015671156721567315674156751567615677156781567915680156811568215683156841568515686156871568815689156901569115692156931569415695156961569715698156991570015701157021570315704157051570615707157081570915710157111571215713157141571515716157171571815719157201572115722157231572415725157261572715728157291573015731157321573315734157351573615737157381573915740157411574215743157441574515746157471574815749157501575115752157531575415755157561575715758157591576015761157621576315764157651576615767157681576915770157711577215773157741577515776157771577815779157801578115782157831578415785157861578715788157891579015791157921579315794157951579615797157981579915800158011580215803158041580515806158071580815809158101581115812158131581415815158161581715818158191582015821158221582315824158251582615827158281582915830158311583215833158341583515836158371583815839158401584115842158431584415845158461584715848158491585015851158521585315854158551585615857158581585915860158611586215863158641586515866158671586815869158701587115872158731587415875158761587715878158791588015881158821588315884158851588615887158881588915890158911589215893158941589515896158971589815899159001590115902159031590415905159061590715908159091591015911159121591315914159151591615917159181591915920159211592215923159241592515926159271592815929159301593115932159331593415935159361593715938159391594015941159421594315944159451594615947159481594915950159511595215953159541595515956159571595815959159601596115962159631596415965159661596715968159691597015971159721597315974159751597615977159781597915980159811598215983159841598515986159871598815989159901599115992159931599415995159961599715998159991600016001160021600316004160051600616007160081600916010160111601216013160141601516016160171601816019160201602116022160231602416025160261602716028160291603016031160321603316034160351603616037160381603916040160411604216043160441604516046160471604816049160501605116052160531605416055160561605716058160591606016061160621606316064160651606616067160681606916070160711607216073160741607516076160771607816079160801608116082160831608416085160861608716088160891609016091160921609316094160951609616097160981609916100161011610216103161041610516106161071610816109161101611116112161131611416115161161611716118161191612016121161221612316124161251612616127161281612916130161311613216133161341613516136161371613816139161401614116142161431614416145161461614716148161491615016151161521615316154161551615616157161581615916160161611616216163161641616516166161671616816169161701617116172161731617416175161761617716178161791618016181161821618316184161851618616187161881618916190161911619216193161941619516196161971619816199162001620116202162031620416205162061620716208162091621016211162121621316214162151621616217162181621916220162211622216223162241622516226162271622816229162301623116232162331623416235162361623716238162391624016241162421624316244162451624616247162481624916250162511625216253162541625516256162571625816259162601626116262162631626416265162661626716268162691627016271162721627316274162751627616277162781627916280162811628216283162841628516286162871628816289162901629116292162931629416295162961629716298162991630016301163021630316304163051630616307163081630916310163111631216313163141631516316163171631816319163201632116322163231632416325163261632716328163291633016331163321633316334163351633616337163381633916340163411634216343163441634516346163471634816349163501635116352163531635416355163561635716358163591636016361163621636316364163651636616367163681636916370163711637216373163741637516376163771637816379163801638116382163831638416385163861638716388163891639016391163921639316394163951639616397163981639916400164011640216403164041640516406164071640816409164101641116412164131641416415164161641716418164191642016421164221642316424164251642616427164281642916430164311643216433164341643516436164371643816439164401644116442164431644416445164461644716448164491645016451164521645316454164551645616457164581645916460164611646216463164641646516466164671646816469164701647116472164731647416475164761647716478164791648016481164821648316484164851648616487164881648916490164911649216493164941649516496164971649816499165001650116502165031650416505165061650716508165091651016511165121651316514165151651616517165181651916520165211652216523165241652516526165271652816529165301653116532165331653416535165361653716538165391654016541165421654316544165451654616547165481654916550165511655216553165541655516556165571655816559165601656116562165631656416565165661656716568165691657016571165721657316574165751657616577165781657916580165811658216583165841658516586165871658816589165901659116592165931659416595165961659716598165991660016601166021660316604166051660616607166081660916610166111661216613166141661516616166171661816619166201662116622166231662416625166261662716628166291663016631166321663316634166351663616637166381663916640166411664216643166441664516646166471664816649166501665116652166531665416655166561665716658166591666016661166621666316664166651666616667166681666916670166711667216673166741667516676166771667816679166801668116682166831668416685166861668716688166891669016691166921669316694166951669616697166981669916700167011670216703167041670516706167071670816709167101671116712167131671416715167161671716718167191672016721167221672316724167251672616727167281672916730167311673216733167341673516736167371673816739167401674116742167431674416745167461674716748167491675016751167521675316754167551675616757167581675916760167611676216763167641676516766167671676816769167701677116772167731677416775167761677716778167791678016781167821678316784167851678616787167881678916790167911679216793167941679516796167971679816799168001680116802168031680416805168061680716808168091681016811168121681316814168151681616817168181681916820168211682216823168241682516826168271682816829168301683116832168331683416835168361683716838168391684016841168421684316844168451684616847168481684916850168511685216853168541685516856168571685816859168601686116862168631686416865168661686716868168691687016871168721687316874168751687616877168781687916880168811688216883168841688516886168871688816889168901689116892168931689416895168961689716898168991690016901169021690316904169051690616907169081690916910169111691216913169141691516916169171691816919169201692116922169231692416925169261692716928169291693016931169321693316934169351693616937169381693916940169411694216943169441694516946169471694816949169501695116952169531695416955169561695716958169591696016961169621696316964169651696616967169681696916970169711697216973169741697516976169771697816979169801698116982169831698416985169861698716988169891699016991169921699316994169951699616997169981699917000170011700217003170041700517006170071700817009170101701117012170131701417015170161701717018170191702017021170221702317024170251702617027170281702917030170311703217033170341703517036170371703817039170401704117042170431704417045170461704717048170491705017051170521705317054170551705617057170581705917060170611706217063170641706517066170671706817069170701707117072170731707417075170761707717078170791708017081170821708317084170851708617087170881708917090170911709217093170941709517096170971709817099171001710117102171031710417105171061710717108171091711017111171121711317114171151711617117171181711917120171211712217123171241712517126171271712817129171301713117132171331713417135171361713717138171391714017141171421714317144171451714617147171481714917150171511715217153171541715517156171571715817159171601716117162171631716417165171661716717168171691717017171171721717317174171751717617177171781717917180171811718217183171841718517186171871718817189171901719117192171931719417195171961719717198171991720017201172021720317204172051720617207172081720917210172111721217213172141721517216172171721817219172201722117222172231722417225172261722717228172291723017231172321723317234172351723617237172381723917240172411724217243172441724517246172471724817249172501725117252172531725417255172561725717258172591726017261172621726317264172651726617267172681726917270172711727217273172741727517276172771727817279172801728117282172831728417285172861728717288172891729017291172921729317294172951729617297172981729917300173011730217303173041730517306173071730817309173101731117312173131731417315173161731717318173191732017321173221732317324173251732617327173281732917330173311733217333173341733517336173371733817339173401734117342173431734417345173461734717348173491735017351173521735317354173551735617357173581735917360173611736217363173641736517366173671736817369173701737117372173731737417375173761737717378173791738017381173821738317384173851738617387173881738917390173911739217393173941739517396173971739817399174001740117402174031740417405174061740717408174091741017411174121741317414174151741617417174181741917420174211742217423174241742517426174271742817429174301743117432174331743417435174361743717438174391744017441174421744317444174451744617447174481744917450174511745217453174541745517456174571745817459174601746117462174631746417465174661746717468174691747017471174721747317474174751747617477174781747917480174811748217483174841748517486174871748817489174901749117492174931749417495174961749717498174991750017501175021750317504175051750617507175081750917510175111751217513175141751517516175171751817519175201752117522175231752417525175261752717528175291753017531175321753317534175351753617537175381753917540175411754217543175441754517546175471754817549175501755117552175531755417555175561755717558175591756017561175621756317564175651756617567175681756917570175711757217573175741757517576175771757817579175801758117582175831758417585175861758717588175891759017591175921759317594175951759617597175981759917600176011760217603176041760517606176071760817609176101761117612176131761417615176161761717618176191762017621176221762317624176251762617627176281762917630176311763217633176341763517636176371763817639176401764117642176431764417645176461764717648176491765017651176521765317654176551765617657176581765917660176611766217663176641766517666176671766817669176701767117672176731767417675176761767717678176791768017681176821768317684176851768617687176881768917690176911769217693176941769517696176971769817699177001770117702177031770417705177061770717708177091771017711177121771317714177151771617717177181771917720177211772217723177241772517726177271772817729177301773117732177331773417735177361773717738177391774017741177421774317744177451774617747177481774917750177511775217753177541775517756177571775817759177601776117762177631776417765177661776717768177691777017771177721777317774177751777617777177781777917780177811778217783177841778517786177871778817789177901779117792177931779417795177961779717798177991780017801178021780317804178051780617807178081780917810178111781217813178141781517816178171781817819178201782117822178231782417825178261782717828178291783017831178321783317834178351783617837178381783917840178411784217843178441784517846178471784817849178501785117852178531785417855178561785717858178591786017861178621786317864178651786617867178681786917870178711787217873178741787517876178771787817879178801788117882178831788417885178861788717888178891789017891178921789317894178951789617897178981789917900179011790217903179041790517906179071790817909179101791117912179131791417915179161791717918179191792017921179221792317924179251792617927179281792917930179311793217933179341793517936179371793817939179401794117942179431794417945179461794717948179491795017951179521795317954179551795617957179581795917960179611796217963179641796517966179671796817969179701797117972179731797417975179761797717978179791798017981179821798317984179851798617987179881798917990179911799217993179941799517996179971799817999180001800118002180031800418005180061800718008180091801018011180121801318014180151801618017180181801918020180211802218023180241802518026180271802818029180301803118032180331803418035180361803718038180391804018041180421804318044180451804618047180481804918050180511805218053180541805518056180571805818059180601806118062180631806418065180661806718068180691807018071180721807318074180751807618077180781807918080180811808218083180841808518086180871808818089180901809118092180931809418095180961809718098180991810018101181021810318104181051810618107181081810918110181111811218113181141811518116181171811818119181201812118122181231812418125181261812718128181291813018131181321813318134181351813618137181381813918140181411814218143181441814518146181471814818149181501815118152181531815418155181561815718158181591816018161181621816318164181651816618167181681816918170181711817218173181741817518176181771817818179181801818118182181831818418185181861818718188181891819018191181921819318194181951819618197181981819918200182011820218203182041820518206182071820818209182101821118212182131821418215182161821718218182191822018221182221822318224182251822618227182281822918230182311823218233182341823518236182371823818239182401824118242182431824418245182461824718248182491825018251182521825318254182551825618257182581825918260182611826218263182641826518266182671826818269182701827118272182731827418275182761827718278182791828018281182821828318284182851828618287182881828918290182911829218293182941829518296182971829818299183001830118302183031830418305183061830718308183091831018311183121831318314183151831618317183181831918320183211832218323183241832518326183271832818329183301833118332183331833418335183361833718338183391834018341183421834318344183451834618347183481834918350183511835218353183541835518356183571835818359183601836118362183631836418365183661836718368183691837018371183721837318374183751837618377183781837918380183811838218383183841838518386183871838818389183901839118392183931839418395183961839718398183991840018401184021840318404184051840618407184081840918410184111841218413184141841518416184171841818419184201842118422184231842418425184261842718428184291843018431184321843318434184351843618437184381843918440184411844218443184441844518446184471844818449184501845118452184531845418455184561845718458184591846018461184621846318464184651846618467184681846918470184711847218473184741847518476184771847818479184801848118482184831848418485184861848718488184891849018491184921849318494184951849618497184981849918500185011850218503185041850518506185071850818509185101851118512185131851418515185161851718518185191852018521185221852318524185251852618527185281852918530185311853218533185341853518536185371853818539185401854118542185431854418545185461854718548185491855018551185521855318554185551855618557185581855918560185611856218563185641856518566185671856818569185701857118572185731857418575185761857718578185791858018581185821858318584185851858618587185881858918590185911859218593185941859518596185971859818599186001860118602186031860418605186061860718608186091861018611186121861318614186151861618617186181861918620186211862218623186241862518626186271862818629186301863118632186331863418635186361863718638186391864018641186421864318644186451864618647186481864918650186511865218653186541865518656186571865818659186601866118662186631866418665186661866718668186691867018671186721867318674186751867618677186781867918680186811868218683186841868518686186871868818689186901869118692186931869418695186961869718698186991870018701187021870318704187051870618707187081870918710187111871218713187141871518716187171871818719187201872118722187231872418725187261872718728187291873018731187321873318734187351873618737187381873918740187411874218743187441874518746187471874818749187501875118752187531875418755187561875718758187591876018761187621876318764187651876618767187681876918770187711877218773187741877518776187771877818779187801878118782187831878418785187861878718788187891879018791187921879318794187951879618797187981879918800188011880218803188041880518806188071880818809188101881118812188131881418815188161881718818188191882018821188221882318824188251882618827188281882918830188311883218833188341883518836188371883818839188401884118842188431884418845188461884718848188491885018851188521885318854188551885618857188581885918860188611886218863188641886518866188671886818869188701887118872188731887418875188761887718878188791888018881188821888318884188851888618887188881888918890188911889218893188941889518896188971889818899189001890118902189031890418905189061890718908189091891018911189121891318914189151891618917189181891918920189211892218923189241892518926189271892818929189301893118932189331893418935189361893718938189391894018941189421894318944189451894618947189481894918950189511895218953189541895518956189571895818959189601896118962189631896418965189661896718968189691897018971189721897318974189751897618977189781897918980189811898218983189841898518986189871898818989189901899118992189931899418995189961899718998189991900019001190021900319004190051900619007190081900919010190111901219013190141901519016190171901819019190201902119022190231902419025190261902719028190291903019031190321903319034190351903619037190381903919040190411904219043190441904519046190471904819049190501905119052190531905419055190561905719058190591906019061190621906319064190651906619067190681906919070190711907219073190741907519076190771907819079190801908119082190831908419085190861908719088190891909019091190921909319094190951909619097190981909919100191011910219103191041910519106191071910819109191101911119112191131911419115191161911719118191191912019121191221912319124191251912619127191281912919130191311913219133191341913519136191371913819139191401914119142191431914419145191461914719148191491915019151191521915319154191551915619157191581915919160191611916219163191641916519166191671916819169191701917119172191731917419175191761917719178191791918019181191821918319184191851918619187191881918919190191911919219193191941919519196191971919819199192001920119202192031920419205192061920719208192091921019211192121921319214192151921619217192181921919220192211922219223192241922519226192271922819229192301923119232192331923419235192361923719238192391924019241192421924319244192451924619247192481924919250192511925219253192541925519256192571925819259192601926119262192631926419265192661926719268192691927019271192721927319274192751927619277192781927919280192811928219283192841928519286192871928819289192901929119292192931929419295192961929719298192991930019301193021930319304193051930619307193081930919310193111931219313193141931519316193171931819319193201932119322193231932419325193261932719328193291933019331193321933319334193351933619337193381933919340193411934219343193441934519346193471934819349193501935119352193531935419355193561935719358193591936019361193621936319364193651936619367193681936919370193711937219373193741937519376193771937819379193801938119382193831938419385193861938719388193891939019391193921939319394193951939619397193981939919400194011940219403194041940519406194071940819409194101941119412194131941419415194161941719418194191942019421194221942319424194251942619427194281942919430194311943219433194341943519436194371943819439194401944119442194431944419445194461944719448194491945019451194521945319454194551945619457194581945919460194611946219463194641946519466194671946819469194701947119472194731947419475194761947719478194791948019481194821948319484194851948619487194881948919490194911949219493194941949519496194971949819499195001950119502195031950419505195061950719508195091951019511195121951319514195151951619517195181951919520195211952219523195241952519526195271952819529195301953119532195331953419535195361953719538195391954019541195421954319544195451954619547195481954919550195511955219553195541955519556195571955819559195601956119562195631956419565195661956719568195691957019571195721957319574195751957619577195781957919580195811958219583195841958519586195871958819589195901959119592195931959419595195961959719598195991960019601196021960319604196051960619607196081960919610196111961219613196141961519616196171961819619196201962119622196231962419625196261962719628196291963019631196321963319634196351963619637196381963919640196411964219643196441964519646196471964819649196501965119652196531965419655196561965719658196591966019661196621966319664196651966619667196681966919670196711967219673196741967519676196771967819679196801968119682196831968419685196861968719688196891969019691196921969319694196951969619697196981969919700197011970219703197041970519706197071970819709197101971119712197131971419715197161971719718197191972019721197221972319724197251972619727197281972919730197311973219733197341973519736197371973819739197401974119742197431974419745197461974719748197491975019751197521975319754197551975619757197581975919760197611976219763197641976519766197671976819769197701977119772197731977419775197761977719778197791978019781197821978319784197851978619787197881978919790197911979219793197941979519796197971979819799198001980119802198031980419805198061980719808198091981019811198121981319814198151981619817198181981919820198211982219823198241982519826198271982819829198301983119832198331983419835198361983719838198391984019841198421984319844198451984619847198481984919850198511985219853198541985519856198571985819859198601986119862198631986419865198661986719868198691987019871198721987319874198751987619877198781987919880198811988219883198841988519886198871988819889198901989119892198931989419895198961989719898198991990019901199021990319904199051990619907199081990919910199111991219913199141991519916199171991819919199201992119922199231992419925199261992719928199291993019931199321993319934199351993619937199381993919940199411994219943199441994519946199471994819949199501995119952199531995419955199561995719958199591996019961199621996319964199651996619967199681996919970199711997219973199741997519976199771997819979199801998119982199831998419985199861998719988199891999019991199921999319994199951999619997199981999920000200012000220003200042000520006200072000820009200102001120012200132001420015200162001720018200192002020021200222002320024200252002620027200282002920030200312003220033200342003520036200372003820039200402004120042200432004420045200462004720048200492005020051200522005320054200552005620057200582005920060200612006220063200642006520066200672006820069200702007120072200732007420075200762007720078200792008020081200822008320084200852008620087200882008920090200912009220093200942009520096200972009820099201002010120102201032010420105201062010720108201092011020111201122011320114201152011620117201182011920120201212012220123201242012520126201272012820129201302013120132201332013420135201362013720138201392014020141201422014320144201452014620147201482014920150201512015220153201542015520156201572015820159201602016120162201632016420165201662016720168201692017020171201722017320174201752017620177201782017920180201812018220183201842018520186201872018820189201902019120192201932019420195201962019720198201992020020201202022020320204202052020620207202082020920210202112021220213202142021520216202172021820219202202022120222202232022420225202262022720228202292023020231202322023320234202352023620237202382023920240202412024220243202442024520246202472024820249202502025120252202532025420255202562025720258202592026020261202622026320264202652026620267202682026920270202712027220273202742027520276202772027820279202802028120282202832028420285202862028720288202892029020291202922029320294202952029620297202982029920300203012030220303203042030520306203072030820309203102031120312203132031420315203162031720318203192032020321203222032320324203252032620327203282032920330203312033220333203342033520336203372033820339203402034120342203432034420345203462034720348203492035020351203522035320354203552035620357203582035920360203612036220363203642036520366203672036820369203702037120372203732037420375203762037720378203792038020381203822038320384203852038620387203882038920390203912039220393203942039520396203972039820399204002040120402204032040420405204062040720408204092041020411204122041320414204152041620417204182041920420204212042220423204242042520426204272042820429204302043120432204332043420435204362043720438204392044020441204422044320444204452044620447204482044920450204512045220453204542045520456204572045820459204602046120462204632046420465204662046720468204692047020471204722047320474204752047620477204782047920480204812048220483204842048520486204872048820489204902049120492204932049420495204962049720498204992050020501205022050320504205052050620507205082050920510205112051220513205142051520516205172051820519205202052120522205232052420525205262052720528205292053020531205322053320534205352053620537205382053920540205412054220543205442054520546205472054820549205502055120552205532055420555205562055720558205592056020561205622056320564205652056620567205682056920570205712057220573205742057520576205772057820579205802058120582205832058420585205862058720588205892059020591205922059320594205952059620597205982059920600206012060220603206042060520606206072060820609206102061120612206132061420615206162061720618206192062020621206222062320624206252062620627206282062920630206312063220633206342063520636206372063820639206402064120642206432064420645206462064720648206492065020651206522065320654206552065620657206582065920660206612066220663206642066520666206672066820669206702067120672206732067420675206762067720678206792068020681206822068320684206852068620687206882068920690206912069220693206942069520696206972069820699207002070120702207032070420705207062070720708207092071020711207122071320714207152071620717207182071920720207212072220723207242072520726207272072820729207302073120732207332073420735207362073720738207392074020741207422074320744207452074620747207482074920750207512075220753207542075520756207572075820759207602076120762207632076420765207662076720768207692077020771207722077320774207752077620777207782077920780207812078220783207842078520786207872078820789207902079120792207932079420795207962079720798207992080020801208022080320804208052080620807208082080920810208112081220813208142081520816208172081820819208202082120822208232082420825208262082720828208292083020831208322083320834208352083620837208382083920840208412084220843208442084520846208472084820849208502085120852208532085420855208562085720858208592086020861208622086320864208652086620867208682086920870208712087220873208742087520876208772087820879208802088120882208832088420885208862088720888208892089020891208922089320894208952089620897208982089920900209012090220903209042090520906209072090820909209102091120912209132091420915209162091720918209192092020921209222092320924209252092620927209282092920930209312093220933209342093520936209372093820939209402094120942209432094420945209462094720948209492095020951209522095320954209552095620957209582095920960209612096220963209642096520966209672096820969209702097120972209732097420975209762097720978209792098020981209822098320984209852098620987209882098920990209912099220993209942099520996209972099820999210002100121002210032100421005210062100721008210092101021011210122101321014210152101621017210182101921020210212102221023210242102521026210272102821029210302103121032210332103421035210362103721038210392104021041210422104321044210452104621047210482104921050210512105221053210542105521056210572105821059210602106121062210632106421065210662106721068210692107021071210722107321074210752107621077210782107921080210812108221083210842108521086210872108821089210902109121092210932109421095210962109721098210992110021101211022110321104211052110621107211082110921110211112111221113211142111521116211172111821119211202112121122211232112421125211262112721128211292113021131211322113321134211352113621137211382113921140211412114221143211442114521146211472114821149211502115121152211532115421155211562115721158211592116021161211622116321164211652116621167211682116921170211712117221173211742117521176211772117821179211802118121182211832118421185211862118721188211892119021191211922119321194211952119621197211982119921200212012120221203212042120521206212072120821209212102121121212212132121421215212162121721218212192122021221212222122321224212252122621227212282122921230212312123221233212342123521236212372123821239212402124121242212432124421245212462124721248212492125021251212522125321254212552125621257212582125921260212612126221263212642126521266212672126821269212702127121272212732127421275212762127721278212792128021281212822128321284212852128621287212882128921290212912129221293212942129521296212972129821299213002130121302213032130421305213062130721308213092131021311213122131321314213152131621317213182131921320213212132221323213242132521326213272132821329213302133121332213332133421335213362133721338213392134021341213422134321344213452134621347213482134921350213512135221353213542135521356213572135821359213602136121362213632136421365213662136721368213692137021371213722137321374213752137621377213782137921380213812138221383213842138521386213872138821389213902139121392213932139421395213962139721398213992140021401214022140321404214052140621407214082140921410214112141221413214142141521416214172141821419214202142121422214232142421425214262142721428214292143021431214322143321434214352143621437214382143921440214412144221443214442144521446214472144821449214502145121452214532145421455214562145721458214592146021461214622146321464214652146621467214682146921470214712147221473214742147521476214772147821479214802148121482214832148421485214862148721488214892149021491214922149321494214952149621497214982149921500215012150221503215042150521506215072150821509215102151121512215132151421515215162151721518215192152021521215222152321524215252152621527215282152921530215312153221533215342153521536215372153821539215402154121542215432154421545215462154721548215492155021551215522155321554215552155621557215582155921560215612156221563215642156521566215672156821569215702157121572215732157421575215762157721578215792158021581215822158321584215852158621587215882158921590215912159221593215942159521596215972159821599216002160121602216032160421605216062160721608216092161021611216122161321614216152161621617216182161921620216212162221623216242162521626216272162821629216302163121632216332163421635216362163721638216392164021641216422164321644216452164621647216482164921650216512165221653216542165521656216572165821659216602166121662216632166421665216662166721668216692167021671216722167321674216752167621677216782167921680216812168221683216842168521686216872168821689216902169121692216932169421695216962169721698216992170021701217022170321704217052170621707217082170921710217112171221713217142171521716217172171821719217202172121722217232172421725217262172721728217292173021731217322173321734217352173621737217382173921740217412174221743217442174521746217472174821749217502175121752217532175421755217562175721758217592176021761217622176321764217652176621767217682176921770217712177221773217742177521776217772177821779217802178121782217832178421785217862178721788217892179021791217922179321794217952179621797217982179921800218012180221803218042180521806218072180821809218102181121812218132181421815218162181721818218192182021821218222182321824218252182621827218282182921830218312183221833218342183521836218372183821839218402184121842218432184421845218462184721848218492185021851218522185321854218552185621857218582185921860218612186221863218642186521866218672186821869218702187121872218732187421875218762187721878218792188021881218822188321884218852188621887218882188921890218912189221893218942189521896218972189821899219002190121902219032190421905219062190721908219092191021911219122191321914219152191621917219182191921920219212192221923219242192521926219272192821929219302193121932219332193421935219362193721938219392194021941219422194321944219452194621947219482194921950219512195221953219542195521956219572195821959219602196121962219632196421965219662196721968219692197021971219722197321974219752197621977219782197921980219812198221983219842198521986219872198821989219902199121992219932199421995219962199721998219992200022001220022200322004220052200622007220082200922010220112201222013220142201522016220172201822019220202202122022220232202422025220262202722028220292203022031220322203322034220352203622037220382203922040220412204222043220442204522046220472204822049220502205122052220532205422055220562205722058220592206022061220622206322064220652206622067220682206922070220712207222073220742207522076220772207822079220802208122082220832208422085220862208722088220892209022091220922209322094220952209622097220982209922100221012210222103221042210522106221072210822109221102211122112221132211422115221162211722118221192212022121221222212322124221252212622127221282212922130221312213222133221342213522136221372213822139221402214122142221432214422145221462214722148221492215022151221522215322154221552215622157221582215922160221612216222163221642216522166221672216822169221702217122172221732217422175221762217722178221792218022181221822218322184221852218622187221882218922190221912219222193221942219522196221972219822199222002220122202222032220422205222062220722208222092221022211222122221322214222152221622217222182221922220222212222222223222242222522226222272222822229222302223122232222332223422235222362223722238222392224022241222422224322244222452224622247222482224922250222512225222253222542225522256222572225822259222602226122262222632226422265222662226722268222692227022271222722227322274222752227622277222782227922280222812228222283222842228522286222872228822289222902229122292222932229422295222962229722298222992230022301223022230322304223052230622307223082230922310223112231222313223142231522316223172231822319223202232122322223232232422325223262232722328223292233022331223322233322334223352233622337223382233922340223412234222343223442234522346223472234822349223502235122352223532235422355223562235722358223592236022361223622236322364223652236622367223682236922370223712237222373223742237522376223772237822379223802238122382223832238422385223862238722388223892239022391223922239322394223952239622397223982239922400224012240222403224042240522406224072240822409224102241122412224132241422415224162241722418224192242022421224222242322424224252242622427224282242922430224312243222433224342243522436224372243822439224402244122442224432244422445224462244722448224492245022451224522245322454224552245622457224582245922460224612246222463224642246522466224672246822469224702247122472224732247422475224762247722478224792248022481224822248322484224852248622487224882248922490224912249222493224942249522496224972249822499225002250122502225032250422505225062250722508225092251022511225122251322514225152251622517225182251922520225212252222523225242252522526225272252822529225302253122532225332253422535225362253722538225392254022541225422254322544225452254622547225482254922550225512255222553225542255522556225572255822559225602256122562225632256422565225662256722568225692257022571225722257322574225752257622577225782257922580225812258222583225842258522586225872258822589225902259122592225932259422595225962259722598225992260022601226022260322604226052260622607226082260922610226112261222613226142261522616226172261822619226202262122622226232262422625226262262722628226292263022631226322263322634226352263622637226382263922640226412264222643226442264522646226472264822649226502265122652226532265422655226562265722658226592266022661226622266322664226652266622667226682266922670226712267222673226742267522676226772267822679226802268122682226832268422685226862268722688226892269022691226922269322694226952269622697226982269922700227012270222703227042270522706227072270822709227102271122712227132271422715227162271722718227192272022721227222272322724227252272622727227282272922730227312273222733227342273522736227372273822739227402274122742227432274422745227462274722748227492275022751227522275322754227552275622757227582275922760227612276222763227642276522766227672276822769227702277122772227732277422775227762277722778227792278022781227822278322784227852278622787227882278922790227912279222793227942279522796227972279822799228002280122802228032280422805228062280722808228092281022811228122281322814228152281622817228182281922820228212282222823228242282522826228272282822829228302283122832228332283422835228362283722838228392284022841228422284322844228452284622847228482284922850228512285222853228542285522856228572285822859228602286122862228632286422865228662286722868228692287022871228722287322874228752287622877228782287922880228812288222883228842288522886228872288822889228902289122892228932289422895228962289722898228992290022901229022290322904229052290622907229082290922910229112291222913229142291522916229172291822919229202292122922229232292422925229262292722928229292293022931229322293322934229352293622937229382293922940229412294222943229442294522946229472294822949229502295122952229532295422955229562295722958229592296022961229622296322964229652296622967229682296922970229712297222973229742297522976229772297822979229802298122982229832298422985229862298722988229892299022991229922299322994229952299622997229982299923000230012300223003230042300523006230072300823009230102301123012230132301423015230162301723018230192302023021230222302323024230252302623027230282302923030230312303223033230342303523036230372303823039230402304123042230432304423045230462304723048230492305023051230522305323054230552305623057230582305923060230612306223063230642306523066230672306823069230702307123072230732307423075230762307723078230792308023081230822308323084230852308623087230882308923090230912309223093230942309523096230972309823099231002310123102231032310423105231062310723108231092311023111231122311323114231152311623117231182311923120231212312223123231242312523126231272312823129231302313123132231332313423135231362313723138231392314023141231422314323144231452314623147231482314923150231512315223153231542315523156231572315823159231602316123162231632316423165231662316723168231692317023171231722317323174231752317623177231782317923180231812318223183231842318523186231872318823189231902319123192231932319423195231962319723198231992320023201232022320323204232052320623207232082320923210232112321223213232142321523216232172321823219232202322123222232232322423225232262322723228232292323023231232322323323234232352323623237232382323923240232412324223243232442324523246232472324823249232502325123252232532325423255232562325723258232592326023261232622326323264232652326623267232682326923270232712327223273232742327523276232772327823279232802328123282232832328423285232862328723288232892329023291232922329323294232952329623297232982329923300233012330223303233042330523306233072330823309233102331123312233132331423315233162331723318233192332023321233222332323324233252332623327233282332923330233312333223333233342333523336233372333823339233402334123342233432334423345233462334723348233492335023351233522335323354233552335623357233582335923360233612336223363233642336523366233672336823369233702337123372233732337423375233762337723378233792338023381233822338323384233852338623387233882338923390233912339223393233942339523396233972339823399234002340123402234032340423405234062340723408234092341023411234122341323414234152341623417234182341923420234212342223423234242342523426234272342823429234302343123432234332343423435234362343723438234392344023441234422344323444234452344623447234482344923450234512345223453234542345523456234572345823459234602346123462234632346423465234662346723468234692347023471234722347323474234752347623477234782347923480234812348223483234842348523486234872348823489234902349123492234932349423495234962349723498234992350023501235022350323504235052350623507235082350923510235112351223513235142351523516235172351823519235202352123522235232352423525235262352723528235292353023531235322353323534235352353623537235382353923540235412354223543235442354523546235472354823549235502355123552235532355423555235562355723558235592356023561235622356323564235652356623567235682356923570235712357223573235742357523576235772357823579235802358123582235832358423585235862358723588235892359023591235922359323594235952359623597235982359923600236012360223603236042360523606236072360823609236102361123612236132361423615236162361723618236192362023621236222362323624236252362623627236282362923630236312363223633236342363523636236372363823639236402364123642236432364423645236462364723648236492365023651236522365323654236552365623657236582365923660236612366223663236642366523666236672366823669236702367123672236732367423675236762367723678236792368023681236822368323684236852368623687236882368923690236912369223693236942369523696236972369823699237002370123702237032370423705237062370723708237092371023711237122371323714237152371623717237182371923720237212372223723237242372523726237272372823729237302373123732237332373423735237362373723738237392374023741237422374323744237452374623747237482374923750237512375223753237542375523756237572375823759237602376123762237632376423765237662376723768237692377023771237722377323774237752377623777237782377923780237812378223783237842378523786237872378823789237902379123792237932379423795237962379723798237992380023801238022380323804238052380623807238082380923810238112381223813238142381523816238172381823819238202382123822238232382423825238262382723828238292383023831238322383323834238352383623837238382383923840238412384223843238442384523846238472384823849238502385123852238532385423855238562385723858238592386023861238622386323864238652386623867238682386923870238712387223873238742387523876238772387823879238802388123882238832388423885238862388723888238892389023891238922389323894238952389623897238982389923900239012390223903239042390523906239072390823909239102391123912239132391423915239162391723918239192392023921239222392323924239252392623927239282392923930239312393223933239342393523936239372393823939239402394123942239432394423945239462394723948239492395023951239522395323954239552395623957239582395923960239612396223963239642396523966239672396823969239702397123972239732397423975239762397723978239792398023981239822398323984239852398623987239882398923990239912399223993239942399523996239972399823999240002400124002240032400424005240062400724008240092401024011240122401324014240152401624017240182401924020240212402224023240242402524026240272402824029240302403124032240332403424035240362403724038240392404024041240422404324044240452404624047240482404924050240512405224053240542405524056240572405824059240602406124062240632406424065240662406724068240692407024071240722407324074240752407624077240782407924080240812408224083240842408524086240872408824089240902409124092240932409424095240962409724098240992410024101241022410324104241052410624107241082410924110241112411224113241142411524116241172411824119241202412124122241232412424125241262412724128241292413024131241322413324134241352413624137241382413924140241412414224143241442414524146241472414824149241502415124152241532415424155241562415724158241592416024161241622416324164241652416624167241682416924170241712417224173241742417524176241772417824179241802418124182241832418424185241862418724188241892419024191241922419324194241952419624197241982419924200242012420224203242042420524206242072420824209242102421124212242132421424215242162421724218242192422024221242222422324224242252422624227242282422924230242312423224233242342423524236242372423824239242402424124242242432424424245242462424724248242492425024251242522425324254242552425624257242582425924260242612426224263242642426524266242672426824269242702427124272242732427424275242762427724278242792428024281242822428324284242852428624287242882428924290242912429224293242942429524296242972429824299243002430124302243032430424305243062430724308243092431024311243122431324314243152431624317243182431924320243212432224323243242432524326243272432824329243302433124332243332433424335243362433724338243392434024341243422434324344243452434624347243482434924350243512435224353243542435524356243572435824359243602436124362243632436424365243662436724368243692437024371243722437324374243752437624377243782437924380243812438224383243842438524386243872438824389243902439124392243932439424395243962439724398243992440024401244022440324404244052440624407244082440924410244112441224413244142441524416244172441824419244202442124422244232442424425244262442724428244292443024431244322443324434244352443624437244382443924440244412444224443244442444524446244472444824449244502445124452244532445424455244562445724458244592446024461244622446324464244652446624467244682446924470244712447224473244742447524476244772447824479244802448124482244832448424485244862448724488244892449024491244922449324494244952449624497244982449924500245012450224503245042450524506245072450824509245102451124512245132451424515245162451724518245192452024521245222452324524245252452624527245282452924530245312453224533245342453524536245372453824539245402454124542245432454424545245462454724548245492455024551245522455324554245552455624557245582455924560245612456224563245642456524566245672456824569245702457124572245732457424575245762457724578245792458024581245822458324584245852458624587245882458924590245912459224593245942459524596245972459824599246002460124602246032460424605246062460724608246092461024611246122461324614246152461624617246182461924620246212462224623246242462524626246272462824629246302463124632246332463424635246362463724638246392464024641246422464324644246452464624647246482464924650246512465224653246542465524656246572465824659246602466124662246632466424665246662466724668246692467024671246722467324674246752467624677246782467924680246812468224683246842468524686246872468824689246902469124692246932469424695246962469724698246992470024701247022470324704247052470624707247082470924710247112471224713247142471524716247172471824719247202472124722247232472424725247262472724728247292473024731247322473324734247352473624737247382473924740247412474224743247442474524746247472474824749247502475124752247532475424755247562475724758247592476024761247622476324764247652476624767247682476924770247712477224773247742477524776247772477824779247802478124782247832478424785247862478724788247892479024791247922479324794247952479624797247982479924800248012480224803248042480524806248072480824809248102481124812248132481424815248162481724818248192482024821248222482324824248252482624827248282482924830248312483224833248342483524836248372483824839248402484124842248432484424845248462484724848248492485024851248522485324854248552485624857248582485924860248612486224863248642486524866248672486824869248702487124872248732487424875248762487724878248792488024881248822488324884248852488624887248882488924890248912489224893248942489524896248972489824899249002490124902249032490424905249062490724908249092491024911249122491324914249152491624917249182491924920249212492224923249242492524926249272492824929249302493124932249332493424935249362493724938249392494024941249422494324944249452494624947249482494924950249512495224953249542495524956249572495824959249602496124962249632496424965249662496724968249692497024971249722497324974249752497624977249782497924980249812498224983249842498524986249872498824989249902499124992249932499424995249962499724998249992500025001250022500325004250052500625007250082500925010250112501225013250142501525016250172501825019250202502125022250232502425025250262502725028250292503025031250322503325034250352503625037250382503925040250412504225043250442504525046250472504825049250502505125052250532505425055250562505725058250592506025061250622506325064250652506625067250682506925070250712507225073250742507525076250772507825079250802508125082250832508425085250862508725088250892509025091250922509325094250952509625097250982509925100251012510225103251042510525106251072510825109251102511125112251132511425115251162511725118251192512025121251222512325124251252512625127251282512925130251312513225133251342513525136251372513825139251402514125142251432514425145251462514725148251492515025151251522515325154251552515625157251582515925160251612516225163251642516525166251672516825169251702517125172251732517425175251762517725178251792518025181251822518325184251852518625187251882518925190251912519225193251942519525196251972519825199252002520125202252032520425205252062520725208252092521025211252122521325214252152521625217252182521925220252212522225223252242522525226252272522825229252302523125232252332523425235252362523725238
  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. TSrcMarkerKind = (
  29. mkLabel,
  30. mkResolverReference,
  31. mkDirectReference
  32. );
  33. PSrcMarker = ^TSrcMarker;
  34. TSrcMarker = record
  35. Kind: TSrcMarkerKind;
  36. Filename: string;
  37. Row: integer;
  38. StartCol, EndCol: integer; // token start, end column
  39. Identifier: string;
  40. Next: PSrcMarker;
  41. end;
  42. { TTestHintMessage }
  43. TTestHintMessage = class
  44. public
  45. Id: int64;
  46. MsgType: TMessageType;
  47. MsgNumber: integer;
  48. Msg: string;
  49. SourcePos: TPasSourcePos;
  50. end;
  51. { TTestPasParser }
  52. TTestPasParser = Class(TPasParser)
  53. end;
  54. TOnFindUnit = function(const aUnitName: String): TPasModule of object;
  55. { TTestEnginePasResolver }
  56. TTestEnginePasResolver = class(TPas2JsResolver)
  57. private
  58. FFilename: string;
  59. FModule: TPasModule;
  60. FOnFindUnit: TOnFindUnit;
  61. FParser: TTestPasParser;
  62. FStreamResolver: TStreamResolver;
  63. FScanner: TPas2jsPasScanner;
  64. FSource: string;
  65. public
  66. destructor Destroy; override;
  67. function FindUnit(const AName, InFilename: String; NameExpr,
  68. InFileExpr: TPasExpr): TPasModule; override;
  69. procedure UsedInterfacesFinished(Section: TPasSection); override;
  70. property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
  71. property Filename: string read FFilename write FFilename;
  72. property StreamResolver: TStreamResolver read FStreamResolver write FStreamResolver;
  73. property Scanner: TPas2jsPasScanner read FScanner write FScanner;
  74. property Parser: TTestPasParser read FParser write FParser;
  75. property Source: string read FSource write FSource;
  76. property Module: TPasModule read FModule;
  77. end;
  78. { TCustomTestModule }
  79. TCustomTestModule = Class(TTestCase)
  80. private
  81. FConverter: TPasToJSConverter;
  82. FEngine: TTestEnginePasResolver;
  83. FExpectedErrorClass: ExceptClass;
  84. FExpectedErrorMsg: string;
  85. FExpectedErrorNumber: integer;
  86. FFilename: string;
  87. FFileResolver: TStreamResolver;
  88. FJSImplementationSrc: TJSSourceElements;
  89. FJSImplementationUses: TJSArrayLiteral;
  90. FJSInitBody: TJSFunctionBody;
  91. FJSImplentationUses: TJSArrayLiteral;
  92. FJSInterfaceUses: TJSArrayLiteral;
  93. FJSModule: TJSSourceElements;
  94. FJSModuleSrc: TJSSourceElements;
  95. FJSSource: TStringList;
  96. FModule: TPasModule;
  97. FJSModuleCallArgs: TJSArguments;
  98. FModules: TObjectList;// list of TTestEnginePasResolver
  99. FParser: TTestPasParser;
  100. FPasProgram: TPasProgram;
  101. FHintMsgs: TObjectList; // list of TTestHintMessage
  102. FHintMsgsGood: TFPList; // list of TTestHintMessage marked as expected
  103. FJSRegModuleCall: TJSCallExpression;
  104. FScanner: TPas2jsPasScanner;
  105. FSkipTests: boolean;
  106. FSource: TStringList;
  107. FFirstPasStatement: TPasImplBlock;
  108. {$IFDEF EnablePasTreeGlobalRefCount}
  109. FElementRefCountAtSetup: int64;
  110. {$ENDIF}
  111. function GetMsgCount: integer;
  112. function GetMsgs(Index: integer): TTestHintMessage;
  113. function GetResolverCount: integer;
  114. function GetResolvers(Index: integer): TTestEnginePasResolver;
  115. function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
  116. procedure OnParserLog(Sender: TObject; const Msg: String);
  117. procedure OnPasResolverLog(Sender: TObject; const Msg: String);
  118. procedure OnScannerLog(Sender: TObject; const Msg: String);
  119. protected
  120. procedure SetUp; override;
  121. function CreateConverter: TPasToJSConverter; virtual;
  122. function LoadUnit(const aUnitName: String): TPasModule;
  123. procedure InitScanner(aScanner: TPas2jsPasScanner); virtual;
  124. procedure TearDown; override;
  125. Procedure Add(Line: string); virtual;
  126. Procedure Add(const Lines: array of string);
  127. Procedure StartParsing; virtual;
  128. procedure ParseModuleQueue; virtual;
  129. procedure ParseModule; virtual;
  130. procedure ParseProgram; virtual;
  131. procedure ParseUnit; virtual;
  132. protected
  133. function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
  134. function AddModule(aFilename: string): TTestEnginePasResolver; virtual;
  135. function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
  136. function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  137. ImplementationSrc: string): TTestEnginePasResolver; virtual;
  138. procedure AddSystemUnit; virtual;
  139. procedure StartProgram(NeedSystemUnit: boolean); virtual;
  140. procedure StartUnit(NeedSystemUnit: boolean); virtual;
  141. procedure ConvertModule; virtual;
  142. procedure ConvertProgram; virtual;
  143. procedure ConvertUnit; virtual;
  144. function ConvertJSModuleToString(El: TJSElement): string; virtual;
  145. procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
  146. function GetDottedIdentifier(El: TJSElement): string;
  147. procedure CheckSource(Msg,Statements: String; InitStatements: string = '';
  148. ImplStatements: string = ''); virtual;
  149. procedure CheckDiff(Msg, Expected, Actual: string); virtual;
  150. procedure CheckUnit(Filename, ExpectedSrc: string); virtual;
  151. procedure CheckHint(MsgType: TMessageType; MsgNumber: integer;
  152. Msg: string; Marker: PSrcMarker = nil); virtual;
  153. procedure CheckResolverUnexpectedHints(WithSourcePos: boolean = false); virtual;
  154. procedure SetExpectedScannerError(Msg: string; MsgNumber: integer);
  155. procedure SetExpectedParserError(Msg: string; MsgNumber: integer);
  156. procedure SetExpectedPasResolverError(Msg: string; MsgNumber: integer);
  157. procedure SetExpectedConverterError(Msg: string; MsgNumber: integer);
  158. function IsErrorExpected(E: Exception): boolean;
  159. procedure HandleScannerError(E: EScannerError);
  160. procedure HandleParserError(E: EParserError);
  161. procedure HandlePasResolveError(E: EPasResolve);
  162. procedure HandlePas2JSError(E: EPas2JS);
  163. procedure HandleException(E: Exception);
  164. procedure FailException(E: Exception);
  165. procedure WriteSources(const aFilename: string; aRow, aCol: integer);
  166. function IndexOfResolver(const Filename: string): integer;
  167. function GetResolver(const Filename: string): TTestEnginePasResolver;
  168. function GetDefaultNamespace: string;
  169. property PasProgram: TPasProgram Read FPasProgram;
  170. property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
  171. property ResolverCount: integer read GetResolverCount;
  172. property Engine: TTestEnginePasResolver read FEngine;
  173. property Filename: string read FFilename;
  174. Property Module: TPasModule Read FModule;
  175. property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
  176. property Converter: TPasToJSConverter read FConverter;
  177. property JSSource: TStringList read FJSSource;
  178. property JSModule: TJSSourceElements read FJSModule;
  179. property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
  180. property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
  181. property JSImplementationUses: TJSArrayLiteral read FJSImplementationUses;
  182. property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
  183. property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
  184. property JSInitBody: TJSFunctionBody read FJSInitBody;
  185. property JSImplementationSrc: TJSSourceElements read FJSImplementationSrc;
  186. property ExpectedErrorClass: ExceptClass read FExpectedErrorClass write FExpectedErrorClass;
  187. property ExpectedErrorMsg: string read FExpectedErrorMsg write FExpectedErrorMsg;
  188. property ExpectedErrorNumber: integer read FExpectedErrorNumber write FExpectedErrorNumber;
  189. property SkipTests: boolean read FSkipTests write FSkipTests;
  190. public
  191. constructor Create; override;
  192. destructor Destroy; override;
  193. property Source: TStringList read FSource;
  194. property FileResolver: TStreamResolver read FFileResolver;
  195. property Scanner: TPas2jsPasScanner read FScanner;
  196. property Parser: TTestPasParser read FParser;
  197. property MsgCount: integer read GetMsgCount;
  198. property Msgs[Index: integer]: TTestHintMessage read GetMsgs;
  199. end;
  200. { TTestModule }
  201. TTestModule = class(TCustomTestModule)
  202. Published
  203. Procedure TestReservedWords;
  204. // program/units
  205. Procedure TestEmptyProgram;
  206. Procedure TestEmptyProgramUseStrict;
  207. Procedure TestEmptyUnit;
  208. Procedure TestEmptyUnitUseStrict;
  209. Procedure TestDottedUnitNames;
  210. Procedure TestDottedUnitNameImpl;
  211. Procedure TestDottedUnitExpr;
  212. Procedure Test_ModeFPCFail;
  213. Procedure Test_ModeSwitchCBlocksFail;
  214. Procedure TestUnit_UseSystem;
  215. Procedure TestUnit_Intf1Impl2Intf1;
  216. Procedure TestIncludeVersion;
  217. // vars/const
  218. Procedure TestVarInt;
  219. Procedure TestVarBaseTypes;
  220. Procedure TestBaseTypeSingleFail;
  221. Procedure TestBaseTypeExtendedFail;
  222. Procedure TestConstBaseTypes;
  223. Procedure TestUnitImplVars;
  224. Procedure TestUnitImplConsts;
  225. Procedure TestUnitImplRecord;
  226. Procedure TestRenameJSNameConflict;
  227. Procedure TestLocalConst;
  228. Procedure TestVarExternal;
  229. Procedure TestVarExternalOtherUnit;
  230. Procedure TestVarAbsoluteFail;
  231. Procedure TestConstExternal;
  232. // numbers
  233. Procedure TestDouble;
  234. Procedure TestInteger;
  235. Procedure TestIntegerRange;
  236. Procedure TestIntegerTypecasts;
  237. Procedure TestBitwiseAndNativeIntWarn;
  238. Procedure TestCurrency;
  239. Procedure TestForBoolDo;
  240. Procedure TestForIntDo;
  241. Procedure TestForIntInDo;
  242. // strings
  243. Procedure TestCharConst;
  244. Procedure TestChar_Compare;
  245. Procedure TestChar_BuiltInProcs;
  246. Procedure TestStringConst;
  247. Procedure TestStringConstSurrogate;
  248. Procedure TestString_Length;
  249. Procedure TestString_Compare;
  250. Procedure TestString_SetLength;
  251. Procedure TestString_CharAt;
  252. Procedure TestStringHMinusFail;
  253. Procedure TestStr;
  254. Procedure TestBaseType_AnsiStringFail;
  255. Procedure TestBaseType_WideStringFail;
  256. Procedure TestBaseType_ShortStringFail;
  257. Procedure TestBaseType_RawByteStringFail;
  258. Procedure TestTypeShortstring_Fail;
  259. Procedure TestCharSet_Custom;
  260. Procedure TestForCharDo;
  261. Procedure TestForCharInDo;
  262. // alias types
  263. Procedure TestAliasTypeRef;
  264. Procedure TestTypeCast_BaseTypes;
  265. Procedure TestTypeCast_AliasBaseTypes;
  266. // functions
  267. Procedure TestEmptyProc;
  268. Procedure TestProcOneParam;
  269. Procedure TestFunctionWithoutParams;
  270. Procedure TestProcedureWithoutParams;
  271. Procedure TestPrgProcVar;
  272. Procedure TestProcTwoArgs;
  273. Procedure TestProc_DefaultValue;
  274. Procedure TestUnitProcVar;
  275. Procedure TestImplProc;
  276. Procedure TestFunctionResult;
  277. Procedure TestNestedProc;
  278. Procedure TestNestedProc_ResultString;
  279. Procedure TestForwardProc;
  280. Procedure TestNestedForwardProc;
  281. Procedure TestAssignFunctionResult;
  282. Procedure TestFunctionResultInCondition;
  283. Procedure TestFunctionResultInForLoop;
  284. Procedure TestFunctionResultInTypeCast;
  285. Procedure TestExit;
  286. Procedure TestBreak;
  287. Procedure TestBreakAsVar;
  288. Procedure TestContinue;
  289. Procedure TestProc_External;
  290. Procedure TestProc_ExternalOtherUnit;
  291. Procedure TestProc_Asm;
  292. Procedure TestProc_Assembler;
  293. Procedure TestProc_VarParam;
  294. Procedure TestProc_VarParamString;
  295. Procedure TestProc_VarParamV;
  296. Procedure TestProc_Overload;
  297. Procedure TestProc_OverloadForward;
  298. Procedure TestProc_OverloadIntfImpl;
  299. Procedure TestProc_OverloadNested;
  300. Procedure TestProc_OverloadUnitCycle;
  301. Procedure TestProc_Varargs;
  302. Procedure TestProc_ConstOrder;
  303. Procedure TestProc_DuplicateConst;
  304. Procedure TestProc_LocalVarAbsolute;
  305. Procedure TestProc_ReservedWords;
  306. // anonymous functions
  307. Procedure TestAnonymousProc_Assign_ObjFPC;
  308. Procedure TestAnonymousProc_Assign_Delphi;
  309. Procedure TestAnonymousProc_Arg;
  310. Procedure TestAnonymousProc_Typecast;
  311. Procedure TestAnonymousProc_With;
  312. Procedure TestAnonymousProc_ExceptOn;
  313. Procedure TestAnonymousProc_Nested;
  314. Procedure TestAnonymousProc_NestedAssignResult;
  315. // enums, sets
  316. Procedure TestEnum_Name;
  317. Procedure TestEnum_Number;
  318. Procedure TestEnum_ConstFail;
  319. Procedure TestEnum_Functions;
  320. Procedure TestEnum_AsParams;
  321. Procedure TestEnumRange_Array;
  322. Procedure TestEnum_ForIn;
  323. Procedure TestEnum_ScopedNumber;
  324. Procedure TestEnum_InFunction;
  325. Procedure TestSet_Enum;
  326. Procedure TestSet_Operators;
  327. Procedure TestSet_Operator_In;
  328. Procedure TestSet_Functions;
  329. Procedure TestSet_PassAsArgClone;
  330. Procedure TestSet_AsParams;
  331. Procedure TestSet_Property;
  332. Procedure TestSet_EnumConst;
  333. Procedure TestSet_IntConst;
  334. Procedure TestSet_AnonymousEnumType;
  335. Procedure TestSet_AnonymousEnumTypeChar; // ToDo
  336. Procedure TestSet_ConstEnum;
  337. Procedure TestSet_ConstChar;
  338. Procedure TestSet_ConstInt;
  339. Procedure TestSet_InFunction;
  340. Procedure TestSet_ForIn;
  341. // statements
  342. Procedure TestNestBegin;
  343. Procedure TestIncDec;
  344. Procedure TestLoHiFpcMode;
  345. Procedure TestLoHiDelphiMode;
  346. Procedure TestAssignments;
  347. Procedure TestArithmeticOperators1;
  348. Procedure TestLogicalOperators;
  349. Procedure TestBitwiseOperators;
  350. Procedure TestFunctionInt;
  351. Procedure TestFunctionString;
  352. Procedure TestIfThen;
  353. Procedure TestForLoop;
  354. Procedure TestForLoopInsideFunction;
  355. Procedure TestForLoop_ReadVarAfter;
  356. Procedure TestForLoop_Nested;
  357. Procedure TestRepeatUntil;
  358. Procedure TestAsmBlock;
  359. Procedure TestAsmPas_Impl; // ToDo
  360. Procedure TestTryFinally;
  361. Procedure TestTryExcept;
  362. Procedure TestTryExcept_ReservedWords;
  363. Procedure TestIfThenRaiseElse;
  364. Procedure TestCaseOf;
  365. Procedure TestCaseOf_UseSwitch;
  366. Procedure TestCaseOfNoElse;
  367. Procedure TestCaseOfNoElse_UseSwitch;
  368. Procedure TestCaseOfRange;
  369. Procedure TestCaseOfString;
  370. Procedure TestCaseOfChar;
  371. Procedure TestCaseOfExternalClassConst;
  372. Procedure TestDebugger;
  373. // arrays
  374. Procedure TestArray_Dynamic;
  375. Procedure TestArray_Dynamic_Nil;
  376. Procedure TestArray_DynMultiDimensional;
  377. Procedure TestArray_StaticInt;
  378. Procedure TestArray_StaticBool;
  379. Procedure TestArray_StaticChar;
  380. Procedure TestArray_StaticMultiDim;
  381. Procedure TestArray_StaticInFunction;
  382. Procedure TestArrayOfRecord;
  383. Procedure TestArray_StaticRecord;
  384. Procedure TestArrayOfSet;
  385. // call(set) literal and clone var
  386. // call([set]) literal and clone var
  387. Procedure TestArray_DynAsParam;
  388. Procedure TestArray_StaticAsParam;
  389. Procedure TestArrayElement_AsParams;
  390. Procedure TestArrayElementFromFuncResult_AsParams;
  391. Procedure TestArrayEnumTypeRange;
  392. Procedure TestArray_SetLengthOutArg;
  393. Procedure TestArray_SetLengthProperty;
  394. Procedure TestArray_SetLengthMultiDim;
  395. Procedure TestArray_OpenArrayOfString;
  396. Procedure TestArray_Concat;
  397. Procedure TestArray_Copy;
  398. Procedure TestArray_InsertDelete;
  399. Procedure TestArray_DynArrayConstObjFPC;
  400. Procedure TestArray_DynArrayConstDelphi;
  401. Procedure TestArray_ArrayLitAsParam;
  402. Procedure TestArray_ArrayLitMultiDimAsParam;
  403. Procedure TestArray_ArrayLitStaticAsParam;
  404. Procedure TestArray_ForInArrOfString;
  405. Procedure TestExternalClass_TypeCastArrayToExternalClass;
  406. Procedure TestExternalClass_TypeCastArrayFromExternalClass;
  407. // record
  408. Procedure TestRecord_Empty;
  409. Procedure TestRecord_Var;
  410. Procedure TestRecord_VarExternal;
  411. Procedure TestRecord_WithDo;
  412. Procedure TestRecord_Assign;
  413. Procedure TestRecord_AsParams;
  414. Procedure TestRecordElement_AsParams;
  415. Procedure TestRecordElementFromFuncResult_AsParams;
  416. Procedure TestRecordElementFromWith_AsParams;
  417. Procedure TestRecord_Equal;
  418. Procedure TestRecord_TypeCastJSValueToRecord;
  419. Procedure TestRecord_VariantFail;
  420. Procedure TestRecord_FieldArray;
  421. Procedure TestRecord_Const;
  422. Procedure TestRecord_TypecastFail;
  423. Procedure TestRecord_InFunction;
  424. // ToDo: Procedure TestRecord_ExternalField;
  425. // ToDo: RTTI of local record
  426. // ToDo: pcu local record, name clash and rtti
  427. // advanced record
  428. Procedure TestAdvRecord_Function;
  429. Procedure TestAdvRecord_Property;
  430. Procedure TestAdvRecord_PropertyDefault;
  431. Procedure TestAdvRecord_Property_ClassMethod;
  432. Procedure TestAdvRecord_Const;
  433. Procedure TestAdvRecord_ExternalField;
  434. Procedure TestAdvRecord_SubRecord;
  435. Procedure TestAdvRecord_SubClass;
  436. Procedure TestAdvRecord_SubInterfaceFail;
  437. Procedure TestAdvRecord_Constructor;
  438. // ToDo: class constructor
  439. // classes
  440. Procedure TestClass_TObjectDefaultConstructor;
  441. Procedure TestClass_TObjectConstructorWithParams;
  442. Procedure TestClass_TObjectConstructorWithDefaultParam;
  443. Procedure TestClass_Var;
  444. Procedure TestClass_Method;
  445. Procedure TestClass_Implementation;
  446. Procedure TestClass_Inheritance;
  447. Procedure TestClass_TypeAlias;
  448. Procedure TestClass_AbstractMethod;
  449. Procedure TestClass_CallInherited_ProcNoParams;
  450. Procedure TestClass_CallInherited_WithParams;
  451. Procedure TestClasS_CallInheritedConstructor;
  452. Procedure TestClass_ClassVar_Assign;
  453. Procedure TestClass_CallClassMethod;
  454. Procedure TestClass_Property;
  455. Procedure TestClass_Property_ClassMethod;
  456. Procedure TestClass_Property_Indexed;
  457. Procedure TestClass_Property_IndexSpec;
  458. Procedure TestClass_PropertyOfTypeArray;
  459. Procedure TestClass_PropertyDefault;
  460. Procedure TestClass_PropertyDefault2;
  461. Procedure TestClass_PropertyOverride;
  462. Procedure TestClass_PropertyIncVisibility;
  463. Procedure TestClass_Assigned;
  464. Procedure TestClass_WithClassDoCreate;
  465. Procedure TestClass_WithClassInstDoProperty;
  466. Procedure TestClass_WithClassInstDoPropertyWithParams;
  467. Procedure TestClass_WithClassInstDoFunc;
  468. Procedure TestClass_TypeCast;
  469. Procedure TestClass_TypeCastUntypedParam;
  470. Procedure TestClass_Overloads;
  471. Procedure TestClass_OverloadsAncestor;
  472. Procedure TestClass_OverloadConstructor;
  473. Procedure TestClass_OverloadDelphiOverride;
  474. Procedure TestClass_ReintroducedVar;
  475. Procedure TestClass_RaiseDescendant;
  476. Procedure TestClass_ExternalMethod;
  477. Procedure TestClass_ExternalVirtualNameMismatchFail;
  478. Procedure TestClass_ExternalOverrideFail;
  479. Procedure TestClass_ExternalVar;
  480. Procedure TestClass_Const;
  481. Procedure TestClass_LocalVarSelfFail;
  482. Procedure TestClass_ArgSelfFail;
  483. Procedure TestClass_NestedProcSelf;
  484. Procedure TestClass_NestedProcSelf2;
  485. Procedure TestClass_NestedProcClassSelf;
  486. Procedure TestClass_NestedProcCallInherited;
  487. Procedure TestClass_TObjectFree;
  488. Procedure TestClass_TObjectFreeNewInstance;
  489. Procedure TestClass_TObjectFreeLowerCase;
  490. Procedure TestClass_TObjectFreeFunctionFail;
  491. Procedure TestClass_TObjectFreePropertyFail;
  492. Procedure TestClass_ForIn;
  493. // class of
  494. Procedure TestClassOf_Create;
  495. Procedure TestClassOf_Call;
  496. Procedure TestClassOf_Assign;
  497. Procedure TestClassOf_Is;
  498. Procedure TestClassOf_Compare;
  499. Procedure TestClassOf_ClassVar;
  500. Procedure TestClassOf_ClassMethod;
  501. Procedure TestClassOf_ClassProperty;
  502. Procedure TestClassOf_ClassMethodSelf;
  503. Procedure TestClassOf_TypeCast;
  504. Procedure TestClassOf_ImplicitFunctionCall;
  505. Procedure TestClassOf_Const;
  506. // nested class
  507. Procedure TestNestedClass_Alias;
  508. Procedure TestNestedClass_Record;
  509. Procedure TestNestedClass_Class;
  510. // external class
  511. Procedure TestExternalClass_Var;
  512. Procedure TestExternalClass_Const;
  513. Procedure TestExternalClass_Dollar;
  514. Procedure TestExternalClass_DuplicateVarFail;
  515. Procedure TestExternalClass_Method;
  516. Procedure TestExternalClass_ClassMethod;
  517. Procedure TestExternalClass_FunctionResultInTypeCast;
  518. Procedure TestExternalClass_NonExternalOverride;
  519. Procedure TestExternalClass_OverloadHint;
  520. Procedure TestExternalClass_SameNamePublishedProperty;
  521. Procedure TestExternalClass_Property;
  522. Procedure TestExternalClass_PropertyDate;
  523. Procedure TestExternalClass_ClassProperty;
  524. Procedure TestExternalClass_ClassOf;
  525. Procedure TestExternalClass_ClassOtherUnit;
  526. Procedure TestExternalClass_Is;
  527. Procedure TestExternalClass_As;
  528. Procedure TestExternalClass_DestructorFail;
  529. Procedure TestExternalClass_New;
  530. Procedure TestExternalClass_ClassOf_New;
  531. Procedure TestExternalClass_FuncClassOf_New;
  532. Procedure TestExternalClass_New_PasClassFail;
  533. Procedure TestExternalClass_New_PasClassBracketsFail;
  534. Procedure TestExternalClass_LocalConstSameName;
  535. Procedure TestExternalClass_ReintroduceOverload;
  536. Procedure TestExternalClass_Inherited;
  537. Procedure TestExternalClass_PascalAncestorFail;
  538. Procedure TestExternalClass_NewInstance;
  539. Procedure TestExternalClass_NewInstance_NonVirtualFail;
  540. Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
  541. Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail;
  542. Procedure TestExternalClass_PascalProperty;
  543. Procedure TestExternalClass_TypeCastToRootClass;
  544. Procedure TestExternalClass_TypeCastToJSObject;
  545. Procedure TestExternalClass_TypeCastStringToExternalString;
  546. Procedure TestExternalClass_TypeCastToJSFunction;
  547. Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
  548. Procedure TestExternalClass_BracketAccessor;
  549. Procedure TestExternalClass_BracketAccessor_Call;
  550. Procedure TestExternalClass_BracketAccessor_2ParamsFail;
  551. Procedure TestExternalClass_BracketAccessor_ReadOnly;
  552. Procedure TestExternalClass_BracketAccessor_WriteOnly;
  553. Procedure TestExternalClass_BracketAccessor_MultiType;
  554. Procedure TestExternalClass_BracketAccessor_Index;
  555. Procedure TestExternalClass_ForInJSObject;
  556. Procedure TestExternalClass_ForInJSArray;
  557. Procedure TestExternalClass_IncompatibleArgDuplicateIdentifier;
  558. // class interfaces
  559. Procedure TestClassInterface_Corba;
  560. Procedure TestClassInterface_ProcExternalFail;
  561. Procedure TestClassInterface_Overloads;
  562. Procedure TestClassInterface_DuplicateGUIInIntfListFail;
  563. Procedure TestClassInterface_DuplicateGUIInAncestorFail;
  564. Procedure TestClassInterface_AncestorImpl;
  565. Procedure TestClassInterface_ImplReintroduce;
  566. Procedure TestClassInterface_MethodResolution;
  567. Procedure TestClassInterface_AncestorMoreInterfaces;
  568. Procedure TestClassInterface_MethodOverride;
  569. Procedure TestClassInterface_Corba_Delegation;
  570. Procedure TestClassInterface_Corba_DelegationStatic;
  571. Procedure TestClassInterface_Corba_Operators;
  572. Procedure TestClassInterface_Corba_Args;
  573. Procedure TestClassInterface_Corba_ForIn;
  574. Procedure TestClassInterface_COM_AssignVar;
  575. Procedure TestClassInterface_COM_AssignArg;
  576. Procedure TestClassInterface_COM_FunctionResult;
  577. Procedure TestClassInterface_COM_InheritedFuncResult;
  578. Procedure TestClassInterface_COM_IsAsTypeCasts;
  579. Procedure TestClassInterface_COM_PassAsArg;
  580. Procedure TestClassInterface_COM_PassToUntypedParam;
  581. Procedure TestClassInterface_COM_FunctionInExpr;
  582. Procedure TestClassInterface_COM_Property;
  583. Procedure TestClassInterface_COM_IntfProperty;
  584. Procedure TestClassInterface_COM_Delegation;
  585. Procedure TestClassInterface_COM_With;
  586. Procedure TestClassInterface_COM_ForIn;
  587. Procedure TestClassInterface_COM_ArrayOfIntfFail;
  588. Procedure TestClassInterface_COM_RecordIntfFail;
  589. Procedure TestClassInterface_COM_UnitInitialization;
  590. Procedure TestClassInterface_GUID;
  591. Procedure TestClassInterface_GUIDProperty;
  592. // helpers
  593. Procedure TestClassHelper_ClassVar;
  594. Procedure TestClassHelper_Method_AccessInstanceFields;
  595. Procedure TestClassHelper_Method_Call;
  596. Procedure TestClassHelper_Method_Nested_Call;
  597. Procedure TestClassHelper_ClassMethod_Call;
  598. Procedure TestClassHelper_ClassOf;
  599. Procedure TestClassHelper_MethodRefObjFPC;
  600. Procedure TestClassHelper_Constructor;
  601. //Procedure TestClassHelper_InheritedObjFPC;
  602. //Procedure TestClassHelper_InheritedDelphi;
  603. // todo: TestClassHelper_Property
  604. // todo: TestClassHelper_Property_Array
  605. // todo: TestClassHelper_Property_Index
  606. // todo: TestClassHelper_ClassProperty
  607. // todo: TestClassHelper_ClassProperty_Array
  608. // todo: TestClassHelper_ClassProperty_Index
  609. // todo: TestClassHelper_Overload
  610. // todo: TestRecordHelper_ClassVar
  611. // todo: TestRecordHelper_Method
  612. // todo: TestRecordHelper_ClassMethod
  613. // todo: TestRecordHelper_NestedMethod
  614. // todo: TestRecorHelper_Constructor;
  615. // todo: TestRecordHelper_Args
  616. // todo: TestRecordHelper_Property
  617. // todo: TestRecordHelper_Property_Array
  618. // todo: TestRecordHelper_ClassProperty
  619. // todo: TestRecordHelper_ClassProperty_Array
  620. // todo: TestTypeHelper_ClassVar
  621. // todo: TestTypeHelper_Method
  622. // todo: TestTypeHelper_ClassMethod
  623. // todo: TestTypeHelper_Constructor;
  624. // todo: TestTypeHelper_Property
  625. // todo: TestTypeHelper_Property_Array
  626. // todo: TestTypeHelper_ClassProperty
  627. // todo: TestTypeHelper_ClassProperty_Array
  628. // proc types
  629. Procedure TestProcType;
  630. Procedure TestProcType_Arg;
  631. Procedure TestProcType_FunctionFPC;
  632. Procedure TestProcType_FunctionDelphi;
  633. Procedure TestProcType_ProcedureDelphi;
  634. Procedure TestProcType_AsParam;
  635. Procedure TestProcType_MethodFPC;
  636. Procedure TestProcType_MethodDelphi;
  637. Procedure TestProcType_PropertyFPC;
  638. Procedure TestProcType_PropertyDelphi;
  639. Procedure TestProcType_WithClassInstDoPropertyFPC;
  640. Procedure TestProcType_Nested;
  641. Procedure TestProcType_NestedOfObject;
  642. Procedure TestProcType_ReferenceToProc;
  643. Procedure TestProcType_ReferenceToMethod;
  644. Procedure TestProcType_Typecast;
  645. Procedure TestProcType_PassProcToUntyped;
  646. Procedure TestProcType_PassProcToArray;
  647. // pointer
  648. Procedure TestPointer;
  649. Procedure TestPointer_Proc;
  650. Procedure TestPointer_AssignRecordFail;
  651. Procedure TestPointer_AssignStaticArrayFail;
  652. Procedure TestPointer_TypeCastJSValueToPointer;
  653. Procedure TestPointer_NonRecordFail;
  654. Procedure TestPointer_AnonymousArgTypeFail;
  655. Procedure TestPointer_AnonymousVarTypeFail;
  656. Procedure TestPointer_AnonymousResultTypeFail;
  657. Procedure TestPointer_AddrOperatorFail;
  658. Procedure TestPointer_ArrayParamsFail;
  659. Procedure TestPointer_PointerAddFail;
  660. Procedure TestPointer_IncPointerFail;
  661. Procedure TestPointer_Record;
  662. Procedure TestPointer_RecordArg;
  663. // jsvalue
  664. Procedure TestJSValue_AssignToJSValue;
  665. Procedure TestJSValue_TypeCastToBaseType;
  666. Procedure TestJSValue_Equal;
  667. Procedure TestJSValue_If;
  668. Procedure TestJSValue_Not;
  669. Procedure TestJSValue_Enum;
  670. Procedure TestJSValue_ClassInstance;
  671. Procedure TestJSValue_ClassOf;
  672. Procedure TestJSValue_ArrayOfJSValue;
  673. Procedure TestJSValue_ArrayLit;
  674. Procedure TestJSValue_Params;
  675. Procedure TestJSValue_UntypedParam;
  676. Procedure TestJSValue_FuncResultType;
  677. Procedure TestJSValue_ProcType_Assign;
  678. Procedure TestJSValue_ProcType_Equal;
  679. Procedure TestJSValue_ProcType_Param;
  680. Procedure TestJSValue_AssignToPointerFail;
  681. Procedure TestJSValue_OverloadDouble;
  682. Procedure TestJSValue_OverloadNativeInt;
  683. Procedure TestJSValue_OverloadWord;
  684. Procedure TestJSValue_OverloadString;
  685. Procedure TestJSValue_OverloadChar;
  686. Procedure TestJSValue_OverloadPointer;
  687. Procedure TestJSValue_ForIn;
  688. // RTTI
  689. Procedure TestRTTI_IntRange;
  690. Procedure TestRTTI_Double;
  691. Procedure TestRTTI_ProcType;
  692. Procedure TestRTTI_ProcType_ArgFromOtherUnit;
  693. Procedure TestRTTI_EnumAndSetType;
  694. Procedure TestRTTI_EnumRange;
  695. Procedure TestRTTI_AnonymousEnumType;
  696. Procedure TestRTTI_StaticArray;
  697. Procedure TestRTTI_DynArray;
  698. Procedure TestRTTI_ArrayNestedAnonymous;
  699. Procedure TestRTTI_PublishedMethodOverloadFail;
  700. Procedure TestRTTI_PublishedMethodExternalFail;
  701. Procedure TestRTTI_PublishedClassPropertyFail;
  702. Procedure TestRTTI_PublishedClassFieldFail;
  703. Procedure TestRTTI_PublishedFieldExternalFail;
  704. Procedure TestRTTI_Class_Field;
  705. Procedure TestRTTI_Class_Method;
  706. Procedure TestRTTI_Class_MethodArgFlags;
  707. Procedure TestRTTI_Class_Property;
  708. Procedure TestRTTI_Class_PropertyParams;
  709. Procedure TestRTTI_Class_OtherUnit_TypeAlias;
  710. Procedure TestRTTI_Class_OmitRTTI;
  711. Procedure TestRTTI_IndexModifier;
  712. Procedure TestRTTI_StoredModifier;
  713. Procedure TestRTTI_DefaultValue;
  714. Procedure TestRTTI_DefaultValueSet;
  715. Procedure TestRTTI_DefaultValueRangeType;
  716. Procedure TestRTTI_DefaultValueInherit;
  717. Procedure TestRTTI_OverrideMethod;
  718. Procedure TestRTTI_OverloadProperty;
  719. // ToDo: array argument
  720. Procedure TestRTTI_ClassForward;
  721. Procedure TestRTTI_ClassOf;
  722. Procedure TestRTTI_Record;
  723. Procedure TestRTTI_RecordAnonymousArray;
  724. Procedure TestRTTI_LocalTypes;
  725. Procedure TestRTTI_TypeInfo_BaseTypes;
  726. Procedure TestRTTI_TypeInfo_Type_BaseTypes;
  727. Procedure TestRTTI_TypeInfo_LocalFail;
  728. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  729. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  730. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  731. Procedure TestRTTI_TypeInfo_FunctionClassType;
  732. Procedure TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
  733. Procedure TestRTTI_Interface_Corba;
  734. Procedure TestRTTI_Interface_COM;
  735. // Resourcestring
  736. Procedure TestResourcestringProgram;
  737. Procedure TestResourcestringUnit;
  738. Procedure TestResourcestringImplementation;
  739. // Attributes
  740. Procedure TestAtributes_Ignore;
  741. // Assertions, checks
  742. procedure TestAssert;
  743. procedure TestAssert_SysUtils;
  744. procedure TestObjectChecks;
  745. procedure TestRangeChecks_AssignInt;
  746. procedure TestRangeChecks_AssignIntRange;
  747. procedure TestRangeChecks_AssignEnum;
  748. procedure TestRangeChecks_AssignEnumRange;
  749. procedure TestRangeChecks_AssignChar;
  750. procedure TestRangeChecks_AssignCharRange;
  751. procedure TestRangeChecks_ArrayIndex;
  752. procedure TestRangeChecks_ArrayOfRecIndex;
  753. procedure TestRangeChecks_StringIndex;
  754. procedure TestRangeChecks_TypecastInt;
  755. end;
  756. function LinesToStr(Args: array of const): string;
  757. function ExtractFileUnitName(aFilename: string): string;
  758. function JSToStr(El: TJSElement): string;
  759. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  760. implementation
  761. function LinesToStr(Args: array of const): string;
  762. var
  763. s: String;
  764. i: Integer;
  765. begin
  766. s:='';
  767. for i:=Low(Args) to High(Args) do
  768. case Args[i].VType of
  769. vtChar: s += Args[i].VChar+LineEnding;
  770. vtString: s += Args[i].VString^+LineEnding;
  771. vtPChar: s += Args[i].VPChar+LineEnding;
  772. vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
  773. vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
  774. vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
  775. vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
  776. vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
  777. end;
  778. Result:=s;
  779. end;
  780. function ExtractFileUnitName(aFilename: string): string;
  781. var
  782. p: Integer;
  783. begin
  784. Result:=ExtractFileName(aFilename);
  785. if Result='' then exit;
  786. for p:=length(Result) downto 1 do
  787. case Result[p] of
  788. '/','\': exit;
  789. '.':
  790. begin
  791. Delete(Result,p,length(Result));
  792. exit;
  793. end;
  794. end;
  795. end;
  796. function JSToStr(El: TJSElement): string;
  797. var
  798. aWriter: TBufferWriter;
  799. aJSWriter: TJSWriter;
  800. begin
  801. aJSWriter:=nil;
  802. aWriter:=TBufferWriter.Create(1000);
  803. try
  804. aJSWriter:=TJSWriter.Create(aWriter);
  805. aJSWriter.IndentSize:=2;
  806. aJSWriter.WriteJS(El);
  807. Result:=aWriter.AsString;
  808. finally
  809. aJSWriter.Free;
  810. aWriter.Free;
  811. end;
  812. end;
  813. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  814. // search diff, ignore changes in spaces
  815. const
  816. SpaceChars = [#9,#10,#13,' '];
  817. var
  818. ExpectedP, ActualP: PChar;
  819. function FindLineEnd(p: PChar): PChar;
  820. begin
  821. Result:=p;
  822. while not (Result^ in [#0,#10,#13]) do inc(Result);
  823. end;
  824. function FindLineStart(p, MinP: PChar): PChar;
  825. begin
  826. while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
  827. Result:=p;
  828. end;
  829. procedure SkipLineEnd(var p: PChar);
  830. begin
  831. if p^ in [#10,#13] then
  832. begin
  833. if (p[1] in [#10,#13]) and (p^<>p[1]) then
  834. inc(p,2)
  835. else
  836. inc(p);
  837. end;
  838. end;
  839. procedure DiffFound;
  840. var
  841. ActLineStartP, ActLineEndP, p, StartPos: PChar;
  842. ExpLine, ActLine: String;
  843. i, LineNo, DiffLineNo: Integer;
  844. begin
  845. writeln('Diff found "',Msg,'". Lines:');
  846. // write correct lines
  847. p:=PChar(Expected);
  848. LineNo:=0;
  849. DiffLineNo:=0;
  850. repeat
  851. StartPos:=p;
  852. while not (p^ in [#0,#10,#13]) do inc(p);
  853. ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
  854. SkipLineEnd(p);
  855. inc(LineNo);
  856. if (p<=ExpectedP) and (p^<>#0) then
  857. begin
  858. writeln('= ',ExpLine);
  859. end else begin
  860. // diff line
  861. if DiffLineNo=0 then DiffLineNo:=LineNo;
  862. // write actual line
  863. ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
  864. ActLineEndP:=FindLineEnd(ActualP);
  865. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  866. writeln('- ',ActLine);
  867. // write expected line
  868. writeln('+ ',ExpLine);
  869. // write empty line with pointer ^
  870. for i:=1 to 2+ExpectedP-StartPos do write(' ');
  871. writeln('^');
  872. Msg:='expected "'+ExpLine+'", but got "'+ActLine+'".';
  873. CheckSrcDiff:=false;
  874. // write up to three following actual lines to get some context
  875. for i:=1 to 3 do begin
  876. ActLineStartP:=ActLineEndP;
  877. SkipLineEnd(ActLineStartP);
  878. if ActLineStartP^=#0 then break;
  879. ActLineEndP:=FindLineEnd(ActLineStartP);
  880. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  881. writeln('~ ',ActLine);
  882. end;
  883. exit;
  884. end;
  885. until p^=#0;
  886. writeln('DiffFound Actual:-----------------------');
  887. writeln(Actual);
  888. writeln('DiffFound Expected:---------------------');
  889. writeln(Expected);
  890. writeln('DiffFound ------------------------------');
  891. Msg:='diff found, but lines are the same, internal error';
  892. CheckSrcDiff:=false;
  893. end;
  894. var
  895. IsSpaceNeeded: Boolean;
  896. LastChar, Quote: Char;
  897. begin
  898. Result:=true;
  899. Msg:='';
  900. if Expected='' then Expected:=' ';
  901. if Actual='' then Actual:=' ';
  902. ExpectedP:=PChar(Expected);
  903. ActualP:=PChar(Actual);
  904. repeat
  905. //writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
  906. case ExpectedP^ of
  907. #0:
  908. begin
  909. // check that rest of Actual has only spaces
  910. while ActualP^ in SpaceChars do inc(ActualP);
  911. if ActualP^<>#0 then
  912. begin
  913. DiffFound;
  914. exit;
  915. end;
  916. exit(true);
  917. end;
  918. ' ',#9,#10,#13:
  919. begin
  920. // skip space in Expected
  921. IsSpaceNeeded:=false;
  922. if ExpectedP>PChar(Expected) then
  923. LastChar:=ExpectedP[-1]
  924. else
  925. LastChar:=#0;
  926. while ExpectedP^ in SpaceChars do inc(ExpectedP);
  927. if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
  928. and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
  929. IsSpaceNeeded:=true;
  930. if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
  931. begin
  932. DiffFound;
  933. exit;
  934. end;
  935. while ActualP^ in SpaceChars do inc(ActualP);
  936. end;
  937. '''','"':
  938. begin
  939. while ActualP^ in SpaceChars do inc(ActualP);
  940. if ExpectedP^<>ActualP^ then
  941. begin
  942. DiffFound;
  943. exit;
  944. end;
  945. Quote:=ExpectedP^;
  946. repeat
  947. inc(ExpectedP);
  948. inc(ActualP);
  949. if ExpectedP^<>ActualP^ then
  950. begin
  951. DiffFound;
  952. exit;
  953. end;
  954. if (ExpectedP^ in [#0,#10,#13]) then
  955. break
  956. else if (ExpectedP^=Quote) then
  957. begin
  958. inc(ExpectedP);
  959. inc(ActualP);
  960. break;
  961. end;
  962. until false;
  963. end;
  964. else
  965. while ActualP^ in SpaceChars do inc(ActualP);
  966. if ExpectedP^<>ActualP^ then
  967. begin
  968. DiffFound;
  969. exit;
  970. end;
  971. inc(ExpectedP);
  972. inc(ActualP);
  973. end;
  974. until false;
  975. end;
  976. { TTestEnginePasResolver }
  977. destructor TTestEnginePasResolver.Destroy;
  978. begin
  979. FreeAndNil(FStreamResolver);
  980. FreeAndNil(FParser);
  981. FreeAndNil(FScanner);
  982. FreeAndNil(FStreamResolver);
  983. if Module<>nil then
  984. begin
  985. Module.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
  986. FModule:=nil;
  987. end;
  988. inherited Destroy;
  989. end;
  990. function TTestEnginePasResolver.FindUnit(const AName, InFilename: String;
  991. NameExpr, InFileExpr: TPasExpr): TPasModule;
  992. begin
  993. Result:=nil;
  994. if InFilename<>'' then
  995. RaiseNotYetImplemented(20180224101926,InFileExpr,'Use testcase tcunitsearch instead');
  996. if Assigned(OnFindUnit) then
  997. Result:=OnFindUnit(AName);
  998. if NameExpr=nil then ;
  999. end;
  1000. procedure TTestEnginePasResolver.UsedInterfacesFinished(Section: TPasSection);
  1001. begin
  1002. // do not parse recursively
  1003. // parse via the queue
  1004. if Section=nil then ;
  1005. end;
  1006. { TCustomTestModule }
  1007. function TCustomTestModule.GetMsgCount: integer;
  1008. begin
  1009. Result:=FHintMsgs.Count;
  1010. end;
  1011. function TCustomTestModule.GetMsgs(Index: integer): TTestHintMessage;
  1012. begin
  1013. Result:=TTestHintMessage(FHintMsgs[Index]);
  1014. end;
  1015. function TCustomTestModule.GetResolverCount: integer;
  1016. begin
  1017. Result:=FModules.Count;
  1018. end;
  1019. function TCustomTestModule.GetResolvers(Index: integer
  1020. ): TTestEnginePasResolver;
  1021. begin
  1022. Result:=TTestEnginePasResolver(FModules[Index]);
  1023. end;
  1024. function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
  1025. ): TPasModule;
  1026. var
  1027. DefNamespace: String;
  1028. begin
  1029. //writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
  1030. if (Pos('.',aUnitName)<1) then
  1031. begin
  1032. DefNamespace:=GetDefaultNamespace;
  1033. if DefNamespace<>'' then
  1034. begin
  1035. Result:=LoadUnit(DefNamespace+'.'+aUnitName);
  1036. if Result<>nil then exit;
  1037. end;
  1038. end;
  1039. Result:=LoadUnit(aUnitName);
  1040. if Result<>nil then exit;
  1041. {$IFDEF VerbosePas2JS}
  1042. writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
  1043. {$ENDIF}
  1044. Fail('can''t find unit "'+aUnitName+'"');
  1045. end;
  1046. procedure TCustomTestModule.OnParserLog(Sender: TObject; const Msg: String);
  1047. var
  1048. aParser: TPasParser;
  1049. Item: TTestHintMessage;
  1050. begin
  1051. aParser:=Sender as TPasParser;
  1052. Item:=TTestHintMessage.Create;
  1053. Item.Id:=aParser.LastMsgNumber;
  1054. Item.MsgType:=aParser.LastMsgType;
  1055. Item.MsgNumber:=aParser.LastMsgNumber;
  1056. Item.Msg:=Msg;
  1057. Item.SourcePos:=aParser.Scanner.CurSourcePos;
  1058. {$IFDEF VerbosePas2JS}
  1059. writeln('TCustomTestModule.OnParserLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
  1060. {$ENDIF}
  1061. FHintMsgs.Add(Item);
  1062. end;
  1063. procedure TCustomTestModule.OnPasResolverLog(Sender: TObject; const Msg: String
  1064. );
  1065. var
  1066. aResolver: TTestEnginePasResolver;
  1067. Item: TTestHintMessage;
  1068. begin
  1069. aResolver:=Sender as TTestEnginePasResolver;
  1070. Item:=TTestHintMessage.Create;
  1071. Item.Id:=aResolver.LastMsgId;
  1072. Item.MsgType:=aResolver.LastMsgType;
  1073. Item.MsgNumber:=aResolver.LastMsgNumber;
  1074. Item.Msg:=Msg;
  1075. Item.SourcePos:=aResolver.LastSourcePos;
  1076. {$IFDEF VerbosePas2JS}
  1077. writeln('TCustomTestModule.OnPasResolverLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
  1078. {$ENDIF}
  1079. FHintMsgs.Add(Item);
  1080. end;
  1081. procedure TCustomTestModule.OnScannerLog(Sender: TObject; const Msg: String);
  1082. var
  1083. Item: TTestHintMessage;
  1084. aScanner: TPas2jsPasScanner;
  1085. begin
  1086. aScanner:=Sender as TPas2jsPasScanner;
  1087. Item:=TTestHintMessage.Create;
  1088. Item.Id:=aScanner.LastMsgNumber;
  1089. Item.MsgType:=aScanner.LastMsgType;
  1090. Item.MsgNumber:=aScanner.LastMsgNumber;
  1091. Item.Msg:=Msg;
  1092. Item.SourcePos:=aScanner.CurSourcePos;
  1093. {$IFDEF VerbosePas2JS}
  1094. writeln('TCustomTestModule.OnScannerLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
  1095. {$ENDIF}
  1096. FHintMsgs.Add(Item);
  1097. end;
  1098. function TCustomTestModule.LoadUnit(const aUnitName: String): TPasModule;
  1099. var
  1100. i: Integer;
  1101. CurEngine: TTestEnginePasResolver;
  1102. CurUnitName: String;
  1103. begin
  1104. //writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
  1105. Result:=nil;
  1106. if (Module.ClassType=TPasModule)
  1107. and (CompareText(Module.Name,aUnitName)=0) then
  1108. exit(Module);
  1109. for i:=0 to ResolverCount-1 do
  1110. begin
  1111. CurEngine:=Resolvers[i];
  1112. CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
  1113. //writeln('TTestModule.FindUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
  1114. if CompareText(aUnitName,CurUnitName)=0 then
  1115. begin
  1116. Result:=CurEngine.Module;
  1117. if Result<>nil then exit;
  1118. //writeln('TTestModule.FindUnit PARSING unit "',CurEngine.Filename,'"');
  1119. FileResolver.FindSourceFile(aUnitName);
  1120. CurEngine.StreamResolver:=TStreamResolver.Create;
  1121. CurEngine.StreamResolver.OwnsStreams:=True;
  1122. //writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
  1123. CurEngine.StreamResolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
  1124. CurEngine.Scanner:=TPas2jsPasScanner.Create(CurEngine.StreamResolver);
  1125. InitScanner(CurEngine.Scanner);
  1126. CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.StreamResolver,CurEngine);
  1127. CurEngine.Parser.Options:=po_tcmodules;
  1128. if CompareText(CurUnitName,'System')=0 then
  1129. CurEngine.Parser.ImplicitUses.Clear;
  1130. CurEngine.Scanner.OpenFile(CurEngine.Filename);
  1131. try
  1132. CurEngine.Parser.NextToken;
  1133. CurEngine.Parser.ParseUnit(CurEngine.FModule);
  1134. except
  1135. on E: Exception do
  1136. HandleException(E);
  1137. end;
  1138. //writeln('TTestModule.FindUnit END ',CurUnitName);
  1139. Result:=CurEngine.Module;
  1140. exit;
  1141. end;
  1142. end;
  1143. end;
  1144. procedure TCustomTestModule.SetUp;
  1145. begin
  1146. {$IFDEF EnablePasTreeGlobalRefCount}
  1147. FElementRefCountAtSetup:=TPasElement.GlobalRefCount;
  1148. {$ENDIF}
  1149. if FModules<>nil then
  1150. begin
  1151. writeln('TCustomTestModule.SetUp FModules<>nil');
  1152. Halt;
  1153. end;
  1154. inherited SetUp;
  1155. FSkipTests:=false;
  1156. FSource:=TStringList.Create;
  1157. FModules:=TObjectList.Create(true);
  1158. FFilename:='test1.pp';
  1159. FFileResolver:=TStreamResolver.Create;
  1160. FFileResolver.OwnsStreams:=True;
  1161. FScanner:=TPas2jsPasScanner.Create(FFileResolver);
  1162. InitScanner(FScanner);
  1163. FEngine:=AddModule(Filename);
  1164. FEngine.Scanner:=FScanner;
  1165. FScanner.Resolver:=FEngine;
  1166. FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
  1167. FParser.OnLog:=@OnParserLog;
  1168. FEngine.Parser:=FParser;
  1169. Parser.Options:=po_tcmodules;
  1170. FModule:=Nil;
  1171. FConverter:=CreateConverter;
  1172. FExpectedErrorClass:=nil;
  1173. end;
  1174. function TCustomTestModule.CreateConverter: TPasToJSConverter;
  1175. begin
  1176. Result:=TPasToJSConverter.Create;
  1177. Result.Options:=co_tcmodules;
  1178. Result.Globals:=TPasToJSConverterGlobals.Create(Result);
  1179. end;
  1180. procedure TCustomTestModule.InitScanner(aScanner: TPas2jsPasScanner);
  1181. begin
  1182. aScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
  1183. aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
  1184. aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
  1185. aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
  1186. aScanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
  1187. aScanner.CurrentBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
  1188. aScanner.OnLog:=@OnScannerLog;
  1189. aScanner.CompilerVersion:='Comp.Ver.tcmodules';
  1190. end;
  1191. procedure TCustomTestModule.TearDown;
  1192. {$IFDEF CheckPasTreeRefCount}
  1193. var
  1194. El: TPasElement;
  1195. {$ENDIF}
  1196. var
  1197. i: Integer;
  1198. CurModule: TPasModule;
  1199. begin
  1200. FHintMsgs.Clear;
  1201. FHintMsgsGood.Clear;
  1202. FSkipTests:=false;
  1203. FJSRegModuleCall:=nil;
  1204. FJSModuleCallArgs:=nil;
  1205. FJSImplentationUses:=nil;
  1206. FJSInterfaceUses:=nil;
  1207. FJSModuleSrc:=nil;
  1208. FJSInitBody:=nil;
  1209. FreeAndNil(FJSSource);
  1210. FreeAndNil(FJSModule);
  1211. FreeAndNil(FConverter);
  1212. Engine.Clear;
  1213. FreeAndNil(FSource);
  1214. FreeAndNil(FFileResolver);
  1215. if FModules<>nil then
  1216. begin
  1217. for i:=0 to FModules.Count-1 do
  1218. begin
  1219. CurModule:=TTestEnginePasResolver(FModules[i]).Module;
  1220. if CurModule=nil then continue;
  1221. //writeln('TCustomTestModule.TearDown ReleaseUsedUnits ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
  1222. CurModule.ReleaseUsedUnits;
  1223. end;
  1224. if FModule<>nil then
  1225. FModule.ReleaseUsedUnits;
  1226. for i:=0 to FModules.Count-1 do
  1227. begin
  1228. CurModule:=TTestEnginePasResolver(FModules[i]).Module;
  1229. if CurModule=nil then continue;
  1230. //writeln('TCustomTestModule.TearDown UsesReleased ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
  1231. end;
  1232. FreeAndNil(FModules);
  1233. ReleaseAndNil(TPasElement(FModule){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
  1234. FEngine:=nil;
  1235. end;
  1236. inherited TearDown;
  1237. {$IFDEF EnablePasTreeGlobalRefCount}
  1238. if FElementRefCountAtSetup<>TPasElement.GlobalRefCount then
  1239. begin
  1240. writeln('TCustomTestModule.TearDown GlobalRefCount Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
  1241. {$IFDEF CheckPasTreeRefCount}
  1242. El:=TPasElement.FirstRefEl;
  1243. while El<>nil do
  1244. begin
  1245. writeln(' ',GetObjName(El),' RefIds.Count=',El.RefIds.Count,':');
  1246. for i:=0 to El.RefIds.Count-1 do
  1247. writeln(' ',El.RefIds[i]);
  1248. El:=El.NextRefEl;
  1249. end;
  1250. {$ENDIF}
  1251. Halt;
  1252. Fail('TCustomTestModule.TearDown Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
  1253. end;
  1254. {$ENDIF}
  1255. end;
  1256. procedure TCustomTestModule.Add(Line: string);
  1257. begin
  1258. Source.Add(Line);
  1259. end;
  1260. procedure TCustomTestModule.Add(const Lines: array of string);
  1261. var
  1262. i: Integer;
  1263. begin
  1264. for i:=low(Lines) to high(Lines) do
  1265. Add(Lines[i]);
  1266. end;
  1267. procedure TCustomTestModule.StartParsing;
  1268. var
  1269. Src: String;
  1270. begin
  1271. Src:=Source.Text;
  1272. FEngine.Source:=Src;
  1273. FileResolver.AddStream(FileName,TStringStream.Create(Src));
  1274. Scanner.OpenFile(FileName);
  1275. Writeln('// Test : ',Self.TestName);
  1276. Writeln(Src);
  1277. end;
  1278. procedure TCustomTestModule.ParseModuleQueue;
  1279. var
  1280. i: Integer;
  1281. CurResolver: TTestEnginePasResolver;
  1282. Found: Boolean;
  1283. Section: TPasSection;
  1284. begin
  1285. // parse til exception or all modules finished
  1286. while not SkipTests do
  1287. begin
  1288. Found:=false;
  1289. for i:=0 to ResolverCount-1 do
  1290. begin
  1291. CurResolver:=Resolvers[i];
  1292. if CurResolver.CurrentParser=nil then continue;
  1293. if not CurResolver.CurrentParser.CanParseContinue(Section) then
  1294. continue;
  1295. CurResolver.Parser.ParseContinue;
  1296. Found:=true;
  1297. break;
  1298. end;
  1299. if not Found then break;
  1300. end;
  1301. for i:=0 to ResolverCount-1 do
  1302. begin
  1303. CurResolver:=Resolvers[i];
  1304. if CurResolver.Parser=nil then
  1305. begin
  1306. if CurResolver.CurrentParser<>nil then
  1307. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' '+GetObjName(CurResolver.Parser)+'=Parser<>CurrentParser='+GetObjName(CurResolver.CurrentParser));
  1308. continue;
  1309. end;
  1310. if CurResolver.Parser.CurModule<>nil then
  1311. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' NOT FINISHED CurModule='+GetObjName(CurResolver.Parser.CurModule));
  1312. end;
  1313. end;
  1314. procedure TCustomTestModule.ParseModule;
  1315. begin
  1316. if SkipTests then exit;
  1317. FFirstPasStatement:=nil;
  1318. try
  1319. StartParsing;
  1320. Parser.ParseMain(FModule);
  1321. ParseModuleQueue;
  1322. except
  1323. on E: Exception do
  1324. HandleException(E);
  1325. end;
  1326. if SkipTests then exit;
  1327. AssertNotNull('Module resulted in Module',Module);
  1328. AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
  1329. TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
  1330. end;
  1331. procedure TCustomTestModule.ParseProgram;
  1332. begin
  1333. if SkipTests then exit;
  1334. ParseModule;
  1335. if SkipTests then exit;
  1336. AssertEquals('Has program',TPasProgram,Module.ClassType);
  1337. FPasProgram:=TPasProgram(Module);
  1338. AssertNotNull('Has program section',PasProgram.ProgramSection);
  1339. AssertNotNull('Has initialization section',PasProgram.InitializationSection);
  1340. if (PasProgram.InitializationSection.Elements.Count>0) then
  1341. if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
  1342. FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
  1343. end;
  1344. procedure TCustomTestModule.ParseUnit;
  1345. begin
  1346. if SkipTests then exit;
  1347. ParseModule;
  1348. if SkipTests then exit;
  1349. AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
  1350. AssertNotNull('Has interface section',Module.InterfaceSection);
  1351. AssertNotNull('Has implementation section',Module.ImplementationSection);
  1352. if (Module.InitializationSection<>nil)
  1353. and (Module.InitializationSection.Elements.Count>0)
  1354. and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
  1355. FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
  1356. end;
  1357. function TCustomTestModule.FindModuleWithFilename(aFilename: string
  1358. ): TTestEnginePasResolver;
  1359. var
  1360. i: Integer;
  1361. begin
  1362. for i:=0 to ResolverCount-1 do
  1363. if CompareText(Resolvers[i].Filename,aFilename)=0 then
  1364. exit(Resolvers[i]);
  1365. Result:=nil;
  1366. end;
  1367. function TCustomTestModule.AddModule(aFilename: string
  1368. ): TTestEnginePasResolver;
  1369. begin
  1370. //writeln('TTestModuleConverter.AddModule ',aFilename);
  1371. if FindModuleWithFilename(aFilename)<>nil then
  1372. Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
  1373. Result:=TTestEnginePasResolver.Create;
  1374. Result.Filename:=aFilename;
  1375. Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
  1376. Result.OnFindUnit:=@OnPasResolverFindUnit;
  1377. Result.OnLog:=@OnPasResolverLog;
  1378. FModules.Add(Result);
  1379. end;
  1380. function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
  1381. ): TTestEnginePasResolver;
  1382. begin
  1383. Result:=AddModule(aFilename);
  1384. Result.Source:=Src;
  1385. end;
  1386. function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  1387. ImplementationSrc: string): TTestEnginePasResolver;
  1388. var
  1389. Src: String;
  1390. begin
  1391. Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
  1392. Src+=LineEnding;
  1393. Src+='interface'+LineEnding;
  1394. Src+=LineEnding;
  1395. Src+=InterfaceSrc;
  1396. Src+='implementation'+LineEnding;
  1397. Src+=LineEnding;
  1398. Src+=ImplementationSrc;
  1399. Src+='end.'+LineEnding;
  1400. Result:=AddModuleWithSrc(aFilename,Src);
  1401. end;
  1402. procedure TCustomTestModule.AddSystemUnit;
  1403. begin
  1404. AddModuleWithIntfImplSrc('system.pp',
  1405. // interface
  1406. LinesToStr([
  1407. 'type',
  1408. ' integer=longint;',
  1409. 'var',
  1410. ' ExitCode: Longint;',
  1411. ''
  1412. // implementation
  1413. ]),LinesToStr([
  1414. ''
  1415. ]));
  1416. end;
  1417. procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean);
  1418. begin
  1419. if NeedSystemUnit then
  1420. AddSystemUnit
  1421. else
  1422. Parser.ImplicitUses.Clear;
  1423. Add('program '+ExtractFileUnitName(Filename)+';');
  1424. Add('');
  1425. end;
  1426. procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean);
  1427. begin
  1428. if NeedSystemUnit then
  1429. AddSystemUnit
  1430. else
  1431. Parser.ImplicitUses.Clear;
  1432. Add('unit Test1;');
  1433. Add('');
  1434. end;
  1435. procedure TCustomTestModule.ConvertModule;
  1436. procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
  1437. out UsesLit: TJSArrayLiteral);
  1438. var
  1439. i: Integer;
  1440. Item: TJSElement;
  1441. Lit: TJSLiteral;
  1442. begin
  1443. UsesLit:=nil;
  1444. AssertNotNull(UsesName+' uses section',Arg.Expr);
  1445. if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
  1446. exit; // null is ok
  1447. AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
  1448. FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
  1449. for i:=0 to FJSInterfaceUses.Elements.Count-1 do
  1450. begin
  1451. Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
  1452. AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
  1453. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
  1454. Lit:=TJSLiteral(Item);
  1455. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
  1456. ord(jsbase.jstString),ord(Lit.Value.ValueType));
  1457. end;
  1458. end;
  1459. procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
  1460. out Src: TJSSourceElements);
  1461. var
  1462. FunDecl: TJSFunctionDeclarationStatement;
  1463. FunDef: TJSFuncDef;
  1464. FunBody: TJSFunctionBody;
  1465. begin
  1466. Src:=nil;
  1467. AssertNotNull(ParamName,Arg.Expr);
  1468. AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
  1469. FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
  1470. AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
  1471. AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
  1472. FunDef:=FunDecl.AFunction as TJSFuncDef;
  1473. AssertEquals(ParamName+' name empty','',String(FunDef.Name));
  1474. AssertNotNull(ParamName+' body',FunDef.Body);
  1475. AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
  1476. FunBody:=FunDef.Body as TJSFunctionBody;
  1477. AssertNotNull(ParamName+' body.A',FunBody.A);
  1478. AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
  1479. Src:=FunBody.A as TJSSourceElements;
  1480. end;
  1481. var
  1482. ModuleNameExpr: TJSLiteral;
  1483. InitFunction: TJSFunctionDeclarationStatement;
  1484. InitAssign: TJSSimpleAssignStatement;
  1485. InitName: String;
  1486. LastNode: TJSElement;
  1487. Arg: TJSArrayLiteralElement;
  1488. begin
  1489. if SkipTests then exit;
  1490. try
  1491. FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
  1492. except
  1493. on E: Exception do
  1494. HandleException(E);
  1495. end;
  1496. if SkipTests then exit;
  1497. if ExpectedErrorClass<>nil then
  1498. Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
  1499. FJSSource:=TStringList.Create;
  1500. FJSSource.Text:=ConvertJSModuleToString(JSModule);
  1501. {$IFDEF VerbosePas2JS}
  1502. writeln('TTestModule.ConvertModule JS:');
  1503. write(FJSSource.Text);
  1504. {$ENDIF}
  1505. // rtl.module(...
  1506. AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
  1507. AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
  1508. AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
  1509. FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
  1510. AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
  1511. AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
  1512. AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
  1513. FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
  1514. // parameter 'unitname'
  1515. if JSModuleCallArgs.Elements.Count<1 then
  1516. Fail('rtl.module first param unit missing');
  1517. Arg:=JSModuleCallArgs.Elements.Elements[0];
  1518. AssertNotNull('module name param',Arg.Expr);
  1519. ModuleNameExpr:=Arg.Expr as TJSLiteral;
  1520. AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
  1521. if Module is TPasProgram then
  1522. AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
  1523. else
  1524. AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
  1525. // main uses section
  1526. if JSModuleCallArgs.Elements.Count<2 then
  1527. Fail('rtl.module second param main uses missing');
  1528. Arg:=JSModuleCallArgs.Elements.Elements[1];
  1529. CheckUsesList('interface',Arg,FJSInterfaceUses);
  1530. // program/library/interface function()
  1531. if JSModuleCallArgs.Elements.Count<3 then
  1532. Fail('rtl.module third param intf-function missing');
  1533. Arg:=JSModuleCallArgs.Elements.Elements[2];
  1534. CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
  1535. // search for $mod.$init or $mod.$main - the last statement
  1536. if Module is TPasProgram then
  1537. begin
  1538. InitName:='$main';
  1539. AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
  1540. end
  1541. else
  1542. InitName:='$init';
  1543. FJSInitBody:=nil;
  1544. if JSModuleSrc.Statements.Count>0 then
  1545. begin
  1546. LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
  1547. if LastNode is TJSSimpleAssignStatement then
  1548. begin
  1549. InitAssign:=LastNode as TJSSimpleAssignStatement;
  1550. if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
  1551. begin
  1552. InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
  1553. FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
  1554. end
  1555. else if Module is TPasProgram then
  1556. CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
  1557. end;
  1558. end;
  1559. // optional: implementation uses section
  1560. if JSModuleCallArgs.Elements.Count<4 then
  1561. exit;
  1562. Arg:=JSModuleCallArgs.Elements.Elements[3];
  1563. CheckUsesList('implementation',Arg,FJSImplentationUses);
  1564. // optional: implementation function()
  1565. if JSModuleCallArgs.Elements.Count<5 then
  1566. exit;
  1567. Arg:=JSModuleCallArgs.Elements.Elements[4];
  1568. CheckFunctionParam('module impl-function',Arg,FJSImplementationSrc);
  1569. end;
  1570. procedure TCustomTestModule.ConvertProgram;
  1571. begin
  1572. Add('end.');
  1573. ParseProgram;
  1574. ConvertModule;
  1575. end;
  1576. procedure TCustomTestModule.ConvertUnit;
  1577. begin
  1578. Add('end.');
  1579. ParseUnit;
  1580. ConvertModule;
  1581. end;
  1582. function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
  1583. begin
  1584. Result:=tcmodules.JSToStr(El);
  1585. end;
  1586. procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
  1587. DottedName: string);
  1588. begin
  1589. if DottedName='' then
  1590. begin
  1591. AssertNull(Msg,El);
  1592. end
  1593. else
  1594. begin
  1595. AssertNotNull(Msg,El);
  1596. AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
  1597. end;
  1598. end;
  1599. function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
  1600. begin
  1601. if El=nil then
  1602. Result:=''
  1603. else if El is TJSPrimaryExpressionIdent then
  1604. Result:=String(TJSPrimaryExpressionIdent(El).Name)
  1605. else if El is TJSDotMemberExpression then
  1606. Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
  1607. else
  1608. AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
  1609. end;
  1610. procedure TCustomTestModule.CheckSource(Msg, Statements: String;
  1611. InitStatements: string; ImplStatements: string);
  1612. var
  1613. ActualSrc, ExpectedSrc, InitName: String;
  1614. begin
  1615. ActualSrc:=JSToStr(JSModuleSrc);
  1616. ExpectedSrc:=
  1617. 'var $mod = this;'+LineEnding
  1618. +Statements;
  1619. if coUseStrict in Converter.Options then
  1620. ExpectedSrc:='"use strict";'+LineEnding+ExpectedSrc;
  1621. if Module is TPasProgram then
  1622. InitName:='$main'
  1623. else
  1624. InitName:='$init';
  1625. if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
  1626. ExpectedSrc:=ExpectedSrc+LineEnding
  1627. +'$mod.'+InitName+' = function () {'+LineEnding
  1628. +InitStatements
  1629. +'};'+LineEnding;
  1630. //writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
  1631. //writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
  1632. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1633. if (JSImplementationSrc<>nil) then
  1634. begin
  1635. ActualSrc:=JSToStr(JSImplementationSrc);
  1636. ExpectedSrc:=
  1637. 'var $mod = this;'+LineEnding
  1638. +'var $impl = $mod.$impl;'+LineEnding
  1639. +ImplStatements;
  1640. end
  1641. else
  1642. begin
  1643. ActualSrc:='';
  1644. ExpectedSrc:=ImplStatements;
  1645. end;
  1646. //writeln('TTestModule.CheckSource InitStatements="',InitStatements,'"');
  1647. //writeln('TCustomTestModule.CheckSource Expected: ',ExpectedSrc);
  1648. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1649. end;
  1650. procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
  1651. // search diff, ignore changes in spaces
  1652. var
  1653. s: string;
  1654. begin
  1655. if CheckSrcDiff(Expected,Actual,s) then exit;
  1656. Fail(Msg+': '+s);
  1657. end;
  1658. procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
  1659. var
  1660. aResolver: TTestEnginePasResolver;
  1661. aConverter: TPasToJSConverter;
  1662. aJSModule: TJSSourceElements;
  1663. ActualSrc: String;
  1664. begin
  1665. aResolver:=GetResolver(Filename);
  1666. AssertNotNull('missing resolver of unit '+Filename,aResolver);
  1667. {$IFDEF VerbosePas2JS}
  1668. writeln('CheckUnit '+Filename+' converting ...');
  1669. {$ENDIF}
  1670. aConverter:=CreateConverter;
  1671. aJSModule:=nil;
  1672. try
  1673. try
  1674. aJSModule:=aConverter.ConvertPasElement(aResolver.Module,aResolver) as TJSSourceElements;
  1675. except
  1676. on E: Exception do
  1677. HandleException(E);
  1678. end;
  1679. ActualSrc:=ConvertJSModuleToString(aJSModule);
  1680. {$IFDEF VerbosePas2JS}
  1681. writeln('TTestModule.CheckUnit ',Filename,' Pas:');
  1682. write(aResolver.Source);
  1683. writeln('TTestModule.CheckUnit ',Filename,' JS:');
  1684. write(ActualSrc);
  1685. {$ENDIF}
  1686. CheckDiff('Converted unit: "'+ChangeFileExt(Filename,'.js')+'"',ExpectedSrc,ActualSrc);
  1687. finally
  1688. aJSModule.Free;
  1689. aConverter.Free;
  1690. end;
  1691. end;
  1692. procedure TCustomTestModule.CheckHint(MsgType: TMessageType;
  1693. MsgNumber: integer; Msg: string; Marker: PSrcMarker);
  1694. var
  1695. i: Integer;
  1696. Item: TTestHintMessage;
  1697. Expected,Actual: string;
  1698. begin
  1699. //writeln('TCustomTestModule.CheckHint MsgCount=',MsgCount);
  1700. for i:=0 to MsgCount-1 do
  1701. begin
  1702. Item:=Msgs[i];
  1703. if (Item.MsgNumber<>MsgNumber) or (Item.Msg<>Msg) then continue;
  1704. if (Marker<>nil) then
  1705. begin
  1706. if Item.SourcePos.Row<>cardinal(Marker^.Row) then continue;
  1707. if (Item.SourcePos.Column<cardinal(Marker^.StartCol))
  1708. or (Item.SourcePos.Column>cardinal(Marker^.EndCol)) then continue;
  1709. end;
  1710. // found
  1711. FHintMsgsGood.Add(Item);
  1712. str(Item.MsgType,Actual);
  1713. str(MsgType,Expected);
  1714. AssertEquals('MsgType',Expected,Actual);
  1715. exit;
  1716. end;
  1717. // needed message missing -> show emitted messages
  1718. WriteSources('',0,0);
  1719. for i:=0 to MsgCount-1 do
  1720. begin
  1721. Item:=Msgs[i];
  1722. write('TCustomTestModule.CheckHint ',i,'/',MsgCount,' ',Item.MsgType,
  1723. ' ('+IntToStr(Item.MsgNumber),')');
  1724. if Marker<>nil then
  1725. write(' '+ExtractFileName(Item.SourcePos.FileName),'(',Item.SourcePos.Row,',',Item.SourcePos.Column,')');
  1726. writeln(' {',Item.Msg,'}');
  1727. end;
  1728. str(MsgType,Expected);
  1729. Actual:='Missing '+Expected+' ('+IntToStr(MsgNumber)+')';
  1730. if Marker<>nil then
  1731. Actual:=Actual+' '+ExtractFileName(Marker^.Filename)+'('+IntToStr(Marker^.Row)+','+IntToStr(Marker^.StartCol)+'..'+IntToStr(Marker^.EndCol)+')';
  1732. Actual:=Actual+' '+Msg;
  1733. Fail(Actual);
  1734. end;
  1735. procedure TCustomTestModule.CheckResolverUnexpectedHints(WithSourcePos: boolean
  1736. );
  1737. var
  1738. i: Integer;
  1739. s, Txt: String;
  1740. Msg: TTestHintMessage;
  1741. begin
  1742. for i:=0 to MsgCount-1 do
  1743. begin
  1744. Msg:=Msgs[i];
  1745. if FHintMsgsGood.IndexOf(Msg)>=0 then continue;
  1746. s:='';
  1747. str(Msg.MsgType,s);
  1748. Txt:='Unexpected resolver message found ['+IntToStr(Msg.Id)+'] '
  1749. +s+': ('+IntToStr(Msg.MsgNumber)+')';
  1750. if WithSourcePos then
  1751. Txt:=Txt+' '+ExtractFileName(Msg.SourcePos.FileName)+'('+IntToStr(Msg.SourcePos.Row)+','+IntToStr(Msg.SourcePos.Column)+')';
  1752. Txt:=Txt+' {'+Msg.Msg+'}';
  1753. Fail(Txt);
  1754. end;
  1755. end;
  1756. procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
  1757. MsgNumber: integer);
  1758. begin
  1759. ExpectedErrorClass:=EScannerError;
  1760. ExpectedErrorMsg:=Msg;
  1761. ExpectedErrorNumber:=MsgNumber;
  1762. end;
  1763. procedure TCustomTestModule.SetExpectedParserError(Msg: string;
  1764. MsgNumber: integer);
  1765. begin
  1766. ExpectedErrorClass:=EParserError;
  1767. ExpectedErrorMsg:=Msg;
  1768. ExpectedErrorNumber:=MsgNumber;
  1769. end;
  1770. procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
  1771. MsgNumber: integer);
  1772. begin
  1773. ExpectedErrorClass:=EPasResolve;
  1774. ExpectedErrorMsg:=Msg;
  1775. ExpectedErrorNumber:=MsgNumber;
  1776. end;
  1777. procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
  1778. MsgNumber: integer);
  1779. begin
  1780. ExpectedErrorClass:=EPas2JS;
  1781. ExpectedErrorMsg:=Msg;
  1782. ExpectedErrorNumber:=MsgNumber;
  1783. end;
  1784. function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
  1785. var
  1786. MsgNumber: Integer;
  1787. Msg: String;
  1788. begin
  1789. Result:=false;
  1790. if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
  1791. Msg:=E.Message;
  1792. if E is EPas2JS then
  1793. MsgNumber:=EPas2JS(E).MsgNumber
  1794. else if E is EPasResolve then
  1795. MsgNumber:=EPasResolve(E).MsgNumber
  1796. else if E is EParserError then
  1797. MsgNumber:=Parser.LastMsgNumber
  1798. else if E is EScannerError then
  1799. begin
  1800. MsgNumber:=Scanner.LastMsgNumber;
  1801. Msg:=Scanner.LastMsg;
  1802. end
  1803. else
  1804. MsgNumber:=0;
  1805. Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
  1806. if Result then
  1807. SkipTests:=true;
  1808. end;
  1809. procedure TCustomTestModule.HandleScannerError(E: EScannerError);
  1810. begin
  1811. if IsErrorExpected(E) then exit;
  1812. WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
  1813. writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
  1814. +' '+Scanner.CurFilename
  1815. +'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
  1816. FailException(E);
  1817. end;
  1818. procedure TCustomTestModule.HandleParserError(E: EParserError);
  1819. begin
  1820. if IsErrorExpected(E) then exit;
  1821. WriteSources(E.Filename,E.Row,E.Column);
  1822. writeln('ERROR: TCustomTestModule.HandleParserError '+E.ClassName+':'+E.Message
  1823. +' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')'
  1824. +' MainModuleScannerLine="'+Scanner.CurLine+'"'
  1825. );
  1826. FailException(E);
  1827. end;
  1828. procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
  1829. var
  1830. P: TPasSourcePos;
  1831. begin
  1832. if IsErrorExpected(E) then exit;
  1833. P:=E.SourcePos;
  1834. WriteSources(P.FileName,P.Row,P.Column);
  1835. writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
  1836. +' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
  1837. FailException(E);
  1838. end;
  1839. procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
  1840. var
  1841. Row, Col: integer;
  1842. begin
  1843. if IsErrorExpected(E) then exit;
  1844. Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
  1845. WriteSources(E.PasElement.SourceFilename,Row,Col);
  1846. writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
  1847. +' '+E.PasElement.SourceFilename
  1848. +'('+IntToStr(Row)+','+IntToStr(Col)+')');
  1849. FailException(E);
  1850. end;
  1851. procedure TCustomTestModule.HandleException(E: Exception);
  1852. begin
  1853. if E is EScannerError then
  1854. HandleScannerError(EScannerError(E))
  1855. else if E is EParserError then
  1856. HandleParserError(EParserError(E))
  1857. else if E is EPasResolve then
  1858. HandlePasResolveError(EPasResolve(E))
  1859. else if E is EPas2JS then
  1860. HandlePas2JSError(EPas2JS(E))
  1861. else
  1862. begin
  1863. if IsErrorExpected(E) then exit;
  1864. if not (E is EAssertionFailedError) then
  1865. begin
  1866. WriteSources('',0,0);
  1867. writeln('ERROR: TCustomTestModule.HandleException '+E.ClassName+':'+E.Message);
  1868. end;
  1869. FailException(E);
  1870. end;
  1871. end;
  1872. procedure TCustomTestModule.FailException(E: Exception);
  1873. var
  1874. MsgNumber: Integer;
  1875. begin
  1876. if ExpectedErrorClass<>nil then
  1877. begin
  1878. if FExpectedErrorClass=E.ClassType then
  1879. begin
  1880. if E is EPas2JS then
  1881. MsgNumber:=EPas2JS(E).MsgNumber
  1882. else if E is EPasResolve then
  1883. MsgNumber:=EPasResolve(E).MsgNumber
  1884. else if E is EParserError then
  1885. MsgNumber:=Parser.LastMsgNumber
  1886. else if E is EScannerError then
  1887. MsgNumber:=Scanner.LastMsgNumber
  1888. else
  1889. MsgNumber:=0;
  1890. AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
  1891. AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
  1892. ExpectedErrorNumber,MsgNumber);
  1893. end else begin
  1894. AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
  1895. end;
  1896. end;
  1897. Fail(E.Message);
  1898. end;
  1899. procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
  1900. aCol: integer);
  1901. var
  1902. IsSrc: Boolean;
  1903. i, j: Integer;
  1904. SrcLines: TStringList;
  1905. Line: string;
  1906. aModule: TTestEnginePasResolver;
  1907. begin
  1908. writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
  1909. for i:=0 to ResolverCount-1 do
  1910. begin
  1911. aModule:=Resolvers[i];
  1912. SrcLines:=TStringList.Create;
  1913. try
  1914. SrcLines.Text:=aModule.Source;
  1915. IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
  1916. writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
  1917. for j:=1 to SrcLines.Count do
  1918. begin
  1919. Line:=SrcLines[j-1];
  1920. if IsSrc and (j=aRow) then
  1921. begin
  1922. write('*');
  1923. Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
  1924. end;
  1925. writeln(Format('%:4d: ',[j]),Line);
  1926. end;
  1927. finally
  1928. SrcLines.Free;
  1929. end;
  1930. end;
  1931. end;
  1932. function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
  1933. var
  1934. i: Integer;
  1935. begin
  1936. for i:=0 to ResolverCount-1 do
  1937. if Filename=Resolvers[i].Filename then exit(i);
  1938. Result:=-1;
  1939. end;
  1940. function TCustomTestModule.GetResolver(const Filename: string
  1941. ): TTestEnginePasResolver;
  1942. var
  1943. i: Integer;
  1944. begin
  1945. i:=IndexOfResolver(Filename);
  1946. if i<0 then exit(nil);
  1947. Result:=Resolvers[i];
  1948. end;
  1949. function TCustomTestModule.GetDefaultNamespace: string;
  1950. var
  1951. C: TClass;
  1952. begin
  1953. Result:='';
  1954. if FModule=nil then exit;
  1955. C:=FModule.ClassType;
  1956. if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
  1957. Result:=Engine.DefaultNameSpace;
  1958. end;
  1959. constructor TCustomTestModule.Create;
  1960. begin
  1961. inherited Create;
  1962. FHintMsgs:=TObjectList.Create(true);
  1963. FHintMsgsGood:=TFPList.Create;
  1964. end;
  1965. destructor TCustomTestModule.Destroy;
  1966. begin
  1967. FreeAndNil(FHintMsgs);
  1968. FreeAndNil(FHintMsgsGood);
  1969. inherited Destroy;
  1970. end;
  1971. { TTestModule }
  1972. procedure TTestModule.TestReservedWords;
  1973. var
  1974. i: integer;
  1975. begin
  1976. for i:=low(JSReservedWords) to High(JSReservedWords)-1 do
  1977. if CompareStr(JSReservedWords[i],JSReservedWords[i+1])>=0 then
  1978. Fail('20170203135442 '+JSReservedWords[i]+' >= '+JSReservedWords[i+1]);
  1979. for i:=low(JSReservedGlobalWords) to High(JSReservedGlobalWords)-1 do
  1980. if CompareStr(JSReservedGlobalWords[i],JSReservedGlobalWords[i+1])>=0 then
  1981. Fail('20170203135443 '+JSReservedGlobalWords[i]+' >= '+JSReservedGlobalWords[i+1]);
  1982. end;
  1983. procedure TTestModule.TestEmptyProgram;
  1984. begin
  1985. StartProgram(false);
  1986. Add('begin');
  1987. ConvertProgram;
  1988. CheckSource('TestEmptyProgram','','');
  1989. end;
  1990. procedure TTestModule.TestEmptyProgramUseStrict;
  1991. begin
  1992. Converter.Options:=Converter.Options+[coUseStrict];
  1993. StartProgram(false);
  1994. Add('begin');
  1995. ConvertProgram;
  1996. CheckSource('TestEmptyProgramUseStrict','','');
  1997. end;
  1998. procedure TTestModule.TestEmptyUnit;
  1999. begin
  2000. StartUnit(false);
  2001. Add('interface');
  2002. Add('implementation');
  2003. ConvertUnit;
  2004. CheckSource('TestEmptyUnit',
  2005. LinesToStr([
  2006. ]),
  2007. '');
  2008. end;
  2009. procedure TTestModule.TestEmptyUnitUseStrict;
  2010. begin
  2011. Converter.Options:=Converter.Options+[coUseStrict];
  2012. StartUnit(false);
  2013. Add('interface');
  2014. Add('implementation');
  2015. ConvertUnit;
  2016. CheckSource('TestEmptyUnitUseStrict',
  2017. LinesToStr([
  2018. ''
  2019. ]),
  2020. '');
  2021. end;
  2022. procedure TTestModule.TestDottedUnitNames;
  2023. begin
  2024. AddModuleWithIntfImplSrc('NS1.Unit2.pas',
  2025. LinesToStr([
  2026. 'var iV: longint;'
  2027. ]),
  2028. '');
  2029. FFilename:='ns1.test1.pp';
  2030. StartProgram(true);
  2031. Add('uses unIt2;');
  2032. Add('implementation');
  2033. Add('var');
  2034. Add(' i: longint;');
  2035. Add('begin');
  2036. Add(' i:=iv;');
  2037. Add(' i:=uNit2.iv;');
  2038. Add(' i:=Ns1.TEst1.i;');
  2039. ConvertProgram;
  2040. CheckSource('TestDottedUnitNames',
  2041. LinesToStr([
  2042. 'this.i = 0;',
  2043. '']),
  2044. LinesToStr([ // this.$init
  2045. '$mod.i = pas["NS1.Unit2"].iV;',
  2046. '$mod.i = pas["NS1.Unit2"].iV;',
  2047. '$mod.i = $mod.i;',
  2048. '']) );
  2049. end;
  2050. procedure TTestModule.TestDottedUnitNameImpl;
  2051. begin
  2052. AddModuleWithIntfImplSrc('TEST.UnitA.pas',
  2053. LinesToStr([
  2054. 'type',
  2055. ' TObject = class end;',
  2056. ' TTestA = class',
  2057. ' end;'
  2058. ]),
  2059. LinesToStr(['uses TEST.UnitB;'])
  2060. );
  2061. AddModuleWithIntfImplSrc('TEST.UnitB.pas',
  2062. LinesToStr([
  2063. 'uses TEST.UnitA;',
  2064. 'type TTestB = class(TTestA);'
  2065. ]),
  2066. ''
  2067. );
  2068. StartProgram(true);
  2069. Add('uses TEST.UnitA;');
  2070. Add('begin');
  2071. ConvertProgram;
  2072. CheckSource('TestDottedUnitNameImpl',
  2073. LinesToStr([
  2074. '']),
  2075. LinesToStr([ // this.$init
  2076. '']) );
  2077. CheckUnit('TEST.UnitA.pas',
  2078. LinesToStr([
  2079. 'rtl.module("TEST.UnitA", ["system"], function () {',
  2080. ' var $mod = this;',
  2081. ' rtl.createClass($mod, "TObject", null, function () {',
  2082. ' this.$init = function () {',
  2083. ' };',
  2084. ' this.$final = function () {',
  2085. ' };',
  2086. ' });',
  2087. ' rtl.createClass($mod, "TTestA", $mod.TObject, function () {',
  2088. ' });',
  2089. '}, ["TEST.UnitB"]);'
  2090. ]));
  2091. CheckUnit('TEST.UnitB.pas',
  2092. LinesToStr([
  2093. 'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
  2094. ' var $mod = this;',
  2095. ' rtl.createClass($mod, "TTestB", pas["TEST.UnitA"].TTestA, function () {',
  2096. ' });',
  2097. '});'
  2098. ]));
  2099. end;
  2100. procedure TTestModule.TestDottedUnitExpr;
  2101. begin
  2102. AddModuleWithIntfImplSrc('NS2.SubNs2.Unit2.pas',
  2103. LinesToStr([
  2104. 'procedure DoIt;'
  2105. ]),
  2106. 'procedure DoIt; begin end;');
  2107. FFilename:='Ns1.SubNs1.Test1.pp';
  2108. StartProgram(true);
  2109. Add('uses Ns2.sUbnS2.unIt2;');
  2110. Add('implementation');
  2111. Add('var');
  2112. Add(' i: longint;');
  2113. Add('begin');
  2114. Add(' ns2.subns2.unit2.doit;');
  2115. Add(' i:=Ns1.SubNS1.TEst1.i;');
  2116. ConvertProgram;
  2117. CheckSource('TestDottedUnitExpr',
  2118. LinesToStr([
  2119. 'this.i = 0;',
  2120. '']),
  2121. LinesToStr([ // this.$init
  2122. 'pas["NS2.SubNs2.Unit2"].DoIt();',
  2123. '$mod.i = $mod.i;',
  2124. '']) );
  2125. end;
  2126. procedure TTestModule.Test_ModeFPCFail;
  2127. begin
  2128. StartProgram(false);
  2129. Add('{$mode FPC}');
  2130. Add('begin');
  2131. SetExpectedScannerError('Invalid mode: "FPC"',nErrInvalidMode);
  2132. ConvertProgram;
  2133. end;
  2134. procedure TTestModule.Test_ModeSwitchCBlocksFail;
  2135. begin
  2136. StartProgram(false);
  2137. Add('{$modeswitch cblocks-}');
  2138. Add('begin');
  2139. SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
  2140. ConvertProgram;
  2141. end;
  2142. procedure TTestModule.TestUnit_UseSystem;
  2143. begin
  2144. StartUnit(true);
  2145. Add([
  2146. 'interface',
  2147. 'var i: integer;',
  2148. 'implementation']);
  2149. ConvertUnit;
  2150. CheckSource('TestUnit_UseSystem',
  2151. LinesToStr([
  2152. 'this.i = 0;',
  2153. '']),
  2154. LinesToStr([
  2155. '']) );
  2156. end;
  2157. procedure TTestModule.TestUnit_Intf1Impl2Intf1;
  2158. begin
  2159. AddModuleWithIntfImplSrc('unit1.pp',
  2160. LinesToStr([
  2161. 'type number = longint;']),
  2162. LinesToStr([
  2163. 'uses test1;',
  2164. 'procedure DoIt;',
  2165. 'begin',
  2166. ' i:=3;',
  2167. 'end;']));
  2168. StartUnit(true);
  2169. Add([
  2170. 'interface',
  2171. 'uses unit1;',
  2172. 'var i: number;',
  2173. 'implementation']);
  2174. ConvertUnit;
  2175. CheckSource('TestUnit_Intf1Impl2Intf1',
  2176. LinesToStr([
  2177. 'this.i = 0;',
  2178. '']),
  2179. LinesToStr([
  2180. '']) );
  2181. end;
  2182. procedure TTestModule.TestIncludeVersion;
  2183. begin
  2184. StartProgram(false);
  2185. Add([
  2186. 'var',
  2187. ' s: string;',
  2188. ' i: word;',
  2189. 'begin',
  2190. ' s:={$I %line%};',
  2191. ' i:={$I %linenum%};',
  2192. ' s:={$I %currentroutine%};',
  2193. ' s:={$I %pas2jsversion%};',
  2194. ' s:={$I %pas2jstarget%};',
  2195. ' s:={$I %pas2jstargetos%};',
  2196. ' s:={$I %pas2jstargetcpu%};',
  2197. ' s:={$I %file%};',
  2198. '']);
  2199. ConvertProgram;
  2200. CheckSource('TestIncludeVersion',
  2201. LinesToStr([
  2202. 'this.s="";',
  2203. 'this.i = 0;']),
  2204. LinesToStr([
  2205. '$mod.s = "7";',
  2206. '$mod.i = 8;',
  2207. '$mod.s = "<anonymous>";',
  2208. '$mod.s = "Comp.Ver.tcmodules";',
  2209. '$mod.s = "Browser";',
  2210. '$mod.s = "Browser";',
  2211. '$mod.s = "ECMAScript5";',
  2212. '$mod.s = "test1.pp";',
  2213. '']));
  2214. end;
  2215. procedure TTestModule.TestVarInt;
  2216. begin
  2217. StartProgram(false);
  2218. Add('var MyI: longint;');
  2219. Add('begin');
  2220. ConvertProgram;
  2221. CheckSource('TestVarInt','this.MyI=0;','');
  2222. end;
  2223. procedure TTestModule.TestVarBaseTypes;
  2224. begin
  2225. StartProgram(false);
  2226. Add('var');
  2227. Add(' i: longint;');
  2228. Add(' s: string;');
  2229. Add(' c: char;');
  2230. Add(' b: boolean;');
  2231. Add(' d: double;');
  2232. Add(' i2: longint = 3;');
  2233. Add(' s2: string = ''foo'';');
  2234. Add(' c2: char = ''4'';');
  2235. Add(' b2: boolean = true;');
  2236. Add(' d2: double = 5.6;');
  2237. Add(' i3: longint = $707;');
  2238. Add(' i4: nativeint = 4503599627370495;');
  2239. Add(' i5: nativeint = -4503599627370495-1;');
  2240. Add(' i6: nativeint = $fffffffffffff;');
  2241. Add(' i7: nativeint = -$fffffffffffff-1;');
  2242. Add(' i8: byte = 00;');
  2243. Add(' u8: nativeuint = $fffffffffffff;');
  2244. Add(' u9: nativeuint = $0000000000000;');
  2245. Add(' u10: nativeuint = $00ff00;');
  2246. Add('begin');
  2247. ConvertProgram;
  2248. CheckSource('TestVarBaseTypes',
  2249. LinesToStr([
  2250. 'this.i = 0;',
  2251. 'this.s = "";',
  2252. 'this.c = "";',
  2253. 'this.b = false;',
  2254. 'this.d = 0.0;',
  2255. 'this.i2 = 3;',
  2256. 'this.s2 = "foo";',
  2257. 'this.c2 = "4";',
  2258. 'this.b2 = true;',
  2259. 'this.d2 = 5.6;',
  2260. 'this.i3 = 0x707;',
  2261. 'this.i4 = 4503599627370495;',
  2262. 'this.i5 = -4503599627370495-1;',
  2263. 'this.i6 = 0xfffffffffffff;',
  2264. 'this.i7 =-0xfffffffffffff-1;',
  2265. 'this.i8 = 0;',
  2266. 'this.u8 = 0xfffffffffffff;',
  2267. 'this.u9 = 0x0;',
  2268. 'this.u10 = 0xff00;'
  2269. ]),
  2270. '');
  2271. end;
  2272. procedure TTestModule.TestBaseTypeSingleFail;
  2273. begin
  2274. StartProgram(false);
  2275. Add('var s: single;');
  2276. SetExpectedPasResolverError('identifier not found "single"',PasResolveEval.nIdentifierNotFound);
  2277. ConvertProgram;
  2278. end;
  2279. procedure TTestModule.TestBaseTypeExtendedFail;
  2280. begin
  2281. StartProgram(false);
  2282. Add('var e: extended;');
  2283. SetExpectedPasResolverError('identifier not found "extended"',PasResolveEval.nIdentifierNotFound);
  2284. ConvertProgram;
  2285. end;
  2286. procedure TTestModule.TestConstBaseTypes;
  2287. begin
  2288. StartProgram(false);
  2289. Add('const');
  2290. Add(' i: longint = 3;');
  2291. Add(' s: string = ''foo'';');
  2292. Add(' c: char = ''4'';');
  2293. Add(' b: boolean = true;');
  2294. Add(' d: double = 5.6;');
  2295. Add(' e = low(word);');
  2296. Add(' f = high(word);');
  2297. Add('begin');
  2298. ConvertProgram;
  2299. CheckSource('TestVarBaseTypes',
  2300. LinesToStr([
  2301. 'this.i=3;',
  2302. 'this.s="foo";',
  2303. 'this.c="4";',
  2304. 'this.b=true;',
  2305. 'this.d=5.6;',
  2306. 'this.e = 0;',
  2307. 'this.f = 65535;'
  2308. ]),
  2309. '');
  2310. end;
  2311. procedure TTestModule.TestAliasTypeRef;
  2312. begin
  2313. StartProgram(false);
  2314. Add('type');
  2315. Add(' a=longint;');
  2316. Add(' b=a;');
  2317. Add('var');
  2318. Add(' c: A;');
  2319. Add(' d: B;');
  2320. Add('begin');
  2321. ConvertProgram;
  2322. CheckSource('TestAliasTypeRef',
  2323. LinesToStr([ // statements
  2324. 'this.c = 0;',
  2325. 'this.d = 0;'
  2326. ]),
  2327. LinesToStr([ // this.$main
  2328. ''
  2329. ]));
  2330. end;
  2331. procedure TTestModule.TestTypeCast_BaseTypes;
  2332. begin
  2333. StartProgram(false);
  2334. Add([
  2335. 'var',
  2336. ' i: longint;',
  2337. ' b: boolean;',
  2338. ' d: double;',
  2339. ' s: string;',
  2340. ' c: char;',
  2341. 'begin',
  2342. ' i:=longint(i);',
  2343. ' i:=longint(b);',
  2344. ' b:=boolean(b);',
  2345. ' b:=boolean(i);',
  2346. ' d:=double(d);',
  2347. ' d:=double(i);',
  2348. ' s:=string(s);',
  2349. ' s:=string(c);',
  2350. ' c:=char(c);',
  2351. ' c:=char(i);',
  2352. ' c:=char(65);',
  2353. ' c:=char(#10);',
  2354. ' c:=char(#$E000);',
  2355. '']);
  2356. ConvertProgram;
  2357. CheckSource('TestAliasTypeRef',
  2358. LinesToStr([ // statements
  2359. 'this.i = 0;',
  2360. 'this.b = false;',
  2361. 'this.d = 0.0;',
  2362. 'this.s = "";',
  2363. 'this.c = "";',
  2364. '']),
  2365. LinesToStr([ // this.$main
  2366. '$mod.i = $mod.i;',
  2367. '$mod.i = ($mod.b ? 1 : 0);',
  2368. '$mod.b = $mod.b;',
  2369. '$mod.b = $mod.i != 0;',
  2370. '$mod.d = $mod.d;',
  2371. '$mod.d = $mod.i;',
  2372. '$mod.s = $mod.s;',
  2373. '$mod.s = $mod.c;',
  2374. '$mod.c = $mod.c;',
  2375. '$mod.c = String.fromCharCode($mod.i);',
  2376. '$mod.c = "A";',
  2377. '$mod.c = "\n";',
  2378. '$mod.c = "";',
  2379. '']));
  2380. end;
  2381. procedure TTestModule.TestTypeCast_AliasBaseTypes;
  2382. begin
  2383. StartProgram(false);
  2384. Add('type');
  2385. Add(' integer = longint;');
  2386. Add(' TYesNo = boolean;');
  2387. Add(' TFloat = double;');
  2388. Add(' TCaption = string;');
  2389. Add(' TChar = char;');
  2390. Add('var');
  2391. Add(' i: integer;');
  2392. Add(' b: TYesNo;');
  2393. Add(' d: TFloat;');
  2394. Add(' s: TCaption;');
  2395. Add(' c: TChar;');
  2396. Add('begin');
  2397. Add(' i:=integer(i);');
  2398. Add(' i:=integer(b);');
  2399. Add(' b:=TYesNo(b);');
  2400. Add(' b:=TYesNo(i);');
  2401. Add(' d:=TFloat(d);');
  2402. Add(' d:=TFloat(i);');
  2403. Add(' s:=TCaption(s);');
  2404. Add(' s:=TCaption(c);');
  2405. Add(' c:=TChar(c);');
  2406. ConvertProgram;
  2407. CheckSource('TestAliasTypeRef',
  2408. LinesToStr([ // statements
  2409. 'this.i = 0;',
  2410. 'this.b = false;',
  2411. 'this.d = 0.0;',
  2412. 'this.s = "";',
  2413. 'this.c = "";',
  2414. '']),
  2415. LinesToStr([ // this.$main
  2416. '$mod.i = $mod.i;',
  2417. '$mod.i = ($mod.b ? 1 : 0);',
  2418. '$mod.b = $mod.b;',
  2419. '$mod.b = $mod.i != 0;',
  2420. '$mod.d = $mod.d;',
  2421. '$mod.d = $mod.i;',
  2422. '$mod.s = $mod.s;',
  2423. '$mod.s = $mod.c;',
  2424. '$mod.c = $mod.c;',
  2425. '']));
  2426. end;
  2427. procedure TTestModule.TestEmptyProc;
  2428. begin
  2429. StartProgram(false);
  2430. Add('procedure Test;');
  2431. Add('begin');
  2432. Add('end;');
  2433. Add('begin');
  2434. ConvertProgram;
  2435. CheckSource('TestEmptyProc',
  2436. LinesToStr([ // statements
  2437. 'this.Test = function () {',
  2438. '};'
  2439. ]),
  2440. LinesToStr([ // this.$main
  2441. ''
  2442. ]));
  2443. end;
  2444. procedure TTestModule.TestProcOneParam;
  2445. begin
  2446. StartProgram(false);
  2447. Add('procedure ProcA(i: longint);');
  2448. Add('begin');
  2449. Add('end;');
  2450. Add('begin');
  2451. Add(' PROCA(3);');
  2452. ConvertProgram;
  2453. CheckSource('TestProcOneParam',
  2454. LinesToStr([ // statements
  2455. 'this.ProcA = function (i) {',
  2456. '};'
  2457. ]),
  2458. LinesToStr([ // this.$main
  2459. '$mod.ProcA(3);'
  2460. ]));
  2461. end;
  2462. procedure TTestModule.TestFunctionWithoutParams;
  2463. begin
  2464. StartProgram(false);
  2465. Add('function FuncA: longint;');
  2466. Add('begin');
  2467. Add('end;');
  2468. Add('var i: longint;');
  2469. Add('begin');
  2470. Add(' I:=FUNCA();');
  2471. Add(' I:=FUNCA;');
  2472. Add(' FUNCA();');
  2473. Add(' FUNCA;');
  2474. ConvertProgram;
  2475. CheckSource('TestProcWithoutParams',
  2476. LinesToStr([ // statements
  2477. 'this.FuncA = function () {',
  2478. ' var Result = 0;',
  2479. ' return Result;',
  2480. '};',
  2481. 'this.i=0;'
  2482. ]),
  2483. LinesToStr([ // this.$main
  2484. '$mod.i=$mod.FuncA();',
  2485. '$mod.i=$mod.FuncA();',
  2486. '$mod.FuncA();',
  2487. '$mod.FuncA();'
  2488. ]));
  2489. end;
  2490. procedure TTestModule.TestProcedureWithoutParams;
  2491. begin
  2492. StartProgram(false);
  2493. Add('procedure ProcA;');
  2494. Add('begin');
  2495. Add('end;');
  2496. Add('begin');
  2497. Add(' PROCA();');
  2498. Add(' PROCA;');
  2499. ConvertProgram;
  2500. CheckSource('TestProcWithoutParams',
  2501. LinesToStr([ // statements
  2502. 'this.ProcA = function () {',
  2503. '};'
  2504. ]),
  2505. LinesToStr([ // this.$main
  2506. '$mod.ProcA();',
  2507. '$mod.ProcA();'
  2508. ]));
  2509. end;
  2510. procedure TTestModule.TestIncDec;
  2511. begin
  2512. StartProgram(false);
  2513. Add([
  2514. 'procedure DoIt(var i: longint);',
  2515. 'begin',
  2516. ' inc(i);',
  2517. ' inc(i,2);',
  2518. 'end;',
  2519. 'var',
  2520. ' Bar: longint;',
  2521. 'begin',
  2522. ' inc(bar);',
  2523. ' inc(bar,2);',
  2524. ' dec(bar);',
  2525. ' dec(bar,3);',
  2526. '']);
  2527. ConvertProgram;
  2528. CheckSource('TestIncDec',
  2529. LinesToStr([ // statements
  2530. 'this.DoIt = function (i) {',
  2531. ' i.set(i.get()+1);',
  2532. ' i.set(i.get()+2);',
  2533. '};',
  2534. 'this.Bar = 0;'
  2535. ]),
  2536. LinesToStr([ // this.$main
  2537. '$mod.Bar+=1;',
  2538. '$mod.Bar+=2;',
  2539. '$mod.Bar-=1;',
  2540. '$mod.Bar-=3;'
  2541. ]));
  2542. end;
  2543. procedure TTestModule.TestLoHiFpcMode;
  2544. begin
  2545. StartProgram(false);
  2546. Add([
  2547. '{$mode objfpc}',
  2548. 'const',
  2549. ' LoByte1 = Lo(Word($1234));',
  2550. ' HiByte1 = Hi(Word($1234));',
  2551. ' LoByte2 = Lo(SmallInt($1234));',
  2552. ' HiByte2 = Hi(SmallInt($1234));',
  2553. ' LoWord1 = Lo($1234CDEF);',
  2554. ' HiWord1 = Hi($1234CDEF);',
  2555. ' LoWord2 = Lo(-$1234CDEF);',
  2556. ' HiWord2 = Hi(-$1234CDEF);',
  2557. ' lo4:byte=lo(byte($34));',
  2558. ' hi4:byte=hi(byte($34));',
  2559. ' lo5:byte=lo(shortint(-$34));',
  2560. ' hi5:byte=hi(shortint(-$34));',
  2561. ' lo6:longword=lo($123456789ABCD);',
  2562. ' hi6:longword=hi($123456789ABCD);',
  2563. ' lo7:longword=lo(-$123456789ABCD);',
  2564. ' hi7:longword=hi(-$123456789ABCD);',
  2565. 'var',
  2566. ' b: Byte;',
  2567. ' ss: shortint;',
  2568. ' w: Word;',
  2569. ' si: SmallInt;',
  2570. ' lw: LongWord;',
  2571. ' li: LongInt;',
  2572. ' b2: Byte;',
  2573. ' ni: nativeint;',
  2574. 'begin',
  2575. ' w := $1234;',
  2576. ' ss := -$12;',
  2577. ' b := lo(ss);',
  2578. ' b := HI(ss);',
  2579. ' b := lo(w);',
  2580. ' b := HI(w);',
  2581. ' b2 := lo(b);',
  2582. ' b2 := hi(b);',
  2583. ' lw := $1234CDEF;',
  2584. ' w := lo(lw);',
  2585. ' w := hi(lw);',
  2586. ' ni := $123456789ABCD;',
  2587. ' lw := lo(ni);',
  2588. ' lw := hi(ni);',
  2589. '']);
  2590. ConvertProgram;
  2591. CheckSource('TestLoHiFpcMode',
  2592. LinesToStr([ // statements
  2593. 'this.LoByte1 = 0x1234 & 0xFF;',
  2594. 'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
  2595. 'this.LoByte2 = 0x1234 & 0xFF;',
  2596. 'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
  2597. 'this.LoWord1 = 0x1234CDEF & 0xFFFF;',
  2598. 'this.HiWord1 = (0x1234CDEF >> 16) & 0xFFFF;',
  2599. 'this.LoWord2 = -0x1234CDEF & 0xFFFF;',
  2600. 'this.HiWord2 = (-0x1234CDEF >> 16) & 0xFFFF;',
  2601. 'this.lo4 = 0x34 & 0xF;',
  2602. 'this.hi4 = (0x34 >> 4) & 0xF;',
  2603. 'this.lo5 = (((-0x34 & 255) << 24) >> 24) & 0xFF;',
  2604. 'this.hi5 = ((((-0x34 & 255) << 24) >> 24) >> 8) & 0xFF;',
  2605. 'this.lo6 = 0x123456789ABCD >>> 0;',
  2606. 'this.hi6 = 74565 >>> 0;',
  2607. 'this.lo7 = -0x123456789ABCD >>> 0;',
  2608. 'this.hi7 = Math.floor(-0x123456789ABCD / 4294967296) >>> 0;',
  2609. 'this.b = 0;',
  2610. 'this.ss = 0;',
  2611. 'this.w = 0;',
  2612. 'this.si = 0;',
  2613. 'this.lw = 0;',
  2614. 'this.li = 0;',
  2615. 'this.b2 = 0;',
  2616. 'this.ni = 0;',
  2617. '']),
  2618. LinesToStr([ // this.$main
  2619. '$mod.w = 0x1234;',
  2620. '$mod.ss = -0x12;',
  2621. '$mod.b = $mod.ss & 0xFF;',
  2622. '$mod.b = ($mod.ss >> 8) & 0xFF;',
  2623. '$mod.b = $mod.w & 0xFF;',
  2624. '$mod.b = ($mod.w >> 8) & 0xFF;',
  2625. '$mod.b2 = $mod.b & 0xF;',
  2626. '$mod.b2 = ($mod.b >> 4) & 0xF;',
  2627. '$mod.lw = 0x1234CDEF;',
  2628. '$mod.w = $mod.lw & 0xFFFF;',
  2629. '$mod.w = ($mod.lw >> 16) & 0xFFFF;',
  2630. '$mod.ni = 0x123456789ABCD;',
  2631. '$mod.lw = $mod.ni >>> 0;',
  2632. '$mod.lw = Math.floor($mod.ni / 4294967296) >>> 0;',
  2633. '']));
  2634. end;
  2635. procedure TTestModule.TestLoHiDelphiMode;
  2636. begin
  2637. StartProgram(false);
  2638. Add([
  2639. '{$mode delphi}',
  2640. 'const',
  2641. ' LoByte1 = Lo(Word($1234));',
  2642. ' HiByte1 = Hi(Word($1234));',
  2643. ' LoByte2 = Lo(SmallInt($1234));',
  2644. ' HiByte2 = Hi(SmallInt($1234));',
  2645. ' LoByte3 = Lo($1234CDEF);',
  2646. ' HiByte3 = Hi($1234CDEF);',
  2647. ' LoByte4 = Lo(-$1234CDEF);',
  2648. ' HiByte4 = Hi(-$1234CDEF);',
  2649. 'var',
  2650. ' b: Byte;',
  2651. ' w: Word;',
  2652. ' si: SmallInt;',
  2653. ' lw: LongWord;',
  2654. ' li: LongInt;',
  2655. 'begin',
  2656. ' w := $1234;',
  2657. ' b := lo(w);',
  2658. ' b := HI(w);',
  2659. ' lw := $1234CDEF;',
  2660. ' b := lo(lw);',
  2661. ' b := hi(lw);',
  2662. '']);
  2663. ConvertProgram;
  2664. CheckSource('TestLoHiDelphiMode',
  2665. LinesToStr([ // statements
  2666. 'this.LoByte1 = 0x1234 & 0xFF;',
  2667. 'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
  2668. 'this.LoByte2 = 0x1234 & 0xFF;',
  2669. 'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
  2670. 'this.LoByte3 = 0x1234CDEF & 0xFF;',
  2671. 'this.HiByte3 = (0x1234CDEF >> 8) & 0xFF;',
  2672. 'this.LoByte4 = -0x1234CDEF & 0xFF;',
  2673. 'this.HiByte4 = (-0x1234CDEF >> 8) & 0xFF;',
  2674. 'this.b = 0;',
  2675. 'this.w = 0;',
  2676. 'this.si = 0;',
  2677. 'this.lw = 0;',
  2678. 'this.li = 0;'
  2679. ]),
  2680. LinesToStr([ // this.$main
  2681. '$mod.w = 0x1234;',
  2682. '$mod.b = $mod.w & 0xFF;',
  2683. '$mod.b = ($mod.w >> 8) & 0xFF;',
  2684. '$mod.lw = 0x1234CDEF;',
  2685. '$mod.b = $mod.lw & 0xFF;',
  2686. '$mod.b = ($mod.lw >> 8) & 0xFF;'
  2687. ]));
  2688. end;
  2689. procedure TTestModule.TestAssignments;
  2690. begin
  2691. StartProgram(false);
  2692. Parser.Options:=Parser.Options+[po_cassignments];
  2693. Add('var');
  2694. Add(' Bar:longint;');
  2695. Add('begin');
  2696. Add(' bar:=3;');
  2697. Add(' bar+=4;');
  2698. Add(' bar-=5;');
  2699. Add(' bar*=6;');
  2700. ConvertProgram;
  2701. CheckSource('TestAssignments',
  2702. LinesToStr([ // statements
  2703. 'this.Bar = 0;'
  2704. ]),
  2705. LinesToStr([ // this.$main
  2706. '$mod.Bar=3;',
  2707. '$mod.Bar+=4;',
  2708. '$mod.Bar-=5;',
  2709. '$mod.Bar*=6;'
  2710. ]));
  2711. end;
  2712. procedure TTestModule.TestArithmeticOperators1;
  2713. begin
  2714. StartProgram(false);
  2715. Add('var');
  2716. Add(' vA,vB,vC:longint;');
  2717. Add('begin');
  2718. Add(' va:=1;');
  2719. Add(' vb:=va+va;');
  2720. Add(' vb:=va div vb;');
  2721. Add(' vb:=va mod vb;');
  2722. Add(' vb:=va+va*vb+va div vb;');
  2723. Add(' vc:=-va;');
  2724. Add(' va:=va-vb;');
  2725. Add(' vb:=va;');
  2726. Add(' if va<vb then vc:=va else vc:=vb;');
  2727. ConvertProgram;
  2728. CheckSource('TestArithmeticOperators1',
  2729. LinesToStr([ // statements
  2730. 'this.vA = 0;',
  2731. 'this.vB = 0;',
  2732. 'this.vC = 0;'
  2733. ]),
  2734. LinesToStr([ // this.$main
  2735. '$mod.vA = 1;',
  2736. '$mod.vB = $mod.vA + $mod.vA;',
  2737. '$mod.vB = Math.floor($mod.vA / $mod.vB);',
  2738. '$mod.vB = $mod.vA % $mod.vB;',
  2739. '$mod.vB = $mod.vA + ($mod.vA * $mod.vB) + Math.floor($mod.vA / $mod.vB);',
  2740. '$mod.vC = -$mod.vA;',
  2741. '$mod.vA = $mod.vA - $mod.vB;',
  2742. '$mod.vB = $mod.vA;',
  2743. 'if ($mod.vA < $mod.vB){ $mod.vC = $mod.vA } else $mod.vC = $mod.vB;'
  2744. ]));
  2745. end;
  2746. procedure TTestModule.TestLogicalOperators;
  2747. begin
  2748. StartProgram(false);
  2749. Add('var');
  2750. Add(' vA,vB,vC:boolean;');
  2751. Add('begin');
  2752. Add(' va:=vb and vc;');
  2753. Add(' va:=vb or vc;');
  2754. Add(' va:=vb xor vc;');
  2755. Add(' va:=true and vc;');
  2756. Add(' va:=(vb and vc) or (va and vb);');
  2757. Add(' va:=not vb;');
  2758. ConvertProgram;
  2759. CheckSource('TestLogicalOperators',
  2760. LinesToStr([ // statements
  2761. 'this.vA = false;',
  2762. 'this.vB = false;',
  2763. 'this.vC = false;'
  2764. ]),
  2765. LinesToStr([ // this.$main
  2766. '$mod.vA = $mod.vB && $mod.vC;',
  2767. '$mod.vA = $mod.vB || $mod.vC;',
  2768. '$mod.vA = $mod.vB ^ $mod.vC;',
  2769. '$mod.vA = true && $mod.vC;',
  2770. '$mod.vA = ($mod.vB && $mod.vC) || ($mod.vA && $mod.vB);',
  2771. '$mod.vA = !$mod.vB;'
  2772. ]));
  2773. end;
  2774. procedure TTestModule.TestBitwiseOperators;
  2775. begin
  2776. StartProgram(false);
  2777. Add('var');
  2778. Add(' vA,vB,vC:longint;');
  2779. Add('begin');
  2780. Add(' va:=vb and vc;');
  2781. Add(' va:=vb or vc;');
  2782. Add(' va:=vb xor vc;');
  2783. Add(' va:=vb shl vc;');
  2784. Add(' va:=vb shr vc;');
  2785. Add(' va:=3 and vc;');
  2786. Add(' va:=(vb and vc) or (va and vb);');
  2787. Add(' va:=not vb;');
  2788. ConvertProgram;
  2789. CheckSource('TestBitwiseOperators',
  2790. LinesToStr([ // statements
  2791. 'this.vA = 0;',
  2792. 'this.vB = 0;',
  2793. 'this.vC = 0;'
  2794. ]),
  2795. LinesToStr([ // this.$main
  2796. '$mod.vA = $mod.vB & $mod.vC;',
  2797. '$mod.vA = $mod.vB | $mod.vC;',
  2798. '$mod.vA = $mod.vB ^ $mod.vC;',
  2799. '$mod.vA = $mod.vB << $mod.vC;',
  2800. '$mod.vA = $mod.vB >>> $mod.vC;',
  2801. '$mod.vA = 3 & $mod.vC;',
  2802. '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
  2803. '$mod.vA = ~$mod.vB;'
  2804. ]));
  2805. end;
  2806. procedure TTestModule.TestPrgProcVar;
  2807. begin
  2808. StartProgram(false);
  2809. Add('procedure Proc1;');
  2810. Add('type');
  2811. Add(' t1=longint;');
  2812. Add('var');
  2813. Add(' vA:t1;');
  2814. Add('begin');
  2815. Add('end;');
  2816. Add('begin');
  2817. ConvertProgram;
  2818. CheckSource('TestPrgProcVar',
  2819. LinesToStr([ // statements
  2820. 'this.Proc1 = function () {',
  2821. ' var vA=0;',
  2822. '};'
  2823. ]),
  2824. LinesToStr([ // this.$main
  2825. ''
  2826. ]));
  2827. end;
  2828. procedure TTestModule.TestUnitProcVar;
  2829. begin
  2830. StartUnit(false);
  2831. Add('interface');
  2832. Add('');
  2833. Add('type tA=string; // unit scope');
  2834. Add('procedure Proc1;');
  2835. Add('');
  2836. Add('implementation');
  2837. Add('');
  2838. Add('procedure Proc1;');
  2839. Add('type tA=longint; // local proc scope');
  2840. Add('var v1:tA; // using local tA');
  2841. Add('begin');
  2842. Add('end;');
  2843. Add('var v2:tA; // using interface tA');
  2844. ConvertUnit;
  2845. CheckSource('TestUnitProcVar',
  2846. LinesToStr([ // statements
  2847. 'var $impl = $mod.$impl;',
  2848. 'this.Proc1 = function () {',
  2849. ' var v1 = 0;',
  2850. '};',
  2851. '']),
  2852. // this.$init
  2853. '',
  2854. // implementation
  2855. LinesToStr([
  2856. '$impl.v2 = "";',
  2857. '']));
  2858. end;
  2859. procedure TTestModule.TestImplProc;
  2860. begin
  2861. StartUnit(false);
  2862. Add('interface');
  2863. Add('');
  2864. Add('procedure Proc1;');
  2865. Add('');
  2866. Add('implementation');
  2867. Add('');
  2868. Add('procedure Proc1; begin end;');
  2869. Add('procedure Proc2; begin end;');
  2870. Add('initialization');
  2871. Add(' Proc1;');
  2872. Add(' Proc2;');
  2873. ConvertUnit;
  2874. CheckSource('TestImplProc',
  2875. LinesToStr([ // statements
  2876. 'var $impl = $mod.$impl;',
  2877. 'this.Proc1 = function () {',
  2878. '};',
  2879. '']),
  2880. LinesToStr([ // this.$init
  2881. '$mod.Proc1();',
  2882. '$impl.Proc2();',
  2883. '']),
  2884. LinesToStr([ // implementation
  2885. '$impl.Proc2 = function () {',
  2886. '};',
  2887. ''])
  2888. );
  2889. end;
  2890. procedure TTestModule.TestFunctionResult;
  2891. begin
  2892. StartProgram(false);
  2893. Add('function Func1: longint;');
  2894. Add('begin');
  2895. Add(' Result:=3;');
  2896. Add(' Func1:=4;');
  2897. Add('end;');
  2898. Add('begin');
  2899. ConvertProgram;
  2900. CheckSource('TestFunctionResult',
  2901. LinesToStr([ // statements
  2902. 'this.Func1 = function () {',
  2903. ' var Result = 0;',
  2904. ' Result = 3;',
  2905. ' Result = 4;',
  2906. ' return Result;',
  2907. '};'
  2908. ]),
  2909. '');
  2910. end;
  2911. procedure TTestModule.TestNestedProc;
  2912. begin
  2913. StartProgram(false);
  2914. Add([
  2915. 'var vInUnit: longint;',
  2916. 'function DoIt(pA,pD: longint): longint;',
  2917. 'var',
  2918. ' vB: longint;',
  2919. ' vC: longint;',
  2920. ' function Nesty(pA: longint): longint; ',
  2921. ' var vB: longint;',
  2922. ' begin',
  2923. ' Result:=pa+vb+vc+pd+vInUnit;',
  2924. ' nesty:=3;',
  2925. ' doit:=4;',
  2926. ' exit;',
  2927. ' end;',
  2928. 'begin',
  2929. ' Result:=pa+vb+vc;',
  2930. ' doit:=6;',
  2931. ' exit;',
  2932. 'end;',
  2933. 'begin']);
  2934. ConvertProgram;
  2935. CheckSource('TestNestedProc',
  2936. LinesToStr([ // statements
  2937. 'this.vInUnit = 0;',
  2938. 'this.DoIt = function (pA, pD) {',
  2939. ' var Result = 0;',
  2940. ' var vB = 0;',
  2941. ' var vC = 0;',
  2942. ' function Nesty(pA) {',
  2943. ' var Result$1 = 0;',
  2944. ' var vB = 0;',
  2945. ' Result$1 = pA + vB + vC + pD + $mod.vInUnit;',
  2946. ' Result$1 = 3;',
  2947. ' Result = 4;',
  2948. ' return Result$1;',
  2949. ' return Result$1;',
  2950. ' };',
  2951. ' Result = pA + vB + vC;',
  2952. ' Result = 6;',
  2953. ' return Result;',
  2954. ' return Result;',
  2955. '};'
  2956. ]),
  2957. '');
  2958. end;
  2959. procedure TTestModule.TestNestedProc_ResultString;
  2960. begin
  2961. StartProgram(false);
  2962. Add([
  2963. 'function DoIt: string;',
  2964. ' function Nesty: string; ',
  2965. ' begin',
  2966. ' nesty:=#65#66;',
  2967. ' nesty[1]:=#67;',
  2968. ' doit:=#68;',
  2969. ' doit[2]:=#69;',
  2970. ' end;',
  2971. 'begin',
  2972. ' doit:=#70;',
  2973. ' doit[3]:=#71;',
  2974. 'end;',
  2975. 'begin']);
  2976. ConvertProgram;
  2977. CheckSource('TestNestedProc_ResultString',
  2978. LinesToStr([ // statements
  2979. 'this.DoIt = function () {',
  2980. ' var Result = "";',
  2981. ' function Nesty() {',
  2982. ' var Result$1 = "";',
  2983. ' Result$1 = "AB";',
  2984. ' Result$1 = rtl.setCharAt(Result$1, 0, "C");',
  2985. ' Result = "D";',
  2986. ' Result = rtl.setCharAt(Result, 1, "E");',
  2987. ' return Result$1;',
  2988. ' };',
  2989. ' Result = "F";',
  2990. ' Result = rtl.setCharAt(Result, 2, "G");',
  2991. ' return Result;',
  2992. '};'
  2993. ]),
  2994. '');
  2995. end;
  2996. procedure TTestModule.TestForwardProc;
  2997. begin
  2998. StartProgram(false);
  2999. Add('procedure FuncA(Bar: longint); forward;');
  3000. Add('procedure FuncB(Bar: longint);');
  3001. Add('begin');
  3002. Add(' funca(bar);');
  3003. Add('end;');
  3004. Add('procedure funca(bar: longint);');
  3005. Add('begin');
  3006. Add(' if bar=3 then ;');
  3007. Add('end;');
  3008. Add('begin');
  3009. Add(' funca(4);');
  3010. Add(' funcb(5);');
  3011. ConvertProgram;
  3012. CheckSource('TestForwardProc',
  3013. LinesToStr([ // statements'
  3014. 'this.FuncB = function (Bar) {',
  3015. ' $mod.FuncA(Bar);',
  3016. '};',
  3017. 'this.FuncA = function (Bar) {',
  3018. ' if (Bar === 3);',
  3019. '};'
  3020. ]),
  3021. LinesToStr([
  3022. '$mod.FuncA(4);',
  3023. '$mod.FuncB(5);'
  3024. ])
  3025. );
  3026. end;
  3027. procedure TTestModule.TestNestedForwardProc;
  3028. begin
  3029. StartProgram(false);
  3030. Add('procedure FuncA;');
  3031. Add(' procedure FuncB(i: longint); forward;');
  3032. Add(' procedure FuncC(i: longint);');
  3033. Add(' begin');
  3034. Add(' funcb(i);');
  3035. Add(' end;');
  3036. Add(' procedure FuncB(i: longint);');
  3037. Add(' begin');
  3038. Add(' if i=3 then ;');
  3039. Add(' end;');
  3040. Add('begin');
  3041. Add(' funcc(4)');
  3042. Add('end;');
  3043. Add('begin');
  3044. Add(' funca;');
  3045. ConvertProgram;
  3046. CheckSource('TestNestedForwardProc',
  3047. LinesToStr([ // statements'
  3048. 'this.FuncA = function () {',
  3049. ' function FuncC(i) {',
  3050. ' FuncB(i);',
  3051. ' };',
  3052. ' function FuncB(i) {',
  3053. ' if (i === 3);',
  3054. ' };',
  3055. ' FuncC(4);',
  3056. '};'
  3057. ]),
  3058. LinesToStr([
  3059. '$mod.FuncA();'
  3060. ])
  3061. );
  3062. end;
  3063. procedure TTestModule.TestAssignFunctionResult;
  3064. begin
  3065. StartProgram(false);
  3066. Add('function Func1: longint;');
  3067. Add('begin');
  3068. Add('end;');
  3069. Add('var i: longint;');
  3070. Add('begin');
  3071. Add(' i:=func1();');
  3072. Add(' i:=func1()+func1();');
  3073. ConvertProgram;
  3074. CheckSource('TestAssignFunctionResult',
  3075. LinesToStr([ // statements
  3076. 'this.Func1 = function () {',
  3077. ' var Result = 0;',
  3078. ' return Result;',
  3079. '};',
  3080. 'this.i = 0;'
  3081. ]),
  3082. LinesToStr([
  3083. '$mod.i = $mod.Func1();',
  3084. '$mod.i = $mod.Func1() + $mod.Func1();'
  3085. ]));
  3086. end;
  3087. procedure TTestModule.TestFunctionResultInCondition;
  3088. begin
  3089. StartProgram(false);
  3090. Add('function Func1: longint;');
  3091. Add('begin');
  3092. Add('end;');
  3093. Add('function Func2: boolean;');
  3094. Add('begin');
  3095. Add('end;');
  3096. Add('var i: longint;');
  3097. Add('begin');
  3098. Add(' if func2 then ;');
  3099. Add(' if i=func1() then ;');
  3100. Add(' if i=func1 then ;');
  3101. ConvertProgram;
  3102. CheckSource('TestFunctionResultInCondition',
  3103. LinesToStr([ // statements
  3104. 'this.Func1 = function () {',
  3105. ' var Result = 0;',
  3106. ' return Result;',
  3107. '};',
  3108. 'this.Func2 = function () {',
  3109. ' var Result = false;',
  3110. ' return Result;',
  3111. '};',
  3112. 'this.i = 0;'
  3113. ]),
  3114. LinesToStr([
  3115. 'if ($mod.Func2());',
  3116. 'if ($mod.i === $mod.Func1());',
  3117. 'if ($mod.i === $mod.Func1());'
  3118. ]));
  3119. end;
  3120. procedure TTestModule.TestFunctionResultInForLoop;
  3121. begin
  3122. StartProgram(false);
  3123. Add([
  3124. 'function Func1(a: array of longint): longint;',
  3125. 'begin',
  3126. ' for Result:=High(a) downto Low(a) do if a[Result]=0 then exit;',
  3127. ' for Result in a do if a[Result]=0 then exit;',
  3128. 'end;',
  3129. 'begin',
  3130. ' Func1([1,2,3])']);
  3131. ConvertProgram;
  3132. CheckSource('TestFunctionResultInForLoop',
  3133. LinesToStr([ // statements
  3134. 'this.Func1 = function (a) {',
  3135. ' var Result = 0;',
  3136. ' for (var $l1 = rtl.length(a) - 1; $l1 >= 0; $l1--) {',
  3137. ' Result = $l1;',
  3138. ' if (a[Result] === 0) return Result;',
  3139. ' };',
  3140. ' for (var $in2 = a, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) {',
  3141. ' Result = $in2[$l3];',
  3142. ' if (a[Result] === 0) return Result;',
  3143. ' };',
  3144. ' return Result;',
  3145. '};',
  3146. '']),
  3147. LinesToStr([
  3148. '$mod.Func1([1, 2, 3]);'
  3149. ]));
  3150. end;
  3151. procedure TTestModule.TestFunctionResultInTypeCast;
  3152. begin
  3153. StartProgram(false);
  3154. Add([
  3155. 'function GetInt: longint;',
  3156. 'begin',
  3157. 'end;',
  3158. 'begin',
  3159. ' if Byte(GetInt)=0 then ;',
  3160. '']);
  3161. ConvertProgram;
  3162. CheckSource('TestFunctionResultInTypeCast',
  3163. LinesToStr([ // statements
  3164. 'this.GetInt = function () {',
  3165. ' var Result = 0;',
  3166. ' return Result;',
  3167. '};',
  3168. '']),
  3169. LinesToStr([
  3170. 'if (($mod.GetInt() & 255) === 0) ;'
  3171. ]));
  3172. end;
  3173. procedure TTestModule.TestExit;
  3174. begin
  3175. StartProgram(false);
  3176. Add('procedure ProcA;');
  3177. Add('begin');
  3178. Add(' exit;');
  3179. Add('end;');
  3180. Add('function FuncB: longint;');
  3181. Add('begin');
  3182. Add(' exit;');
  3183. Add(' exit(3);');
  3184. Add('end;');
  3185. Add('function FuncC: string;');
  3186. Add('begin');
  3187. Add(' exit;');
  3188. Add(' exit(''a'');');
  3189. Add(' exit(''abc'');');
  3190. Add('end;');
  3191. Add('begin');
  3192. Add(' exit;');
  3193. Add(' exit(1);');
  3194. ConvertProgram;
  3195. CheckSource('TestExit',
  3196. LinesToStr([ // statements
  3197. 'this.ProcA = function () {',
  3198. ' return;',
  3199. '};',
  3200. 'this.FuncB = function () {',
  3201. ' var Result = 0;',
  3202. ' return Result;',
  3203. ' return 3;',
  3204. ' return Result;',
  3205. '};',
  3206. 'this.FuncC = function () {',
  3207. ' var Result = "";',
  3208. ' return Result;',
  3209. ' return "a";',
  3210. ' return "abc";',
  3211. ' return Result;',
  3212. '};'
  3213. ]),
  3214. LinesToStr([
  3215. 'return;',
  3216. 'return 1;',
  3217. '']));
  3218. end;
  3219. procedure TTestModule.TestBreak;
  3220. begin
  3221. StartProgram(false);
  3222. Add([
  3223. 'var',
  3224. ' i: longint;',
  3225. 'begin',
  3226. ' repeat',
  3227. ' break;',
  3228. ' until true;',
  3229. ' while true do',
  3230. ' break;',
  3231. ' for i:=1 to 2 do',
  3232. ' break;']);
  3233. ConvertProgram;
  3234. CheckSource('TestBreak',
  3235. LinesToStr([ // statements
  3236. 'this.i = 0;'
  3237. ]),
  3238. LinesToStr([
  3239. 'do {',
  3240. ' break;',
  3241. '} while (!true);',
  3242. 'while (true) break;',
  3243. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) break;',
  3244. '']));
  3245. end;
  3246. procedure TTestModule.TestBreakAsVar;
  3247. begin
  3248. StartProgram(false);
  3249. Add([
  3250. 'procedure DoIt(break: boolean);',
  3251. 'begin',
  3252. ' if break then ;',
  3253. 'end;',
  3254. 'var',
  3255. ' break: boolean;',
  3256. 'begin',
  3257. ' if break then ;']);
  3258. ConvertProgram;
  3259. CheckSource('TestBreakAsVar',
  3260. LinesToStr([ // statements
  3261. 'this.DoIt = function (Break) {',
  3262. ' if (Break) ;',
  3263. '};',
  3264. 'this.Break = false;',
  3265. '']),
  3266. LinesToStr([
  3267. 'if($mod.Break) ;',
  3268. '']));
  3269. end;
  3270. procedure TTestModule.TestContinue;
  3271. begin
  3272. StartProgram(false);
  3273. Add('var i: longint;');
  3274. Add('begin');
  3275. Add(' repeat');
  3276. Add(' continue;');
  3277. Add(' until true;');
  3278. Add(' while true do');
  3279. Add(' continue;');
  3280. Add(' for i:=1 to 2 do');
  3281. Add(' continue;');
  3282. ConvertProgram;
  3283. CheckSource('TestContinue',
  3284. LinesToStr([ // statements
  3285. 'this.i = 0;'
  3286. ]),
  3287. LinesToStr([
  3288. 'do {',
  3289. ' continue;',
  3290. '} while (!true);',
  3291. 'while (true) continue;',
  3292. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) continue;',
  3293. '']));
  3294. end;
  3295. procedure TTestModule.TestProc_External;
  3296. begin
  3297. StartProgram(false);
  3298. Add('procedure Foo; external name ''console.log'';');
  3299. Add('function Bar: longint; external name ''get.item'';');
  3300. Add('function Bla(s: string): longint; external name ''apply.something'';');
  3301. Add('var');
  3302. Add(' i: longint;');
  3303. Add('begin');
  3304. Add(' Foo;');
  3305. Add(' i:=Bar;');
  3306. Add(' i:=Bla(''abc'');');
  3307. ConvertProgram;
  3308. CheckSource('TestProc_External',
  3309. LinesToStr([ // statements
  3310. 'this.i = 0;'
  3311. ]),
  3312. LinesToStr([
  3313. 'console.log();',
  3314. '$mod.i = get.item();',
  3315. '$mod.i = apply.something("abc");'
  3316. ]));
  3317. end;
  3318. procedure TTestModule.TestProc_ExternalOtherUnit;
  3319. begin
  3320. AddModuleWithIntfImplSrc('unit2.pas',
  3321. LinesToStr([
  3322. 'procedure Now; external name ''Date.now'';',
  3323. 'procedure DoIt;'
  3324. ]),
  3325. 'procedure doit; begin end;');
  3326. StartUnit(true);
  3327. Add('interface');
  3328. Add('uses unit2;');
  3329. Add('implementation');
  3330. Add('begin');
  3331. Add(' now;');
  3332. Add(' now();');
  3333. Add(' uNit2.now;');
  3334. Add(' uNit2.now();');
  3335. Add(' doit;');
  3336. Add(' uNit2.doit;');
  3337. ConvertUnit;
  3338. CheckSource('TestProc_ExternalOtherUnit',
  3339. LinesToStr([
  3340. '']),
  3341. LinesToStr([
  3342. 'Date.now();',
  3343. 'Date.now();',
  3344. 'Date.now();',
  3345. 'Date.now();',
  3346. 'pas.unit2.DoIt();',
  3347. 'pas.unit2.DoIt();',
  3348. '']));
  3349. end;
  3350. procedure TTestModule.TestProc_Asm;
  3351. begin
  3352. StartProgram(false);
  3353. Add([
  3354. 'function DoIt: longint;',
  3355. 'begin;',
  3356. ' asm',
  3357. ' { a:{ b:{}, c:[]}, d:''1'' };',
  3358. ' end;',
  3359. ' asm console.log(); end;',
  3360. ' asm',
  3361. ' s = "'' ";',
  3362. ' s = ''" '';',
  3363. ' s = s + "world" + "''";',
  3364. ' // end',
  3365. ' s = ''end'';',
  3366. ' s = "end";',
  3367. ' end;',
  3368. 'end;',
  3369. 'begin']);
  3370. ConvertProgram;
  3371. CheckSource('TestProc_Asm',
  3372. LinesToStr([ // statements
  3373. 'this.DoIt = function () {',
  3374. ' var Result = 0;',
  3375. ' { a:{ b:{}, c:[]}, d:''1'' };',
  3376. ' console.log();',
  3377. ' s = "'' ";',
  3378. ' s = ''" '';',
  3379. ' s = s + "world" + "''";',
  3380. ' // end',
  3381. ' s = ''end'';',
  3382. ' s = "end";',
  3383. ' return Result;',
  3384. '};'
  3385. ]),
  3386. LinesToStr([
  3387. ''
  3388. ]));
  3389. end;
  3390. procedure TTestModule.TestProc_Assembler;
  3391. begin
  3392. StartProgram(false);
  3393. Add('function DoIt: longint; assembler;');
  3394. Add('asm');
  3395. Add('{ a:{ b:{}, c:[]}, d:''1'' };');
  3396. Add('end;');
  3397. Add('begin');
  3398. ConvertProgram;
  3399. CheckSource('TestProc_Assembler',
  3400. LinesToStr([ // statements
  3401. 'this.DoIt = function () {',
  3402. ' { a:{ b:{}, c:[]}, d:''1'' };',
  3403. '};'
  3404. ]),
  3405. LinesToStr([
  3406. ''
  3407. ]));
  3408. end;
  3409. procedure TTestModule.TestProc_VarParam;
  3410. begin
  3411. StartProgram(false);
  3412. Add('type integer = longint;');
  3413. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  3414. Add('var vJ: integer;');
  3415. Add('begin');
  3416. Add(' vg:=vg+1;');
  3417. Add(' vj:=vh+2;');
  3418. Add(' vi:=vi+3;');
  3419. Add(' doit(vg,vg,vg);');
  3420. Add(' doit(vh,vh,vj);');
  3421. Add(' doit(vi,vi,vi);');
  3422. Add(' doit(vj,vj,vj);');
  3423. Add('end;');
  3424. Add('var i: integer;');
  3425. Add('begin');
  3426. Add(' doit(i,i,i);');
  3427. ConvertProgram;
  3428. CheckSource('TestProc_VarParam',
  3429. LinesToStr([ // statements
  3430. 'this.DoIt = function (vG,vH,vI) {',
  3431. ' var vJ = 0;',
  3432. ' vG = vG + 1;',
  3433. ' vJ = vH + 2;',
  3434. ' vI.set(vI.get()+3);',
  3435. ' $mod.DoIt(vG, vG, {',
  3436. ' get: function () {',
  3437. ' return vG;',
  3438. ' },',
  3439. ' set: function (v) {',
  3440. ' vG = v;',
  3441. ' }',
  3442. ' });',
  3443. ' $mod.DoIt(vH, vH, {',
  3444. ' get: function () {',
  3445. ' return vJ;',
  3446. ' },',
  3447. ' set: function (v) {',
  3448. ' vJ = v;',
  3449. ' }',
  3450. ' });',
  3451. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  3452. ' $mod.DoIt(vJ, vJ, {',
  3453. ' get: function () {',
  3454. ' return vJ;',
  3455. ' },',
  3456. ' set: function (v) {',
  3457. ' vJ = v;',
  3458. ' }',
  3459. ' });',
  3460. '};',
  3461. 'this.i = 0;'
  3462. ]),
  3463. LinesToStr([
  3464. '$mod.DoIt($mod.i,$mod.i,{',
  3465. ' p: $mod,',
  3466. ' get: function () {',
  3467. ' return this.p.i;',
  3468. ' },',
  3469. ' set: function (v) {',
  3470. ' this.p.i = v;',
  3471. ' }',
  3472. '});'
  3473. ]));
  3474. end;
  3475. procedure TTestModule.TestProc_VarParamString;
  3476. begin
  3477. StartProgram(false);
  3478. Add(['type TCaption = string;',
  3479. 'procedure DoIt(vA: TCaption; var vB: TCaption; out vC: TCaption);',
  3480. 'var c: char;',
  3481. 'begin',
  3482. ' va[1]:=c;',
  3483. ' vb[2]:=c;',
  3484. ' vc[3]:=c;',
  3485. 'end;',
  3486. 'begin']);
  3487. ConvertProgram;
  3488. CheckSource('TestProc_VarParamString',
  3489. LinesToStr([ // statements
  3490. 'this.DoIt = function (vA,vB,vC) {',
  3491. ' var c = "";',
  3492. ' vA = rtl.setCharAt(vA, 0, c);',
  3493. ' vB.set(rtl.setCharAt(vB.get(), 1, c));',
  3494. ' vC.set(rtl.setCharAt(vC.get(), 2, c));',
  3495. '};',
  3496. '']),
  3497. LinesToStr([
  3498. ]));
  3499. end;
  3500. procedure TTestModule.TestProc_VarParamV;
  3501. begin
  3502. StartProgram(false);
  3503. Add([
  3504. 'procedure Inc2(var i: longint);',
  3505. 'begin',
  3506. ' i:=i+2;',
  3507. 'end;',
  3508. 'procedure DoIt(v: longint);',
  3509. 'var p: array of longint;',
  3510. 'begin',
  3511. ' Inc2(v);',
  3512. ' Inc2(p[v]);',
  3513. 'end;',
  3514. 'begin']);
  3515. ConvertProgram;
  3516. CheckSource('TestProc_VarParamV',
  3517. LinesToStr([ // statements
  3518. 'this.Inc2 = function (i) {',
  3519. ' i.set(i.get()+2);',
  3520. '};',
  3521. 'this.DoIt = function (v) {',
  3522. ' var p = [];',
  3523. ' $mod.Inc2({get: function () {',
  3524. ' return v;',
  3525. ' }, set: function (w) {',
  3526. ' v = w;',
  3527. ' }});',
  3528. ' $mod.Inc2({',
  3529. ' a: v,',
  3530. ' p: p,',
  3531. ' get: function () {',
  3532. ' return this.p[this.a];',
  3533. ' },',
  3534. ' set: function (v) {',
  3535. ' this.p[this.a] = v;',
  3536. ' }',
  3537. ' });',
  3538. '};',
  3539. '']),
  3540. LinesToStr([
  3541. '']));
  3542. end;
  3543. procedure TTestModule.TestProc_Overload;
  3544. begin
  3545. StartProgram(false);
  3546. Add('procedure DoIt(vI: longint); begin end;');
  3547. Add('procedure DoIt(vI, vJ: longint); begin end;');
  3548. Add('procedure DoIt(vD: double); begin end;');
  3549. Add('begin');
  3550. Add(' DoIt(1);');
  3551. Add(' DoIt(2,3);');
  3552. Add(' DoIt(4.5);');
  3553. ConvertProgram;
  3554. CheckSource('TestProcedureOverload',
  3555. LinesToStr([ // statements
  3556. 'this.DoIt = function (vI) {',
  3557. '};',
  3558. 'this.DoIt$1 = function (vI, vJ) {',
  3559. '};',
  3560. 'this.DoIt$2 = function (vD) {',
  3561. '};',
  3562. '']),
  3563. LinesToStr([
  3564. '$mod.DoIt(1);',
  3565. '$mod.DoIt$1(2, 3);',
  3566. '$mod.DoIt$2(4.5);',
  3567. '']));
  3568. end;
  3569. procedure TTestModule.TestProc_OverloadForward;
  3570. begin
  3571. StartProgram(false);
  3572. Add('procedure DoIt(vI: longint); forward;');
  3573. Add('procedure DoIt(vI, vJ: longint); begin end;');
  3574. Add('procedure doit(vi: longint); begin end;');
  3575. Add('begin');
  3576. Add(' doit(1);');
  3577. Add(' doit(2,3);');
  3578. ConvertProgram;
  3579. CheckSource('TestProcedureOverloadForward',
  3580. LinesToStr([ // statements
  3581. 'this.DoIt$1 = function (vI, vJ) {',
  3582. '};',
  3583. 'this.DoIt = function (vI) {',
  3584. '};',
  3585. '']),
  3586. LinesToStr([
  3587. '$mod.DoIt(1);',
  3588. '$mod.DoIt$1(2, 3);',
  3589. '']));
  3590. end;
  3591. procedure TTestModule.TestProc_OverloadIntfImpl;
  3592. begin
  3593. StartUnit(false);
  3594. Add('interface');
  3595. Add('procedure DoIt(vI: longint);');
  3596. Add('procedure DoIt(vI, vJ: longint);');
  3597. Add('implementation');
  3598. Add('procedure DoIt(vI, vJ, vK, vL, vM: longint); forward;');
  3599. Add('procedure DoIt(vI, vJ, vK: longint); begin end;');
  3600. Add('procedure DoIt(vi: longint); begin end;');
  3601. Add('procedure DoIt(vI, vJ, vK, vL: longint); begin end;');
  3602. Add('procedure DoIt(vi, vj: longint); begin end;');
  3603. Add('procedure DoIt(vi, vj, vk, vl, vm: longint); begin end;');
  3604. Add('begin');
  3605. Add(' doit(1);');
  3606. Add(' doit(2,3);');
  3607. Add(' doit(4,5,6);');
  3608. Add(' doit(7,8,9,10);');
  3609. Add(' doit(11,12,13,14,15);');
  3610. ConvertUnit;
  3611. CheckSource('TestProcedureOverloadUnit',
  3612. LinesToStr([ // statements
  3613. 'var $impl = $mod.$impl;',
  3614. 'this.DoIt = function (vI) {',
  3615. '};',
  3616. 'this.DoIt$1 = function (vI, vJ) {',
  3617. '};',
  3618. '']),
  3619. LinesToStr([ // this.$init
  3620. '$mod.DoIt(1);',
  3621. '$mod.DoIt$1(2, 3);',
  3622. '$impl.DoIt$3(4,5,6);',
  3623. '$impl.DoIt$4(7,8,9,10);',
  3624. '$impl.DoIt$2(11,12,13,14,15);',
  3625. '']),
  3626. LinesToStr([ // implementation
  3627. '$impl.DoIt$3 = function (vI, vJ, vK) {',
  3628. '};',
  3629. '$impl.DoIt$4 = function (vI, vJ, vK, vL) {',
  3630. '};',
  3631. '$impl.DoIt$2 = function (vI, vJ, vK, vL, vM) {',
  3632. '};',
  3633. '']));
  3634. end;
  3635. procedure TTestModule.TestProc_OverloadNested;
  3636. begin
  3637. StartProgram(false);
  3638. Add([
  3639. 'procedure DoIt(vA: longint); overload; forward;',
  3640. 'procedure DoIt(vB, vC: longint); overload;',
  3641. 'begin // 2 param overload',
  3642. ' doit(1);',
  3643. ' doit(1,2);',
  3644. 'end;',
  3645. 'procedure doit(vA: longint);',
  3646. ' procedure DoIt(vA, vB, vC: longint); overload; forward;',
  3647. ' procedure DoIt(vA, vB, vC, vD: longint); overload;',
  3648. ' begin // 4 param overload',
  3649. ' doit(1);',
  3650. ' doit(1,2);',
  3651. ' doit(1,2,3);',
  3652. ' doit(1,2,3,4);',
  3653. ' end;',
  3654. ' procedure doit(vA, vB, vC: longint);',
  3655. ' procedure DoIt(vA, vB, vC, vD, vE: longint); overload; forward;',
  3656. ' procedure DoIt(vA, vB, vC, vD, vE, vF: longint); overload;',
  3657. ' begin // 6 param overload',
  3658. ' doit(1);',
  3659. ' doit(1,2);',
  3660. ' doit(1,2,3);',
  3661. ' doit(1,2,3,4);',
  3662. ' doit(1,2,3,4,5);',
  3663. ' doit(1,2,3,4,5,6);',
  3664. ' end;',
  3665. ' procedure doit(vA, vB, vC, vD, vE: longint);',
  3666. ' begin // 5 param overload',
  3667. ' doit(1);',
  3668. ' doit(1,2);',
  3669. ' doit(1,2,3);',
  3670. ' doit(1,2,3,4);',
  3671. ' doit(1,2,3,4,5);',
  3672. ' doit(1,2,3,4,5,6);',
  3673. ' end;',
  3674. ' begin // 3 param overload',
  3675. ' doit(1);',
  3676. ' doit(1,2);',
  3677. ' doit(1,2,3);',
  3678. ' doit(1,2,3,4);',
  3679. ' doit(1,2,3,4,5);',
  3680. ' doit(1,2,3,4,5,6);',
  3681. ' end;',
  3682. 'begin // 1 param overload',
  3683. ' doit(1);',
  3684. ' doit(1,2);',
  3685. ' doit(1,2,3);',
  3686. ' doit(1,2,3,4);',
  3687. 'end;',
  3688. 'begin // main',
  3689. ' doit(1);',
  3690. ' doit(1,2);']);
  3691. ConvertProgram;
  3692. CheckSource('TestProcedureOverloadNested',
  3693. LinesToStr([ // statements
  3694. 'this.DoIt$1 = function (vB, vC) {',
  3695. ' $mod.DoIt(1);',
  3696. ' $mod.DoIt$1(1, 2);',
  3697. '};',
  3698. 'this.DoIt = function (vA) {',
  3699. ' function DoIt$3(vA, vB, vC, vD) {',
  3700. ' $mod.DoIt(1);',
  3701. ' $mod.DoIt$1(1, 2);',
  3702. ' DoIt$2(1, 2, 3);',
  3703. ' DoIt$3(1, 2, 3, 4);',
  3704. ' };',
  3705. ' function DoIt$2(vA, vB, vC) {',
  3706. ' function DoIt$5(vA, vB, vC, vD, vE, vF) {',
  3707. ' $mod.DoIt(1);',
  3708. ' $mod.DoIt$1(1, 2);',
  3709. ' DoIt$2(1, 2, 3);',
  3710. ' DoIt$3(1, 2, 3, 4);',
  3711. ' DoIt$4(1, 2, 3, 4, 5);',
  3712. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3713. ' };',
  3714. ' function DoIt$4(vA, vB, vC, vD, vE) {',
  3715. ' $mod.DoIt(1);',
  3716. ' $mod.DoIt$1(1, 2);',
  3717. ' DoIt$2(1, 2, 3);',
  3718. ' DoIt$3(1, 2, 3, 4);',
  3719. ' DoIt$4(1, 2, 3, 4, 5);',
  3720. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3721. ' };',
  3722. ' $mod.DoIt(1);',
  3723. ' $mod.DoIt$1(1, 2);',
  3724. ' DoIt$2(1, 2, 3);',
  3725. ' DoIt$3(1, 2, 3, 4);',
  3726. ' DoIt$4(1, 2, 3, 4, 5);',
  3727. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3728. ' };',
  3729. ' $mod.DoIt(1);',
  3730. ' $mod.DoIt$1(1, 2);',
  3731. ' DoIt$2(1, 2, 3);',
  3732. ' DoIt$3(1, 2, 3, 4);',
  3733. '};',
  3734. '']),
  3735. LinesToStr([
  3736. '$mod.DoIt(1);',
  3737. '$mod.DoIt$1(1, 2);',
  3738. '']));
  3739. end;
  3740. procedure TTestModule.TestProc_OverloadUnitCycle;
  3741. begin
  3742. AddModuleWithIntfImplSrc('Unit2.pas',
  3743. LinesToStr([
  3744. 'type',
  3745. ' TObject = class',
  3746. ' procedure DoIt(b: boolean); virtual; abstract;',
  3747. ' procedure DoIt(i: longint); virtual; abstract;',
  3748. ' end;',
  3749. '']),
  3750. 'uses test1;');
  3751. StartUnit(true);
  3752. Add([
  3753. 'interface',
  3754. 'uses unit2;',
  3755. 'type',
  3756. ' TEagle = class(TObject)',
  3757. ' procedure DoIt(b: boolean); override;',
  3758. ' procedure DoIt(i: longint); override;',
  3759. ' end;',
  3760. 'implementation',
  3761. 'procedure TEagle.DoIt(b: boolean); begin end;',
  3762. 'procedure TEagle.DoIt(i: longint); begin end;',
  3763. '']);
  3764. ConvertUnit;
  3765. CheckSource('TestProc_OverloadUnitCycle',
  3766. LinesToStr([ // statements
  3767. 'rtl.createClass($mod, "TEagle", pas.Unit2.TObject, function () {',
  3768. ' this.DoIt = function (b) {',
  3769. ' };',
  3770. ' this.DoIt$1 = function (i) {',
  3771. ' };',
  3772. '});',
  3773. '']),
  3774. '',
  3775. LinesToStr([
  3776. '']));
  3777. end;
  3778. procedure TTestModule.TestProc_Varargs;
  3779. begin
  3780. StartProgram(false);
  3781. Add([
  3782. 'procedure ProcA(i:longint); varargs; external name ''ProcA'';',
  3783. 'procedure ProcB; varargs; external name ''ProcB'';',
  3784. 'procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';',
  3785. 'function GetIt: longint; begin end;',
  3786. 'begin',
  3787. ' ProcA(1);',
  3788. ' ProcA(1,2);',
  3789. ' ProcA(1,2.0);',
  3790. ' ProcA(1,2,3);',
  3791. ' ProcA(1,''2'');',
  3792. ' ProcA(2,'''');',
  3793. ' ProcA(3,false);',
  3794. ' ProcB;',
  3795. ' ProcB();',
  3796. ' ProcB(4);',
  3797. ' ProcB(''foo'');',
  3798. ' ProcC;',
  3799. ' ProcC();',
  3800. ' ProcC(4);',
  3801. ' ProcC(5,''foo'');',
  3802. ' ProcB(GetIt);',
  3803. ' ProcB(GetIt());',
  3804. ' ProcB(GetIt,GetIt());']);
  3805. ConvertProgram;
  3806. CheckSource('TestProc_Varargs',
  3807. LinesToStr([ // statements
  3808. 'this.GetIt = function () {',
  3809. ' var Result = 0;',
  3810. ' return Result;',
  3811. '};',
  3812. '']),
  3813. LinesToStr([
  3814. 'ProcA(1);',
  3815. 'ProcA(1, 2);',
  3816. 'ProcA(1, 2.0);',
  3817. 'ProcA(1, 2, 3);',
  3818. 'ProcA(1, "2");',
  3819. 'ProcA(2, "");',
  3820. 'ProcA(3, false);',
  3821. 'ProcB();',
  3822. 'ProcB();',
  3823. 'ProcB(4);',
  3824. 'ProcB("foo");',
  3825. 'ProcC(17);',
  3826. 'ProcC(17);',
  3827. 'ProcC(4);',
  3828. 'ProcC(5, "foo");',
  3829. 'ProcB($mod.GetIt());',
  3830. 'ProcB($mod.GetIt());',
  3831. 'ProcB($mod.GetIt(), $mod.GetIt());',
  3832. '']));
  3833. end;
  3834. procedure TTestModule.TestProc_ConstOrder;
  3835. begin
  3836. StartProgram(false);
  3837. Add([
  3838. 'const A = 3;',
  3839. 'const B = A+1;',
  3840. 'procedure DoIt;',
  3841. 'const C = A+1;',
  3842. 'const D = B+1;',
  3843. 'const E = D+C+B+A;',
  3844. 'begin',
  3845. 'end;',
  3846. 'begin'
  3847. ]);
  3848. ConvertProgram;
  3849. CheckSource('TestProc_ConstOrder',
  3850. LinesToStr([ // statements
  3851. 'this.A = 3;',
  3852. 'this.B = 3 + 1;',
  3853. 'var C = 3 + 1;',
  3854. 'var D = 4 + 1;',
  3855. 'var E = 5 + 4 + 4 + 3;',
  3856. 'this.DoIt = function () {',
  3857. '};',
  3858. '']),
  3859. LinesToStr([
  3860. ''
  3861. ]));
  3862. end;
  3863. procedure TTestModule.TestProc_DuplicateConst;
  3864. begin
  3865. StartProgram(false);
  3866. Add([
  3867. 'const A = 1;',
  3868. 'procedure DoIt;',
  3869. 'const A = 2;',
  3870. ' procedure SubIt;',
  3871. ' const A = 21;',
  3872. ' begin',
  3873. ' end;',
  3874. 'begin',
  3875. 'end;',
  3876. 'procedure DoSome;',
  3877. 'const A = 3;',
  3878. 'begin',
  3879. 'end;',
  3880. 'begin'
  3881. ]);
  3882. ConvertProgram;
  3883. CheckSource('TestProc_DuplicateConst',
  3884. LinesToStr([ // statements
  3885. 'this.A = 1;',
  3886. 'var A$1 = 2;',
  3887. 'var A$2 = 21;',
  3888. 'this.DoIt = function () {',
  3889. ' function SubIt() {',
  3890. ' };',
  3891. '};',
  3892. 'var A$3 = 3;',
  3893. 'this.DoSome = function () {',
  3894. '};',
  3895. '']),
  3896. LinesToStr([
  3897. ''
  3898. ]));
  3899. end;
  3900. procedure TTestModule.TestProc_LocalVarAbsolute;
  3901. begin
  3902. StartProgram(false);
  3903. Add([
  3904. 'type',
  3905. ' TObject = class',
  3906. ' Index: longint;',
  3907. ' procedure DoAbs(Item: pointer);',
  3908. ' end;',
  3909. 'procedure TObject.DoAbs(Item: pointer);',
  3910. 'var',
  3911. ' o: TObject absolute Item;',
  3912. 'begin',
  3913. ' if o.Index<o.Index then o.Index:=o.Index;',
  3914. 'end;',
  3915. 'procedure DoIt(i: longint; p: pointer);',
  3916. 'var',
  3917. ' d: double absolute i;',
  3918. ' s: string absolute d;',
  3919. ' oi: TObject absolute i;',
  3920. ' op: TObject absolute p;',
  3921. 'begin',
  3922. ' if d=d then d:=d;',
  3923. ' if s=s then s:=s;',
  3924. ' if oi.Index<oi.Index then oi.Index:=oi.Index;',
  3925. ' if op.Index=op.Index then op.Index:=op.Index;',
  3926. 'end;',
  3927. 'begin']);
  3928. ConvertProgram;
  3929. CheckSource('TestProc_LocalVarAbsolute',
  3930. LinesToStr([ // statements
  3931. 'rtl.createClass($mod, "TObject", null, function () {',
  3932. ' this.$init = function () {',
  3933. ' this.Index = 0;',
  3934. ' };',
  3935. ' this.$final = function () {',
  3936. ' };',
  3937. ' this.DoAbs = function (Item) {',
  3938. ' if (Item.Index < Item.Index) Item.Index = Item.Index;',
  3939. ' };',
  3940. '});',
  3941. 'this.DoIt = function (i, p) {',
  3942. ' if (i === i) i = i;',
  3943. ' if (i === i) i = i;',
  3944. ' if (i.Index < i.Index) i.Index = i.Index;',
  3945. ' if (p.Index === p.Index) p.Index = p.Index;',
  3946. '};'
  3947. ]),
  3948. LinesToStr([
  3949. ]));
  3950. end;
  3951. procedure TTestModule.TestProc_ReservedWords;
  3952. begin
  3953. StartProgram(false);
  3954. Add([
  3955. 'procedure Date(ArrayBuffer: longint);',
  3956. 'const',
  3957. ' NaN: longint = 3;',
  3958. 'var',
  3959. ' &Boolean: longint;',
  3960. ' procedure Error(ArrayBuffer: longint);',
  3961. ' begin',
  3962. ' end;',
  3963. 'begin',
  3964. ' Nan:=&bOolean;',
  3965. 'end;',
  3966. 'begin',
  3967. ' Date(1);']);
  3968. ConvertProgram;
  3969. CheckSource('TestProc_ReservedWords',
  3970. LinesToStr([ // statements
  3971. 'var naN = 3;',
  3972. 'this.Date = function (arrayBuffer) {',
  3973. ' var boolean = 0;',
  3974. ' function error(arrayBuffer) {',
  3975. ' };',
  3976. ' naN = boolean;',
  3977. '};',
  3978. '']),
  3979. LinesToStr([
  3980. ' $mod.Date(1);'
  3981. ]));
  3982. end;
  3983. procedure TTestModule.TestAnonymousProc_Assign_ObjFPC;
  3984. begin
  3985. StartProgram(false);
  3986. Add([
  3987. '{$mode objfpc}',
  3988. 'type',
  3989. ' TFunc = reference to function(x: word): word;',
  3990. 'var Func: TFunc;',
  3991. 'procedure DoIt(a: word);',
  3992. 'begin',
  3993. ' Func:=function(b:word): word',
  3994. ' begin',
  3995. ' Result:=a+b;',
  3996. ' exit(b);',
  3997. ' exit(Result);',
  3998. ' end;',// test semicolon
  3999. ' a:=3;',
  4000. 'end;',
  4001. 'begin',
  4002. ' Func:=function(c:word):word begin',
  4003. ' Result:=3+c;',
  4004. ' exit(c);',
  4005. ' exit(Result);',
  4006. ' end;']);
  4007. ConvertProgram;
  4008. CheckSource('TestAnonymousProc_Assign_ObjFPC',
  4009. LinesToStr([ // statements
  4010. 'this.Func = null;',
  4011. 'this.DoIt = function (a) {',
  4012. ' $mod.Func = function (b) {',
  4013. ' var Result = 0;',
  4014. ' Result = a + b;',
  4015. ' return b;',
  4016. ' return Result;',
  4017. ' return Result;',
  4018. ' };',
  4019. ' a = 3;',
  4020. '};',
  4021. '']),
  4022. LinesToStr([
  4023. '$mod.Func = function (c) {',
  4024. ' var Result = 0;',
  4025. ' Result = 3 + c;',
  4026. ' return c;',
  4027. ' return Result;',
  4028. ' return Result;',
  4029. '};',
  4030. '']));
  4031. end;
  4032. procedure TTestModule.TestAnonymousProc_Assign_Delphi;
  4033. begin
  4034. StartProgram(false);
  4035. Add([
  4036. '{$mode delphi}',
  4037. 'type',
  4038. ' TProc = reference to procedure(x: word);',
  4039. 'procedure DoIt(a: word);',
  4040. 'var Proc: TProc;',
  4041. 'begin',
  4042. ' Proc:=procedure(b:word) begin end;',
  4043. 'end;',
  4044. 'var Proc: TProc;',
  4045. 'begin',
  4046. ' Proc:=procedure(c:word) begin end;',
  4047. '']);
  4048. ConvertProgram;
  4049. CheckSource('TestAnonymousProc_Assign_Delphi',
  4050. LinesToStr([ // statements
  4051. 'this.DoIt = function (a) {',
  4052. ' var Proc = null;',
  4053. ' Proc = function (b) {',
  4054. ' };',
  4055. '};',
  4056. 'this.Proc = null;',
  4057. '']),
  4058. LinesToStr([
  4059. '$mod.Proc = function (c) {',
  4060. '};',
  4061. '']));
  4062. end;
  4063. procedure TTestModule.TestAnonymousProc_Arg;
  4064. begin
  4065. StartProgram(false);
  4066. Add([
  4067. 'type',
  4068. ' TProc = reference to procedure;',
  4069. ' TFunc = reference to function(x: word): word;',
  4070. 'procedure DoMore(f,g: TProc);',
  4071. 'begin',
  4072. 'end;',
  4073. 'procedure DoOdd(v: jsvalue);',
  4074. 'begin',
  4075. 'end;',
  4076. 'procedure DoIt(f: TFunc);',
  4077. 'begin',
  4078. ' DoIt(function(b:word): word',
  4079. ' begin',
  4080. ' Result:=1+b;',
  4081. ' end);',
  4082. ' DoMore(procedure begin end, procedure begin end);',
  4083. ' DoOdd(procedure begin end);',
  4084. 'end;',
  4085. 'begin',
  4086. ' DoMore(procedure begin end,',
  4087. ' procedure assembler asm',
  4088. ' console.log("c");',
  4089. ' end);',
  4090. '']);
  4091. ConvertProgram;
  4092. CheckSource('TestAnonymousProc_Arg',
  4093. LinesToStr([ // statements
  4094. 'this.DoMore = function (f, g) {',
  4095. '};',
  4096. 'this.DoOdd = function (v) {',
  4097. '};',
  4098. 'this.DoIt = function (f) {',
  4099. ' $mod.DoIt(function (b) {',
  4100. ' var Result = 0;',
  4101. ' Result = 1 + b;',
  4102. ' return Result;',
  4103. ' });',
  4104. ' $mod.DoMore(function () {',
  4105. ' }, function () {',
  4106. ' });',
  4107. ' $mod.DoOdd(function () {',
  4108. ' });',
  4109. '};',
  4110. '']),
  4111. LinesToStr([
  4112. '$mod.DoMore(function () {',
  4113. '}, function () {',
  4114. ' console.log("c");',
  4115. '});',
  4116. '']));
  4117. end;
  4118. procedure TTestModule.TestAnonymousProc_Typecast;
  4119. begin
  4120. StartProgram(false);
  4121. Add([
  4122. 'type',
  4123. ' TProc = reference to procedure(w: word);',
  4124. ' TArr = array of word;',
  4125. ' TFuncArr = reference to function: TArr;',
  4126. 'procedure DoIt(p: TProc);',
  4127. 'var',
  4128. ' w: word;',
  4129. ' a: TArr;',
  4130. 'begin',
  4131. ' p:=TProc(procedure(b: smallint) begin end);',
  4132. ' a:=TFuncArr(function: TArr begin end)();',
  4133. ' w:=TFuncArr(function: TArr begin end)()[3];',
  4134. 'end;',
  4135. 'begin']);
  4136. ConvertProgram;
  4137. CheckSource('TestAnonymousProc_Typecast',
  4138. LinesToStr([ // statements
  4139. 'this.DoIt = function (p) {',
  4140. ' var w = 0;',
  4141. ' var a = [];',
  4142. ' p = function (b) {',
  4143. ' };',
  4144. ' a = function () {',
  4145. ' var Result = [];',
  4146. ' return Result;',
  4147. ' }();',
  4148. ' w = function () {',
  4149. ' var Result = [];',
  4150. ' return Result;',
  4151. ' }()[3];',
  4152. '};',
  4153. '']),
  4154. LinesToStr([
  4155. '']));
  4156. end;
  4157. procedure TTestModule.TestAnonymousProc_With;
  4158. begin
  4159. StartProgram(false);
  4160. Add([
  4161. 'type',
  4162. ' TProc = reference to procedure(w: word);',
  4163. ' TObject = class',
  4164. ' b: boolean;',
  4165. ' end;',
  4166. 'var',
  4167. ' p: TProc;',
  4168. ' bird: TObject;',
  4169. 'begin',
  4170. ' with bird do',
  4171. ' p:=procedure(w: word)',
  4172. ' begin',
  4173. ' b:=w>2;',
  4174. ' end;',
  4175. '']);
  4176. ConvertProgram;
  4177. CheckSource('TestAnonymousProc_With',
  4178. LinesToStr([ // statements
  4179. 'rtl.createClass($mod, "TObject", null, function () {',
  4180. ' this.$init = function () {',
  4181. ' this.b = false;',
  4182. ' };',
  4183. ' this.$final = function () {',
  4184. ' };',
  4185. '});',
  4186. 'this.p = null;',
  4187. 'this.bird = null;',
  4188. '']),
  4189. LinesToStr([
  4190. 'var $with1 = $mod.bird;',
  4191. '$mod.p = function (w) {',
  4192. ' $with1.b = w > 2;',
  4193. '};',
  4194. '']));
  4195. end;
  4196. procedure TTestModule.TestAnonymousProc_ExceptOn;
  4197. begin
  4198. StartProgram(false);
  4199. Add([
  4200. 'type',
  4201. ' TProc = reference to procedure;',
  4202. ' TObject = class',
  4203. ' b: boolean;',
  4204. ' end;',
  4205. 'procedure DoIt;',
  4206. 'var',
  4207. ' p: TProc;',
  4208. 'begin',
  4209. ' try',
  4210. ' except',
  4211. ' on E: TObject do',
  4212. ' p:=procedure',
  4213. ' begin',
  4214. ' E.b:=true;',
  4215. ' end;',
  4216. ' end;',
  4217. 'end;',
  4218. 'begin']);
  4219. ConvertProgram;
  4220. CheckSource('TestAnonymousProc_ExceptOn',
  4221. LinesToStr([ // statements
  4222. 'rtl.createClass($mod, "TObject", null, function () {',
  4223. ' this.$init = function () {',
  4224. ' this.b = false;',
  4225. ' };',
  4226. ' this.$final = function () {',
  4227. ' };',
  4228. '});',
  4229. 'this.DoIt = function () {',
  4230. ' var p = null;',
  4231. ' try {} catch ($e) {',
  4232. ' if ($mod.TObject.isPrototypeOf($e)) {',
  4233. ' var E = $e;',
  4234. ' p = function () {',
  4235. ' E.b = true;',
  4236. ' };',
  4237. ' } else throw $e',
  4238. ' };',
  4239. '};',
  4240. '']),
  4241. LinesToStr([
  4242. '']));
  4243. end;
  4244. procedure TTestModule.TestAnonymousProc_Nested;
  4245. begin
  4246. StartProgram(false);
  4247. Add([
  4248. 'type',
  4249. ' TProc = reference to procedure;',
  4250. ' TObject = class',
  4251. ' i: byte;',
  4252. ' procedure DoIt;',
  4253. ' end;',
  4254. 'procedure TObject.DoIt;',
  4255. 'var',
  4256. ' p: TProc;',
  4257. ' procedure Sub;',
  4258. ' begin',
  4259. ' p:=procedure',
  4260. ' begin',
  4261. ' i:=3;',
  4262. ' Self.i:=4;',
  4263. ' p:=procedure',
  4264. ' procedure SubSub;',
  4265. ' begin',
  4266. ' i:=13;',
  4267. ' Self.i:=14;',
  4268. ' end;',
  4269. ' begin',
  4270. ' i:=13;',
  4271. ' Self.i:=14;',
  4272. ' end;',
  4273. ' end;',
  4274. ' end;',
  4275. 'begin',
  4276. 'end;',
  4277. 'begin']);
  4278. ConvertProgram;
  4279. CheckSource('TestAnonymousProc_Nested',
  4280. LinesToStr([ // statements
  4281. 'rtl.createClass($mod, "TObject", null, function () {',
  4282. ' this.$init = function () {',
  4283. ' this.i = 0;',
  4284. ' };',
  4285. ' this.$final = function () {',
  4286. ' };',
  4287. ' this.DoIt = function () {',
  4288. ' var $Self = this;',
  4289. ' var p = null;',
  4290. ' function Sub() {',
  4291. ' p = function () {',
  4292. ' $Self.i = 3;',
  4293. ' $Self.i = 4;',
  4294. ' p = function () {',
  4295. ' function SubSub() {',
  4296. ' $Self.i = 13;',
  4297. ' $Self.i = 14;',
  4298. ' };',
  4299. ' $Self.i = 13;',
  4300. ' $Self.i = 14;',
  4301. ' };',
  4302. ' };',
  4303. ' };',
  4304. ' };',
  4305. '});',
  4306. '']),
  4307. LinesToStr([
  4308. '']));
  4309. end;
  4310. procedure TTestModule.TestAnonymousProc_NestedAssignResult;
  4311. begin
  4312. StartProgram(false);
  4313. Add([
  4314. 'type',
  4315. ' TProc = reference to procedure;',
  4316. 'function DoIt: TProc;',
  4317. ' function Sub: TProc;',
  4318. ' begin',
  4319. ' Result:=procedure',
  4320. ' begin',
  4321. ' Sub:=procedure',
  4322. ' procedure SubSub;',
  4323. ' begin',
  4324. ' Result:=nil;',
  4325. ' Sub:=nil;',
  4326. ' DoIt:=nil;',
  4327. ' end;',
  4328. ' begin',
  4329. ' Result:=nil;',
  4330. ' Sub:=nil;',
  4331. ' DoIt:=nil;',
  4332. ' end;',
  4333. ' end;',
  4334. ' end;',
  4335. 'begin',
  4336. 'end;',
  4337. 'begin']);
  4338. ConvertProgram;
  4339. CheckSource('TestAnonymousProc_NestedAssignResult',
  4340. LinesToStr([ // statements
  4341. 'this.DoIt = function () {',
  4342. ' var Result = null;',
  4343. ' function Sub() {',
  4344. ' var Result$1 = null;',
  4345. ' Result$1 = function () {',
  4346. ' Result$1 = function () {',
  4347. ' function SubSub() {',
  4348. ' Result$1 = null;',
  4349. ' Result$1 = null;',
  4350. ' Result = null;',
  4351. ' };',
  4352. ' Result$1 = null;',
  4353. ' Result$1 = null;',
  4354. ' Result = null;',
  4355. ' };',
  4356. ' };',
  4357. ' return Result$1;',
  4358. ' };',
  4359. ' return Result;',
  4360. '};',
  4361. '']),
  4362. LinesToStr([
  4363. '']));
  4364. end;
  4365. procedure TTestModule.TestEnum_Name;
  4366. begin
  4367. StartProgram(false);
  4368. Add('type TMyEnum = (Red, Green, Blue);');
  4369. Add('var e: TMyEnum;');
  4370. Add('var f: TMyEnum = Blue;');
  4371. Add('begin');
  4372. Add(' e:=green;');
  4373. Add(' e:=default(TMyEnum);');
  4374. ConvertProgram;
  4375. CheckSource('TestEnumName',
  4376. LinesToStr([ // statements
  4377. 'this.TMyEnum = {',
  4378. ' "0":"Red",',
  4379. ' Red:0,',
  4380. ' "1":"Green",',
  4381. ' Green:1,',
  4382. ' "2":"Blue",',
  4383. ' Blue:2',
  4384. ' };',
  4385. 'this.e = 0;',
  4386. 'this.f = $mod.TMyEnum.Blue;'
  4387. ]),
  4388. LinesToStr([
  4389. '$mod.e=$mod.TMyEnum.Green;',
  4390. '$mod.e=$mod.TMyEnum.Red;'
  4391. ]));
  4392. end;
  4393. procedure TTestModule.TestEnum_Number;
  4394. begin
  4395. Converter.Options:=Converter.Options+[coEnumNumbers];
  4396. StartProgram(false);
  4397. Add('type TMyEnum = (Red, Green);');
  4398. Add('var');
  4399. Add(' e: TMyEnum;');
  4400. Add(' f: TMyEnum = Green;');
  4401. Add(' i: longint;');
  4402. Add('begin');
  4403. Add(' e:=green;');
  4404. Add(' i:=longint(e);');
  4405. ConvertProgram;
  4406. CheckSource('TestEnumNumber',
  4407. LinesToStr([ // statements
  4408. 'this.TMyEnum = {',
  4409. ' "0":"Red",',
  4410. ' Red:0,',
  4411. ' "1":"Green",',
  4412. ' Green:1',
  4413. ' };',
  4414. 'this.e = 0;',
  4415. 'this.f = 1;',
  4416. 'this.i = 0;'
  4417. ]),
  4418. LinesToStr([
  4419. '$mod.e=1;',
  4420. '$mod.i=$mod.e;'
  4421. ]));
  4422. end;
  4423. procedure TTestModule.TestEnum_ConstFail;
  4424. begin
  4425. StartProgram(false);
  4426. Add([
  4427. 'type TMyEnum = (Red = 100, Green = 101);',
  4428. 'var',
  4429. ' e: TMyEnum;',
  4430. ' f: TMyEnum = Green;',
  4431. 'begin',
  4432. ' e:=green;']);
  4433. SetExpectedPasResolverError('not yet implemented: Red:TPasEnumValue [20180126202434] enum const',3002);
  4434. ConvertProgram;
  4435. end;
  4436. procedure TTestModule.TestEnum_Functions;
  4437. begin
  4438. StartProgram(false);
  4439. Add([
  4440. 'type TMyEnum = (Red, Green);',
  4441. 'procedure DoIt(var e: TMyEnum; var i: word);',
  4442. 'var',
  4443. ' v: longint;',
  4444. ' s: string;',
  4445. 'begin',
  4446. ' val(s,e,v);',
  4447. ' val(s,e,i);',
  4448. 'end;',
  4449. 'var',
  4450. ' e: TMyEnum;',
  4451. ' i: longint;',
  4452. ' s: string;',
  4453. ' b: boolean;',
  4454. 'begin',
  4455. ' i:=ord(red);',
  4456. ' i:=ord(green);',
  4457. ' i:=ord(e);',
  4458. ' i:=ord(b);',
  4459. ' e:=low(tmyenum);',
  4460. ' e:=low(e);',
  4461. ' b:=low(boolean);',
  4462. ' e:=high(tmyenum);',
  4463. ' e:=high(e);',
  4464. ' b:=high(boolean);',
  4465. ' e:=pred(green);',
  4466. ' e:=pred(e);',
  4467. ' b:=pred(b);',
  4468. ' e:=succ(red);',
  4469. ' e:=succ(e);',
  4470. ' b:=succ(b);',
  4471. ' e:=tmyenum(1);',
  4472. ' e:=tmyenum(i);',
  4473. ' s:=str(e);',
  4474. ' str(e,s);',
  4475. ' str(red,s);',
  4476. ' s:=str(e:3);',
  4477. ' writestr(s,e:3,red);',
  4478. ' val(s,e,i);',
  4479. ' e:=TMyEnum(i);',
  4480. ' i:=longint(e);']);
  4481. ConvertProgram;
  4482. CheckSource('TestEnum_Functions',
  4483. LinesToStr([ // statements
  4484. 'this.TMyEnum = {',
  4485. ' "0":"Red",',
  4486. ' Red:0,',
  4487. ' "1":"Green",',
  4488. ' Green:1',
  4489. ' };',
  4490. 'this.DoIt = function (e, i) {',
  4491. ' var v = 0;',
  4492. ' var s = "";',
  4493. ' e.set(rtl.valEnum(s, $mod.TMyEnum, function (w) {',
  4494. ' v = w;',
  4495. ' }));',
  4496. ' e.set(rtl.valEnum(s, $mod.TMyEnum, i.set));',
  4497. '};',
  4498. 'this.e = 0;',
  4499. 'this.i = 0;',
  4500. 'this.s = "";',
  4501. 'this.b = false;',
  4502. '']),
  4503. LinesToStr([
  4504. '$mod.i=$mod.TMyEnum.Red;',
  4505. '$mod.i=$mod.TMyEnum.Green;',
  4506. '$mod.i=$mod.e;',
  4507. '$mod.i=$mod.b+0;',
  4508. '$mod.e=$mod.TMyEnum.Red;',
  4509. '$mod.e=$mod.TMyEnum.Red;',
  4510. '$mod.b=false;',
  4511. '$mod.e=$mod.TMyEnum.Green;',
  4512. '$mod.e=$mod.TMyEnum.Green;',
  4513. '$mod.b=true;',
  4514. '$mod.e=$mod.TMyEnum.Green-1;',
  4515. '$mod.e=$mod.e-1;',
  4516. '$mod.b=false;',
  4517. '$mod.e=$mod.TMyEnum.Red+1;',
  4518. '$mod.e=$mod.e+1;',
  4519. '$mod.b=true;',
  4520. '$mod.e=1;',
  4521. '$mod.e=$mod.i;',
  4522. '$mod.s = $mod.TMyEnum[$mod.e];',
  4523. '$mod.s = $mod.TMyEnum[$mod.e];',
  4524. '$mod.s = $mod.TMyEnum[$mod.TMyEnum.Red];',
  4525. '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
  4526. '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3)+$mod.TMyEnum[$mod.TMyEnum.Red];',
  4527. '$mod.e = rtl.valEnum($mod.s, $mod.TMyEnum, function (v) {',
  4528. ' $mod.i = v;',
  4529. '});',
  4530. '$mod.e=$mod.i;',
  4531. '$mod.i=$mod.e;',
  4532. '']));
  4533. end;
  4534. procedure TTestModule.TestEnum_AsParams;
  4535. begin
  4536. StartProgram(false);
  4537. Add('type TEnum = (Red,Blue);');
  4538. Add('procedure DoIt(vG: TEnum; const vH: TEnum; var vI: TEnum);');
  4539. Add('var vJ: TEnum;');
  4540. Add('begin');
  4541. Add(' vg:=vg;');
  4542. Add(' vj:=vh;');
  4543. Add(' vi:=vi;');
  4544. Add(' doit(vg,vg,vg);');
  4545. Add(' doit(vh,vh,vj);');
  4546. Add(' doit(vi,vi,vi);');
  4547. Add(' doit(vj,vj,vj);');
  4548. Add('end;');
  4549. Add('var i: TEnum;');
  4550. Add('begin');
  4551. Add(' doit(i,i,i);');
  4552. ConvertProgram;
  4553. CheckSource('TestEnum_AsParams',
  4554. LinesToStr([ // statements
  4555. 'this.TEnum = {',
  4556. ' "0": "Red",',
  4557. ' Red: 0,',
  4558. ' "1": "Blue",',
  4559. ' Blue: 1',
  4560. '};',
  4561. 'this.DoIt = function (vG,vH,vI) {',
  4562. ' var vJ = 0;',
  4563. ' vG = vG;',
  4564. ' vJ = vH;',
  4565. ' vI.set(vI.get());',
  4566. ' $mod.DoIt(vG, vG, {',
  4567. ' get: function () {',
  4568. ' return vG;',
  4569. ' },',
  4570. ' set: function (v) {',
  4571. ' vG = v;',
  4572. ' }',
  4573. ' });',
  4574. ' $mod.DoIt(vH, vH, {',
  4575. ' get: function () {',
  4576. ' return vJ;',
  4577. ' },',
  4578. ' set: function (v) {',
  4579. ' vJ = v;',
  4580. ' }',
  4581. ' });',
  4582. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  4583. ' $mod.DoIt(vJ, vJ, {',
  4584. ' get: function () {',
  4585. ' return vJ;',
  4586. ' },',
  4587. ' set: function (v) {',
  4588. ' vJ = v;',
  4589. ' }',
  4590. ' });',
  4591. '};',
  4592. 'this.i = 0;'
  4593. ]),
  4594. LinesToStr([
  4595. '$mod.DoIt($mod.i,$mod.i,{',
  4596. ' p: $mod,',
  4597. ' get: function () {',
  4598. ' return this.p.i;',
  4599. ' },',
  4600. ' set: function (v) {',
  4601. ' this.p.i = v;',
  4602. ' }',
  4603. '});'
  4604. ]));
  4605. end;
  4606. procedure TTestModule.TestEnumRange_Array;
  4607. begin
  4608. StartProgram(false);
  4609. Add([
  4610. 'type',
  4611. ' TEnum = (Red, Green, Blue);',
  4612. ' TEnumRg = green..blue;',
  4613. ' TArr = array[TEnumRg] of byte;',
  4614. ' TArr2 = array[green..blue] of byte;',
  4615. 'var',
  4616. ' a: TArr;',
  4617. ' b: TArr = (3,4);',
  4618. ' c: TArr2 = (5,6);',
  4619. 'begin',
  4620. ' a[green] := b[blue];',
  4621. ' c[green] := c[blue];',
  4622. '']);
  4623. ConvertProgram;
  4624. CheckSource('TestEnumRange_Array',
  4625. LinesToStr([ // statements
  4626. 'this.TEnum = {',
  4627. ' "0": "Red",',
  4628. ' Red: 0,',
  4629. ' "1": "Green",',
  4630. ' Green: 1,',
  4631. ' "2": "Blue",',
  4632. ' Blue: 2',
  4633. '};',
  4634. 'this.a = rtl.arraySetLength(null, 0, 2);',
  4635. 'this.b = [3, 4];',
  4636. 'this.c = [5, 6];',
  4637. '']),
  4638. LinesToStr([
  4639. ' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
  4640. ' $mod.c[$mod.TEnum.Green - 1] = $mod.c[$mod.TEnum.Blue - 1];',
  4641. '']));
  4642. end;
  4643. procedure TTestModule.TestEnum_ForIn;
  4644. begin
  4645. StartProgram(false);
  4646. Add([
  4647. 'type',
  4648. ' TEnum = (Red, Green, Blue);',
  4649. ' TEnumRg = green..blue;',
  4650. ' TArr = array[TEnum] of byte;',
  4651. ' TArrRg = array[TEnumRg] of byte;',
  4652. 'var',
  4653. ' e: TEnum;',
  4654. ' a1: TArr = (3,4,5);',
  4655. ' a2: TArrRg = (11,12);',
  4656. ' b: byte;',
  4657. 'begin',
  4658. ' for e in TEnum do ;',
  4659. ' for e in TEnumRg do ;',
  4660. ' for e in TArr do ;',
  4661. ' for e in TArrRg do ;',
  4662. ' for b in a1 do ;',
  4663. ' for b in a2 do ;',
  4664. '']);
  4665. ConvertProgram;
  4666. CheckSource('TestEnum_ForIn',
  4667. LinesToStr([ // statements
  4668. 'this.TEnum = {',
  4669. ' "0": "Red",',
  4670. ' Red: 0,',
  4671. ' "1": "Green",',
  4672. ' Green: 1,',
  4673. ' "2": "Blue",',
  4674. ' Blue: 2',
  4675. '};',
  4676. 'this.e = 0;',
  4677. 'this.a1 = [3, 4, 5];',
  4678. 'this.a2 = [11, 12];',
  4679. 'this.b = 0;',
  4680. '']),
  4681. LinesToStr([
  4682. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  4683. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  4684. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  4685. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  4686. ' for (var $in1 = $mod.a1, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.b = $in1[$l2];',
  4687. ' for (var $in4 = $mod.a2, $l5 = 0, $end6 = rtl.length($in4) - 1; $l5 <= $end6; $l5++) $mod.b = $in4[$l5];',
  4688. '']));
  4689. end;
  4690. procedure TTestModule.TestEnum_ScopedNumber;
  4691. begin
  4692. Converter.Options:=Converter.Options+[coEnumNumbers];
  4693. StartProgram(false);
  4694. Add([
  4695. 'type',
  4696. ' TEnum = (Red, Green);',
  4697. 'var',
  4698. ' e: TEnum;',
  4699. 'begin',
  4700. ' e:=TEnum.Green;',
  4701. '']);
  4702. ConvertProgram;
  4703. CheckSource('TestEnum_ScopedNumber',
  4704. LinesToStr([ // statements
  4705. 'this.TEnum = {',
  4706. ' "0": "Red",',
  4707. ' Red: 0,',
  4708. ' "1": "Green",',
  4709. ' Green: 1',
  4710. '};',
  4711. 'this.e = 0;',
  4712. '']),
  4713. LinesToStr([
  4714. '$mod.e = 1;']));
  4715. end;
  4716. procedure TTestModule.TestEnum_InFunction;
  4717. begin
  4718. StartProgram(false);
  4719. Add([
  4720. 'const TEnum = 3;',
  4721. 'procedure DoIt;',
  4722. 'type',
  4723. ' TEnum = (Red, Green, Blue);',
  4724. ' procedure Sub;',
  4725. ' type',
  4726. ' TEnumSub = (Left, Right);',
  4727. ' var',
  4728. ' es: TEnumSub;',
  4729. ' begin',
  4730. ' es:=Left;',
  4731. ' end;',
  4732. 'var',
  4733. ' e, e2: TEnum;',
  4734. 'begin',
  4735. ' if e in [red,blue] then e2:=e;',
  4736. 'end;',
  4737. 'begin']);
  4738. ConvertProgram;
  4739. CheckSource('TestEnum_InFunction',
  4740. LinesToStr([ // statements
  4741. 'this.TEnum = 3;',
  4742. 'var TEnum$1 = {',
  4743. ' "0":"Red",',
  4744. ' Red:0,',
  4745. ' "1":"Green",',
  4746. ' Green:1,',
  4747. ' "2":"Blue",',
  4748. ' Blue:2',
  4749. ' };',
  4750. 'var TEnumSub = {',
  4751. ' "0": "Left",',
  4752. ' Left: 0,',
  4753. ' "1": "Right",',
  4754. ' Right: 1',
  4755. '};',
  4756. 'this.DoIt = function () {',
  4757. ' function Sub() {',
  4758. ' var es = 0;',
  4759. ' es = TEnumSub.Left;',
  4760. ' };',
  4761. ' var e = 0;',
  4762. ' var e2 = 0;',
  4763. ' if (e in rtl.createSet(TEnum$1.Red, TEnum$1.Blue)) e2 = e;',
  4764. '};',
  4765. '']),
  4766. LinesToStr([
  4767. '']));
  4768. end;
  4769. procedure TTestModule.TestSet_Enum;
  4770. begin
  4771. StartProgram(false);
  4772. Add([
  4773. 'type',
  4774. ' TColor = (Red, Green, Blue);',
  4775. ' TColors = set of TColor;',
  4776. 'var',
  4777. ' c: TColor;',
  4778. ' s: TColors;',
  4779. ' t: TColors = [];',
  4780. ' u: TColors = [Red];',
  4781. 'begin',
  4782. ' s:=[];',
  4783. ' s:=[Green];',
  4784. ' s:=[Green,Blue];',
  4785. ' s:=[Red..Blue];',
  4786. ' s:=[Red,Green..Blue];',
  4787. ' s:=[Red,c];',
  4788. ' s:=t;',
  4789. ' s:=default(TColors);',
  4790. '']);
  4791. ConvertProgram;
  4792. CheckSource('TestSet',
  4793. LinesToStr([ // statements
  4794. 'this.TColor = {',
  4795. ' "0":"Red",',
  4796. ' Red:0,',
  4797. ' "1":"Green",',
  4798. ' Green:1,',
  4799. ' "2":"Blue",',
  4800. ' Blue:2',
  4801. ' };',
  4802. 'this.c = 0;',
  4803. 'this.s = {};',
  4804. 'this.t = {};',
  4805. 'this.u = rtl.createSet($mod.TColor.Red);'
  4806. ]),
  4807. LinesToStr([
  4808. '$mod.s={};',
  4809. '$mod.s=rtl.createSet($mod.TColor.Green);',
  4810. '$mod.s=rtl.createSet($mod.TColor.Green,$mod.TColor.Blue);',
  4811. '$mod.s=rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);',
  4812. '$mod.s=rtl.createSet($mod.TColor.Red,null,$mod.TColor.Green,$mod.TColor.Blue);',
  4813. '$mod.s=rtl.createSet($mod.TColor.Red,$mod.c);',
  4814. '$mod.s=rtl.refSet($mod.t);',
  4815. '$mod.s={};',
  4816. '']));
  4817. end;
  4818. procedure TTestModule.TestSet_Operators;
  4819. begin
  4820. StartProgram(false);
  4821. Add('type');
  4822. Add(' TColor = (Red, Green, Blue);');
  4823. Add(' TColors = set of tcolor;');
  4824. Add('var');
  4825. Add(' vC: TColor;');
  4826. Add(' vS: TColors;');
  4827. Add(' vT: TColors;');
  4828. Add(' vU: TColors;');
  4829. Add(' B: boolean;');
  4830. Add('begin');
  4831. Add(' include(vs,green);');
  4832. Add(' exclude(vs,vc);');
  4833. Add(' vs:=vt+vu;');
  4834. Add(' vs:=vt+[red];');
  4835. Add(' vs:=[red]+vt;');
  4836. Add(' vs:=[red]+[green];');
  4837. Add(' vs:=vt-vu;');
  4838. Add(' vs:=vt-[red];');
  4839. Add(' vs:=[red]-vt;');
  4840. Add(' vs:=[red]-[green];');
  4841. Add(' vs:=vt*vu;');
  4842. Add(' vs:=vt*[red];');
  4843. Add(' vs:=[red]*vt;');
  4844. Add(' vs:=[red]*[green];');
  4845. Add(' vs:=vt><vu;');
  4846. Add(' vs:=vt><[red];');
  4847. Add(' vs:=[red]><vt;');
  4848. Add(' vs:=[red]><[green];');
  4849. Add(' b:=vt=vu;');
  4850. Add(' b:=vt=[red];');
  4851. Add(' b:=[red]=vt;');
  4852. Add(' b:=[red]=[green];');
  4853. Add(' b:=vt<>vu;');
  4854. Add(' b:=vt<>[red];');
  4855. Add(' b:=[red]<>vt;');
  4856. Add(' b:=[red]<>[green];');
  4857. Add(' b:=vt<=vu;');
  4858. Add(' b:=vt<=[red];');
  4859. Add(' b:=[red]<=vt;');
  4860. Add(' b:=[red]<=[green];');
  4861. Add(' b:=vt>=vu;');
  4862. Add(' b:=vt>=[red];');
  4863. Add(' b:=[red]>=vt;');
  4864. Add(' b:=[red]>=[green];');
  4865. ConvertProgram;
  4866. CheckSource('TestSet_Operators',
  4867. LinesToStr([ // statements
  4868. 'this.TColor = {',
  4869. ' "0":"Red",',
  4870. ' Red:0,',
  4871. ' "1":"Green",',
  4872. ' Green:1,',
  4873. ' "2":"Blue",',
  4874. ' Blue:2',
  4875. ' };',
  4876. 'this.vC = 0;',
  4877. 'this.vS = {};',
  4878. 'this.vT = {};',
  4879. 'this.vU = {};',
  4880. 'this.B = false;'
  4881. ]),
  4882. LinesToStr([
  4883. '$mod.vS = rtl.includeSet($mod.vS,$mod.TColor.Green);',
  4884. '$mod.vS = rtl.excludeSet($mod.vS,$mod.vC);',
  4885. '$mod.vS = rtl.unionSet($mod.vT, $mod.vU);',
  4886. '$mod.vS = rtl.unionSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4887. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4888. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4889. '$mod.vS = rtl.diffSet($mod.vT, $mod.vU);',
  4890. '$mod.vS = rtl.diffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4891. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4892. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4893. '$mod.vS = rtl.intersectSet($mod.vT, $mod.vU);',
  4894. '$mod.vS = rtl.intersectSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4895. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4896. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4897. '$mod.vS = rtl.symDiffSet($mod.vT, $mod.vU);',
  4898. '$mod.vS = rtl.symDiffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4899. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4900. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4901. '$mod.B = rtl.eqSet($mod.vT, $mod.vU);',
  4902. '$mod.B = rtl.eqSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4903. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4904. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4905. '$mod.B = rtl.neSet($mod.vT, $mod.vU);',
  4906. '$mod.B = rtl.neSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4907. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4908. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4909. '$mod.B = rtl.leSet($mod.vT, $mod.vU);',
  4910. '$mod.B = rtl.leSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4911. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4912. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4913. '$mod.B = rtl.geSet($mod.vT, $mod.vU);',
  4914. '$mod.B = rtl.geSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4915. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4916. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4917. '']));
  4918. end;
  4919. procedure TTestModule.TestSet_Operator_In;
  4920. begin
  4921. StartProgram(false);
  4922. Add('type');
  4923. Add(' TColor = (Red, Green, Blue);');
  4924. Add(' TColors = set of tcolor;');
  4925. Add('var');
  4926. Add(' vC: tcolor;');
  4927. Add(' vT: tcolors;');
  4928. Add(' B: boolean;');
  4929. Add('begin');
  4930. Add(' b:=red in vt;');
  4931. Add(' b:=vc in vt;');
  4932. Add(' b:=green in [red..blue];');
  4933. Add(' b:=vc in [red..blue];');
  4934. Add(' ');
  4935. Add(' if red in vt then ;');
  4936. Add(' while vC in vt do ;');
  4937. Add(' repeat');
  4938. Add(' until vC in vt;');
  4939. ConvertProgram;
  4940. CheckSource('TestSet_Operator_In',
  4941. LinesToStr([ // statements
  4942. 'this.TColor = {',
  4943. ' "0":"Red",',
  4944. ' Red:0,',
  4945. ' "1":"Green",',
  4946. ' Green:1,',
  4947. ' "2":"Blue",',
  4948. ' Blue:2',
  4949. ' };',
  4950. 'this.vC = 0;',
  4951. 'this.vT = {};',
  4952. 'this.B = false;'
  4953. ]),
  4954. LinesToStr([
  4955. '$mod.B = $mod.TColor.Red in $mod.vT;',
  4956. '$mod.B = $mod.vC in $mod.vT;',
  4957. '$mod.B = $mod.TColor.Green in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  4958. '$mod.B = $mod.vC in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  4959. 'if ($mod.TColor.Red in $mod.vT) ;',
  4960. 'while ($mod.vC in $mod.vT) {',
  4961. '};',
  4962. 'do {',
  4963. '} while (!($mod.vC in $mod.vT));',
  4964. '']));
  4965. end;
  4966. procedure TTestModule.TestSet_Functions;
  4967. begin
  4968. StartProgram(false);
  4969. Add('type');
  4970. Add(' TMyEnum = (Red, Green);');
  4971. Add(' TMyEnums = set of TMyEnum;');
  4972. Add('var');
  4973. Add(' e: TMyEnum;');
  4974. Add(' s: TMyEnums;');
  4975. Add('begin');
  4976. Add(' e:=Low(TMyEnums);');
  4977. Add(' e:=Low(s);');
  4978. Add(' e:=High(TMyEnums);');
  4979. Add(' e:=High(s);');
  4980. ConvertProgram;
  4981. CheckSource('TestSetFunctions',
  4982. LinesToStr([ // statements
  4983. 'this.TMyEnum = {',
  4984. ' "0":"Red",',
  4985. ' Red:0,',
  4986. ' "1":"Green",',
  4987. ' Green:1',
  4988. ' };',
  4989. 'this.e = 0;',
  4990. 'this.s = {};'
  4991. ]),
  4992. LinesToStr([
  4993. '$mod.e=$mod.TMyEnum.Red;',
  4994. '$mod.e=$mod.TMyEnum.Red;',
  4995. '$mod.e=$mod.TMyEnum.Green;',
  4996. '$mod.e=$mod.TMyEnum.Green;',
  4997. '']));
  4998. end;
  4999. procedure TTestModule.TestSet_PassAsArgClone;
  5000. begin
  5001. StartProgram(false);
  5002. Add('type');
  5003. Add(' TMyEnum = (Red, Green);');
  5004. Add(' TMyEnums = set of TMyEnum;');
  5005. Add('procedure DoDefault(s: tmyenums); begin end;');
  5006. Add('procedure DoConst(const s: tmyenums); begin end;');
  5007. Add('var');
  5008. Add(' aSet: tmyenums;');
  5009. Add('begin');
  5010. Add(' dodefault(aset);');
  5011. Add(' doconst(aset);');
  5012. ConvertProgram;
  5013. CheckSource('TestSetFunctions',
  5014. LinesToStr([ // statements
  5015. 'this.TMyEnum = {',
  5016. ' "0":"Red",',
  5017. ' Red:0,',
  5018. ' "1":"Green",',
  5019. ' Green:1',
  5020. ' };',
  5021. 'this.DoDefault = function (s) {',
  5022. '};',
  5023. 'this.DoConst = function (s) {',
  5024. '};',
  5025. 'this.aSet = {};'
  5026. ]),
  5027. LinesToStr([
  5028. '$mod.DoDefault(rtl.refSet($mod.aSet));',
  5029. '$mod.DoConst($mod.aSet);',
  5030. '']));
  5031. end;
  5032. procedure TTestModule.TestSet_AsParams;
  5033. begin
  5034. StartProgram(false);
  5035. Add([
  5036. 'type TEnum = (Red,Blue);',
  5037. 'type TEnums = set of TEnum;',
  5038. 'function DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums): TEnums;',
  5039. 'var vJ: TEnums;',
  5040. 'begin',
  5041. ' Include(vg,red);',
  5042. ' Include(result,blue);',
  5043. ' vg:=vg;',
  5044. ' vj:=vh;',
  5045. ' vi:=vi;',
  5046. ' doit(vg,vg,vg);',
  5047. ' doit(vh,vh,vj);',
  5048. ' doit(vi,vi,vi);',
  5049. ' doit(vj,vj,vj);',
  5050. 'end;',
  5051. 'var i: TEnums;',
  5052. 'begin',
  5053. ' doit(i,i,i);']);
  5054. ConvertProgram;
  5055. CheckSource('TestSet_AsParams',
  5056. LinesToStr([ // statements
  5057. 'this.TEnum = {',
  5058. ' "0": "Red",',
  5059. ' Red: 0,',
  5060. ' "1": "Blue",',
  5061. ' Blue: 1',
  5062. '};',
  5063. 'this.DoIt = function (vG,vH,vI) {',
  5064. ' var Result = {};',
  5065. ' var vJ = {};',
  5066. ' vG = rtl.includeSet(vG, $mod.TEnum.Red);',
  5067. ' Result = rtl.includeSet(Result, $mod.TEnum.Blue);',
  5068. ' vG = rtl.refSet(vG);',
  5069. ' vJ = rtl.refSet(vH);',
  5070. ' vI.set(rtl.refSet(vI.get()));',
  5071. ' $mod.DoIt(rtl.refSet(vG), vG, {',
  5072. ' get: function () {',
  5073. ' return vG;',
  5074. ' },',
  5075. ' set: function (v) {',
  5076. ' vG = v;',
  5077. ' }',
  5078. ' });',
  5079. ' $mod.DoIt(rtl.refSet(vH), vH, {',
  5080. ' get: function () {',
  5081. ' return vJ;',
  5082. ' },',
  5083. ' set: function (v) {',
  5084. ' vJ = v;',
  5085. ' }',
  5086. ' });',
  5087. ' $mod.DoIt(rtl.refSet(vI.get()), vI.get(), vI);',
  5088. ' $mod.DoIt(rtl.refSet(vJ), vJ, {',
  5089. ' get: function () {',
  5090. ' return vJ;',
  5091. ' },',
  5092. ' set: function (v) {',
  5093. ' vJ = v;',
  5094. ' }',
  5095. ' });',
  5096. ' return Result;',
  5097. '};',
  5098. 'this.i = {};'
  5099. ]),
  5100. LinesToStr([
  5101. '$mod.DoIt(rtl.refSet($mod.i),$mod.i,{',
  5102. ' p: $mod,',
  5103. ' get: function () {',
  5104. ' return this.p.i;',
  5105. ' },',
  5106. ' set: function (v) {',
  5107. ' this.p.i = v;',
  5108. ' }',
  5109. '});'
  5110. ]));
  5111. end;
  5112. procedure TTestModule.TestSet_Property;
  5113. begin
  5114. StartProgram(false);
  5115. Add('type');
  5116. Add(' TEnum = (Red,Blue);');
  5117. Add(' TEnums = set of TEnum;');
  5118. Add(' TObject = class');
  5119. Add(' function GetColors: TEnums; external name ''GetColors'';');
  5120. Add(' procedure SetColors(const Value: TEnums); external name ''SetColors'';');
  5121. Add(' property Colors: TEnums read GetColors write SetColors;');
  5122. Add(' end;');
  5123. Add('procedure DoIt(i: TEnums; const j: TEnums; var k: TEnums; out l: TEnums);');
  5124. Add('begin end;');
  5125. Add('var Obj: TObject;');
  5126. Add('begin');
  5127. Add(' Include(Obj.Colors,Red);');
  5128. Add(' Exclude(Obj.Colors,Red);');
  5129. //Add(' DoIt(Obj.Colors,Obj.Colors,Obj.Colors,Obj.Colors);');
  5130. ConvertProgram;
  5131. CheckSource('TestSet_Property',
  5132. LinesToStr([ // statements
  5133. 'this.TEnum = {',
  5134. ' "0": "Red",',
  5135. ' Red: 0,',
  5136. ' "1": "Blue",',
  5137. ' Blue: 1',
  5138. '};',
  5139. 'rtl.createClass($mod, "TObject", null, function () {',
  5140. ' this.$init = function () {',
  5141. ' };',
  5142. ' this.$final = function () {',
  5143. ' };',
  5144. '});',
  5145. 'this.DoIt = function (i, j, k, l) {',
  5146. '};',
  5147. 'this.Obj = null;',
  5148. '']),
  5149. LinesToStr([
  5150. '$mod.Obj.SetColors(rtl.includeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  5151. '$mod.Obj.SetColors(rtl.excludeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  5152. '']));
  5153. end;
  5154. procedure TTestModule.TestSet_EnumConst;
  5155. begin
  5156. StartProgram(false);
  5157. Add([
  5158. 'type',
  5159. ' TEnum = (Red,Blue);',
  5160. ' TEnums = set of TEnum;',
  5161. 'const',
  5162. ' Orange = red;',
  5163. 'var',
  5164. ' Enum: tenum;',
  5165. ' Enums: tenums;',
  5166. 'begin',
  5167. ' Include(enums,orange);',
  5168. ' Exclude(enums,orange);',
  5169. ' if orange in enums then;',
  5170. ' if orange in [orange,red] then;']);
  5171. ConvertProgram;
  5172. CheckSource('TestSet_EnumConst',
  5173. LinesToStr([ // statements
  5174. 'this.TEnum = {',
  5175. ' "0": "Red",',
  5176. ' Red: 0,',
  5177. ' "1": "Blue",',
  5178. ' Blue: 1',
  5179. '};',
  5180. 'this.Orange = $mod.TEnum.Red;',
  5181. 'this.Enum = 0;',
  5182. 'this.Enums = {};',
  5183. '']),
  5184. LinesToStr([
  5185. '$mod.Enums = rtl.includeSet($mod.Enums, $mod.TEnum.Red);',
  5186. '$mod.Enums = rtl.excludeSet($mod.Enums, $mod.TEnum.Red);',
  5187. 'if ($mod.TEnum.Red in $mod.Enums) ;',
  5188. 'if ($mod.TEnum.Red in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Red)) ;',
  5189. '']));
  5190. end;
  5191. procedure TTestModule.TestSet_IntConst;
  5192. begin
  5193. StartProgram(false);
  5194. Add([
  5195. 'type',
  5196. ' TEnums = set of Byte;',
  5197. 'const',
  5198. ' Orange = 0;',
  5199. 'var',
  5200. ' Enum: byte;',
  5201. ' Enums: tenums;',
  5202. 'begin',
  5203. ' Enums:=[];',
  5204. ' Enums:=[0];',
  5205. ' Enums:=[1..2];',
  5206. //' Include(enums,orange);',
  5207. //' Exclude(enums,orange);',
  5208. ' if orange in enums then;',
  5209. ' if orange in [orange,1] then;']);
  5210. ConvertProgram;
  5211. CheckSource('TestSet_IntConst',
  5212. LinesToStr([ // statements
  5213. 'this.Orange = 0;',
  5214. 'this.Enum = 0;',
  5215. 'this.Enums = {};',
  5216. '']),
  5217. LinesToStr([
  5218. '$mod.Enums = {};',
  5219. '$mod.Enums = rtl.createSet(0);',
  5220. '$mod.Enums = rtl.createSet(null, 1, 2);',
  5221. 'if (0 in $mod.Enums) ;',
  5222. 'if (0 in rtl.createSet(0, 1)) ;',
  5223. '']));
  5224. end;
  5225. procedure TTestModule.TestSet_AnonymousEnumType;
  5226. begin
  5227. StartProgram(false);
  5228. Add('type');
  5229. Add(' TFlags = set of (red, green);');
  5230. Add('const');
  5231. Add(' favorite = red;');
  5232. Add('var');
  5233. Add(' f: TFlags;');
  5234. Add(' i: longint;');
  5235. Add('begin');
  5236. Add(' Include(f,red);');
  5237. Add(' Include(f,favorite);');
  5238. Add(' i:=ord(red);');
  5239. Add(' i:=ord(favorite);');
  5240. Add(' i:=ord(low(TFlags));');
  5241. Add(' i:=ord(low(f));');
  5242. Add(' i:=ord(low(favorite));');
  5243. Add(' i:=ord(high(TFlags));');
  5244. Add(' i:=ord(high(f));');
  5245. Add(' i:=ord(high(favorite));');
  5246. Add(' f:=[green,favorite];');
  5247. ConvertProgram;
  5248. CheckSource('TestSet_AnonymousEnumType',
  5249. LinesToStr([ // statements
  5250. 'this.TFlags$a = {',
  5251. ' "0": "red",',
  5252. ' red: 0,',
  5253. ' "1": "green",',
  5254. ' green: 1',
  5255. '};',
  5256. 'this.favorite = $mod.TFlags$a.red;',
  5257. 'this.f = {};',
  5258. 'this.i = 0;',
  5259. '']),
  5260. LinesToStr([
  5261. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  5262. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  5263. '$mod.i = $mod.TFlags$a.red;',
  5264. '$mod.i = $mod.TFlags$a.red;',
  5265. '$mod.i = $mod.TFlags$a.red;',
  5266. '$mod.i = $mod.TFlags$a.red;',
  5267. '$mod.i = $mod.TFlags$a.red;',
  5268. '$mod.i = $mod.TFlags$a.green;',
  5269. '$mod.i = $mod.TFlags$a.green;',
  5270. '$mod.i = $mod.TFlags$a.green;',
  5271. '$mod.f = rtl.createSet($mod.TFlags$a.green, $mod.TFlags$a.red);',
  5272. '']));
  5273. end;
  5274. procedure TTestModule.TestSet_AnonymousEnumTypeChar;
  5275. begin
  5276. exit;
  5277. StartProgram(false);
  5278. Add([
  5279. 'type',
  5280. ' TAtoZ = ''A''..''Z'';',
  5281. ' TSetOfAZ = set of TAtoZ;',
  5282. 'var',
  5283. ' c: char;',
  5284. ' a: TAtoZ;',
  5285. ' s: TSetOfAZ = [''P'',''A''];',
  5286. ' i: longint;',
  5287. 'begin',
  5288. ' Include(s,''S'');',
  5289. ' Include(s,c);',
  5290. ' Include(s,a);',
  5291. ' c:=low(TAtoZ);',
  5292. ' i:=ord(low(TAtoZ));',
  5293. ' a:=high(TAtoZ);',
  5294. ' a:=high(TSetOfAtoZ);',
  5295. ' s:=[a,c,''M''];',
  5296. '']);
  5297. ConvertProgram;
  5298. CheckSource('TestSet_AnonymousEnumTypeChar',
  5299. LinesToStr([ // statements
  5300. '']),
  5301. LinesToStr([
  5302. '']));
  5303. end;
  5304. procedure TTestModule.TestSet_ConstEnum;
  5305. begin
  5306. StartProgram(false);
  5307. Add([
  5308. 'type',
  5309. ' TEnum = (red,blue,green);',
  5310. ' TEnums = set of TEnum;',
  5311. 'const',
  5312. ' teAny = [low(TEnum)..high(TEnum)];',
  5313. ' teRedBlue = [low(TEnum)..pred(high(TEnum))];',
  5314. 'var',
  5315. ' e: TEnum;',
  5316. ' s: TEnums;',
  5317. 'begin',
  5318. ' if blue in teAny then;',
  5319. ' if blue in teAny+[e] then;',
  5320. ' if blue in teAny+teRedBlue then;',
  5321. ' if e in [red,blue] then;',
  5322. ' s:=teAny;',
  5323. ' s:=teAny+[e];',
  5324. ' s:=[e]+teAny;',
  5325. ' s:=teAny+teRedBlue;',
  5326. ' s:=teAny+teRedBlue+[e];',
  5327. '']);
  5328. ConvertProgram;
  5329. CheckSource('TestSet_ConstEnum',
  5330. LinesToStr([ // statements
  5331. 'this.TEnum = {',
  5332. ' "0": "red",',
  5333. ' red: 0,',
  5334. ' "1": "blue",',
  5335. ' blue: 1,',
  5336. ' "2": "green",',
  5337. ' green: 2',
  5338. '};',
  5339. 'this.teAny = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green);',
  5340. 'this.teRedBlue = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green - 1);',
  5341. 'this.e = 0;',
  5342. 'this.s = {};',
  5343. '']),
  5344. LinesToStr([
  5345. 'if ($mod.TEnum.blue in $mod.teAny) ;',
  5346. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, rtl.createSet($mod.e))) ;',
  5347. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, $mod.teRedBlue)) ;',
  5348. 'if ($mod.e in rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)) ;',
  5349. '$mod.s = rtl.refSet($mod.teAny);',
  5350. '$mod.s = rtl.unionSet($mod.teAny, rtl.createSet($mod.e));',
  5351. '$mod.s = rtl.unionSet(rtl.createSet($mod.e), $mod.teAny);',
  5352. '$mod.s = rtl.unionSet($mod.teAny, $mod.teRedBlue);',
  5353. '$mod.s = rtl.unionSet(rtl.unionSet($mod.teAny, $mod.teRedBlue), rtl.createSet($mod.e));',
  5354. '']));
  5355. end;
  5356. procedure TTestModule.TestSet_ConstChar;
  5357. begin
  5358. StartProgram(false);
  5359. Add([
  5360. 'const',
  5361. ' LowChars = [''a''..''z''];',
  5362. ' Chars = LowChars+[''A''..''Z''];',
  5363. ' sc = [''А'', ''Я''];',
  5364. 'var',
  5365. ' c: char;',
  5366. ' s: string;',
  5367. 'begin',
  5368. ' if c in lowchars then ;',
  5369. ' if ''a'' in lowchars then ;',
  5370. ' if s[1] in lowchars then ;',
  5371. ' if c in chars then ;',
  5372. ' if c in [''a''..''z'',''_''] then ;',
  5373. ' if ''b'' in [''a''..''z'',''_''] then ;',
  5374. ' if ''Я'' in sc then ;',
  5375. '']);
  5376. ConvertProgram;
  5377. CheckSource('TestSet_ConstChar',
  5378. LinesToStr([ // statements
  5379. 'this.LowChars = rtl.createSet(null, 97, 122);',
  5380. 'this.Chars = rtl.unionSet($mod.LowChars, rtl.createSet(null, 65, 90));',
  5381. 'this.sc = rtl.createSet(1040, 1071);',
  5382. 'this.c = "";',
  5383. 'this.s = "";',
  5384. '']),
  5385. LinesToStr([
  5386. 'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
  5387. 'if (97 in $mod.LowChars) ;',
  5388. 'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
  5389. 'if ($mod.c.charCodeAt() in $mod.Chars) ;',
  5390. 'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
  5391. 'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
  5392. 'if (1071 in $mod.sc) ;',
  5393. '']));
  5394. end;
  5395. procedure TTestModule.TestSet_ConstInt;
  5396. begin
  5397. StartProgram(false);
  5398. Add([
  5399. 'const',
  5400. ' Months = [1..12];',
  5401. ' Mirror = [-12..-1]+Months;',
  5402. 'var',
  5403. ' i: smallint;',
  5404. 'begin',
  5405. ' if 3 in Months then;',
  5406. ' if i in Months+[i] then;',
  5407. ' if i in Months+Mirror then;',
  5408. ' if i in [4..6,8] then;',
  5409. '']);
  5410. ConvertProgram;
  5411. CheckSource('TestSet_ConstInt',
  5412. LinesToStr([ // statements
  5413. 'this.Months = rtl.createSet(null, 1, 12);',
  5414. 'this.Mirror = rtl.unionSet(rtl.createSet(null, -12, -1), $mod.Months);',
  5415. 'this.i = 0;',
  5416. '']),
  5417. LinesToStr([
  5418. 'if (3 in $mod.Months) ;',
  5419. 'if ($mod.i in rtl.unionSet($mod.Months, rtl.createSet($mod.i))) ;',
  5420. 'if ($mod.i in rtl.unionSet($mod.Months, $mod.Mirror)) ;',
  5421. 'if ($mod.i in rtl.createSet(null, 4, 6, 8)) ;',
  5422. '']));
  5423. end;
  5424. procedure TTestModule.TestSet_InFunction;
  5425. begin
  5426. StartProgram(false);
  5427. Add([
  5428. 'const',
  5429. ' TEnum = 3;',
  5430. ' TSetOfEnum = 4;',
  5431. ' TSetOfAno = 5;',
  5432. 'procedure DoIt;',
  5433. 'type',
  5434. ' TEnum = (red, blue);',
  5435. ' TSetOfEnum = set of TEnum;',
  5436. ' TSetOfAno = set of (up,down);',
  5437. 'var',
  5438. ' e: TEnum;',
  5439. ' se: TSetOfEnum;',
  5440. ' sa: TSetOfAno;',
  5441. 'begin',
  5442. ' se:=[e];',
  5443. ' sa:=[up];',
  5444. 'end;',
  5445. 'begin',
  5446. '']);
  5447. ConvertProgram;
  5448. CheckSource('TestSet_InFunction',
  5449. LinesToStr([ // statements
  5450. 'this.TEnum = 3;',
  5451. 'this.TSetOfEnum = 4;',
  5452. 'this.TSetOfAno = 5;',
  5453. 'var TEnum$1 = {',
  5454. ' "0": "red",',
  5455. ' red: 0,',
  5456. ' "1": "blue",',
  5457. ' blue: 1',
  5458. '};',
  5459. 'var TSetOfAno$a = {',
  5460. ' "0": "up",',
  5461. ' up: 0,',
  5462. ' "1": "down",',
  5463. ' down: 1',
  5464. '};',
  5465. 'this.DoIt = function () {',
  5466. ' var e = 0;',
  5467. ' var se = {};',
  5468. ' var sa = {};',
  5469. ' se = rtl.createSet(e);',
  5470. ' sa = rtl.createSet(TSetOfAno$a.up);',
  5471. '};',
  5472. '']),
  5473. LinesToStr([
  5474. '']));
  5475. end;
  5476. procedure TTestModule.TestSet_ForIn;
  5477. begin
  5478. StartProgram(false);
  5479. Add([
  5480. 'type',
  5481. ' TEnum = (Red, Green, Blue);',
  5482. ' TEnumRg = green..blue;',
  5483. ' TSetOfEnum = set of TEnum;',
  5484. ' TSetOfEnumRg = set of TEnumRg;',
  5485. 'var',
  5486. ' e, e2: TEnum;',
  5487. ' er: TEnum;',
  5488. ' s: TSetOfEnum;',
  5489. 'begin',
  5490. ' for e in TSetOfEnum do ;',
  5491. ' for e in TSetOfEnumRg do ;',
  5492. ' for e in [] do e2:=e;',
  5493. ' for e in [red..green] do e2:=e;',
  5494. ' for e in [green,blue] do e2:=e;',
  5495. ' for e in [red,blue] do e2:=e;',
  5496. ' for e in s do e2:=e;',
  5497. ' for er in TSetOfEnumRg do ;',
  5498. '']);
  5499. ConvertProgram;
  5500. CheckSource('TestSet_ForIn',
  5501. LinesToStr([ // statements
  5502. 'this.TEnum = {',
  5503. ' "0":"Red",',
  5504. ' Red:0,',
  5505. ' "1":"Green",',
  5506. ' Green:1,',
  5507. ' "2":"Blue",',
  5508. ' Blue:2',
  5509. ' };',
  5510. 'this.e = 0;',
  5511. 'this.e2 = 0;',
  5512. 'this.er = 0;',
  5513. 'this.s = {};',
  5514. '']),
  5515. LinesToStr([
  5516. 'for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  5517. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  5518. 'for ($mod.e = 0; $mod.e <= 1; $mod.e++) $mod.e2 = $mod.e;',
  5519. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) $mod.e2 = $mod.e;',
  5520. 'for ($mod.e in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Blue)) $mod.e2 = $mod.e;',
  5521. 'for (var $l1 in $mod.s){',
  5522. ' $mod.e = +$l1;',
  5523. ' $mod.e2 = $mod.e;',
  5524. '};',
  5525. 'for ($mod.er = 1; $mod.er <= 2; $mod.er++) ;',
  5526. '']));
  5527. end;
  5528. procedure TTestModule.TestNestBegin;
  5529. begin
  5530. StartProgram(false);
  5531. Add('begin');
  5532. Add(' begin');
  5533. Add(' begin');
  5534. Add(' end;');
  5535. Add(' begin');
  5536. Add(' if true then ;');
  5537. Add(' end;');
  5538. Add(' end;');
  5539. ConvertProgram;
  5540. CheckSource('TestNestBegin',
  5541. '',
  5542. 'if (true) ;');
  5543. end;
  5544. procedure TTestModule.TestUnitImplVars;
  5545. begin
  5546. StartUnit(false);
  5547. Add('interface');
  5548. Add('implementation');
  5549. Add('var');
  5550. Add(' V1:longint;');
  5551. Add(' V2:longint = 3;');
  5552. Add(' V3:string = ''abc'';');
  5553. ConvertUnit;
  5554. CheckSource('TestUnitImplVars',
  5555. LinesToStr([ // statements
  5556. 'var $impl = $mod.$impl;',
  5557. '']),
  5558. '', // this.$init
  5559. LinesToStr([ // implementation
  5560. '$impl.V1 = 0;',
  5561. '$impl.V2 = 3;',
  5562. '$impl.V3 = "abc";',
  5563. '']) );
  5564. end;
  5565. procedure TTestModule.TestUnitImplConsts;
  5566. begin
  5567. StartUnit(false);
  5568. Add('interface');
  5569. Add('implementation');
  5570. Add('const');
  5571. Add(' v1 = 3;');
  5572. Add(' v2:longint = 4;');
  5573. Add(' v3:string = ''abc'';');
  5574. ConvertUnit;
  5575. CheckSource('TestUnitImplConsts',
  5576. LinesToStr([ // statements
  5577. 'var $impl = $mod.$impl;',
  5578. '']),
  5579. '', // this.$init
  5580. LinesToStr([ // implementation
  5581. '$impl.v1 = 3;',
  5582. '$impl.v2 = 4;',
  5583. '$impl.v3 = "abc";',
  5584. '']) );
  5585. end;
  5586. procedure TTestModule.TestUnitImplRecord;
  5587. begin
  5588. StartUnit(false);
  5589. Add('interface');
  5590. Add('implementation');
  5591. Add('type');
  5592. Add(' TMyRecord = record');
  5593. Add(' i: longint;');
  5594. Add(' end;');
  5595. Add('var aRec: TMyRecord;');
  5596. Add('initialization');
  5597. Add(' arec.i:=3;');
  5598. ConvertUnit;
  5599. CheckSource('TestUnitImplRecord',
  5600. LinesToStr([ // statements
  5601. 'var $impl = $mod.$impl;',
  5602. '']),
  5603. // this.$init
  5604. '$impl.aRec.i = 3;',
  5605. LinesToStr([ // implementation
  5606. 'rtl.recNewT($impl, "TMyRecord", function () {',
  5607. ' this.i = 0;',
  5608. ' this.$eq = function (b) {',
  5609. ' return this.i === b.i;',
  5610. ' };',
  5611. ' this.$assign = function (s) {',
  5612. ' this.i = s.i;',
  5613. ' return this;',
  5614. ' };',
  5615. '});',
  5616. '$impl.aRec = $impl.TMyRecord.$new();',
  5617. '']) );
  5618. end;
  5619. procedure TTestModule.TestRenameJSNameConflict;
  5620. begin
  5621. StartProgram(false);
  5622. Add('var apply: longint;');
  5623. Add('var bind: longint;');
  5624. Add('var call: longint;');
  5625. Add('begin');
  5626. ConvertProgram;
  5627. CheckSource('TestRenameJSNameConflict',
  5628. LinesToStr([ // statements
  5629. 'this.Apply = 0;',
  5630. 'this.Bind = 0;',
  5631. 'this.Call = 0;'
  5632. ]),
  5633. LinesToStr([ // this.$main
  5634. ''
  5635. ]));
  5636. end;
  5637. procedure TTestModule.TestLocalConst;
  5638. begin
  5639. StartProgram(false);
  5640. Add('procedure DoIt;');
  5641. Add('const');
  5642. Add(' cA: longint = 1;');
  5643. Add(' cB = 2;');
  5644. Add(' procedure Sub;');
  5645. Add(' const');
  5646. Add(' csA = 3;');
  5647. Add(' cB: double = 4;');
  5648. Add(' begin');
  5649. Add(' cb:=cb+csa;');
  5650. Add(' ca:=ca+csa+5;');
  5651. Add(' end;');
  5652. Add('begin');
  5653. Add(' ca:=ca+cb+6;');
  5654. Add('end;');
  5655. Add('begin');
  5656. ConvertProgram;
  5657. CheckSource('TestLocalConst',
  5658. LinesToStr([
  5659. 'var cA = 1;',
  5660. 'var cB = 2;',
  5661. 'var csA = 3;',
  5662. 'var cB$1 = 4;',
  5663. 'this.DoIt = function () {',
  5664. ' function Sub() {',
  5665. ' cB$1 = cB$1 + 3;',
  5666. ' cA = cA + 3 + 5;',
  5667. ' };',
  5668. ' cA = cA + 2 + 6;',
  5669. '};'
  5670. ]),
  5671. LinesToStr([
  5672. ]));
  5673. end;
  5674. procedure TTestModule.TestVarExternal;
  5675. begin
  5676. StartProgram(false);
  5677. Add('var');
  5678. Add(' NaN: double; external name ''Global.NaN'';');
  5679. Add(' d: double;');
  5680. Add('begin');
  5681. Add(' d:=NaN;');
  5682. ConvertProgram;
  5683. CheckSource('TestVarExternal',
  5684. LinesToStr([
  5685. 'this.d = 0.0;'
  5686. ]),
  5687. LinesToStr([
  5688. '$mod.d = Global.NaN;'
  5689. ]));
  5690. end;
  5691. procedure TTestModule.TestVarExternalOtherUnit;
  5692. begin
  5693. AddModuleWithIntfImplSrc('unit2.pas',
  5694. LinesToStr([
  5695. 'var NaN: double; external name ''Global.NaN'';',
  5696. 'var iV: longint;'
  5697. ]),
  5698. '');
  5699. StartUnit(true);
  5700. Add('interface');
  5701. Add('uses unit2;');
  5702. Add('implementation');
  5703. Add('var');
  5704. Add(' d: double;');
  5705. Add(' i: longint; external name ''$i'';');
  5706. Add('begin');
  5707. Add(' d:=nan;');
  5708. Add(' d:=uNit2.nan;');
  5709. Add(' d:=test1.d;');
  5710. Add(' i:=iv;');
  5711. Add(' i:=uNit2.iv;');
  5712. Add(' i:=test1.i;');
  5713. ConvertUnit;
  5714. CheckSource('TestVarExternalOtherUnit',
  5715. LinesToStr([
  5716. 'var $impl = $mod.$impl;',
  5717. '']),
  5718. LinesToStr([ // this.$init
  5719. '$impl.d = Global.NaN;',
  5720. '$impl.d = Global.NaN;',
  5721. '$impl.d = $impl.d;',
  5722. '$i = pas.unit2.iV;',
  5723. '$i = pas.unit2.iV;',
  5724. '$i = $i;',
  5725. '']),
  5726. LinesToStr([ // implementation
  5727. '$impl.d = 0.0;',
  5728. '']) );
  5729. end;
  5730. procedure TTestModule.TestVarAbsoluteFail;
  5731. begin
  5732. StartProgram(false);
  5733. Add([
  5734. 'var',
  5735. ' a: longint;',
  5736. ' b: longword absolute a;',
  5737. 'begin']);
  5738. SetExpectedPasResolverError('Invalid variable modifier "absolute"',nInvalidVariableModifier);
  5739. ConvertProgram;
  5740. end;
  5741. procedure TTestModule.TestConstExternal;
  5742. begin
  5743. StartProgram(false);
  5744. Add([
  5745. 'const',
  5746. ' PI: double; external name ''Global.PI'';',
  5747. ' Tau = 2*pi;',
  5748. 'var d: double;',
  5749. 'begin',
  5750. ' d:=pi;',
  5751. ' d:=tau+pi;']);
  5752. ConvertProgram;
  5753. CheckSource('TestConstExternal',
  5754. LinesToStr([
  5755. 'this.Tau = 2*Global.PI;',
  5756. 'this.d = 0.0;'
  5757. ]),
  5758. LinesToStr([
  5759. '$mod.d = Global.PI;',
  5760. '$mod.d = $mod.Tau + Global.PI;'
  5761. ]));
  5762. end;
  5763. procedure TTestModule.TestDouble;
  5764. begin
  5765. StartProgram(false);
  5766. Add([
  5767. 'type',
  5768. ' TDateTime = double;',
  5769. 'const',
  5770. ' a = TDateTime(2.7);',
  5771. ' b = a + TDateTime(1.7);',
  5772. ' c = 0.9 + 0.1;',
  5773. ' f0_1 = 0.1;',
  5774. ' f0_3 = 0.3;',
  5775. ' fn0_1 = -0.1;',
  5776. ' fn0_3 = -0.3;',
  5777. ' fn0_003 = -0.003;',
  5778. ' fn0_123456789 = -0.123456789;',
  5779. ' fn300_0 = -300.0;',
  5780. ' fn123456_0 = -123456.0;',
  5781. ' fn1234567_8 = -1234567.8;',
  5782. ' fn12345678_9 = -12345678.9;',
  5783. ' f1_0En12 = 1E-12;',
  5784. ' fn1_0En12 = -1E-12;',
  5785. ' maxdouble = 1.7e+308;',
  5786. ' mindouble = -1.7e+308;',
  5787. ' MinSafeIntDouble = -$10000000000000;',
  5788. ' MinSafeIntDouble2 = -$fffffffffffff-1;',
  5789. ' MaxSafeIntDouble = $fffffffffffff;',
  5790. ' DZeroResolution = 1E-12;',
  5791. ' Minus1 = -1E-12;',
  5792. ' EPS = 1E-9;',
  5793. ' DELTA = 0.001;',
  5794. ' Big = 129.789E+100;',
  5795. ' Test0_15 = 0.15;',
  5796. ' Test999 = 2.9999999999999;',
  5797. ' Test111999 = 211199999999999000.0;',
  5798. ' TestMinus111999 = -211199999999999000.0;',
  5799. 'var',
  5800. ' d: double = b;',
  5801. 'begin',
  5802. ' d:=1.0;',
  5803. ' d:=1.0/3.0;',
  5804. ' d:=1/3;',
  5805. ' d:=5.0E-324;',
  5806. ' d:=1.7E308;',
  5807. ' d:=001.00E00;',
  5808. ' d:=002.00E001;',
  5809. ' d:=003.000E000;',
  5810. ' d:=-004.00E-00;',
  5811. ' d:=-005.00E-001;',
  5812. ' d:=10**3;',
  5813. ' d:=10 mod 3;',
  5814. ' d:=10 div 3;',
  5815. ' d:=c;',
  5816. ' d:=f0_1;',
  5817. ' d:=f0_3;',
  5818. ' d:=fn0_1;',
  5819. ' d:=fn0_3;',
  5820. ' d:=fn0_003;',
  5821. ' d:=fn0_123456789;',
  5822. ' d:=fn300_0;',
  5823. ' d:=fn123456_0;',
  5824. ' d:=fn1234567_8;',
  5825. ' d:=fn12345678_9;',
  5826. ' d:=f1_0En12;',
  5827. ' d:=fn1_0En12;',
  5828. ' d:=maxdouble;',
  5829. ' d:=mindouble;',
  5830. ' d:=MinSafeIntDouble;',
  5831. ' d:=double(MinSafeIntDouble);',
  5832. ' d:=MinSafeIntDouble2;',
  5833. ' d:=double(MinSafeIntDouble2);',
  5834. ' d:=MaxSafeIntDouble;',
  5835. ' d:=default(double);',
  5836. '']);
  5837. ConvertProgram;
  5838. CheckSource('TestDouble',
  5839. LinesToStr([
  5840. 'this.a = 2.7;',
  5841. 'this.b = 2.7 + 1.7;',
  5842. 'this.c = 0.9 + 0.1;',
  5843. 'this.f0_1 = 0.1;',
  5844. 'this.f0_3 = 0.3;',
  5845. 'this.fn0_1 = -0.1;',
  5846. 'this.fn0_3 = -0.3;',
  5847. 'this.fn0_003 = -0.003;',
  5848. 'this.fn0_123456789 = -0.123456789;',
  5849. 'this.fn300_0 = -300.0;',
  5850. 'this.fn123456_0 = -123456.0;',
  5851. 'this.fn1234567_8 = -1234567.8;',
  5852. 'this.fn12345678_9 = -12345678.9;',
  5853. 'this.f1_0En12 = 1E-12;',
  5854. 'this.fn1_0En12 = -1E-12;',
  5855. 'this.maxdouble = 1.7e+308;',
  5856. 'this.mindouble = -1.7e+308;',
  5857. 'this.MinSafeIntDouble = -0x10000000000000;',
  5858. 'this.MinSafeIntDouble2 = -0xfffffffffffff - 1;',
  5859. 'this.MaxSafeIntDouble = 0xfffffffffffff;',
  5860. 'this.DZeroResolution = 1E-12;',
  5861. 'this.Minus1 = -1E-12;',
  5862. 'this.EPS = 1E-9;',
  5863. 'this.DELTA = 0.001;',
  5864. 'this.Big = 129.789E+100;',
  5865. 'this.Test0_15 = 0.15;',
  5866. 'this.Test999 = 2.9999999999999;',
  5867. 'this.Test111999 = 211199999999999000.0;',
  5868. 'this.TestMinus111999 = -211199999999999000.0;',
  5869. 'this.d = 4.4;'
  5870. ]),
  5871. LinesToStr([
  5872. '$mod.d = 1.0;',
  5873. '$mod.d = 1.0 / 3.0;',
  5874. '$mod.d = 1 / 3;',
  5875. '$mod.d = 5.0E-324;',
  5876. '$mod.d = 1.7E308;',
  5877. '$mod.d = 1.00E0;',
  5878. '$mod.d = 2.00E1;',
  5879. '$mod.d = 3.000E0;',
  5880. '$mod.d = -4.00E-0;',
  5881. '$mod.d = -5.00E-1;',
  5882. '$mod.d = Math.pow(10, 3);',
  5883. '$mod.d = 10 % 3;',
  5884. '$mod.d = Math.floor(10 / 3);',
  5885. '$mod.d = 1;',
  5886. '$mod.d = 0.1;',
  5887. '$mod.d = 0.3;',
  5888. '$mod.d = -0.1;',
  5889. '$mod.d = -0.3;',
  5890. '$mod.d = -0.003;',
  5891. '$mod.d = -0.123456789;',
  5892. '$mod.d = -300;',
  5893. '$mod.d = -123456;',
  5894. '$mod.d = -1234567.8;',
  5895. '$mod.d = -1.23456789E7;',
  5896. '$mod.d = 1E-12;',
  5897. '$mod.d = -1E-12;',
  5898. '$mod.d = 1.7E308;',
  5899. '$mod.d = -1.7E308;',
  5900. '$mod.d = -4503599627370496;',
  5901. '$mod.d = -4503599627370496;',
  5902. '$mod.d = -4503599627370496;',
  5903. '$mod.d = -4503599627370496;',
  5904. '$mod.d = 4503599627370495;',
  5905. '$mod.d = 0.0;',
  5906. '']));
  5907. end;
  5908. procedure TTestModule.TestInteger;
  5909. begin
  5910. StartProgram(false);
  5911. Add([
  5912. 'const',
  5913. ' MinInt = low(NativeInt);',
  5914. ' MaxInt = high(NativeInt);',
  5915. 'type',
  5916. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  5917. 'const',
  5918. ' a = low(TMyInt)+High(TMyInt);',
  5919. 'var',
  5920. ' i: TMyInt;',
  5921. 'begin',
  5922. ' i:=-MinInt;',
  5923. ' i:=default(TMyInt);',
  5924. ' i:=low(i)+high(i);',
  5925. '']);
  5926. ConvertProgram;
  5927. CheckSource('TestIntegerRange',
  5928. LinesToStr([
  5929. 'this.MinInt = -4503599627370496;',
  5930. 'this.MaxInt = 4503599627370495;',
  5931. 'this.a = -4503599627370496 + 4503599627370495;',
  5932. 'this.i = 0;',
  5933. '']),
  5934. LinesToStr([
  5935. '$mod.i = - -4503599627370496;',
  5936. '$mod.i = -4503599627370496;',
  5937. '$mod.i = -4503599627370496 + 4503599627370495;',
  5938. '']));
  5939. end;
  5940. procedure TTestModule.TestIntegerRange;
  5941. begin
  5942. StartProgram(false);
  5943. Add([
  5944. 'const',
  5945. ' MinInt = -1;',
  5946. ' MaxInt = +1;',
  5947. 'type',
  5948. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  5949. ' TInt2 = 1..3;',
  5950. 'const',
  5951. ' a = low(TMyInt)+High(TMyInt);',
  5952. ' b = low(TInt2)+High(TInt2);',
  5953. ' s1 = [1];',
  5954. ' s2 = [1,2];',
  5955. ' s3 = [1..3];',
  5956. ' s4 = [low(shortint)..high(shortint)];',
  5957. ' s5 = [succ(low(shortint))..pred(high(shortint))];',
  5958. ' s6 = 1 in s2;',
  5959. 'var',
  5960. ' i: TMyInt;',
  5961. ' i2: TInt2;',
  5962. 'begin',
  5963. ' i:=i2;',
  5964. ' i:=default(TMyInt);',
  5965. ' if i=i2 then ;']);
  5966. ConvertProgram;
  5967. CheckSource('TestIntegerRange',
  5968. LinesToStr([
  5969. 'this.MinInt = -1;',
  5970. 'this.MaxInt = +1;',
  5971. 'this.a = -1 + 1;',
  5972. 'this.b = 1 + 3;',
  5973. 'this.s1 = rtl.createSet(1);',
  5974. 'this.s2 = rtl.createSet(1, 2);',
  5975. 'this.s3 = rtl.createSet(null, 1, 3);',
  5976. 'this.s4 = rtl.createSet(null, -128, 127);',
  5977. 'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
  5978. 'this.s6 = 1 in $mod.s2;',
  5979. 'this.i = 0;',
  5980. 'this.i2 = 0;',
  5981. '']),
  5982. LinesToStr([
  5983. '$mod.i = $mod.i2;',
  5984. '$mod.i = -1;',
  5985. 'if ($mod.i === $mod.i2) ;',
  5986. '']));
  5987. end;
  5988. procedure TTestModule.TestIntegerTypecasts;
  5989. begin
  5990. StartProgram(false);
  5991. Add([
  5992. 'var',
  5993. ' i: nativeint;',
  5994. ' b: byte;',
  5995. ' sh: shortint;',
  5996. ' w: word;',
  5997. ' sm: smallint;',
  5998. ' lw: longword;',
  5999. ' li: longint;',
  6000. 'begin',
  6001. ' b:=byte(i);',
  6002. ' sh:=shortint(i);',
  6003. ' w:=word(i);',
  6004. ' sm:=smallint(i);',
  6005. ' lw:=longword(i);',
  6006. ' li:=longint(i);',
  6007. '']);
  6008. ConvertProgram;
  6009. CheckSource('TestIntegerTypecasts',
  6010. LinesToStr([
  6011. 'this.i = 0;',
  6012. 'this.b = 0;',
  6013. 'this.sh = 0;',
  6014. 'this.w = 0;',
  6015. 'this.sm = 0;',
  6016. 'this.lw = 0;',
  6017. 'this.li = 0;',
  6018. '']),
  6019. LinesToStr([
  6020. '$mod.b = $mod.i & 255;',
  6021. '$mod.sh = (($mod.i & 255) << 24) >> 24;',
  6022. '$mod.w = $mod.i & 65535;',
  6023. '$mod.sm = (($mod.i & 65535) << 16) >> 16;',
  6024. '$mod.lw = $mod.i >>> 0;',
  6025. '$mod.li = $mod.i & 0xFFFFFFFF;',
  6026. '']));
  6027. end;
  6028. procedure TTestModule.TestBitwiseAndNativeIntWarn;
  6029. begin
  6030. StartProgram(false);
  6031. Add([
  6032. 'var',
  6033. ' i,j: nativeint;',
  6034. 'begin',
  6035. ' i:=i and j;',
  6036. '']);
  6037. ConvertProgram;
  6038. CheckSource('TestBitwiseAndNativeIntWarn',
  6039. LinesToStr([
  6040. 'this.i = 0;',
  6041. 'this.j = 0;',
  6042. '']),
  6043. LinesToStr([
  6044. '$mod.i = $mod.i & $mod.j;',
  6045. '']));
  6046. CheckHint(mtWarning,nBitWiseOperationsAre32Bit,sBitWiseOperationsAre32Bit);
  6047. end;
  6048. procedure TTestModule.TestCurrency;
  6049. begin
  6050. StartProgram(false);
  6051. Add([
  6052. 'type',
  6053. ' TCoin = currency;',
  6054. 'const',
  6055. ' a = TCoin(2.7);',
  6056. ' b = a + TCoin(1.7);',
  6057. ' MinSafeIntCurrency: TCoin = -92233720368.5477;',
  6058. ' MaxSafeIntCurrency: TCoin = 92233720368.5477;',
  6059. 'var',
  6060. ' c: TCoin = b;',
  6061. ' i: nativeint;',
  6062. ' d: double;',
  6063. ' j: jsvalue;',
  6064. 'function DoIt(c: currency): currency; begin end;',
  6065. 'function GetIt(d: double): double; begin end;',
  6066. 'procedure Write(v: jsvalue); begin end;',
  6067. 'begin',
  6068. ' c:=1.0;',
  6069. ' c:=0.1;',
  6070. ' c:=1.0/3.0;',
  6071. ' c:=1/3;',
  6072. ' c:=a;',
  6073. ' d:=c;',
  6074. ' c:=d;',
  6075. ' c:=currency(c);',
  6076. ' c:=currency(d);',
  6077. ' d:=double(c);',
  6078. ' c:=i;',
  6079. ' c:=currency(i);',
  6080. //' i:=c;', not allowed
  6081. ' i:=nativeint(c);',
  6082. ' c:=c+a;',
  6083. ' c:=-c-a;',
  6084. ' c:=d+c;',
  6085. ' c:=c+d;',
  6086. ' c:=d-c;',
  6087. ' c:=c-d;',
  6088. ' c:=c*a;',
  6089. ' c:=a*c;',
  6090. ' c:=d*c;',
  6091. ' c:=c*d;',
  6092. ' c:=c/a;',
  6093. ' c:=a/c;',
  6094. ' c:=d/c;',
  6095. ' c:=c/d;',
  6096. ' c:=c**a;',
  6097. ' c:=a**c;',
  6098. ' c:=d**c;',
  6099. ' c:=c**d;',
  6100. ' if c=c then ;',
  6101. ' if c=a then ;',
  6102. ' if a=c then ;',
  6103. ' if d=c then ;',
  6104. ' if c=d then ;',
  6105. ' c:=DoIt(c);',
  6106. ' c:=DoIt(i);',
  6107. ' c:=DoIt(d);',
  6108. ' c:=GetIt(c);',
  6109. ' j:=c;',
  6110. ' Write(c);',
  6111. ' c:=default(currency);',
  6112. ' j:=str(c);',
  6113. ' j:=str(c:0:3);',
  6114. '']);
  6115. ConvertProgram;
  6116. CheckSource('TestCurrency',
  6117. LinesToStr([
  6118. 'this.a = 27000;',
  6119. 'this.b = $mod.a + 17000;',
  6120. 'this.MinSafeIntCurrency = -92233720368.5477;',
  6121. 'this.MaxSafeIntCurrency = 92233720368.5477;',
  6122. 'this.c = $mod.b;',
  6123. 'this.i = 0;',
  6124. 'this.d = 0.0;',
  6125. 'this.j = undefined;',
  6126. 'this.DoIt = function (c) {',
  6127. ' var Result = 0;',
  6128. ' return Result;',
  6129. '};',
  6130. 'this.GetIt = function (d) {',
  6131. ' var Result = 0.0;',
  6132. ' return Result;',
  6133. '};',
  6134. 'this.Write = function (v) {',
  6135. '};',
  6136. '']),
  6137. LinesToStr([
  6138. '$mod.c = 10000;',
  6139. '$mod.c = 1000;',
  6140. '$mod.c = Math.floor((1.0 / 3.0) * 10000);',
  6141. '$mod.c = Math.floor((1 / 3) * 10000);',
  6142. '$mod.c = $mod.a;',
  6143. '$mod.d = $mod.c / 10000;',
  6144. '$mod.c = Math.floor($mod.d * 10000);',
  6145. '$mod.c = $mod.c;',
  6146. '$mod.c = $mod.d * 10000;',
  6147. '$mod.d = $mod.c / 10000;',
  6148. '$mod.c = $mod.i * 10000;',
  6149. '$mod.c = $mod.i * 10000;',
  6150. '$mod.i = Math.floor($mod.c / 10000);',
  6151. '$mod.c = $mod.c + $mod.a;',
  6152. '$mod.c = -$mod.c - $mod.a;',
  6153. '$mod.c = ($mod.d * 10000) + $mod.c;',
  6154. '$mod.c = $mod.c + ($mod.d * 10000);',
  6155. '$mod.c = ($mod.d * 10000) - $mod.c;',
  6156. '$mod.c = $mod.c - ($mod.d * 10000);',
  6157. '$mod.c = ($mod.c * $mod.a) / 10000;',
  6158. '$mod.c = ($mod.a * $mod.c) / 10000;',
  6159. '$mod.c = $mod.d * $mod.c;',
  6160. '$mod.c = $mod.c * $mod.d;',
  6161. '$mod.c = Math.floor(($mod.c / $mod.a) * 10000);',
  6162. '$mod.c = Math.floor(($mod.a / $mod.c) * 10000);',
  6163. '$mod.c = Math.floor($mod.d / $mod.c);',
  6164. '$mod.c = Math.floor($mod.c / $mod.d);',
  6165. '$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.a / 10000) * 10000);',
  6166. '$mod.c = Math.floor(Math.pow($mod.a / 10000, $mod.c / 10000) * 10000);',
  6167. '$mod.c = Math.floor(Math.pow($mod.d, $mod.c / 10000) * 10000);',
  6168. '$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.d) * 10000);',
  6169. 'if ($mod.c === $mod.c) ;',
  6170. 'if ($mod.c === $mod.a) ;',
  6171. 'if ($mod.a === $mod.c) ;',
  6172. 'if (($mod.d * 10000) === $mod.c) ;',
  6173. 'if ($mod.c === ($mod.d * 10000)) ;',
  6174. '$mod.c = $mod.DoIt($mod.c);',
  6175. '$mod.c = $mod.DoIt($mod.i * 10000);',
  6176. '$mod.c = $mod.DoIt($mod.d * 10000);',
  6177. '$mod.c = Math.floor($mod.GetIt($mod.c / 10000) * 10000);',
  6178. '$mod.j = $mod.c / 10000;',
  6179. '$mod.Write($mod.c / 10000);',
  6180. '$mod.c = 0;',
  6181. '$mod.j = rtl.floatToStr($mod.c / 10000);',
  6182. '$mod.j = rtl.floatToStr($mod.c / 10000, 0, 3);',
  6183. '']));
  6184. end;
  6185. procedure TTestModule.TestForBoolDo;
  6186. begin
  6187. StartProgram(false);
  6188. Add([
  6189. 'var b: boolean;',
  6190. 'begin',
  6191. ' for b:=false to true do ;',
  6192. ' for b:=b downto false do ;',
  6193. ' for b in boolean do ;',
  6194. '']);
  6195. ConvertProgram;
  6196. CheckSource('TestForBoolDo',
  6197. LinesToStr([ // statements
  6198. 'this.b = false;']),
  6199. LinesToStr([ // this.$main
  6200. 'for (var $l1 = 0; $l1 <= 1; $l1++) $mod.b = $l1 !== 0;',
  6201. 'for (var $l2 = +$mod.b; $l2 >= 0; $l2--) $mod.b = $l2 !== 0;',
  6202. 'for (var $l3 = 0; $l3 <= 1; $l3++) $mod.b = $l3 !== 0;',
  6203. '']));
  6204. end;
  6205. procedure TTestModule.TestForIntDo;
  6206. begin
  6207. StartProgram(false);
  6208. Add([
  6209. 'var i: longint;',
  6210. 'begin',
  6211. ' for i:=3 to 5 do ;',
  6212. ' for i:=i downto 2 do ;',
  6213. ' for i in byte do ;',
  6214. '']);
  6215. ConvertProgram;
  6216. CheckSource('TestForIntDo',
  6217. LinesToStr([ // statements
  6218. 'this.i = 0;']),
  6219. LinesToStr([ // this.$main
  6220. 'for ($mod.i = 3; $mod.i <= 5; $mod.i++) ;',
  6221. 'for (var $l1 = $mod.i; $l1 >= 2; $l1--) $mod.i = $l1;',
  6222. 'for (var $l2 = 0; $l2 <= 255; $l2++) $mod.i = $l2;',
  6223. '']));
  6224. end;
  6225. procedure TTestModule.TestForIntInDo;
  6226. begin
  6227. StartProgram(false);
  6228. Add([
  6229. 'type',
  6230. ' TSetOfInt = set of byte;',
  6231. ' TIntRg = 3..7;',
  6232. ' TSetOfIntRg = set of TIntRg;',
  6233. 'var',
  6234. ' i,i2: longint;',
  6235. ' a1: array of byte;',
  6236. ' a2: array[1..3] of byte;',
  6237. ' soi: TSetOfInt;',
  6238. ' soir: TSetOfIntRg;',
  6239. ' ir: TIntRg;',
  6240. 'begin',
  6241. ' for i in byte do ;',
  6242. ' for i in a1 do ;',
  6243. ' for i in a2 do ;',
  6244. ' for i in [11..13] do ;',
  6245. ' for i in TSetOfInt do ;',
  6246. ' for i in TIntRg do ;',
  6247. ' for i in soi do i2:=i;',
  6248. ' for i in TSetOfIntRg do ;',
  6249. ' for i in soir do ;',
  6250. ' for ir in TIntRg do ;',
  6251. ' for ir in TSetOfIntRg do ;',
  6252. ' for ir in soir do ;',
  6253. '']);
  6254. ConvertProgram;
  6255. CheckSource('TestForIntInDo',
  6256. LinesToStr([ // statements
  6257. 'this.i = 0;',
  6258. 'this.i2 = 0;',
  6259. 'this.a1 = [];',
  6260. 'this.a2 = rtl.arraySetLength(null, 0, 3);',
  6261. 'this.soi = {};',
  6262. 'this.soir = {};',
  6263. 'this.ir = 0;',
  6264. '']),
  6265. LinesToStr([ // this.$main
  6266. 'for (var $l1 = 0; $l1 <= 255; $l1++) $mod.i = $l1;',
  6267. 'for (var $in2 = $mod.a1, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) $mod.i = $in2[$l3];',
  6268. 'for (var $in5 = $mod.a2, $l6 = 0, $end7 = rtl.length($in5) - 1; $l6 <= $end7; $l6++) $mod.i = $in5[$l6];',
  6269. 'for (var $l8 = 11; $l8 <= 13; $l8++) $mod.i = $l8;',
  6270. 'for (var $l9 = 0; $l9 <= 255; $l9++) $mod.i = $l9;',
  6271. 'for (var $l10 = 3; $l10 <= 7; $l10++) $mod.i = $l10;',
  6272. 'for (var $l11 in $mod.soi) {',
  6273. ' $mod.i = +$l11;',
  6274. ' $mod.i2 = $mod.i;',
  6275. '};',
  6276. 'for (var $l12 = 3; $l12 <= 7; $l12++) $mod.i = $l12;',
  6277. 'for (var $l13 in $mod.soir) $mod.i = +$l13;',
  6278. 'for (var $l14 = 3; $l14 <= 7; $l14++) $mod.ir = $l14;',
  6279. 'for (var $l15 = 3; $l15 <= 7; $l15++) $mod.ir = $l15;',
  6280. 'for (var $l16 in $mod.soir) $mod.ir = +$l16;',
  6281. '']));
  6282. end;
  6283. procedure TTestModule.TestCharConst;
  6284. begin
  6285. StartProgram(false);
  6286. Add([
  6287. 'const',
  6288. ' a = #$00F3;',
  6289. ' c: char = ''1'';',
  6290. 'begin',
  6291. ' c:=#0;',
  6292. ' c:=#1;',
  6293. ' c:=#9;',
  6294. ' c:=#10;',
  6295. ' c:=#13;',
  6296. ' c:=#31;',
  6297. ' c:=#32;',
  6298. ' c:=#$A;',
  6299. ' c:=#$0A;',
  6300. ' c:=#$b;',
  6301. ' c:=#$0b;',
  6302. ' c:=^A;',
  6303. ' c:=''"'';',
  6304. ' c:=default(char);',
  6305. ' c:=#$00E4;', // ä
  6306. ' c:=''ä'';',
  6307. ' c:=#$E4;', // ä
  6308. ' c:=#$D800;', // invalid UTF-16
  6309. ' c:=#$DFFF;', // invalid UTF-16
  6310. ' c:=#$FFFF;', // last UCS-2
  6311. ' c:=high(c);', // last UCS-2
  6312. '']);
  6313. ConvertProgram;
  6314. CheckSource('TestCharConst',
  6315. LinesToStr([
  6316. 'this.a="ó";',
  6317. 'this.c="1";'
  6318. ]),
  6319. LinesToStr([
  6320. '$mod.c="\x00";',
  6321. '$mod.c="\x01";',
  6322. '$mod.c="\t";',
  6323. '$mod.c="\n";',
  6324. '$mod.c="\r";',
  6325. '$mod.c="\x1F";',
  6326. '$mod.c=" ";',
  6327. '$mod.c="\n";',
  6328. '$mod.c="\n";',
  6329. '$mod.c="\x0B";',
  6330. '$mod.c="\x0B";',
  6331. '$mod.c="\x01";',
  6332. '$mod.c=''"'';',
  6333. '$mod.c="\x00";',
  6334. '$mod.c = "ä";',
  6335. '$mod.c = "ä";',
  6336. '$mod.c = "ä";',
  6337. '$mod.c="\uD800";',
  6338. '$mod.c="\uDFFF";',
  6339. '$mod.c="\uFFFF";',
  6340. '$mod.c="\uFFFF";',
  6341. '']));
  6342. end;
  6343. procedure TTestModule.TestChar_Compare;
  6344. begin
  6345. StartProgram(false);
  6346. Add('var');
  6347. Add(' c: char;');
  6348. Add(' b: boolean;');
  6349. Add('begin');
  6350. Add(' b:=c=''1'';');
  6351. Add(' b:=''2''=c;');
  6352. Add(' b:=''3''=''4'';');
  6353. Add(' b:=c<>''5'';');
  6354. Add(' b:=''6''<>c;');
  6355. Add(' b:=c>''7'';');
  6356. Add(' b:=''8''>c;');
  6357. Add(' b:=c>=''9'';');
  6358. Add(' b:=''A''>=c;');
  6359. Add(' b:=c<''B'';');
  6360. Add(' b:=''C''<c;');
  6361. Add(' b:=c<=''D'';');
  6362. Add(' b:=''E''<=c;');
  6363. ConvertProgram;
  6364. CheckSource('TestChar_Compare',
  6365. LinesToStr([
  6366. 'this.c="";',
  6367. 'this.b = false;'
  6368. ]),
  6369. LinesToStr([
  6370. '$mod.b = $mod.c === "1";',
  6371. '$mod.b = "2" === $mod.c;',
  6372. '$mod.b = "3" === "4";',
  6373. '$mod.b = $mod.c !== "5";',
  6374. '$mod.b = "6" !== $mod.c;',
  6375. '$mod.b = $mod.c > "7";',
  6376. '$mod.b = "8" > $mod.c;',
  6377. '$mod.b = $mod.c >= "9";',
  6378. '$mod.b = "A" >= $mod.c;',
  6379. '$mod.b = $mod.c < "B";',
  6380. '$mod.b = "C" < $mod.c;',
  6381. '$mod.b = $mod.c <= "D";',
  6382. '$mod.b = "E" <= $mod.c;',
  6383. '']));
  6384. end;
  6385. procedure TTestModule.TestChar_BuiltInProcs;
  6386. begin
  6387. StartProgram(false);
  6388. Add([
  6389. 'var',
  6390. ' c: char;',
  6391. ' i: longint;',
  6392. ' s: string;',
  6393. 'begin',
  6394. ' i:=ord(c);',
  6395. ' i:=ord(s[i]);',
  6396. ' c:=chr(i);',
  6397. ' c:=pred(c);',
  6398. ' c:=succ(c);',
  6399. ' c:=low(c);',
  6400. ' c:=high(c);',
  6401. ' i:=byte(c);',
  6402. ' i:=word(c);',
  6403. ' i:=longint(c);',
  6404. '']);
  6405. ConvertProgram;
  6406. CheckSource('TestChar_BuiltInProcs',
  6407. LinesToStr([
  6408. 'this.c = "";',
  6409. 'this.i = 0;',
  6410. 'this.s = "";'
  6411. ]),
  6412. LinesToStr([
  6413. '$mod.i = $mod.c.charCodeAt();',
  6414. '$mod.i = $mod.s.charCodeAt($mod.i-1);',
  6415. '$mod.c = String.fromCharCode($mod.i);',
  6416. '$mod.c = String.fromCharCode($mod.c.charCodeAt() - 1);',
  6417. '$mod.c = String.fromCharCode($mod.c.charCodeAt() + 1);',
  6418. '$mod.c = "\x00";',
  6419. '$mod.c = "\uFFFF";',
  6420. '$mod.i = $mod.c.charCodeAt() & 255;',
  6421. '$mod.i = $mod.c.charCodeAt();',
  6422. '$mod.i = $mod.c.charCodeAt() & 0xFFFFFFFF;',
  6423. '']));
  6424. end;
  6425. procedure TTestModule.TestStringConst;
  6426. begin
  6427. StartProgram(false);
  6428. Add([
  6429. '{$H+}',
  6430. 'const',
  6431. ' a = #$00F3#$017C;', // first <256, then >=256
  6432. ' b = string(''a'');',
  6433. ' c = string(''ä'');',
  6434. ' d = UnicodeString(''b'');',
  6435. ' e = UnicodeString(''ö'');',
  6436. 'var',
  6437. ' s: string = ''abc'';',
  6438. 'begin',
  6439. ' s:='''';',
  6440. ' s:=#13#10;',
  6441. ' s:=#9''foo'';',
  6442. ' s:=#$A9;',
  6443. ' s:=''foo''#13''bar'';',
  6444. ' s:=''"'';',
  6445. ' s:=''"''''"'';',
  6446. ' s:=#$20AC;', // euro
  6447. ' s:=#$10437;', // outside BMP
  6448. ' s:=default(string);',
  6449. ' s:=concat(s);',
  6450. ' s:=concat(s,''a'',s)',
  6451. '']);
  6452. ConvertProgram;
  6453. CheckSource('TestStringConst',
  6454. LinesToStr([
  6455. 'this.a = "óż";',
  6456. 'this.b = "a";',
  6457. 'this.c = "ä";',
  6458. 'this.d = "b";',
  6459. 'this.e = "ö";',
  6460. 'this.s="abc";',
  6461. '']),
  6462. LinesToStr([
  6463. '$mod.s="";',
  6464. '$mod.s="\r\n";',
  6465. '$mod.s="\tfoo";',
  6466. '$mod.s="©";',
  6467. '$mod.s="foo\rbar";',
  6468. '$mod.s=''"'';',
  6469. '$mod.s=''"\''"'';',
  6470. '$mod.s="€";',
  6471. '$mod.s="'#$F0#$90#$90#$B7'";',
  6472. '$mod.s="";',
  6473. '$mod.s = $mod.s;',
  6474. '$mod.s = $mod.s.concat("a", $mod.s);',
  6475. '']));
  6476. end;
  6477. procedure TTestModule.TestStringConstSurrogate;
  6478. begin
  6479. StartProgram(false);
  6480. Add([
  6481. 'var',
  6482. ' s: string;',
  6483. 'begin',
  6484. ' s:=''😊'';', // 1F60A
  6485. '']);
  6486. ConvertProgram;
  6487. CheckSource('TestStringConstSurrogate',
  6488. LinesToStr([
  6489. 'this.s="";'
  6490. ]),
  6491. LinesToStr([
  6492. '$mod.s="😊";'
  6493. ]));
  6494. end;
  6495. procedure TTestModule.TestString_Length;
  6496. begin
  6497. StartProgram(false);
  6498. Add('const c = ''foo'';');
  6499. Add('var');
  6500. Add(' s: string;');
  6501. Add(' i: longint;');
  6502. Add('begin');
  6503. Add(' i:=length(s);');
  6504. Add(' i:=length(s+s);');
  6505. Add(' i:=length(''abc'');');
  6506. Add(' i:=length(c);');
  6507. ConvertProgram;
  6508. CheckSource('TestString_Length',
  6509. LinesToStr([
  6510. 'this.c = "foo";',
  6511. 'this.s = "";',
  6512. 'this.i = 0;',
  6513. '']),
  6514. LinesToStr([
  6515. '$mod.i = $mod.s.length;',
  6516. '$mod.i = ($mod.s+$mod.s).length;',
  6517. '$mod.i = "abc".length;',
  6518. '$mod.i = $mod.c.length;',
  6519. '']));
  6520. end;
  6521. procedure TTestModule.TestString_Compare;
  6522. begin
  6523. StartProgram(false);
  6524. Add('var');
  6525. Add(' s, t: string;');
  6526. Add(' b: boolean;');
  6527. Add('begin');
  6528. Add(' b:=s=t;');
  6529. Add(' b:=s<>t;');
  6530. Add(' b:=s>t;');
  6531. Add(' b:=s>=t;');
  6532. Add(' b:=s<t;');
  6533. Add(' b:=s<=t;');
  6534. ConvertProgram;
  6535. CheckSource('TestString_Compare',
  6536. LinesToStr([ // statements
  6537. 'this.s = "";',
  6538. 'this.t = "";',
  6539. 'this.b =false;'
  6540. ]),
  6541. LinesToStr([ // this.$main
  6542. '$mod.b = $mod.s === $mod.t;',
  6543. '$mod.b = $mod.s !== $mod.t;',
  6544. '$mod.b = $mod.s > $mod.t;',
  6545. '$mod.b = $mod.s >= $mod.t;',
  6546. '$mod.b = $mod.s < $mod.t;',
  6547. '$mod.b = $mod.s <= $mod.t;',
  6548. '']));
  6549. end;
  6550. procedure TTestModule.TestString_SetLength;
  6551. begin
  6552. StartProgram(false);
  6553. Add([
  6554. 'procedure DoIt(var s: string);',
  6555. 'begin',
  6556. ' SetLength(s,2);',
  6557. 'end;',
  6558. 'var s: string;',
  6559. 'begin',
  6560. ' SetLength(s,3);',
  6561. '']);
  6562. ConvertProgram;
  6563. CheckSource('TestString_SetLength',
  6564. LinesToStr([ // statements
  6565. 'this.DoIt = function (s) {',
  6566. ' s.set(rtl.strSetLength(s.get(), 2));',
  6567. '};',
  6568. 'this.s = "";',
  6569. '']),
  6570. LinesToStr([ // this.$main
  6571. '$mod.s = rtl.strSetLength($mod.s, 3);'
  6572. ]));
  6573. end;
  6574. procedure TTestModule.TestString_CharAt;
  6575. begin
  6576. StartProgram(false);
  6577. Add([
  6578. 'var',
  6579. ' s: string;',
  6580. ' c: char;',
  6581. ' b: boolean;',
  6582. 'begin',
  6583. ' b:= s[1] = c;',
  6584. ' b:= c = s[1];',
  6585. ' b:= c <> s[1];',
  6586. ' b:= c > s[1];',
  6587. ' b:= c >= s[1];',
  6588. ' b:= c < s[2];',
  6589. ' b:= c <= s[1];',
  6590. ' s[1] := c;',
  6591. ' s[2+3] := c;']);
  6592. ConvertProgram;
  6593. CheckSource('TestString_CharAt',
  6594. LinesToStr([ // statements
  6595. 'this.s = "";',
  6596. 'this.c = "";',
  6597. 'this.b = false;'
  6598. ]),
  6599. LinesToStr([ // this.$main
  6600. '$mod.b = $mod.s.charAt(0) === $mod.c;',
  6601. '$mod.b = $mod.c === $mod.s.charAt(0);',
  6602. '$mod.b = $mod.c !== $mod.s.charAt(0);',
  6603. '$mod.b = $mod.c > $mod.s.charAt(0);',
  6604. '$mod.b = $mod.c >= $mod.s.charAt(0);',
  6605. '$mod.b = $mod.c < $mod.s.charAt(1);',
  6606. '$mod.b = $mod.c <= $mod.s.charAt(0);',
  6607. '$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
  6608. '$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
  6609. '']));
  6610. end;
  6611. procedure TTestModule.TestStringHMinusFail;
  6612. begin
  6613. StartProgram(false);
  6614. Add([
  6615. '{$H-}',
  6616. 'var s: string;',
  6617. 'begin']);
  6618. ConvertProgram;
  6619. CheckHint(mtWarning,nWarnIllegalCompilerDirectiveX,'Warning: test1.pp(3,6) : Illegal compiler directive "H-"');
  6620. end;
  6621. procedure TTestModule.TestStr;
  6622. begin
  6623. StartProgram(false);
  6624. Add('var');
  6625. Add(' b: boolean;');
  6626. Add(' i: longint;');
  6627. Add(' d: double;');
  6628. Add(' s: string;');
  6629. Add('begin');
  6630. Add(' str(b,s);');
  6631. Add(' str(i,s);');
  6632. Add(' str(d,s);');
  6633. Add(' str(i:3,s);');
  6634. Add(' str(d:3:2,s);');
  6635. Add(' Str(12.456:12:1,s);');
  6636. Add(' Str(12.456:12,s);');
  6637. Add(' s:=str(b);');
  6638. Add(' s:=str(i);');
  6639. Add(' s:=str(d);');
  6640. Add(' s:=str(i,i);');
  6641. Add(' s:=str(i:3);');
  6642. Add(' s:=str(d:3:2);');
  6643. Add(' s:=str(i:4,i);');
  6644. Add(' s:=str(i,i:5);');
  6645. Add(' s:=str(i:4,i:5);');
  6646. Add(' s:=str(s,s);');
  6647. Add(' s:=str(s,''foo'');');
  6648. ConvertProgram;
  6649. CheckSource('TestStr',
  6650. LinesToStr([ // statements
  6651. 'this.b = false;',
  6652. 'this.i = 0;',
  6653. 'this.d = 0.0;',
  6654. 'this.s = "";',
  6655. '']),
  6656. LinesToStr([ // this.$main
  6657. '$mod.s = ""+$mod.b;',
  6658. '$mod.s = ""+$mod.i;',
  6659. '$mod.s = rtl.floatToStr($mod.d);',
  6660. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  6661. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  6662. '$mod.s = rtl.floatToStr(12.456,12,1);',
  6663. '$mod.s = rtl.floatToStr(12.456,12);',
  6664. '$mod.s = ""+$mod.b;',
  6665. '$mod.s = ""+$mod.i;',
  6666. '$mod.s = rtl.floatToStr($mod.d);',
  6667. '$mod.s = ""+$mod.i+$mod.i;',
  6668. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  6669. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  6670. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
  6671. '$mod.s = "" + $mod.i + rtl.spaceLeft("" + $mod.i, 5);',
  6672. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
  6673. '$mod.s = $mod.s + $mod.s;',
  6674. '$mod.s = $mod.s + "foo";',
  6675. '']));
  6676. end;
  6677. procedure TTestModule.TestBaseType_AnsiStringFail;
  6678. begin
  6679. StartProgram(false);
  6680. Add('var s: AnsiString');
  6681. SetExpectedPasResolverError('identifier not found "AnsiString"',PasResolveEval.nIdentifierNotFound);
  6682. ConvertProgram;
  6683. end;
  6684. procedure TTestModule.TestBaseType_WideStringFail;
  6685. begin
  6686. StartProgram(false);
  6687. Add('var s: WideString');
  6688. SetExpectedPasResolverError('identifier not found "WideString"',PasResolveEval.nIdentifierNotFound);
  6689. ConvertProgram;
  6690. end;
  6691. procedure TTestModule.TestBaseType_ShortStringFail;
  6692. begin
  6693. StartProgram(false);
  6694. Add('var s: ShortString');
  6695. SetExpectedPasResolverError('identifier not found "ShortString"',PasResolveEval.nIdentifierNotFound);
  6696. ConvertProgram;
  6697. end;
  6698. procedure TTestModule.TestBaseType_RawByteStringFail;
  6699. begin
  6700. StartProgram(false);
  6701. Add('var s: RawByteString');
  6702. SetExpectedPasResolverError('identifier not found "RawByteString"',PasResolveEval.nIdentifierNotFound);
  6703. ConvertProgram;
  6704. end;
  6705. procedure TTestModule.TestTypeShortstring_Fail;
  6706. begin
  6707. StartProgram(false);
  6708. Add('type t = string[12];');
  6709. Add('var s: t;');
  6710. Add('begin');
  6711. SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
  6712. ConvertProgram;
  6713. end;
  6714. procedure TTestModule.TestCharSet_Custom;
  6715. begin
  6716. StartProgram(false);
  6717. Add([
  6718. 'type',
  6719. ' TCharRg = ''a''..''z'';',
  6720. ' TSetOfCharRg = set of TCharRg;',
  6721. ' TCharRg2 = ''m''..''p'';',
  6722. 'const',
  6723. ' crg: TCharRg = ''b'';',
  6724. 'var',
  6725. ' c: char;',
  6726. ' crg2: TCharRg2;',
  6727. ' s: TSetOfCharRg;',
  6728. 'begin',
  6729. ' c:=crg;',
  6730. ' crg:=c;',
  6731. ' crg2:=crg;',
  6732. ' if c=crg then ;',
  6733. ' if crg=c then ;',
  6734. ' if crg=crg2 then ;',
  6735. ' if c in s then ;',
  6736. ' if crg2 in s then ;',
  6737. ' c:=default(TCharRg);',
  6738. '']);
  6739. ConvertProgram;
  6740. CheckSource('TestCharSet_Custom',
  6741. LinesToStr([ // statements
  6742. 'this.crg = "b";',
  6743. 'this.c = "";',
  6744. 'this.crg2 = "m";',
  6745. 'this.s = {};',
  6746. '']),
  6747. LinesToStr([ // this.$main
  6748. '$mod.c = $mod.crg;',
  6749. '$mod.crg = $mod.c;',
  6750. '$mod.crg2 = $mod.crg;',
  6751. 'if ($mod.c === $mod.crg) ;',
  6752. 'if ($mod.crg === $mod.c) ;',
  6753. 'if ($mod.crg === $mod.crg2) ;',
  6754. 'if ($mod.c.charCodeAt() in $mod.s) ;',
  6755. 'if ($mod.crg2.charCodeAt() in $mod.s) ;',
  6756. '$mod.c = "a";',
  6757. '']));
  6758. end;
  6759. procedure TTestModule.TestForCharDo;
  6760. begin
  6761. StartProgram(false);
  6762. Add([
  6763. 'var c: char;',
  6764. 'begin',
  6765. ' for c:=''a'' to ''c'' do ;',
  6766. ' for c:=c downto ''a'' do ;',
  6767. ' for c:=''Б'' to ''Я'' do ;',
  6768. '']);
  6769. ConvertProgram;
  6770. CheckSource('TestForCharDo',
  6771. LinesToStr([ // statements
  6772. 'this.c = "";']),
  6773. LinesToStr([ // this.$main
  6774. 'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
  6775. 'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $l2--) $mod.c = String.fromCharCode($l2);',
  6776. 'for (var $l3 = 1041; $l3 <= 1071; $l3++) $mod.c = String.fromCharCode($l3);',
  6777. '']));
  6778. end;
  6779. procedure TTestModule.TestForCharInDo;
  6780. begin
  6781. StartProgram(false);
  6782. Add([
  6783. 'type',
  6784. ' TSetOfChar = set of char;',
  6785. ' TCharRg = ''a''..''z'';',
  6786. ' TSetOfCharRg = set of TCharRg;',
  6787. 'const Foo = ''foo'';',
  6788. 'var',
  6789. ' c,c2: char;',
  6790. ' s: string;',
  6791. ' a1: array of char;',
  6792. ' a2: array[1..3] of char;',
  6793. ' soc: TSetOfChar;',
  6794. ' socr: TSetOfCharRg;',
  6795. ' cr: TCharRg;',
  6796. 'begin',
  6797. ' for c in foo do ;',
  6798. ' for c in s do ;',
  6799. ' for c in char do ;',
  6800. ' for c in a1 do ;',
  6801. ' for c in a2 do ;',
  6802. ' for c in [''1''..''3''] do ;',
  6803. ' for c in TSetOfChar do ;',
  6804. ' for c in TCharRg do ;',
  6805. ' for c in soc do c2:=c;',
  6806. ' for c in TSetOfCharRg do ;',
  6807. ' for c in socr do ;',
  6808. ' for cr in TCharRg do ;',
  6809. ' for cr in TSetOfCharRg do ;',
  6810. ' for cr in socr do ;',
  6811. '']);
  6812. ConvertProgram;
  6813. CheckSource('TestForCharInDo',
  6814. LinesToStr([ // statements
  6815. 'this.Foo = "foo";',
  6816. 'this.c = "";',
  6817. 'this.c2 = "";',
  6818. 'this.s = "";',
  6819. 'this.a1 = [];',
  6820. 'this.a2 = rtl.arraySetLength(null, "", 3);',
  6821. 'this.soc = {};',
  6822. 'this.socr = {};',
  6823. 'this.cr = "a";',
  6824. '']),
  6825. LinesToStr([ // this.$main
  6826. 'for (var $in1 = $mod.Foo, $l2 = 0, $end3 = $in1.length - 1; $l2 <= $end3; $l2++) $mod.c = $in1.charAt($l2);',
  6827. 'for (var $in4 = $mod.s, $l5 = 0, $end6 = $in4.length - 1; $l5 <= $end6; $l5++) $mod.c = $in4.charAt($l5);',
  6828. 'for (var $l7 = 0; $l7 <= 65535; $l7++) $mod.c = String.fromCharCode($l7);',
  6829. 'for (var $in8 = $mod.a1, $l9 = 0, $end10 = rtl.length($in8) - 1; $l9 <= $end10; $l9++) $mod.c = $in8[$l9];',
  6830. 'for (var $in11 = $mod.a2, $l12 = 0, $end13 = rtl.length($in11) - 1; $l12 <= $end13; $l12++) $mod.c = $in11[$l12];',
  6831. 'for (var $l14 = 49; $l14 <= 51; $l14++) $mod.c = String.fromCharCode($l14);',
  6832. 'for (var $l15 = 0; $l15 <= 65535; $l15++) $mod.c = String.fromCharCode($l15);',
  6833. 'for (var $l16 = 97; $l16 <= 122; $l16++) $mod.c = String.fromCharCode($l16);',
  6834. 'for (var $l17 in $mod.soc) {',
  6835. ' $mod.c = String.fromCharCode($l17);',
  6836. ' $mod.c2 = $mod.c;',
  6837. '};',
  6838. 'for (var $l18 = 97; $l18 <= 122; $l18++) $mod.c = String.fromCharCode($l18);',
  6839. 'for (var $l19 in $mod.socr) $mod.c = String.fromCharCode($l19);',
  6840. 'for (var $l20 = 97; $l20 <= 122; $l20++) $mod.cr = String.fromCharCode($l20);',
  6841. 'for (var $l21 = 97; $l21 <= 122; $l21++) $mod.cr = String.fromCharCode($l21);',
  6842. 'for (var $l22 in $mod.socr) $mod.cr = String.fromCharCode($l22);',
  6843. '']));
  6844. end;
  6845. procedure TTestModule.TestProcTwoArgs;
  6846. begin
  6847. StartProgram(false);
  6848. Add('procedure Test(a,b: longint);');
  6849. Add('begin');
  6850. Add('end;');
  6851. Add('begin');
  6852. ConvertProgram;
  6853. CheckSource('TestProcTwoArgs',
  6854. LinesToStr([ // statements
  6855. 'this.Test = function (a,b) {',
  6856. '};'
  6857. ]),
  6858. LinesToStr([ // this.$main
  6859. ''
  6860. ]));
  6861. end;
  6862. procedure TTestModule.TestProc_DefaultValue;
  6863. begin
  6864. StartProgram(false);
  6865. Add('procedure p1(i: longint = 1);');
  6866. Add('begin');
  6867. Add('end;');
  6868. Add('procedure p2(i: longint = 1; c: char = ''a'');');
  6869. Add('begin');
  6870. Add('end;');
  6871. Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');');
  6872. Add('begin');
  6873. Add('end;');
  6874. Add('begin');
  6875. Add(' p1;');
  6876. Add(' p1();');
  6877. Add(' p1(11);');
  6878. Add(' p2;');
  6879. Add(' p2();');
  6880. Add(' p2(12);');
  6881. Add(' p2(13,''b'');');
  6882. Add(' p3();');
  6883. ConvertProgram;
  6884. CheckSource('TestProc_DefaultValue',
  6885. LinesToStr([ // statements
  6886. 'this.p1 = function (i) {',
  6887. '};',
  6888. 'this.p2 = function (i,c) {',
  6889. '};',
  6890. 'this.p3 = function (d,b,s) {',
  6891. '};'
  6892. ]),
  6893. LinesToStr([ // this.$main
  6894. ' $mod.p1(1);',
  6895. ' $mod.p1(1);',
  6896. ' $mod.p1(11);',
  6897. ' $mod.p2(1,"a");',
  6898. ' $mod.p2(1,"a");',
  6899. ' $mod.p2(12,"a");',
  6900. ' $mod.p2(13,"b");',
  6901. ' $mod.p3(1.0,false,"abc");'
  6902. ]));
  6903. end;
  6904. procedure TTestModule.TestFunctionInt;
  6905. begin
  6906. StartProgram(false);
  6907. Add('function MyTest(Bar: longint): longint;');
  6908. Add('begin');
  6909. Add(' Result:=2*bar');
  6910. Add('end;');
  6911. Add('begin');
  6912. ConvertProgram;
  6913. CheckSource('TestFunctionInt',
  6914. LinesToStr([ // statements
  6915. 'this.MyTest = function (Bar) {',
  6916. ' var Result = 0;',
  6917. ' Result = 2*Bar;',
  6918. ' return Result;',
  6919. '};'
  6920. ]),
  6921. LinesToStr([ // this.$main
  6922. ''
  6923. ]));
  6924. end;
  6925. procedure TTestModule.TestFunctionString;
  6926. begin
  6927. StartProgram(false);
  6928. Add('function Test(Bar: string): string;');
  6929. Add('begin');
  6930. Add(' Result:=bar+BAR');
  6931. Add('end;');
  6932. Add('begin');
  6933. ConvertProgram;
  6934. CheckSource('TestFunctionString',
  6935. LinesToStr([ // statements
  6936. 'this.Test = function (Bar) {',
  6937. ' var Result = "";',
  6938. ' Result = Bar+Bar;',
  6939. ' return Result;',
  6940. '};'
  6941. ]),
  6942. LinesToStr([ // this.$main
  6943. ''
  6944. ]));
  6945. end;
  6946. procedure TTestModule.TestIfThen;
  6947. begin
  6948. StartProgram(false);
  6949. Add([
  6950. 'var b: boolean;',
  6951. 'begin',
  6952. ' if b then ;',
  6953. ' if b then else ;']);
  6954. ConvertProgram;
  6955. CheckSource('TestIfThen',
  6956. LinesToStr([ // statements
  6957. 'this.b = false;',
  6958. '']),
  6959. LinesToStr([ // this.$main
  6960. 'if ($mod.b) ;',
  6961. 'if ($mod.b) ;',
  6962. '']));
  6963. end;
  6964. procedure TTestModule.TestForLoop;
  6965. begin
  6966. StartProgram(false);
  6967. Add('var');
  6968. Add(' vI, vJ, vN: longint;');
  6969. Add('begin');
  6970. Add(' VJ:=0;');
  6971. Add(' VN:=3;');
  6972. Add(' for VI:=1 to VN do');
  6973. Add(' begin');
  6974. Add(' VJ:=VJ+VI;');
  6975. Add(' end;');
  6976. ConvertProgram;
  6977. CheckSource('TestForLoop',
  6978. LinesToStr([ // statements
  6979. 'this.vI = 0;',
  6980. 'this.vJ = 0;',
  6981. 'this.vN = 0;'
  6982. ]),
  6983. LinesToStr([ // this.$main
  6984. ' $mod.vJ = 0;',
  6985. ' $mod.vN = 3;',
  6986. ' for (var $l1 = 1, $end2 = $mod.vN; $l1 <= $end2; $l1++) {',
  6987. ' $mod.vI = $l1;',
  6988. ' $mod.vJ = $mod.vJ + $mod.vI;',
  6989. ' };',
  6990. '']));
  6991. end;
  6992. procedure TTestModule.TestForLoopInsideFunction;
  6993. begin
  6994. StartProgram(false);
  6995. Add('function SumNumbers(Count: longint): longint;');
  6996. Add('var');
  6997. Add(' vI, vJ: longint;');
  6998. Add('begin');
  6999. Add(' vj:=0;');
  7000. Add(' for vi:=1 to count do');
  7001. Add(' begin');
  7002. Add(' vj:=vj+vi;');
  7003. Add(' end;');
  7004. Add('end;');
  7005. Add('begin');
  7006. Add(' sumnumbers(3);');
  7007. ConvertProgram;
  7008. CheckSource('TestForLoopInsideFunction',
  7009. LinesToStr([ // statements
  7010. 'this.SumNumbers = function (Count) {',
  7011. ' var Result = 0;',
  7012. ' var vI = 0;',
  7013. ' var vJ = 0;',
  7014. ' vJ = 0;',
  7015. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  7016. ' vI = $l1;',
  7017. ' vJ = vJ + vI;',
  7018. ' };',
  7019. ' return Result;',
  7020. '};'
  7021. ]),
  7022. LinesToStr([ // $mod.$main
  7023. ' $mod.SumNumbers(3);'
  7024. ]));
  7025. end;
  7026. procedure TTestModule.TestForLoop_ReadVarAfter;
  7027. begin
  7028. StartProgram(false);
  7029. Add('var');
  7030. Add(' vI: longint;');
  7031. Add('begin');
  7032. Add(' for vi:=1 to 2 do ;');
  7033. Add(' if vi=3 then ;');
  7034. ConvertProgram;
  7035. CheckSource('TestForLoop',
  7036. LinesToStr([ // statements
  7037. 'this.vI = 0;'
  7038. ]),
  7039. LinesToStr([ // this.$main
  7040. ' for ($mod.vI = 1; $mod.vI <= 2; $mod.vI++) ;',
  7041. ' if ($mod.vI===3) ;'
  7042. ]));
  7043. end;
  7044. procedure TTestModule.TestForLoop_Nested;
  7045. begin
  7046. StartProgram(false);
  7047. Add('function SumNumbers(Count: longint): longint;');
  7048. Add('var');
  7049. Add(' vI, vJ, vK: longint;');
  7050. Add('begin');
  7051. Add(' VK:=0;');
  7052. Add(' for VI:=1 to count do');
  7053. Add(' begin');
  7054. Add(' for vj:=1 to vi do');
  7055. Add(' begin');
  7056. Add(' vk:=VK+VI;');
  7057. Add(' end;');
  7058. Add(' end;');
  7059. Add('end;');
  7060. Add('begin');
  7061. Add(' sumnumbers(3);');
  7062. ConvertProgram;
  7063. CheckSource('TestForLoopInFunction',
  7064. LinesToStr([ // statements
  7065. 'this.SumNumbers = function (Count) {',
  7066. ' var Result = 0;',
  7067. ' var vI = 0;',
  7068. ' var vJ = 0;',
  7069. ' var vK = 0;',
  7070. ' vK = 0;',
  7071. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  7072. ' vI = $l1;',
  7073. ' for (var $l3 = 1, $end4 = vI; $l3 <= $end4; $l3++) {',
  7074. ' vJ = $l3;',
  7075. ' vK = vK + vI;',
  7076. ' };',
  7077. ' };',
  7078. ' return Result;',
  7079. '};'
  7080. ]),
  7081. LinesToStr([ // $mod.$main
  7082. ' $mod.SumNumbers(3);'
  7083. ]));
  7084. end;
  7085. procedure TTestModule.TestRepeatUntil;
  7086. begin
  7087. StartProgram(false);
  7088. Add('var');
  7089. Add(' vI, vJ, vN: longint;');
  7090. Add('begin');
  7091. Add(' vn:=3;');
  7092. Add(' vj:=0;');
  7093. Add(' VI:=0;');
  7094. Add(' repeat');
  7095. Add(' VI:=vi+1;');
  7096. Add(' vj:=VJ+vI;');
  7097. Add(' until vi>=vn');
  7098. ConvertProgram;
  7099. CheckSource('TestRepeatUntil',
  7100. LinesToStr([ // statements
  7101. 'this.vI = 0;',
  7102. 'this.vJ = 0;',
  7103. 'this.vN = 0;'
  7104. ]),
  7105. LinesToStr([ // $mod.$main
  7106. ' $mod.vN = 3;',
  7107. ' $mod.vJ = 0;',
  7108. ' $mod.vI = 0;',
  7109. ' do{',
  7110. ' $mod.vI = $mod.vI + 1;',
  7111. ' $mod.vJ = $mod.vJ + $mod.vI;',
  7112. ' }while(!($mod.vI>=$mod.vN));'
  7113. ]));
  7114. end;
  7115. procedure TTestModule.TestAsmBlock;
  7116. begin
  7117. StartProgram(false);
  7118. Add([
  7119. 'var',
  7120. ' vI: longint;',
  7121. 'begin',
  7122. ' vi:=1;',
  7123. ' asm',
  7124. ' if (vI===1) {',
  7125. ' vI=2;',
  7126. //' console.log(''end;'');', ToDo
  7127. ' }',
  7128. ' if (vI===2){ vI=3; }',
  7129. ' end;',
  7130. ' VI:=4;']);
  7131. ConvertProgram;
  7132. CheckSource('TestAsmBlock',
  7133. LinesToStr([ // statements
  7134. 'this.vI = 0;'
  7135. ]),
  7136. LinesToStr([ // $mod.$main
  7137. '$mod.vI = 1;',
  7138. 'if (vI===1) {',
  7139. ' vI=2;',
  7140. '}',
  7141. 'if (vI===2){ vI=3; }',
  7142. ';',
  7143. '$mod.vI = 4;'
  7144. ]));
  7145. end;
  7146. procedure TTestModule.TestAsmPas_Impl;
  7147. begin
  7148. StartUnit(false);
  7149. Add('interface');
  7150. Add('const cIntf: longint = 1;');
  7151. Add('var vIntf: longint;');
  7152. Add('implementation');
  7153. Add('const cImpl: longint = 2;');
  7154. Add('var vImpl: longint;');
  7155. Add('procedure DoIt;');
  7156. Add('const cLoc: longint = 3;');
  7157. Add('var vLoc: longint;');
  7158. Add('begin;');
  7159. Add(' asm');
  7160. //Add(' pas(vIntf)=pas(cIntf);');
  7161. //Add(' pas(vImpl)=pas(cImpl);');
  7162. //Add(' pas(vLoc)=pas(cLoc);');
  7163. Add(' end;');
  7164. Add('end;');
  7165. ConvertUnit;
  7166. CheckSource('TestAsmPas_Impl',
  7167. LinesToStr([
  7168. 'var $impl = $mod.$impl;',
  7169. 'this.cIntf = 1;',
  7170. 'this.vIntf = 0;',
  7171. '']),
  7172. '', // this.$init
  7173. LinesToStr([ // implementation
  7174. '$impl.cImpl = 2;',
  7175. '$impl.vImpl = 0;',
  7176. 'var cLoc = 3;',
  7177. '$impl.DoIt = function () {',
  7178. ' var vLoc = 0;',
  7179. '};',
  7180. '']) );
  7181. end;
  7182. procedure TTestModule.TestTryFinally;
  7183. begin
  7184. StartProgram(false);
  7185. Add('var i: longint;');
  7186. Add('begin');
  7187. Add(' try');
  7188. Add(' i:=0; i:=2 div i;');
  7189. Add(' finally');
  7190. Add(' i:=3');
  7191. Add(' end;');
  7192. ConvertProgram;
  7193. CheckSource('TestTryFinally',
  7194. LinesToStr([ // statements
  7195. 'this.i = 0;'
  7196. ]),
  7197. LinesToStr([ // $mod.$main
  7198. 'try {',
  7199. ' $mod.i = 0;',
  7200. ' $mod.i = Math.floor(2 / $mod.i);',
  7201. '} finally {',
  7202. ' $mod.i = 3;',
  7203. '};'
  7204. ]));
  7205. end;
  7206. procedure TTestModule.TestTryExcept;
  7207. begin
  7208. StartProgram(false);
  7209. Add('type');
  7210. Add(' TObject = class end;');
  7211. Add(' Exception = class Msg: string; end;');
  7212. Add(' EInvalidCast = class(Exception) end;');
  7213. Add('var vI: longint;');
  7214. Add('begin');
  7215. Add(' try');
  7216. Add(' vi:=1;');
  7217. Add(' except');
  7218. Add(' vi:=2');
  7219. Add(' end;');
  7220. Add(' try');
  7221. Add(' vi:=3;');
  7222. Add(' except');
  7223. Add(' raise;');
  7224. Add(' end;');
  7225. Add(' try');
  7226. Add(' VI:=4;');
  7227. Add(' except');
  7228. Add(' on einvalidcast do');
  7229. Add(' raise;');
  7230. Add(' on E: exception do');
  7231. Add(' if e.msg='''' then');
  7232. Add(' raise e;');
  7233. Add(' else');
  7234. Add(' vi:=5');
  7235. Add(' end;');
  7236. Add(' try');
  7237. Add(' VI:=6;');
  7238. Add(' except');
  7239. Add(' on einvalidcast do ;');
  7240. Add(' end;');
  7241. ConvertProgram;
  7242. CheckSource('TestTryExcept',
  7243. LinesToStr([ // statements
  7244. 'rtl.createClass($mod, "TObject", null, function () {',
  7245. ' this.$init = function () {',
  7246. ' };',
  7247. ' this.$final = function () {',
  7248. ' };',
  7249. '});',
  7250. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  7251. ' this.$init = function () {',
  7252. ' $mod.TObject.$init.call(this);',
  7253. ' this.Msg = "";',
  7254. ' };',
  7255. '});',
  7256. 'rtl.createClass($mod, "EInvalidCast", $mod.Exception, function () {',
  7257. '});',
  7258. 'this.vI = 0;'
  7259. ]),
  7260. LinesToStr([ // $mod.$main
  7261. 'try {',
  7262. ' $mod.vI = 1;',
  7263. '} catch ($e) {',
  7264. ' $mod.vI = 2;',
  7265. '};',
  7266. 'try {',
  7267. ' $mod.vI = 3;',
  7268. '} catch ($e) {',
  7269. ' throw $e;',
  7270. '};',
  7271. 'try {',
  7272. ' $mod.vI = 4;',
  7273. '} catch ($e) {',
  7274. ' if ($mod.EInvalidCast.isPrototypeOf($e)){',
  7275. ' throw $e',
  7276. ' } else if ($mod.Exception.isPrototypeOf($e)) {',
  7277. ' var E = $e;',
  7278. ' if (E.Msg === "") throw E;',
  7279. ' } else {',
  7280. ' $mod.vI = 5;',
  7281. ' }',
  7282. '};',
  7283. 'try {',
  7284. ' $mod.vI = 6;',
  7285. '} catch ($e) {',
  7286. ' if ($mod.EInvalidCast.isPrototypeOf($e)){' ,
  7287. ' } else throw $e',
  7288. '};',
  7289. '']));
  7290. end;
  7291. procedure TTestModule.TestTryExcept_ReservedWords;
  7292. begin
  7293. StartProgram(false);
  7294. Add([
  7295. 'type',
  7296. ' TObject = class end;',
  7297. ' Exception = class',
  7298. ' Symbol: string;',
  7299. ' end;',
  7300. 'var &try: longint;',
  7301. 'begin',
  7302. ' try',
  7303. ' &try:=4;',
  7304. ' except',
  7305. ' on Error: exception do',
  7306. ' if errOR.symBol='''' then',
  7307. ' raise ERRor;',
  7308. ' end;',
  7309. '']);
  7310. ConvertProgram;
  7311. CheckSource('TestTryExcept_ReservedWords',
  7312. LinesToStr([ // statements
  7313. 'rtl.createClass($mod, "TObject", null, function () {',
  7314. ' this.$init = function () {',
  7315. ' };',
  7316. ' this.$final = function () {',
  7317. ' };',
  7318. '});',
  7319. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  7320. ' this.$init = function () {',
  7321. ' $mod.TObject.$init.call(this);',
  7322. ' this.Symbol = "";',
  7323. ' };',
  7324. '});',
  7325. 'this.Try = 0;',
  7326. '']),
  7327. LinesToStr([ // $mod.$main
  7328. 'try {',
  7329. ' $mod.Try = 4;',
  7330. '} catch ($e) {',
  7331. ' if ($mod.Exception.isPrototypeOf($e)) {',
  7332. ' var error = $e;',
  7333. ' if (error.Symbol === "") throw error;',
  7334. ' } else throw $e',
  7335. '};',
  7336. '']));
  7337. end;
  7338. procedure TTestModule.TestIfThenRaiseElse;
  7339. begin
  7340. StartProgram(false);
  7341. Add([
  7342. 'type',
  7343. ' TObject = class',
  7344. ' constructor Create;',
  7345. ' end;',
  7346. 'constructor TObject.Create;',
  7347. 'begin',
  7348. 'end;',
  7349. 'var b: boolean;',
  7350. 'begin',
  7351. ' if b then',
  7352. ' raise TObject.Create',
  7353. ' else',
  7354. ' b:=false;',
  7355. '']);
  7356. ConvertProgram;
  7357. CheckSource('TestIfThenRaiseElse',
  7358. LinesToStr([ // statements
  7359. 'rtl.createClass($mod, "TObject", null, function () {',
  7360. ' this.$init = function () {',
  7361. ' };',
  7362. ' this.$final = function () {',
  7363. ' };',
  7364. ' this.Create = function () {',
  7365. ' return this;',
  7366. ' };',
  7367. '});',
  7368. 'this.b = false;',
  7369. '']),
  7370. LinesToStr([ // $mod.$main
  7371. 'if ($mod.b) {',
  7372. ' throw $mod.TObject.$create("Create")}',
  7373. ' else $mod.b = false;',
  7374. '']));
  7375. end;
  7376. procedure TTestModule.TestCaseOf;
  7377. begin
  7378. StartProgram(false);
  7379. Add([
  7380. 'const e: longint; external name ''$e'';',
  7381. 'var vI: longint;',
  7382. 'begin',
  7383. ' case vi of',
  7384. ' 1: ;',
  7385. ' 2: vi:=3;',
  7386. ' e: ;',
  7387. ' else',
  7388. ' VI:=4',
  7389. ' end;']);
  7390. ConvertProgram;
  7391. CheckSource('TestCaseOf',
  7392. LinesToStr([ // statements
  7393. 'this.vI = 0;'
  7394. ]),
  7395. LinesToStr([ // $mod.$main
  7396. 'var $tmp1 = $mod.vI;',
  7397. 'if ($tmp1 === 1) {}',
  7398. 'else if ($tmp1 === 2) {',
  7399. ' $mod.vI = 3}',
  7400. ' else if ($tmp1 === $e) {}',
  7401. 'else {',
  7402. ' $mod.vI = 4;',
  7403. '};'
  7404. ]));
  7405. end;
  7406. procedure TTestModule.TestCaseOf_UseSwitch;
  7407. begin
  7408. StartProgram(false);
  7409. Converter.UseSwitchStatement:=true;
  7410. Add('var Vi: longint;');
  7411. Add('begin');
  7412. Add(' case vi of');
  7413. Add(' 1: ;');
  7414. Add(' 2: VI:=3;');
  7415. Add(' else');
  7416. Add(' vi:=4');
  7417. Add(' end;');
  7418. ConvertProgram;
  7419. CheckSource('TestCaseOf_UseSwitch',
  7420. LinesToStr([ // statements
  7421. 'this.Vi = 0;'
  7422. ]),
  7423. LinesToStr([ // $mod.$main
  7424. 'switch ($mod.Vi) {',
  7425. 'case 1:',
  7426. ' break;',
  7427. 'case 2:',
  7428. ' $mod.Vi = 3;',
  7429. ' break;',
  7430. 'default:',
  7431. ' $mod.Vi = 4;',
  7432. '};'
  7433. ]));
  7434. end;
  7435. procedure TTestModule.TestCaseOfNoElse;
  7436. begin
  7437. StartProgram(false);
  7438. Add('var Vi: longint;');
  7439. Add('begin');
  7440. Add(' case vi of');
  7441. Add(' 1: begin vi:=2; VI:=3; end;');
  7442. Add(' end;');
  7443. ConvertProgram;
  7444. CheckSource('TestCaseOfNoElse',
  7445. LinesToStr([ // statements
  7446. 'this.Vi = 0;'
  7447. ]),
  7448. LinesToStr([ // $mod.$main
  7449. 'var $tmp1 = $mod.Vi;',
  7450. 'if ($tmp1 === 1) {',
  7451. ' $mod.Vi = 2;',
  7452. ' $mod.Vi = 3;',
  7453. '};'
  7454. ]));
  7455. end;
  7456. procedure TTestModule.TestCaseOfNoElse_UseSwitch;
  7457. begin
  7458. StartProgram(false);
  7459. Converter.UseSwitchStatement:=true;
  7460. Add('var vI: longint;');
  7461. Add('begin');
  7462. Add(' case vi of');
  7463. Add(' 1: begin VI:=2; vi:=3; end;');
  7464. Add(' end;');
  7465. ConvertProgram;
  7466. CheckSource('TestCaseOfNoElse_UseSwitch',
  7467. LinesToStr([ // statements
  7468. 'this.vI = 0;'
  7469. ]),
  7470. LinesToStr([ // $mod.$main
  7471. 'switch ($mod.vI) {',
  7472. 'case 1:',
  7473. ' $mod.vI = 2;',
  7474. ' $mod.vI = 3;',
  7475. ' break;',
  7476. '};'
  7477. ]));
  7478. end;
  7479. procedure TTestModule.TestCaseOfRange;
  7480. begin
  7481. StartProgram(false);
  7482. Add('var vI: longint;');
  7483. Add('begin');
  7484. Add(' case vi of');
  7485. Add(' 1..3: vi:=14;');
  7486. Add(' 4,5: vi:=16;');
  7487. Add(' 6..7,9..10: ;');
  7488. Add(' else ;');
  7489. Add(' end;');
  7490. ConvertProgram;
  7491. CheckSource('TestCaseOfRange',
  7492. LinesToStr([ // statements
  7493. 'this.vI = 0;'
  7494. ]),
  7495. LinesToStr([ // $mod.$main
  7496. 'var $tmp1 = $mod.vI;',
  7497. 'if (($tmp1 >= 1) && ($tmp1 <= 3)){',
  7498. ' $mod.vI = 14',
  7499. '} else if (($tmp1 === 4) || ($tmp1 === 5)){',
  7500. ' $mod.vI = 16',
  7501. '} else if ((($tmp1 >= 6) && ($tmp1 <= 7)) || (($tmp1 >= 9) && ($tmp1 <= 10))) ;'
  7502. ]));
  7503. end;
  7504. procedure TTestModule.TestCaseOfString;
  7505. begin
  7506. StartProgram(false);
  7507. Add([
  7508. 'var s,h: string;',
  7509. 'begin',
  7510. ' case s of',
  7511. ' ''foo'': s:=h;',
  7512. ' ''a''..''z'': h:=s;',
  7513. ' ''ў'', ''ё'': ;',
  7514. ' ''Б''..''Я'': ;',
  7515. ' end;',
  7516. '']);
  7517. ConvertProgram;
  7518. CheckSource('TestCaseOfString',
  7519. LinesToStr([ // statements
  7520. 'this.s = "";',
  7521. 'this.h = "";',
  7522. '']),
  7523. LinesToStr([ // $mod.$main
  7524. 'var $tmp1 = $mod.s;',
  7525. 'if ($tmp1 === "foo") {',
  7526. ' $mod.s = $mod.h}',
  7527. ' else if (($tmp1.length === 1) && ($tmp1 >= "a") && ($tmp1 <= "z")) {',
  7528. ' $mod.h = $mod.s}',
  7529. ' else if (($tmp1 === "ў") || ($tmp1 === "ё")) {}',
  7530. ' else if (($tmp1.length === 1) && ($tmp1 >= "Б") && ($tmp1 <= "Я")) ;',
  7531. '']));
  7532. end;
  7533. procedure TTestModule.TestCaseOfChar;
  7534. begin
  7535. StartProgram(false);
  7536. Add([
  7537. 'var s,h: char;',
  7538. 'begin',
  7539. ' case s of',
  7540. ' ''a''..''z'': h:=s;',
  7541. ' ''ä'': ;',
  7542. ' ''ў'', ''ё'': ;',
  7543. ' ''Б''..''Я'': ;',
  7544. ' end;',
  7545. '']);
  7546. ConvertProgram;
  7547. CheckSource('TestCaseOfString',
  7548. LinesToStr([ // statements
  7549. 'this.s = "";',
  7550. 'this.h = "";',
  7551. '']),
  7552. LinesToStr([ // $mod.$main
  7553. 'var $tmp1 = $mod.s;',
  7554. 'if (($tmp1 >= "a") && ($tmp1 <= "z")) {',
  7555. ' $mod.h = $mod.s}',
  7556. ' else if ($tmp1 === "ä") {}',
  7557. ' else if (($tmp1 === "ў") || ($tmp1 === "ё")) {}',
  7558. ' else if (($tmp1 >= "Б") && ($tmp1 <= "Я")) ;',
  7559. '']));
  7560. end;
  7561. procedure TTestModule.TestCaseOfExternalClassConst;
  7562. begin
  7563. StartProgram(false);
  7564. Add([
  7565. '{$modeswitch externalclass}',
  7566. 'type',
  7567. ' TBird = class external name ''Bird''',
  7568. ' const e: longint;',
  7569. ' end;',
  7570. 'var vI: longint;',
  7571. 'begin',
  7572. ' case vi of',
  7573. ' 1: vi:=3;',
  7574. ' TBird.e: ;',
  7575. ' end;']);
  7576. ConvertProgram;
  7577. CheckSource('TestCaseOfExternalClassConst',
  7578. LinesToStr([ // statements
  7579. 'this.vI = 0;'
  7580. ]),
  7581. LinesToStr([ // $mod.$main
  7582. 'var $tmp1 = $mod.vI;',
  7583. 'if ($tmp1 === 1) {',
  7584. ' $mod.vI = 3}',
  7585. ' else if ($tmp1 === Bird.e) ;'
  7586. ]));
  7587. end;
  7588. procedure TTestModule.TestDebugger;
  7589. begin
  7590. StartProgram(false);
  7591. Add([
  7592. 'procedure DoIt;',
  7593. 'begin',
  7594. ' deBugger;',
  7595. ' DeBugger();',
  7596. 'end;',
  7597. 'begin',
  7598. ' Debugger;']);
  7599. ConvertProgram;
  7600. CheckSource('TestDebugger',
  7601. LinesToStr([ // statements
  7602. 'this.DoIt = function () {',
  7603. ' debugger;',
  7604. ' debugger;',
  7605. '};',
  7606. '']),
  7607. LinesToStr([ // $mod.$main
  7608. 'debugger;',
  7609. '']));
  7610. end;
  7611. procedure TTestModule.TestArray_Dynamic;
  7612. begin
  7613. StartProgram(false);
  7614. Add(['type',
  7615. ' TArrayInt = array of longint;',
  7616. 'var',
  7617. ' Arr: TArrayInt;',
  7618. ' i: longint;',
  7619. ' b: boolean;',
  7620. 'begin',
  7621. ' SetLength(arr,3);',
  7622. ' arr[0]:=4;',
  7623. ' arr[1]:=length(arr)+arr[0];',
  7624. ' arr[i]:=5;',
  7625. ' arr[arr[i]]:=arr[6];',
  7626. ' i:=low(arr);',
  7627. ' i:=high(arr);',
  7628. ' b:=Assigned(arr);',
  7629. ' Arr:=default(TArrayInt);']);
  7630. ConvertProgram;
  7631. CheckSource('TestArray_Dynamic',
  7632. LinesToStr([ // statements
  7633. 'this.Arr = [];',
  7634. 'this.i = 0;',
  7635. 'this.b = false;'
  7636. ]),
  7637. LinesToStr([ // $mod.$main
  7638. '$mod.Arr = rtl.arraySetLength($mod.Arr,0,3);',
  7639. '$mod.Arr[0] = 4;',
  7640. '$mod.Arr[1] = rtl.length($mod.Arr) + $mod.Arr[0];',
  7641. '$mod.Arr[$mod.i] = 5;',
  7642. '$mod.Arr[$mod.Arr[$mod.i]] = $mod.Arr[6];',
  7643. '$mod.i = 0;',
  7644. '$mod.i = rtl.length($mod.Arr) - 1;',
  7645. '$mod.b = rtl.length($mod.Arr) > 0;',
  7646. '$mod.Arr = [];',
  7647. '']));
  7648. end;
  7649. procedure TTestModule.TestArray_Dynamic_Nil;
  7650. begin
  7651. StartProgram(false);
  7652. Add('type');
  7653. Add(' TArrayInt = array of longint;');
  7654. Add('var');
  7655. Add(' Arr: TArrayInt;');
  7656. Add('procedure DoIt(const i: TArrayInt; j: TArrayInt); begin end;');
  7657. Add('begin');
  7658. Add(' arr:=nil;');
  7659. Add(' if arr=nil then;');
  7660. Add(' if nil=arr then;');
  7661. Add(' if arr<>nil then;');
  7662. Add(' if nil<>arr then;');
  7663. Add(' DoIt(nil,nil);');
  7664. ConvertProgram;
  7665. CheckSource('TestArray_Dynamic',
  7666. LinesToStr([ // statements
  7667. 'this.Arr = [];',
  7668. 'this.DoIt = function(i,j){',
  7669. '};'
  7670. ]),
  7671. LinesToStr([ // $mod.$main
  7672. '$mod.Arr = [];',
  7673. 'if (rtl.length($mod.Arr) === 0) ;',
  7674. 'if (rtl.length($mod.Arr) === 0) ;',
  7675. 'if (rtl.length($mod.Arr) > 0) ;',
  7676. 'if (rtl.length($mod.Arr) > 0) ;',
  7677. '$mod.DoIt([],[]);',
  7678. '']));
  7679. end;
  7680. procedure TTestModule.TestArray_DynMultiDimensional;
  7681. begin
  7682. StartProgram(false);
  7683. Add('type');
  7684. Add(' TArrayInt = array of longint;');
  7685. Add(' TArrayArrayInt = array of TArrayInt;');
  7686. Add('var');
  7687. Add(' Arr: TArrayInt;');
  7688. Add(' Arr2: TArrayArrayInt;');
  7689. Add(' i: longint;');
  7690. Add('begin');
  7691. Add(' arr2:=nil;');
  7692. Add(' if arr2=nil then;');
  7693. Add(' if nil=arr2 then;');
  7694. Add(' i:=low(arr2);');
  7695. Add(' i:=low(arr2[1]);');
  7696. Add(' i:=high(arr2);');
  7697. Add(' i:=high(arr2[2]);');
  7698. Add(' arr2[3]:=arr;');
  7699. Add(' arr2[4][5]:=i;');
  7700. Add(' i:=arr2[6][7];');
  7701. Add(' arr2[8,9]:=i;');
  7702. Add(' i:=arr2[10,11];');
  7703. Add(' SetLength(arr2,14);');
  7704. Add(' SetLength(arr2[15],16);');
  7705. ConvertProgram;
  7706. CheckSource('TestArray_Dynamic',
  7707. LinesToStr([ // statements
  7708. 'this.Arr = [];',
  7709. 'this.Arr2 = [];',
  7710. 'this.i = 0;'
  7711. ]),
  7712. LinesToStr([ // $mod.$main
  7713. '$mod.Arr2 = [];',
  7714. 'if (rtl.length($mod.Arr2) === 0) ;',
  7715. 'if (rtl.length($mod.Arr2) === 0) ;',
  7716. '$mod.i = 0;',
  7717. '$mod.i = 0;',
  7718. '$mod.i = rtl.length($mod.Arr2) - 1;',
  7719. '$mod.i = rtl.length($mod.Arr2[2]) - 1;',
  7720. '$mod.Arr2[3] = $mod.Arr;',
  7721. '$mod.Arr2[4][5] = $mod.i;',
  7722. '$mod.i = $mod.Arr2[6][7];',
  7723. '$mod.Arr2[8][9] = $mod.i;',
  7724. '$mod.i = $mod.Arr2[10][11];',
  7725. '$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
  7726. '$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
  7727. '']));
  7728. end;
  7729. procedure TTestModule.TestArray_StaticInt;
  7730. begin
  7731. StartProgram(false);
  7732. Add('type');
  7733. Add(' TArrayInt = array[2..4] of longint;');
  7734. Add('var');
  7735. Add(' Arr: TArrayInt;');
  7736. Add(' Arr2: TArrayInt = (5,6,7);');
  7737. Add(' i: longint;');
  7738. Add(' b: boolean;');
  7739. Add('begin');
  7740. Add(' arr[2]:=4;');
  7741. Add(' arr[3]:=arr[2]+arr[3];');
  7742. Add(' arr[i]:=5;');
  7743. Add(' arr[arr[i]]:=arr[high(arr)];');
  7744. Add(' i:=low(arr);');
  7745. Add(' i:=high(arr);');
  7746. Add(' b:=arr[2]=arr[3];');
  7747. Add(' arr:=default(TArrayInt);');
  7748. ConvertProgram;
  7749. CheckSource('TestArray_StaticInt',
  7750. LinesToStr([ // statements
  7751. 'this.Arr = rtl.arraySetLength(null,0,3);',
  7752. 'this.Arr2 = [5, 6, 7];',
  7753. 'this.i = 0;',
  7754. 'this.b = false;'
  7755. ]),
  7756. LinesToStr([ // $mod.$main
  7757. '$mod.Arr[0] = 4;',
  7758. '$mod.Arr[1] = $mod.Arr[0] + $mod.Arr[1];',
  7759. '$mod.Arr[$mod.i-2] = 5;',
  7760. '$mod.Arr[$mod.Arr[$mod.i-2]-2] = $mod.Arr[2];',
  7761. '$mod.i = 2;',
  7762. '$mod.i = 4;',
  7763. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  7764. '$mod.Arr = rtl.arraySetLength(null,0,3).slice(0);',
  7765. '']));
  7766. end;
  7767. procedure TTestModule.TestArray_StaticBool;
  7768. begin
  7769. StartProgram(false);
  7770. Add('type');
  7771. Add(' TBools = array[boolean] of boolean;');
  7772. Add(' TBool2 = array[true..true] of boolean;');
  7773. Add('var');
  7774. Add(' Arr: TBools;');
  7775. Add(' Arr2: TBool2;');
  7776. Add(' Arr3: TBools = (true,false);');
  7777. Add(' b: boolean;');
  7778. Add('begin');
  7779. Add(' b:=low(arr);');
  7780. Add(' b:=high(arr);');
  7781. Add(' arr[true]:=false;');
  7782. Add(' arr[false]:=arr[b] or arr[true];');
  7783. Add(' arr[b]:=true;');
  7784. Add(' arr[arr[b]]:=arr[high(arr)];');
  7785. Add(' b:=arr[false]=arr[true];');
  7786. Add(' b:=low(arr2);');
  7787. Add(' b:=high(arr2);');
  7788. Add(' arr2[true]:=true;');
  7789. Add(' arr2[true]:=arr2[true] and arr2[b];');
  7790. Add(' arr2[b]:=false;');
  7791. ConvertProgram;
  7792. CheckSource('TestArray_StaticBool',
  7793. LinesToStr([ // statements
  7794. 'this.Arr = rtl.arraySetLength(null,false,2);',
  7795. 'this.Arr2 = rtl.arraySetLength(null,false,1);',
  7796. 'this.Arr3 = [true, false];',
  7797. 'this.b = false;'
  7798. ]),
  7799. LinesToStr([ // $mod.$main
  7800. '$mod.b = false;',
  7801. '$mod.b = true;',
  7802. '$mod.Arr[1] = false;',
  7803. '$mod.Arr[0] = $mod.Arr[+$mod.b] || $mod.Arr[1];',
  7804. '$mod.Arr[+$mod.b] = true;',
  7805. '$mod.Arr[+$mod.Arr[+$mod.b]] = $mod.Arr[1];',
  7806. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  7807. '$mod.b = true;',
  7808. '$mod.b = true;',
  7809. '$mod.Arr2[0] = true;',
  7810. '$mod.Arr2[0] = $mod.Arr2[0] && $mod.Arr2[1-$mod.b];',
  7811. '$mod.Arr2[1-$mod.b] = false;',
  7812. '']));
  7813. end;
  7814. procedure TTestModule.TestArray_StaticChar;
  7815. begin
  7816. StartProgram(false);
  7817. Add([
  7818. 'type',
  7819. ' TChars = array[char] of char;',
  7820. ' TChars2 = array[''a''..''z''] of char;',
  7821. 'var',
  7822. ' Arr: TChars;',
  7823. ' Arr2: TChars2;',
  7824. ' Arr3: array[2..4] of char = (''p'',''a'',''s'');',
  7825. ' Arr4: array[11..13] of char = ''pas'';',
  7826. ' Arr5: array[21..22] of char = ''äö'';',
  7827. ' Arr6: array[31..32] of char = ''ä''+''ö'';',
  7828. ' c: char;',
  7829. ' b: boolean;',
  7830. 'begin',
  7831. ' c:=low(arr);',
  7832. ' c:=high(arr);',
  7833. ' arr[''B'']:=''a'';',
  7834. ' arr[''D'']:=arr[c];',
  7835. ' arr[c]:=arr[''d''];',
  7836. ' arr[arr[c]]:=arr[high(arr)];',
  7837. ' b:=arr[low(arr)]=arr[''e''];',
  7838. ' c:=low(arr2);',
  7839. ' c:=high(arr2);',
  7840. ' arr2[''b'']:=''f'';',
  7841. ' arr2[''a'']:=arr2[c];',
  7842. ' arr2[c]:=arr2[''g''];']);
  7843. ConvertProgram;
  7844. CheckSource('TestArray_StaticChar',
  7845. LinesToStr([ // statements
  7846. 'this.Arr = rtl.arraySetLength(null, "", 65536);',
  7847. 'this.Arr2 = rtl.arraySetLength(null, "", 26);',
  7848. 'this.Arr3 = ["p", "a", "s"];',
  7849. 'this.Arr4 = ["p", "a", "s"];',
  7850. 'this.Arr5 = ["ä", "ö"];',
  7851. 'this.Arr6 = ["ä", "ö"];',
  7852. 'this.c = "";',
  7853. 'this.b = false;',
  7854. '']),
  7855. LinesToStr([ // $mod.$main
  7856. '$mod.c = "\x00";',
  7857. '$mod.c = "\uFFFF";',
  7858. '$mod.Arr[66] = "a";',
  7859. '$mod.Arr[68] = $mod.Arr[$mod.c.charCodeAt()];',
  7860. '$mod.Arr[$mod.c.charCodeAt()] = $mod.Arr[100];',
  7861. '$mod.Arr[$mod.Arr[$mod.c.charCodeAt()].charCodeAt()] = $mod.Arr[65535];',
  7862. '$mod.b = $mod.Arr[0] === $mod.Arr[101];',
  7863. '$mod.c = "a";',
  7864. '$mod.c = "z";',
  7865. '$mod.Arr2[1] = "f";',
  7866. '$mod.Arr2[0] = $mod.Arr2[$mod.c.charCodeAt() - 97];',
  7867. '$mod.Arr2[$mod.c.charCodeAt() - 97] = $mod.Arr2[6];',
  7868. '']));
  7869. end;
  7870. procedure TTestModule.TestArray_StaticMultiDim;
  7871. begin
  7872. StartProgram(false);
  7873. Add([
  7874. 'type',
  7875. ' TArrayInt = array[1..3] of longint;',
  7876. ' TArrayArrayInt = array[5..6] of TArrayInt;',
  7877. 'var',
  7878. ' Arr: TArrayInt;',
  7879. ' Arr2: TArrayArrayInt;',
  7880. ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
  7881. ' i: longint;',
  7882. 'begin',
  7883. ' i:=low(arr);',
  7884. ' i:=low(arr2);',
  7885. ' i:=low(arr2[5]);',
  7886. ' i:=high(arr);',
  7887. ' i:=high(arr2);',
  7888. ' i:=high(arr2[6]);',
  7889. ' arr2[5]:=arr;',
  7890. ' arr2[6][2]:=i;',
  7891. ' i:=arr2[6][3];',
  7892. ' arr2[6,3]:=i;',
  7893. ' i:=arr2[5,2];',
  7894. ' arr2:=arr2;',// clone multi dim static array
  7895. //' arr3:=arr3;',// clone anonymous multi dim static array
  7896. '']);
  7897. ConvertProgram;
  7898. CheckSource('TestArray_StaticMultiDim',
  7899. LinesToStr([ // statements
  7900. 'this.TArrayArrayInt$clone = function (a) {',
  7901. ' var r = [];',
  7902. ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
  7903. ' return r;',
  7904. '};',
  7905. 'this.Arr = rtl.arraySetLength(null, 0, 3);',
  7906. 'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
  7907. 'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
  7908. 'this.i = 0;'
  7909. ]),
  7910. LinesToStr([ // $mod.$main
  7911. '$mod.i = 1;',
  7912. '$mod.i = 5;',
  7913. '$mod.i = 1;',
  7914. '$mod.i = 3;',
  7915. '$mod.i = 6;',
  7916. '$mod.i = 3;',
  7917. '$mod.Arr2[0] = $mod.Arr.slice(0);',
  7918. '$mod.Arr2[1][1] = $mod.i;',
  7919. '$mod.i = $mod.Arr2[1][2];',
  7920. '$mod.Arr2[1][2] = $mod.i;',
  7921. '$mod.i = $mod.Arr2[0][1];',
  7922. '$mod.Arr2 = $mod.TArrayArrayInt$clone($mod.Arr2);',
  7923. '']));
  7924. end;
  7925. procedure TTestModule.TestArray_StaticInFunction;
  7926. begin
  7927. StartProgram(false);
  7928. Add([
  7929. 'const TArrayInt = 3;',
  7930. 'const TArrayArrayInt = 4;',
  7931. 'procedure DoIt;',
  7932. 'type',
  7933. ' TArrayInt = array[1..3] of longint;',
  7934. ' TArrayArrayInt = array[5..6] of TArrayInt;',
  7935. 'var',
  7936. ' Arr: TArrayInt;',
  7937. ' Arr2: TArrayArrayInt;',
  7938. ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
  7939. ' i: longint;',
  7940. 'begin',
  7941. ' arr2[5]:=arr;',
  7942. ' arr2:=arr2;',// clone multi dim static array
  7943. 'end;',
  7944. 'begin',
  7945. '']);
  7946. ConvertProgram;
  7947. CheckSource('TestArray_StaticInFunction',
  7948. LinesToStr([ // statements
  7949. 'this.TArrayInt = 3;',
  7950. 'this.TArrayArrayInt = 4;',
  7951. 'var TArrayArrayInt$1$clone = function (a) {',
  7952. ' var r = [];',
  7953. ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
  7954. ' return r;',
  7955. '};',
  7956. 'this.DoIt = function () {',
  7957. ' var Arr = rtl.arraySetLength(null, 0, 3);',
  7958. ' var Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
  7959. ' var Arr3 = [[11, 12, 13], [21, 22, 23]];',
  7960. ' var i = 0;',
  7961. ' Arr2[0] = Arr.slice(0);',
  7962. ' Arr2 = TArrayArrayInt$1$clone(Arr2);',
  7963. '};',
  7964. '']),
  7965. LinesToStr([ // $mod.$main
  7966. '']));
  7967. end;
  7968. procedure TTestModule.TestArrayOfRecord;
  7969. begin
  7970. StartProgram(false);
  7971. Add([
  7972. 'type',
  7973. ' TRec = record',
  7974. ' Int: longint;',
  7975. ' end;',
  7976. ' TArrayRec = array of TRec;',
  7977. 'procedure DoIt(vd: TRec; const vc: TRec; var vv: TRec);',
  7978. 'begin',
  7979. 'end;',
  7980. 'var',
  7981. ' Arr: TArrayRec;',
  7982. ' r: TRec;',
  7983. ' i: longint;',
  7984. 'begin',
  7985. ' SetLength(arr,3);',
  7986. ' arr[0].int:=4;',
  7987. ' arr[1].int:=length(arr)+arr[2].int;',
  7988. ' arr[arr[i].int].int:=arr[5].int;',
  7989. ' arr[7]:=r;',
  7990. ' r:=arr[8];',
  7991. ' i:=low(arr);',
  7992. ' i:=high(arr);',
  7993. ' DoIt(Arr[9],Arr[10],Arr[11]);']);
  7994. ConvertProgram;
  7995. CheckSource('TestArrayOfRecord',
  7996. LinesToStr([ // statements
  7997. 'rtl.recNewT($mod, "TRec", function () {',
  7998. ' this.Int = 0;',
  7999. ' this.$eq = function (b) {',
  8000. ' return this.Int === b.Int;',
  8001. ' };',
  8002. ' this.$assign = function (s) {',
  8003. ' this.Int = s.Int;',
  8004. ' return this;',
  8005. ' };',
  8006. '});',
  8007. 'this.DoIt = function (vd, vc, vv) {',
  8008. '};',
  8009. 'this.Arr = [];',
  8010. 'this.r = $mod.TRec.$new();',
  8011. 'this.i = 0;'
  8012. ]),
  8013. LinesToStr([ // $mod.$main
  8014. '$mod.Arr = rtl.arraySetLength($mod.Arr,$mod.TRec,3);',
  8015. '$mod.Arr[0].Int = 4;',
  8016. '$mod.Arr[1].Int = rtl.length($mod.Arr)+$mod.Arr[2].Int;',
  8017. '$mod.Arr[$mod.Arr[$mod.i].Int].Int = $mod.Arr[5].Int;',
  8018. '$mod.Arr[7].$assign($mod.r);',
  8019. '$mod.r.$assign($mod.Arr[8]);',
  8020. '$mod.i = 0;',
  8021. '$mod.i = rtl.length($mod.Arr)-1;',
  8022. '$mod.DoIt($mod.TRec.$clone($mod.Arr[9]), $mod.Arr[10], $mod.Arr[11]);',
  8023. '']));
  8024. end;
  8025. procedure TTestModule.TestArray_StaticRecord;
  8026. begin
  8027. StartProgram(false);
  8028. Add([
  8029. 'type',
  8030. ' TRec = record',
  8031. ' Int: longint;',
  8032. ' end;',
  8033. ' TArrayRec = array[1..2] of TRec;',
  8034. 'var',
  8035. ' Arr: TArrayRec;',
  8036. 'begin',
  8037. ' arr[1].int:=length(arr)+low(arr)+high(arr);',
  8038. '']);
  8039. ConvertProgram;
  8040. CheckSource('TestArray_StaticRecord',
  8041. LinesToStr([ // statements
  8042. 'rtl.recNewT($mod, "TRec", function () {',
  8043. ' this.Int = 0;',
  8044. ' this.$eq = function (b) {',
  8045. ' return this.Int === b.Int;',
  8046. ' };',
  8047. ' this.$assign = function (s) {',
  8048. ' this.Int = s.Int;',
  8049. ' return this;',
  8050. ' };',
  8051. '});',
  8052. 'this.TArrayRec$clone = function (a) {',
  8053. ' var r = [];',
  8054. ' for (var i = 0; i < 2; i++) r.push($mod.TRec.$clone(a[i]));',
  8055. ' return r;',
  8056. '};',
  8057. 'this.Arr = rtl.arraySetLength(null, $mod.TRec, 2);',
  8058. '']),
  8059. LinesToStr([ // $mod.$main
  8060. '$mod.Arr[0].Int = 2 + 1 + 2;']));
  8061. end;
  8062. procedure TTestModule.TestArrayOfSet;
  8063. begin
  8064. StartProgram(false);
  8065. Add([
  8066. 'type',
  8067. ' TFlag = (big,small);',
  8068. ' TSetOfFlag = set of tflag;',
  8069. ' TArrayFlag = array of TSetOfFlag;',
  8070. 'procedure DoIt(const a: Tarrayflag);',
  8071. 'begin',
  8072. 'end;',
  8073. 'var',
  8074. ' f: TFlag;',
  8075. ' s: TSetOfFlag;',
  8076. ' Arr: TArrayFlag;',
  8077. ' i: longint;',
  8078. 'begin',
  8079. ' SetLength(arr,3);',
  8080. ' arr[0]:=s;',
  8081. ' arr[1]:=[big];',
  8082. ' arr[2]:=[big]+s;',
  8083. ' arr[3]:=s+[big];',
  8084. ' arr[4]:=arr[5];',
  8085. ' s:=arr[6];',
  8086. ' i:=low(arr);',
  8087. ' i:=high(arr);',
  8088. ' DoIt(arr);',
  8089. ' DoIt([s]);',
  8090. ' DoIt([[],s]);',
  8091. ' DoIt([s,[]]);',
  8092. '']);
  8093. ConvertProgram;
  8094. CheckSource('TestArrayOfSet',
  8095. LinesToStr([ // statements
  8096. 'this.TFlag = {',
  8097. ' "0": "big",',
  8098. ' big: 0,',
  8099. ' "1": "small",',
  8100. ' small: 1',
  8101. '};',
  8102. 'this.DoIt = function (a) {',
  8103. '};',
  8104. 'this.f = 0;',
  8105. 'this.s = {};',
  8106. 'this.Arr = [];',
  8107. 'this.i = 0;',
  8108. '']),
  8109. LinesToStr([ // $mod.$main
  8110. '$mod.Arr = rtl.arraySetLength($mod.Arr, {}, 3);',
  8111. '$mod.Arr[0] = rtl.refSet($mod.s);',
  8112. '$mod.Arr[1] = rtl.createSet($mod.TFlag.big);',
  8113. '$mod.Arr[2] = rtl.unionSet(rtl.createSet($mod.TFlag.big), $mod.s);',
  8114. '$mod.Arr[3] = rtl.unionSet($mod.s, rtl.createSet($mod.TFlag.big));',
  8115. '$mod.Arr[4] = rtl.refSet($mod.Arr[5]);',
  8116. '$mod.s = rtl.refSet($mod.Arr[6]);',
  8117. '$mod.i = 0;',
  8118. '$mod.i = rtl.length($mod.Arr) - 1;',
  8119. '$mod.DoIt($mod.Arr);',
  8120. '$mod.DoIt([rtl.refSet($mod.s)]);',
  8121. '$mod.DoIt([{}, rtl.refSet($mod.s)]);',
  8122. '$mod.DoIt([rtl.refSet($mod.s), {}]);',
  8123. '']));
  8124. end;
  8125. procedure TTestModule.TestArray_DynAsParam;
  8126. begin
  8127. StartProgram(false);
  8128. Add([
  8129. 'type integer = longint;',
  8130. 'type TArrInt = array of integer;',
  8131. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  8132. 'var vJ: TArrInt;',
  8133. 'begin',
  8134. ' vg:=vg;',
  8135. ' vj:=vh;',
  8136. ' vi:=vi;',
  8137. ' doit(vg,vg,vg);',
  8138. ' doit(vh,vh,vj);',
  8139. ' doit(vi,vi,vi);',
  8140. ' doit(vj,vj,vj);',
  8141. 'end;',
  8142. 'var i: TArrInt;',
  8143. 'begin',
  8144. ' doit(i,i,i);']);
  8145. ConvertProgram;
  8146. CheckSource('TestArray_DynAsParams',
  8147. LinesToStr([ // statements
  8148. 'this.DoIt = function (vG,vH,vI) {',
  8149. ' var vJ = [];',
  8150. ' vG = vG;',
  8151. ' vJ = vH;',
  8152. ' vI.set(vI.get());',
  8153. ' $mod.DoIt(vG, vG, {',
  8154. ' get: function () {',
  8155. ' return vG;',
  8156. ' },',
  8157. ' set: function (v) {',
  8158. ' vG = v;',
  8159. ' }',
  8160. ' });',
  8161. ' $mod.DoIt(vH, vH, {',
  8162. ' get: function () {',
  8163. ' return vJ;',
  8164. ' },',
  8165. ' set: function (v) {',
  8166. ' vJ = v;',
  8167. ' }',
  8168. ' });',
  8169. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  8170. ' $mod.DoIt(vJ, vJ, {',
  8171. ' get: function () {',
  8172. ' return vJ;',
  8173. ' },',
  8174. ' set: function (v) {',
  8175. ' vJ = v;',
  8176. ' }',
  8177. ' });',
  8178. '};',
  8179. 'this.i = [];'
  8180. ]),
  8181. LinesToStr([
  8182. '$mod.DoIt($mod.i,$mod.i,{',
  8183. ' p: $mod,',
  8184. ' get: function () {',
  8185. ' return this.p.i;',
  8186. ' },',
  8187. ' set: function (v) {',
  8188. ' this.p.i = v;',
  8189. ' }',
  8190. '});'
  8191. ]));
  8192. end;
  8193. procedure TTestModule.TestArray_StaticAsParam;
  8194. begin
  8195. StartProgram(false);
  8196. Add([
  8197. 'type integer = longint;',
  8198. 'type TArrInt = array[1..2] of integer;',
  8199. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  8200. 'var vJ: TArrInt;',
  8201. 'begin',
  8202. ' vg:=vg;',
  8203. ' vj:=vh;',
  8204. ' vi:=vi;',
  8205. ' doit(vg,vg,vg);',
  8206. ' doit(vh,vh,vj);',
  8207. ' doit(vi,vi,vi);',
  8208. ' doit(vj,vj,vj);',
  8209. 'end;',
  8210. 'var i: TArrInt;',
  8211. 'begin',
  8212. ' doit(i,i,i);']);
  8213. ConvertProgram;
  8214. CheckSource('TestArray_StaticAsParams',
  8215. LinesToStr([ // statements
  8216. 'this.DoIt = function (vG,vH,vI) {',
  8217. ' var vJ = rtl.arraySetLength(null, 0, 2);',
  8218. ' vG = vG.slice(0);',
  8219. ' vJ = vH.slice(0);',
  8220. ' vI.set(vI.get().slice(0));',
  8221. ' $mod.DoIt(vG.slice(0), vG, {',
  8222. ' get: function () {',
  8223. ' return vG;',
  8224. ' },',
  8225. ' set: function (v) {',
  8226. ' vG = v;',
  8227. ' }',
  8228. ' });',
  8229. ' $mod.DoIt(vH.slice(0), vH, {',
  8230. ' get: function () {',
  8231. ' return vJ;',
  8232. ' },',
  8233. ' set: function (v) {',
  8234. ' vJ = v;',
  8235. ' }',
  8236. ' });',
  8237. ' $mod.DoIt(vI.get().slice(0), vI.get(), vI);',
  8238. ' $mod.DoIt(vJ.slice(0), vJ, {',
  8239. ' get: function () {',
  8240. ' return vJ;',
  8241. ' },',
  8242. ' set: function (v) {',
  8243. ' vJ = v;',
  8244. ' }',
  8245. ' });',
  8246. '};',
  8247. 'this.i = rtl.arraySetLength(null, 0, 2);'
  8248. ]),
  8249. LinesToStr([
  8250. '$mod.DoIt($mod.i.slice(0),$mod.i,{',
  8251. ' p: $mod,',
  8252. ' get: function () {',
  8253. ' return this.p.i;',
  8254. ' },',
  8255. ' set: function (v) {',
  8256. ' this.p.i = v;',
  8257. ' }',
  8258. '});'
  8259. ]));
  8260. end;
  8261. procedure TTestModule.TestArrayElement_AsParams;
  8262. begin
  8263. StartProgram(false);
  8264. Add('type integer = longint;');
  8265. Add('type TArrayInt = array of integer;');
  8266. Add('procedure DoIt(vG: Integer; const vH: Integer; var vI: Integer);');
  8267. Add('var vJ: tarrayint;');
  8268. Add('begin');
  8269. Add(' vi:=vi;');
  8270. Add(' doit(vi,vi,vi);');
  8271. Add(' doit(vj[1+1],vj[1+2],vj[1+3]);');
  8272. Add('end;');
  8273. Add('var a: TArrayInt;');
  8274. Add('begin');
  8275. Add(' doit(a[1+4],a[1+5],a[1+6]);');
  8276. ConvertProgram;
  8277. CheckSource('TestArrayElement_AsParams',
  8278. LinesToStr([ // statements
  8279. 'this.DoIt = function (vG,vH,vI) {',
  8280. ' var vJ = [];',
  8281. ' vI.set(vI.get());',
  8282. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  8283. ' $mod.DoIt(vJ[1+1], vJ[1+2], {',
  8284. ' a:1+3,',
  8285. ' p:vJ,',
  8286. ' get: function () {',
  8287. ' return this.p[this.a];',
  8288. ' },',
  8289. ' set: function (v) {',
  8290. ' this.p[this.a] = v;',
  8291. ' }',
  8292. ' });',
  8293. '};',
  8294. 'this.a = [];'
  8295. ]),
  8296. LinesToStr([
  8297. '$mod.DoIt($mod.a[1+4],$mod.a[1+5],{',
  8298. ' a: 1+6,',
  8299. ' p: $mod.a,',
  8300. ' get: function () {',
  8301. ' return this.p[this.a];',
  8302. ' },',
  8303. ' set: function (v) {',
  8304. ' this.p[this.a] = v;',
  8305. ' }',
  8306. '});'
  8307. ]));
  8308. end;
  8309. procedure TTestModule.TestArrayElementFromFuncResult_AsParams;
  8310. begin
  8311. StartProgram(false);
  8312. Add('type Integer = longint;');
  8313. Add('type TArrayInt = array of integer;');
  8314. Add('function GetArr(vB: integer = 0): tarrayint;');
  8315. Add('begin');
  8316. Add('end;');
  8317. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  8318. Add('begin');
  8319. Add('end;');
  8320. Add('begin');
  8321. Add(' doit(getarr[1+1],getarr[1+2],getarr[1+3]);');
  8322. Add(' doit(getarr()[2+1],getarr()[2+2],getarr()[2+3]);');
  8323. Add(' doit(getarr(7)[3+1],getarr(8)[3+2],getarr(9)[3+3]);');
  8324. ConvertProgram;
  8325. CheckSource('TestArrayElementFromFuncResult_AsParams',
  8326. LinesToStr([ // statements
  8327. 'this.GetArr = function (vB) {',
  8328. ' var Result = [];',
  8329. ' return Result;',
  8330. '};',
  8331. 'this.DoIt = function (vG,vH,vI) {',
  8332. '};'
  8333. ]),
  8334. LinesToStr([
  8335. '$mod.DoIt($mod.GetArr(0)[1+1],$mod.GetArr(0)[1+2],{',
  8336. ' a: 1+3,',
  8337. ' p: $mod.GetArr(0),',
  8338. ' get: function () {',
  8339. ' return this.p[this.a];',
  8340. ' },',
  8341. ' set: function (v) {',
  8342. ' this.p[this.a] = v;',
  8343. ' }',
  8344. '});',
  8345. '$mod.DoIt($mod.GetArr(0)[2+1],$mod.GetArr(0)[2+2],{',
  8346. ' a: 2+3,',
  8347. ' p: $mod.GetArr(0),',
  8348. ' get: function () {',
  8349. ' return this.p[this.a];',
  8350. ' },',
  8351. ' set: function (v) {',
  8352. ' this.p[this.a] = v;',
  8353. ' }',
  8354. '});',
  8355. '$mod.DoIt($mod.GetArr(7)[3+1],$mod.GetArr(8)[3+2],{',
  8356. ' a: 3+3,',
  8357. ' p: $mod.GetArr(9),',
  8358. ' get: function () {',
  8359. ' return this.p[this.a];',
  8360. ' },',
  8361. ' set: function (v) {',
  8362. ' this.p[this.a] = v;',
  8363. ' }',
  8364. '});',
  8365. '']));
  8366. end;
  8367. procedure TTestModule.TestArrayEnumTypeRange;
  8368. begin
  8369. StartProgram(false);
  8370. Add([
  8371. 'type',
  8372. ' TEnum = (red,blue);',
  8373. ' TEnumArray = array[TEnum] of longint;',
  8374. 'var',
  8375. ' e: TEnum;',
  8376. ' i: longint;',
  8377. ' a: TEnumArray;',
  8378. ' numbers: TEnumArray = (1,2);',
  8379. ' names: array[TEnum] of string = (''red'',''blue'');',
  8380. 'begin',
  8381. ' e:=low(a);',
  8382. ' e:=high(a);',
  8383. ' i:=a[red];',
  8384. ' a[e]:=a[e];']);
  8385. ConvertProgram;
  8386. CheckSource('TestArrayEnumTypeRange',
  8387. LinesToStr([ // statements
  8388. ' this.TEnum = {',
  8389. ' "0": "red",',
  8390. ' red: 0,',
  8391. ' "1": "blue",',
  8392. ' blue: 1',
  8393. '};',
  8394. 'this.e = 0;',
  8395. 'this.i = 0;',
  8396. 'this.a = rtl.arraySetLength(null,0,2);',
  8397. 'this.numbers = [1, 2];',
  8398. 'this.names = ["red", "blue"];',
  8399. '']),
  8400. LinesToStr([ // $mod.$main
  8401. '$mod.e = $mod.TEnum.red;',
  8402. '$mod.e = $mod.TEnum.blue;',
  8403. '$mod.i = $mod.a[$mod.TEnum.red];',
  8404. '$mod.a[$mod.e] = $mod.a[$mod.e];',
  8405. '']));
  8406. end;
  8407. procedure TTestModule.TestArray_SetLengthOutArg;
  8408. begin
  8409. StartProgram(false);
  8410. Add([
  8411. 'type TArrInt = array of longint;',
  8412. 'procedure DoIt(out a: TArrInt);',
  8413. 'begin',
  8414. ' SetLength(a,2);',
  8415. 'end;',
  8416. 'begin',
  8417. '']);
  8418. ConvertProgram;
  8419. CheckSource('TestArray_SetLengthOutArg',
  8420. LinesToStr([ // statements
  8421. 'this.DoIt = function (a) {',
  8422. ' a.set(rtl.arraySetLength(a.get(), 0, 2));',
  8423. '};',
  8424. '']),
  8425. LinesToStr([
  8426. '']));
  8427. end;
  8428. procedure TTestModule.TestArray_SetLengthProperty;
  8429. begin
  8430. StartProgram(false);
  8431. Add('type');
  8432. Add(' TArrInt = array of longint;');
  8433. Add(' TObject = class');
  8434. Add(' function GetColors: TArrInt; external name ''GetColors'';');
  8435. Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
  8436. Add(' property Colors: TArrInt read GetColors write SetColors;');
  8437. Add(' end;');
  8438. Add('var Obj: TObject;');
  8439. Add('begin');
  8440. Add(' SetLength(Obj.Colors,2);');
  8441. ConvertProgram;
  8442. CheckSource('TestArray_SetLengthProperty',
  8443. LinesToStr([ // statements
  8444. 'rtl.createClass($mod, "TObject", null, function () {',
  8445. ' this.$init = function () {',
  8446. ' };',
  8447. ' this.$final = function () {',
  8448. ' };',
  8449. '});',
  8450. 'this.Obj = null;',
  8451. '']),
  8452. LinesToStr([
  8453. '$mod.Obj.SetColors(rtl.arraySetLength($mod.Obj.GetColors(), 0, 2));',
  8454. '']));
  8455. end;
  8456. procedure TTestModule.TestArray_SetLengthMultiDim;
  8457. begin
  8458. StartProgram(false);
  8459. Add([
  8460. 'type',
  8461. ' TArrArrInt = array of array of longint;',
  8462. 'var',
  8463. ' a: TArrArrInt;',
  8464. 'begin',
  8465. ' SetLength(a,2);',
  8466. ' SetLength(a,3,4);',
  8467. '']);
  8468. ConvertProgram;
  8469. CheckSource('TestArray_SetLengthMultiDim',
  8470. LinesToStr([ // statements
  8471. 'this.a = [];']),
  8472. LinesToStr([
  8473. '$mod.a = rtl.arraySetLength($mod.a, [], 2);',
  8474. '$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
  8475. '']));
  8476. end;
  8477. procedure TTestModule.TestArray_OpenArrayOfString;
  8478. begin
  8479. StartProgram(false);
  8480. Add('procedure DoIt(const a: array of String);');
  8481. Add('var');
  8482. Add(' i: longint;');
  8483. Add(' s: string;');
  8484. Add('begin');
  8485. Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
  8486. Add('end;');
  8487. Add('var s: string;');
  8488. Add('begin');
  8489. Add(' DoIt([]);');
  8490. Add(' DoIt([s,''foo'','''',s+s]);');
  8491. ConvertProgram;
  8492. CheckSource('TestArray_OpenArrayOfString',
  8493. LinesToStr([ // statements
  8494. 'this.DoIt = function (a) {',
  8495. ' var i = 0;',
  8496. ' var s = "";',
  8497. ' for (var $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
  8498. ' i = $l1;',
  8499. ' s = a[rtl.length(a) - i - 1];',
  8500. ' };',
  8501. '};',
  8502. 'this.s = "";',
  8503. '']),
  8504. LinesToStr([
  8505. '$mod.DoIt([]);',
  8506. '$mod.DoIt([$mod.s, "foo", "", $mod.s + $mod.s]);',
  8507. '']));
  8508. end;
  8509. procedure TTestModule.TestArray_Concat;
  8510. begin
  8511. StartProgram(false);
  8512. Add([
  8513. 'type',
  8514. ' integer = longint;',
  8515. ' TFlag = (big,small);',
  8516. ' TFlags = set of TFlag;',
  8517. ' TRec = record',
  8518. ' i: integer;',
  8519. ' end;',
  8520. ' TArrInt = array of integer;',
  8521. ' TArrRec = array of TRec;',
  8522. ' TArrFlag = array of TFlag;',
  8523. ' TArrSet = array of TFlags;',
  8524. ' TArrJSValue = array of jsvalue;',
  8525. 'var',
  8526. ' ArrInt: tarrint;',
  8527. ' ArrRec: tarrrec;',
  8528. ' ArrFlag: tarrflag;',
  8529. ' ArrSet: tarrset;',
  8530. ' ArrJSValue: tarrjsvalue;',
  8531. 'begin',
  8532. ' arrint:=concat(arrint);',
  8533. ' arrint:=concat(arrint,arrint);',
  8534. ' arrint:=concat(arrint,arrint,arrint);',
  8535. ' arrrec:=concat(arrrec);',
  8536. ' arrrec:=concat(arrrec,arrrec);',
  8537. ' arrrec:=concat(arrrec,arrrec,arrrec);',
  8538. ' arrset:=concat(arrset);',
  8539. ' arrset:=concat(arrset,arrset);',
  8540. ' arrset:=concat(arrset,arrset,arrset);',
  8541. ' arrjsvalue:=concat(arrjsvalue);',
  8542. ' arrjsvalue:=concat(arrjsvalue,arrjsvalue);',
  8543. ' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);',
  8544. ' arrint:=concat([1],arrint);',
  8545. ' arrflag:=concat([big]);',
  8546. ' arrflag:=concat([big],arrflag);',
  8547. ' arrflag:=concat(arrflag,[small]);',
  8548. '']);
  8549. ConvertProgram;
  8550. CheckSource('TestArray_Concat',
  8551. LinesToStr([ // statements
  8552. 'this.TFlag = {',
  8553. ' "0": "big",',
  8554. ' big: 0,',
  8555. ' "1": "small",',
  8556. ' small: 1',
  8557. '};',
  8558. 'rtl.recNewT($mod, "TRec", function () {',
  8559. ' this.i = 0;',
  8560. ' this.$eq = function (b) {',
  8561. ' return this.i === b.i;',
  8562. ' };',
  8563. ' this.$assign = function (s) {',
  8564. ' this.i = s.i;',
  8565. ' return this;',
  8566. ' };',
  8567. '});',
  8568. 'this.ArrInt = [];',
  8569. 'this.ArrRec = [];',
  8570. 'this.ArrFlag = [];',
  8571. 'this.ArrSet = [];',
  8572. 'this.ArrJSValue = [];',
  8573. '']),
  8574. LinesToStr([ // $mod.$main
  8575. '$mod.ArrInt = $mod.ArrInt;',
  8576. '$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt);',
  8577. '$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt, $mod.ArrInt);',
  8578. '$mod.ArrRec = $mod.ArrRec;',
  8579. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
  8580. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec, $mod.ArrRec);',
  8581. '$mod.ArrSet = $mod.ArrSet;',
  8582. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
  8583. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet, $mod.ArrSet);',
  8584. '$mod.ArrJSValue = $mod.ArrJSValue;',
  8585. '$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue);',
  8586. '$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue, $mod.ArrJSValue);',
  8587. '$mod.ArrInt = rtl.arrayConcatN([1], $mod.ArrInt);',
  8588. '$mod.ArrFlag = [$mod.TFlag.big];',
  8589. '$mod.ArrFlag = rtl.arrayConcatN([$mod.TFlag.big], $mod.ArrFlag);',
  8590. '$mod.ArrFlag = rtl.arrayConcatN($mod.ArrFlag, [$mod.TFlag.small]);',
  8591. '']));
  8592. end;
  8593. procedure TTestModule.TestArray_Copy;
  8594. begin
  8595. StartProgram(false);
  8596. Add([
  8597. 'type',
  8598. ' integer = longint;',
  8599. ' TFlag = (big,small);',
  8600. ' TFlags = set of TFlag;',
  8601. ' TRec = record',
  8602. ' i: integer;',
  8603. ' end;',
  8604. ' TArrInt = array of integer;',
  8605. ' TArrRec = array of TRec;',
  8606. ' TArrSet = array of TFlags;',
  8607. ' TArrJSValue = array of jsvalue;',
  8608. 'var',
  8609. ' ArrInt: tarrint;',
  8610. ' ArrRec: tarrrec;',
  8611. ' ArrSet: tarrset;',
  8612. ' ArrJSValue: tarrjsvalue;',
  8613. 'begin',
  8614. ' arrint:=copy(arrint);',
  8615. ' arrint:=copy(arrint,2);',
  8616. ' arrint:=copy(arrint,3,4);',
  8617. ' arrint:=copy([1,1],1,2);',
  8618. ' arrrec:=copy(arrrec);',
  8619. ' arrrec:=copy(arrrec,5);',
  8620. ' arrrec:=copy(arrrec,6,7);',
  8621. ' arrset:=copy(arrset);',
  8622. ' arrset:=copy(arrset,8);',
  8623. ' arrset:=copy(arrset,9,10);',
  8624. ' arrjsvalue:=copy(arrjsvalue);',
  8625. ' arrjsvalue:=copy(arrjsvalue,11);',
  8626. ' arrjsvalue:=copy(arrjsvalue,12,13);',
  8627. ' ']);
  8628. ConvertProgram;
  8629. CheckSource('TestArray_Copy',
  8630. LinesToStr([ // statements
  8631. 'this.TFlag = {',
  8632. ' "0": "big",',
  8633. ' big: 0,',
  8634. ' "1": "small",',
  8635. ' small: 1',
  8636. '};',
  8637. 'rtl.recNewT($mod, "TRec", function () {',
  8638. ' this.i = 0;',
  8639. ' this.$eq = function (b) {',
  8640. ' return this.i === b.i;',
  8641. ' };',
  8642. ' this.$assign = function (s) {',
  8643. ' this.i = s.i;',
  8644. ' return this;',
  8645. ' };',
  8646. '});',
  8647. 'this.ArrInt = [];',
  8648. 'this.ArrRec = [];',
  8649. 'this.ArrSet = [];',
  8650. 'this.ArrJSValue = [];',
  8651. '']),
  8652. LinesToStr([ // $mod.$main
  8653. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 0);',
  8654. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 2);',
  8655. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 3, 4);',
  8656. '$mod.ArrInt = rtl.arrayCopy(0, [1, 1], 1, 2);',
  8657. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 0);',
  8658. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 5);',
  8659. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 6, 7);',
  8660. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 0);',
  8661. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 8);',
  8662. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 9, 10);',
  8663. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 0);',
  8664. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 11);',
  8665. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 12, 13);',
  8666. '']));
  8667. end;
  8668. procedure TTestModule.TestArray_InsertDelete;
  8669. begin
  8670. StartProgram(false);
  8671. Add([
  8672. 'type',
  8673. ' integer = longint;',
  8674. ' TFlag = (big,small);',
  8675. ' TFlags = set of TFlag;',
  8676. ' TRec = record',
  8677. ' i: integer;',
  8678. ' end;',
  8679. ' TArrInt = array of integer;',
  8680. ' TArrRec = array of TRec;',
  8681. ' TArrSet = array of TFlags;',
  8682. ' TArrJSValue = array of jsvalue;',
  8683. ' TArrArrInt = array of TArrInt;',
  8684. 'var',
  8685. ' ArrInt: tarrint;',
  8686. ' ArrRec: tarrrec;',
  8687. ' ArrSet: tarrset;',
  8688. ' ArrJSValue: tarrjsvalue;',
  8689. ' ArrArrInt: TArrArrInt;',
  8690. 'begin',
  8691. ' Insert(1,arrint,2);',
  8692. ' Insert(arrint[3],arrint,4);',
  8693. ' Insert(arrrec[5],arrrec,6);',
  8694. ' Insert(arrset[7],arrset,7);',
  8695. ' Insert(arrjsvalue[8],arrjsvalue,9);',
  8696. ' Insert(10,arrjsvalue,11);',
  8697. ' Insert([23],arrarrint,22);',
  8698. ' Delete(arrint,12,13);',
  8699. ' Delete(arrrec,14,15);',
  8700. ' Delete(arrset,17,18);',
  8701. ' Delete(arrjsvalue,19,10);']);
  8702. ConvertProgram;
  8703. CheckSource('TestArray_InsertDelete',
  8704. LinesToStr([ // statements
  8705. 'this.TFlag = {',
  8706. ' "0": "big",',
  8707. ' big: 0,',
  8708. ' "1": "small",',
  8709. ' small: 1',
  8710. '};',
  8711. 'rtl.recNewT($mod, "TRec", function () {',
  8712. ' this.i = 0;',
  8713. ' this.$eq = function (b) {',
  8714. ' return this.i === b.i;',
  8715. ' };',
  8716. ' this.$assign = function (s) {',
  8717. ' this.i = s.i;',
  8718. ' return this;',
  8719. ' };',
  8720. '});',
  8721. 'this.ArrInt = [];',
  8722. 'this.ArrRec = [];',
  8723. 'this.ArrSet = [];',
  8724. 'this.ArrJSValue = [];',
  8725. 'this.ArrArrInt = [];',
  8726. '']),
  8727. LinesToStr([ // $mod.$main
  8728. '$mod.ArrInt.splice(2, 0, 1);',
  8729. '$mod.ArrInt.splice(4, 0, $mod.ArrInt[3]);',
  8730. '$mod.ArrRec.splice(6, 0, $mod.ArrRec[5]);',
  8731. '$mod.ArrSet.splice(7, 0, $mod.ArrSet[7]);',
  8732. '$mod.ArrJSValue.splice(9, 0, $mod.ArrJSValue[8]);',
  8733. '$mod.ArrJSValue.splice(11, 0, 10);',
  8734. '$mod.ArrArrInt.splice(22, 0, [23]);',
  8735. '$mod.ArrInt.splice(12, 13);',
  8736. '$mod.ArrRec.splice(14, 15);',
  8737. '$mod.ArrSet.splice(17, 18);',
  8738. '$mod.ArrJSValue.splice(19, 10);',
  8739. '']));
  8740. end;
  8741. procedure TTestModule.TestArray_DynArrayConstObjFPC;
  8742. begin
  8743. StartProgram(false);
  8744. Add([
  8745. '{$modeswitch arrayoperators}',
  8746. 'type',
  8747. ' integer = longint;',
  8748. ' TArrInt = array of integer;',
  8749. ' TArrStr = array of string;',
  8750. 'const',
  8751. ' Ints: TArrInt = (1,2,3);',
  8752. ' Aliases: TarrStr = (''foo'',''b'');',
  8753. ' OneInt: TArrInt = (7);',
  8754. ' OneStr: array of integer = (7);',
  8755. ' Chars: array of char = ''aoc'';',
  8756. ' Names: array of string = (''a'',''foo'');',
  8757. ' NameCount = low(Names)+high(Names)+length(Names);',
  8758. 'var i: integer;',
  8759. 'begin',
  8760. ' Ints:=[];',
  8761. ' Ints:=[1,1];',
  8762. ' Ints:=[1]+[2];',
  8763. ' Ints:=[2];',
  8764. ' Ints:=[]+ints;',
  8765. ' Ints:=Ints+[];',
  8766. ' Ints:=Ints+OneInt;',
  8767. ' Ints:=Ints+[1,1];',
  8768. ' Ints:=[i,i]+Ints;',
  8769. ' Ints:=[1]+[i]+[3];',
  8770. '']);
  8771. ConvertProgram;
  8772. CheckSource('TestArray_DynArrayConstObjFPC',
  8773. LinesToStr([ // statements
  8774. 'this.Ints = [1, 2, 3];',
  8775. 'this.Aliases = ["foo", "b"];',
  8776. 'this.OneInt = [7];',
  8777. 'this.OneStr = [7];',
  8778. 'this.Chars = ["a", "o", "c"];',
  8779. 'this.Names = ["a", "foo"];',
  8780. 'this.NameCount = 0 + (rtl.length($mod.Names) - 1) + rtl.length($mod.Names);',
  8781. 'this.i = 0;',
  8782. '']),
  8783. LinesToStr([ // $mod.$main
  8784. '$mod.Ints = [];',
  8785. '$mod.Ints = [1, 1];',
  8786. '$mod.Ints = rtl.arrayConcatN([1], [2]);',
  8787. '$mod.Ints = [2];',
  8788. '$mod.Ints = rtl.arrayConcatN([], $mod.Ints);',
  8789. '$mod.Ints = rtl.arrayConcatN($mod.Ints, []);',
  8790. '$mod.Ints = rtl.arrayConcatN($mod.Ints, $mod.OneInt);',
  8791. '$mod.Ints = rtl.arrayConcatN($mod.Ints, [1, 1]);',
  8792. '$mod.Ints = rtl.arrayConcatN([$mod.i, $mod.i], $mod.Ints);',
  8793. '$mod.Ints = rtl.arrayConcatN(rtl.arrayConcatN([1], [$mod.i]), [3]);',
  8794. '']));
  8795. end;
  8796. procedure TTestModule.TestArray_DynArrayConstDelphi;
  8797. begin
  8798. StartProgram(false);
  8799. // Note: const c = [1,1]; defines a set!
  8800. Add([
  8801. '{$mode delphi}',
  8802. 'type',
  8803. ' integer = longint;',
  8804. ' TArrInt = array of integer;',
  8805. ' TArrStr = array of string;',
  8806. 'const',
  8807. ' Ints: TArrInt = [1,1,2];',
  8808. ' Aliases: TarrStr = [''foo'',''b''];',
  8809. ' OneInt: TArrInt = [7];',
  8810. ' OneStr: array of integer = [7]+[8];',
  8811. ' Chars: array of char = ''aoc'';',
  8812. ' Names: array of string = [''a'',''a''];',
  8813. ' NameCount = low(Names)+high(Names)+length(Names);',
  8814. 'begin',
  8815. '']);
  8816. ConvertProgram;
  8817. CheckSource('TestArray_DynArrayConstDelphi',
  8818. LinesToStr([ // statements
  8819. 'this.Ints = [1, 1, 2];',
  8820. 'this.Aliases = ["foo", "b"];',
  8821. 'this.OneInt = [7];',
  8822. 'this.OneStr = rtl.arrayConcatN([7],[8]);',
  8823. 'this.Chars = ["a", "o", "c"];',
  8824. 'this.Names = ["a", "a"];',
  8825. 'this.NameCount = 0 + (rtl.length($mod.Names) - 1) + rtl.length($mod.Names);',
  8826. '']),
  8827. LinesToStr([ // $mod.$main
  8828. '']));
  8829. end;
  8830. procedure TTestModule.TestArray_ArrayLitAsParam;
  8831. begin
  8832. StartProgram(false);
  8833. Add([
  8834. '{$modeswitch arrayoperators}',
  8835. 'type',
  8836. ' integer = longint;',
  8837. ' TArrInt = array of integer;',
  8838. ' TArrSet = array of (red,green,blue);',
  8839. 'procedure DoOpenInt(a: array of integer); forward;',
  8840. 'procedure DoInt(a: TArrInt);',
  8841. 'begin',
  8842. ' DoInt(a+[1]);',
  8843. ' DoInt([1]+a);',
  8844. ' DoOpenInt(a);',
  8845. ' DoOpenInt(a+[1]);',
  8846. ' DoOpenInt([1]+a);',
  8847. 'end;',
  8848. 'procedure DoOpenInt(a: array of integer);',
  8849. 'begin',
  8850. ' DoOpenInt(a+[1]);',
  8851. ' DoOpenInt([1]+a);',
  8852. ' DoInt(a);',
  8853. ' DoInt(a+[1]);',
  8854. ' DoInt([1]+a);',
  8855. 'end;',
  8856. 'procedure DoSet(a: TArrSet);',
  8857. 'begin',
  8858. ' DoSet(a+[red]);',
  8859. ' DoSet([blue]+a);',
  8860. 'end;',
  8861. 'var',
  8862. ' i: TArrInt;',
  8863. ' s: TArrSet;',
  8864. 'begin',
  8865. ' DoInt([1]);',
  8866. ' DoInt([1]+[2]);',
  8867. ' DoInt(i+[1]);',
  8868. ' DoInt([1]+i);',
  8869. ' DoOpenInt([1]);',
  8870. ' DoOpenInt([1]+[2]);',
  8871. ' DoOpenInt(i+[1]);',
  8872. ' DoOpenInt([1]+i);',
  8873. ' DoSet([red]);',
  8874. ' DoSet([blue]+[green]);',
  8875. ' DoSet(s+[blue]);',
  8876. ' DoSet([red]+s);',
  8877. '']);
  8878. ConvertProgram;
  8879. CheckSource('TestArray_ArrayLitAsParam',
  8880. LinesToStr([ // statements
  8881. 'this.TArrSet$a = {',
  8882. ' "0": "red",',
  8883. ' red: 0,',
  8884. ' "1": "green",',
  8885. ' green: 1,',
  8886. ' "2": "blue",',
  8887. ' blue: 2',
  8888. '};',
  8889. 'this.DoInt = function (a) {',
  8890. ' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
  8891. ' $mod.DoInt(rtl.arrayConcatN([1], a));',
  8892. ' $mod.DoOpenInt(a);',
  8893. ' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
  8894. ' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
  8895. '};',
  8896. 'this.DoOpenInt = function (a) {',
  8897. ' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
  8898. ' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
  8899. ' $mod.DoInt(a);',
  8900. ' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
  8901. ' $mod.DoInt(rtl.arrayConcatN([1], a));',
  8902. '};',
  8903. 'this.DoSet = function (a) {',
  8904. ' $mod.DoSet(rtl.arrayConcatN(a, [$mod.TArrSet$a.red]));',
  8905. ' $mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], a));',
  8906. '};',
  8907. 'this.i = [];',
  8908. 'this.s = [];',
  8909. '']),
  8910. LinesToStr([ // $mod.$main
  8911. '$mod.DoInt([1]);',
  8912. '$mod.DoInt(rtl.arrayConcatN([1], [2]));',
  8913. '$mod.DoInt(rtl.arrayConcatN($mod.i, [1]));',
  8914. '$mod.DoInt(rtl.arrayConcatN([1], $mod.i));',
  8915. '$mod.DoOpenInt([1]);',
  8916. '$mod.DoOpenInt(rtl.arrayConcatN([1], [2]));',
  8917. '$mod.DoOpenInt(rtl.arrayConcatN($mod.i, [1]));',
  8918. '$mod.DoOpenInt(rtl.arrayConcatN([1], $mod.i));',
  8919. '$mod.DoSet([$mod.TArrSet$a.red]);',
  8920. '$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], [$mod.TArrSet$a.green]));',
  8921. '$mod.DoSet(rtl.arrayConcatN($mod.s, [$mod.TArrSet$a.blue]));',
  8922. '$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.red], $mod.s));',
  8923. '']));
  8924. end;
  8925. procedure TTestModule.TestArray_ArrayLitMultiDimAsParam;
  8926. begin
  8927. StartProgram(false);
  8928. Add([
  8929. '{$modeswitch arrayoperators}',
  8930. 'type',
  8931. ' integer = longint;',
  8932. ' TArrInt = array of integer;',
  8933. ' TArrArrInt = array of TArrInt;',
  8934. 'procedure DoInt(a: TArrArrInt);',
  8935. 'begin',
  8936. ' DoInt(a+[[1]]);',
  8937. ' DoInt([[1]]+a);',
  8938. ' DoInt(a);',
  8939. 'end;',
  8940. 'var',
  8941. ' i: TArrInt;',
  8942. ' a: TArrArrInt;',
  8943. 'begin',
  8944. ' a:=[[1]];',
  8945. ' a:=[i];',
  8946. ' a:=a+[i];',
  8947. ' a:=[i]+a;',
  8948. ' a:=[[1]+i];',
  8949. ' a:=[[1]+[2]];',
  8950. ' a:=[i+[2]];',
  8951. ' DoInt([[1]]);',
  8952. ' DoInt([[1]+[2],[3,4],[5]]);',
  8953. ' DoInt([i+[1]]+a);',
  8954. ' DoInt([i]+a);',
  8955. '']);
  8956. ConvertProgram;
  8957. CheckSource('TestArray_ArrayLitMultiDimAsParam',
  8958. LinesToStr([ // statements
  8959. 'this.DoInt = function (a) {',
  8960. ' $mod.DoInt(rtl.arrayConcatN(a, [[1]]));',
  8961. ' $mod.DoInt(rtl.arrayConcatN([[1]], a));',
  8962. ' $mod.DoInt(a);',
  8963. '};',
  8964. 'this.i = [];',
  8965. 'this.a = [];',
  8966. '']),
  8967. LinesToStr([ // $mod.$main
  8968. '$mod.a = [[1]];',
  8969. '$mod.a = [$mod.i];',
  8970. '$mod.a = rtl.arrayConcatN($mod.a, [$mod.i]);',
  8971. '$mod.a = rtl.arrayConcatN([$mod.i], $mod.a);',
  8972. '$mod.a = [rtl.arrayConcatN([1], $mod.i)];',
  8973. '$mod.a = [rtl.arrayConcatN([1], [2])];',
  8974. '$mod.a = [rtl.arrayConcatN($mod.i, [2])];',
  8975. '$mod.DoInt([[1]]);',
  8976. '$mod.DoInt([rtl.arrayConcatN([1], [2]), [3, 4], [5]]);',
  8977. '$mod.DoInt(rtl.arrayConcatN([rtl.arrayConcatN($mod.i, [1])], $mod.a));',
  8978. '$mod.DoInt(rtl.arrayConcatN([$mod.i], $mod.a));',
  8979. '']));
  8980. end;
  8981. procedure TTestModule.TestArray_ArrayLitStaticAsParam;
  8982. begin
  8983. StartProgram(false);
  8984. Add([
  8985. '{$modeswitch arrayoperators}',
  8986. 'type',
  8987. ' integer = longint;',
  8988. ' TArrInt = array[1..2] of integer;',
  8989. ' TArrArrInt = array of TArrInt;',
  8990. 'procedure DoInt(a: TArrArrInt);',
  8991. 'begin',
  8992. ' DoInt(a+[[1,2]]);',
  8993. ' DoInt([[1,2]]+a);',
  8994. ' DoInt(a);',
  8995. 'end;',
  8996. 'var',
  8997. ' i: TArrInt;',
  8998. ' a: TArrArrInt;',
  8999. 'begin',
  9000. ' a:=[[1,1]];',
  9001. ' a:=[i];',
  9002. ' a:=a+[i];',
  9003. ' a:=[i]+a;',
  9004. ' DoInt([[1,1]]);',
  9005. ' DoInt([[1,2],[3,4]]);',
  9006. '']);
  9007. ConvertProgram;
  9008. CheckSource('TestArray_ArrayLitStaticAsParam',
  9009. LinesToStr([ // statements
  9010. 'this.DoInt = function (a) {',
  9011. ' $mod.DoInt(rtl.arrayConcatN(a, [[1, 2]]));',
  9012. ' $mod.DoInt(rtl.arrayConcatN([[1, 2]], a));',
  9013. ' $mod.DoInt(a);',
  9014. '};',
  9015. 'this.i = rtl.arraySetLength(null, 0, 2);',
  9016. 'this.a = [];',
  9017. '']),
  9018. LinesToStr([ // $mod.$main
  9019. '$mod.a = [[1, 1]];',
  9020. '$mod.a = [$mod.i.slice(0)];',
  9021. '$mod.a = rtl.arrayConcatN($mod.a, [$mod.i.slice(0)]);',
  9022. '$mod.a = rtl.arrayConcatN([$mod.i.slice(0)], $mod.a);',
  9023. '$mod.DoInt([[1, 1]]);',
  9024. '$mod.DoInt([[1, 2], [3, 4]]);',
  9025. '']));
  9026. end;
  9027. procedure TTestModule.TestArray_ForInArrOfString;
  9028. begin
  9029. StartProgram(false);
  9030. Add([
  9031. 'type',
  9032. 'type',
  9033. ' TMonthNameArray = array [1..12] of string;',
  9034. ' TMonthNames = TMonthNameArray;',
  9035. ' TObject = class',
  9036. ' private',
  9037. ' function GetLongMonthNames: TMonthNames; virtual; abstract;',
  9038. ' public',
  9039. ' Property LongMonthNames : TMonthNames Read GetLongMonthNames;',
  9040. ' end;',
  9041. 'var f: TObject;',
  9042. ' Month: string;',
  9043. 'begin',
  9044. ' for Month in f.LongMonthNames do ;',
  9045. '']);
  9046. ConvertProgram;
  9047. CheckSource('TestArray_ForInArrOfString',
  9048. LinesToStr([ // statements
  9049. 'rtl.createClass($mod, "TObject", null, function () {',
  9050. ' this.$init = function () {',
  9051. ' };',
  9052. ' this.$final = function () {',
  9053. ' };',
  9054. '});',
  9055. 'this.f = null;',
  9056. 'this.Month = "";',
  9057. '']),
  9058. LinesToStr([ // $mod.$main
  9059. 'for (var $in1 = $mod.f.GetLongMonthNames(), $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.Month = $in1[$l2];',
  9060. '']));
  9061. end;
  9062. procedure TTestModule.TestExternalClass_TypeCastArrayToExternalClass;
  9063. begin
  9064. StartProgram(false);
  9065. Add([
  9066. '{$modeswitch externalclass}',
  9067. 'type',
  9068. ' TJSObject = class external name ''Object''',
  9069. ' end;',
  9070. ' TJSArray = class external name ''Array''',
  9071. ' class function isArray(Value: JSValue) : boolean;',
  9072. ' function concat() : TJSArray; varargs;',
  9073. ' end;',
  9074. 'var',
  9075. ' aObj: TJSArray;',
  9076. ' a: array of longint;',
  9077. ' o: TJSObject;',
  9078. 'begin',
  9079. ' if TJSArray.isArray(65) then ;',
  9080. ' aObj:=TJSArray(a).concat(a);',
  9081. ' o:=TJSObject(a);']);
  9082. ConvertProgram;
  9083. CheckSource('TestExternalClass_TypeCastArrayToExternalClass',
  9084. LinesToStr([ // statements
  9085. 'this.aObj = null;',
  9086. 'this.a = [];',
  9087. 'this.o = null;',
  9088. '']),
  9089. LinesToStr([ // $mod.$main
  9090. 'if (Array.isArray(65)) ;',
  9091. '$mod.aObj = $mod.a.concat($mod.a);',
  9092. '$mod.o = $mod.a;',
  9093. '']));
  9094. end;
  9095. procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalClass;
  9096. begin
  9097. StartProgram(false);
  9098. Add([
  9099. '{$modeswitch externalclass}',
  9100. 'type',
  9101. ' TArrStr = array of string;',
  9102. ' TJSArray = class external name ''Array''',
  9103. ' end;',
  9104. ' TJSObject = class external name ''Object''',
  9105. ' end;',
  9106. 'var',
  9107. ' aObj: TJSArray;',
  9108. ' a: TArrStr;',
  9109. ' jo: TJSObject;',
  9110. 'begin',
  9111. ' a:=TArrStr(aObj);',
  9112. ' TArrStr(aObj)[1]:=TArrStr(aObj)[2];',
  9113. ' a:=TarrStr(jo);',
  9114. '']);
  9115. ConvertProgram;
  9116. CheckSource('TestExternalClass_TypeCastArrayFromExternalClass',
  9117. LinesToStr([ // statements
  9118. 'this.aObj = null;',
  9119. 'this.a = [];',
  9120. 'this.jo = null;',
  9121. '']),
  9122. LinesToStr([ // $mod.$main
  9123. '$mod.a = $mod.aObj;',
  9124. '$mod.aObj[1] = $mod.aObj[2];',
  9125. '$mod.a = $mod.jo;',
  9126. '']));
  9127. end;
  9128. procedure TTestModule.TestRecord_Empty;
  9129. begin
  9130. StartProgram(false);
  9131. Add(['type',
  9132. ' TRecA = record',
  9133. ' end;',
  9134. 'var a,b: TRecA;',
  9135. 'begin',
  9136. ' if a=b then ;']);
  9137. ConvertProgram;
  9138. CheckSource('TestRecord_Empty',
  9139. LinesToStr([ // statements
  9140. 'rtl.recNewT($mod, "TRecA", function () {',
  9141. ' this.$eq = function (b) {',
  9142. ' return true;',
  9143. ' };',
  9144. ' this.$assign = function (s) {',
  9145. ' return this;',
  9146. ' };',
  9147. '});',
  9148. 'this.a = $mod.TRecA.$new();',
  9149. 'this.b = $mod.TRecA.$new();',
  9150. '']),
  9151. LinesToStr([ // $mod.$main
  9152. 'if ($mod.a.$eq($mod.b)) ;'
  9153. ]));
  9154. end;
  9155. procedure TTestModule.TestRecord_Var;
  9156. begin
  9157. StartProgram(false);
  9158. Add('type');
  9159. Add(' TRecA = record');
  9160. Add(' Bold: longint;');
  9161. Add(' end;');
  9162. Add('var Rec: TRecA;');
  9163. Add('begin');
  9164. Add(' rec.bold:=123');
  9165. ConvertProgram;
  9166. CheckSource('TestRecord_Var',
  9167. LinesToStr([ // statements
  9168. 'rtl.recNewT($mod, "TRecA", function () {',
  9169. ' this.Bold = 0;',
  9170. ' this.$eq = function (b) {',
  9171. ' return this.Bold === b.Bold;',
  9172. ' };',
  9173. ' this.$assign = function (s) {',
  9174. ' this.Bold = s.Bold;',
  9175. ' return this;',
  9176. ' };',
  9177. '});',
  9178. 'this.Rec = $mod.TRecA.$new();',
  9179. '']),
  9180. LinesToStr([ // $mod.$main
  9181. '$mod.Rec.Bold = 123;'
  9182. ]));
  9183. end;
  9184. procedure TTestModule.TestRecord_VarExternal;
  9185. begin
  9186. StartProgram(false);
  9187. Add([
  9188. '{$modeswitch externalclass}',
  9189. 'type',
  9190. ' TRecA = record',
  9191. ' i: byte;',
  9192. ' length_: longint external name ''length'';',
  9193. ' end;',
  9194. 'var Rec: TRecA;',
  9195. 'begin',
  9196. ' rec.length_ := rec.length_',
  9197. '']);
  9198. ConvertProgram;
  9199. CheckSource('TestRecord_VarExternal',
  9200. LinesToStr([ // statements
  9201. 'rtl.recNewT($mod, "TRecA", function () {',
  9202. ' this.i = 0;',
  9203. ' this.$eq = function (b) {',
  9204. ' return (this.i === b.i) && (this.length === b.length);',
  9205. ' };',
  9206. ' this.$assign = function (s) {',
  9207. ' this.i = s.i;',
  9208. ' this.length = s.length;',
  9209. ' return this;',
  9210. ' };',
  9211. '});',
  9212. 'this.Rec = $mod.TRecA.$new();',
  9213. '']),
  9214. LinesToStr([ // $mod.$main
  9215. '$mod.Rec.length = $mod.Rec.length;'
  9216. ]));
  9217. end;
  9218. procedure TTestModule.TestRecord_WithDo;
  9219. begin
  9220. StartProgram(false);
  9221. Add('type');
  9222. Add(' TRec = record');
  9223. Add(' vI: longint;');
  9224. Add(' end;');
  9225. Add('var');
  9226. Add(' Int: longint;');
  9227. Add(' r: TRec;');
  9228. Add('begin');
  9229. Add(' with r do');
  9230. Add(' int:=vi;');
  9231. Add(' with r do begin');
  9232. Add(' int:=vi;');
  9233. Add(' vi:=int;');
  9234. Add(' end;');
  9235. ConvertProgram;
  9236. CheckSource('TestWithRecordDo',
  9237. LinesToStr([ // statements
  9238. 'rtl.recNewT($mod, "TRec", function () {',
  9239. ' this.vI = 0;',
  9240. ' this.$eq = function (b) {',
  9241. ' return this.vI === b.vI;',
  9242. ' };',
  9243. ' this.$assign = function (s) {',
  9244. ' this.vI = s.vI;',
  9245. ' return this;',
  9246. ' };',
  9247. '});',
  9248. 'this.Int = 0;',
  9249. 'this.r = $mod.TRec.$new();',
  9250. '']),
  9251. LinesToStr([ // $mod.$main
  9252. 'var $with1 = $mod.r;',
  9253. '$mod.Int = $with1.vI;',
  9254. 'var $with2 = $mod.r;',
  9255. '$mod.Int = $with2.vI;',
  9256. '$with2.vI = $mod.Int;'
  9257. ]));
  9258. end;
  9259. procedure TTestModule.TestRecord_Assign;
  9260. begin
  9261. StartProgram(false);
  9262. Add('type');
  9263. Add(' TEnum = (red,green);');
  9264. Add(' TEnums = set of TEnum;');
  9265. Add(' TSmallRec = record');
  9266. Add(' N: longint;');
  9267. Add(' end;');
  9268. Add(' TBigRec = record');
  9269. Add(' Int: longint;');
  9270. Add(' D: double;');
  9271. Add(' Arr: array of longint;');
  9272. Add(' Arr2: array[1..2] of longint;');
  9273. Add(' Small: TSmallRec;');
  9274. Add(' Enums: TEnums;');
  9275. Add(' end;');
  9276. Add('var');
  9277. Add(' r, s: TBigRec;');
  9278. Add('begin');
  9279. Add(' r:=s;');
  9280. Add(' r:=default(TBigRec);');
  9281. Add(' r:=default(s);');
  9282. ConvertProgram;
  9283. CheckSource('TestRecord_Assign',
  9284. LinesToStr([ // statements
  9285. 'this.TEnum = {',
  9286. ' "0": "red",',
  9287. ' red: 0,',
  9288. ' "1": "green",',
  9289. ' green: 1',
  9290. '};',
  9291. 'rtl.recNewT($mod, "TSmallRec", function () {',
  9292. ' this.N = 0;',
  9293. ' this.$eq = function (b) {',
  9294. ' return this.N === b.N;',
  9295. ' };',
  9296. ' this.$assign = function (s) {',
  9297. ' this.N = s.N;',
  9298. ' return this;',
  9299. ' };',
  9300. '});',
  9301. 'rtl.recNewT($mod, "TBigRec", function () {',
  9302. ' this.Int = 0;',
  9303. ' this.D = 0.0;',
  9304. ' this.Arr = [];',
  9305. ' this.$new = function () {',
  9306. ' var r = Object.create(this);',
  9307. ' r.Arr2 = rtl.arraySetLength(null, 0, 2);',
  9308. ' r.Small = $mod.TSmallRec.$new();',
  9309. ' r.Enums = {};',
  9310. ' return r;',
  9311. ' };',
  9312. ' this.$eq = function (b) {',
  9313. ' return (this.Int === b.Int) && (this.D === b.D) && (this.Arr === b.Arr) && rtl.arrayEq(this.Arr2, b.Arr2) && this.Small.$eq(b.Small) && rtl.eqSet(this.Enums, b.Enums);',
  9314. ' };',
  9315. ' this.$assign = function (s) {',
  9316. ' this.Int = s.Int;',
  9317. ' this.D = s.D;',
  9318. ' this.Arr = s.Arr;',
  9319. ' this.Arr2 = s.Arr2.slice(0);',
  9320. ' this.Small.$assign(s.Small);',
  9321. ' this.Enums = rtl.refSet(s.Enums);',
  9322. ' return this;',
  9323. ' };',
  9324. '});',
  9325. 'this.r = $mod.TBigRec.$new();',
  9326. 'this.s = $mod.TBigRec.$new();',
  9327. '']),
  9328. LinesToStr([ // $mod.$main
  9329. '$mod.r.$assign($mod.s);',
  9330. '$mod.r.$assign($mod.TBigRec.$new());',
  9331. '$mod.r.$assign($mod.TBigRec.$new());',
  9332. '']));
  9333. end;
  9334. procedure TTestModule.TestRecord_AsParams;
  9335. begin
  9336. StartProgram(false);
  9337. Add([
  9338. 'type',
  9339. ' integer = longint;',
  9340. ' TRecord = record',
  9341. ' i: integer;',
  9342. ' end;',
  9343. 'procedure DoIt(vD: TRecord; const vC: TRecord; var vV: TRecord; var U);',
  9344. 'var vL: TRecord;',
  9345. 'begin',
  9346. ' vd:=vd;',
  9347. ' vd.i:=vd.i;',
  9348. ' vl:=vc;',
  9349. ' vv:=vv;',
  9350. ' vv.i:=vv.i;',
  9351. ' U:=vl;',
  9352. ' U:=vd;',
  9353. ' U:=vc;',
  9354. ' U:=vv;',
  9355. ' doit(vd,vd,vd,vd);',
  9356. ' doit(vc,vc,vl,vl);',
  9357. ' doit(vv,vv,vv,vv);',
  9358. ' doit(vl,vl,vl,vl);',
  9359. 'end;',
  9360. 'var i: TRecord;',
  9361. 'begin',
  9362. ' doit(i,i,i,i);']);
  9363. ConvertProgram;
  9364. CheckSource('TestRecord_AsParams',
  9365. LinesToStr([ // statements
  9366. 'rtl.recNewT($mod, "TRecord", function () {',
  9367. ' this.i = 0;',
  9368. ' this.$eq = function (b) {',
  9369. ' return this.i === b.i;',
  9370. ' };',
  9371. ' this.$assign = function (s) {',
  9372. ' this.i = s.i;',
  9373. ' return this;',
  9374. ' };',
  9375. '});',
  9376. 'this.DoIt = function (vD, vC, vV, U) {',
  9377. ' var vL = $mod.TRecord.$new();',
  9378. ' vD.$assign(vD);',
  9379. ' vD.i = vD.i;',
  9380. ' vL.$assign(vC);',
  9381. ' vV.$assign(vV);',
  9382. ' vV.i = vV.i;',
  9383. ' U.set(vL);',
  9384. ' U.set(vD);',
  9385. ' U.set(vC);',
  9386. ' U.set(vV);',
  9387. ' $mod.DoIt($mod.TRecord.$clone(vD), vD, vD, {',
  9388. ' get: function () {',
  9389. ' return vD;',
  9390. ' },',
  9391. ' set: function (v) {',
  9392. ' vD.$assign(v);',
  9393. ' }',
  9394. ' });',
  9395. ' $mod.DoIt($mod.TRecord.$clone(vC), vC, vL, {',
  9396. ' get: function () {',
  9397. ' return vL;',
  9398. ' },',
  9399. ' set: function (v) {',
  9400. ' vL.$assign(v);',
  9401. ' }',
  9402. ' });',
  9403. ' $mod.DoIt($mod.TRecord.$clone(vV), vV, vV, {',
  9404. ' get: function () {',
  9405. ' return vV;',
  9406. ' },',
  9407. ' set: function (v) {',
  9408. ' vV.$assign(v);',
  9409. ' }',
  9410. ' });',
  9411. ' $mod.DoIt($mod.TRecord.$clone(vL), vL, vL, {',
  9412. ' get: function () {',
  9413. ' return vL;',
  9414. ' },',
  9415. ' set: function (v) {',
  9416. ' vL.$assign(v);',
  9417. ' }',
  9418. ' });',
  9419. '};',
  9420. 'this.i = $mod.TRecord.$new();'
  9421. ]),
  9422. LinesToStr([
  9423. '$mod.DoIt($mod.TRecord.$clone($mod.i), $mod.i, $mod.i, {',
  9424. ' p: $mod,',
  9425. ' get: function () {',
  9426. ' return this.p.i;',
  9427. ' },',
  9428. ' set: function (v) {',
  9429. ' this.p.i.$assign(v);',
  9430. ' }',
  9431. '});',
  9432. '']));
  9433. end;
  9434. procedure TTestModule.TestRecordElement_AsParams;
  9435. begin
  9436. StartProgram(false);
  9437. Add('type');
  9438. Add(' integer = longint;');
  9439. Add(' TRecord = record');
  9440. Add(' i: integer;');
  9441. Add(' end;');
  9442. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  9443. Add('var vJ: TRecord;');
  9444. Add('begin');
  9445. Add(' doit(vj.i,vj.i,vj.i);');
  9446. Add('end;');
  9447. Add('var r: TRecord;');
  9448. Add('begin');
  9449. Add(' doit(r.i,r.i,r.i);');
  9450. ConvertProgram;
  9451. CheckSource('TestRecordElement_AsParams',
  9452. LinesToStr([ // statements
  9453. 'rtl.recNewT($mod, "TRecord", function () {',
  9454. ' this.i = 0;',
  9455. ' this.$eq = function (b) {',
  9456. ' return this.i === b.i;',
  9457. ' };',
  9458. ' this.$assign = function (s) {',
  9459. ' this.i = s.i;',
  9460. ' return this;',
  9461. ' };',
  9462. '});',
  9463. 'this.DoIt = function (vG,vH,vI) {',
  9464. ' var vJ = $mod.TRecord.$new();',
  9465. ' $mod.DoIt(vJ.i, vJ.i, {',
  9466. ' p: vJ,',
  9467. ' get: function () {',
  9468. ' return this.p.i;',
  9469. ' },',
  9470. ' set: function (v) {',
  9471. ' this.p.i = v;',
  9472. ' }',
  9473. ' });',
  9474. '};',
  9475. 'this.r = $mod.TRecord.$new();'
  9476. ]),
  9477. LinesToStr([
  9478. '$mod.DoIt($mod.r.i,$mod.r.i,{',
  9479. ' p: $mod.r,',
  9480. ' get: function () {',
  9481. ' return this.p.i;',
  9482. ' },',
  9483. ' set: function (v) {',
  9484. ' this.p.i = v;',
  9485. ' }',
  9486. '});'
  9487. ]));
  9488. end;
  9489. procedure TTestModule.TestRecordElementFromFuncResult_AsParams;
  9490. begin
  9491. StartProgram(false);
  9492. Add('type');
  9493. Add(' integer = longint;');
  9494. Add(' TRecord = record');
  9495. Add(' i: integer;');
  9496. Add(' end;');
  9497. Add('function GetRec(vB: integer = 0): TRecord;');
  9498. Add('begin');
  9499. Add('end;');
  9500. Add('procedure DoIt(vG: integer; const vH: integer);');
  9501. Add('begin');
  9502. Add('end;');
  9503. Add('begin');
  9504. Add(' doit(getrec.i,getrec.i);');
  9505. Add(' doit(getrec().i,getrec().i);');
  9506. Add(' doit(getrec(1).i,getrec(2).i);');
  9507. ConvertProgram;
  9508. CheckSource('TestRecordElementFromFuncResult_AsParams',
  9509. LinesToStr([ // statements
  9510. 'rtl.recNewT($mod, "TRecord", function () {',
  9511. ' this.i = 0;',
  9512. ' this.$eq = function (b) {',
  9513. ' return this.i === b.i;',
  9514. ' };',
  9515. ' this.$assign = function (s) {',
  9516. ' this.i = s.i;',
  9517. ' return this;',
  9518. ' };',
  9519. '});',
  9520. 'this.GetRec = function (vB) {',
  9521. ' var Result = $mod.TRecord.$new();',
  9522. ' return Result;',
  9523. '};',
  9524. 'this.DoIt = function (vG, vH) {',
  9525. '};',
  9526. '']),
  9527. LinesToStr([
  9528. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  9529. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  9530. '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);',
  9531. '']));
  9532. end;
  9533. procedure TTestModule.TestRecordElementFromWith_AsParams;
  9534. begin
  9535. StartProgram(false);
  9536. Add('type');
  9537. Add(' integer = longint;');
  9538. Add(' TRecord = record');
  9539. Add(' i: integer;');
  9540. Add(' end;');
  9541. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  9542. Add('begin');
  9543. Add('end;');
  9544. Add('var r: trecord;');
  9545. Add('begin');
  9546. Add(' with r do ');
  9547. Add(' doit(i,i,i);');
  9548. ConvertProgram;
  9549. CheckSource('TestRecordElementFromWith_AsParams',
  9550. LinesToStr([ // statements
  9551. 'rtl.recNewT($mod, "TRecord", function () {',
  9552. ' this.i = 0;',
  9553. ' this.$eq = function (b) {',
  9554. ' return this.i === b.i;',
  9555. ' };',
  9556. ' this.$assign = function (s) {',
  9557. ' this.i = s.i;',
  9558. ' return this;',
  9559. ' };',
  9560. '});',
  9561. 'this.DoIt = function (vG,vH,vI) {',
  9562. '};',
  9563. 'this.r = $mod.TRecord.$new();'
  9564. ]),
  9565. LinesToStr([
  9566. 'var $with1 = $mod.r;',
  9567. '$mod.DoIt($with1.i,$with1.i,{',
  9568. ' p: $with1,',
  9569. ' get: function () {',
  9570. ' return this.p.i;',
  9571. ' },',
  9572. ' set: function (v) {',
  9573. ' this.p.i = v;',
  9574. ' }',
  9575. '});',
  9576. '']));
  9577. end;
  9578. procedure TTestModule.TestRecord_Equal;
  9579. begin
  9580. StartProgram(false);
  9581. Add('type');
  9582. Add(' integer = longint;');
  9583. Add(' TFlag = (red,blue);');
  9584. Add(' TFlags = set of TFlag;');
  9585. Add(' TProc = procedure;');
  9586. Add(' TRecord = record');
  9587. Add(' i: integer;');
  9588. Add(' Event: TProc;');
  9589. Add(' f: TFlags;');
  9590. Add(' end;');
  9591. Add(' TNested = record');
  9592. Add(' r: TRecord;');
  9593. Add(' end;');
  9594. Add('var');
  9595. Add(' b: boolean;');
  9596. Add(' r,s: trecord;');
  9597. Add('begin');
  9598. Add(' b:=r=s;');
  9599. Add(' b:=r<>s;');
  9600. ConvertProgram;
  9601. CheckSource('TestRecord_Equal',
  9602. LinesToStr([ // statements
  9603. 'this.TFlag = {',
  9604. ' "0": "red",',
  9605. ' red: 0,',
  9606. ' "1": "blue",',
  9607. ' blue: 1',
  9608. '};',
  9609. 'rtl.recNewT($mod, "TRecord", function () {',
  9610. ' this.i = 0;',
  9611. ' this.Event = null;',
  9612. ' this.$new = function () {',
  9613. ' var r = Object.create(this);',
  9614. ' r.f = {};',
  9615. ' return r;',
  9616. ' };',
  9617. ' this.$eq = function (b) {',
  9618. ' return (this.i === b.i) && rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f);',
  9619. ' };',
  9620. ' this.$assign = function (s) {',
  9621. ' this.i = s.i;',
  9622. ' this.Event = s.Event;',
  9623. ' this.f = rtl.refSet(s.f);',
  9624. ' return this;',
  9625. ' };',
  9626. '});',
  9627. 'rtl.recNewT($mod, "TNested", function () {',
  9628. ' this.$new = function () {',
  9629. ' var r = Object.create(this);',
  9630. ' r.r = $mod.TRecord.$new();',
  9631. ' return r;',
  9632. ' };',
  9633. ' this.$eq = function (b) {',
  9634. ' return this.r.$eq(b.r);',
  9635. ' };',
  9636. ' this.$assign = function (s) {',
  9637. ' this.r.$assign(s.r);',
  9638. ' return this;',
  9639. ' };',
  9640. '});',
  9641. 'this.b = false;',
  9642. 'this.r = $mod.TRecord.$new();',
  9643. 'this.s = $mod.TRecord.$new();',
  9644. '']),
  9645. LinesToStr([
  9646. '$mod.b = $mod.r.$eq($mod.s);',
  9647. '$mod.b = !$mod.r.$eq($mod.s);',
  9648. '']));
  9649. end;
  9650. procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
  9651. begin
  9652. StartProgram(false);
  9653. Add('type');
  9654. Add(' TRecord = record');
  9655. Add(' i: longint;');
  9656. Add(' end;');
  9657. Add('var');
  9658. Add(' Jv: jsvalue;');
  9659. Add(' Rec: trecord;');
  9660. Add('begin');
  9661. Add(' rec:=trecord(jv);');
  9662. ConvertProgram;
  9663. CheckSource('TestRecord_TypeCastJSValueToRecord',
  9664. LinesToStr([ // statements
  9665. 'rtl.recNewT($mod, "TRecord", function () {',
  9666. ' this.i = 0;',
  9667. ' this.$eq = function (b) {',
  9668. ' return this.i === b.i;',
  9669. ' };',
  9670. ' this.$assign = function (s) {',
  9671. ' this.i = s.i;',
  9672. ' return this;',
  9673. ' };',
  9674. '});',
  9675. 'this.Jv = undefined;',
  9676. 'this.Rec = $mod.TRecord.$new();',
  9677. '']),
  9678. LinesToStr([
  9679. '$mod.Rec.$assign(rtl.getObject($mod.Jv));',
  9680. '']));
  9681. end;
  9682. procedure TTestModule.TestRecord_VariantFail;
  9683. begin
  9684. StartProgram(false);
  9685. Add([
  9686. 'type',
  9687. ' TRec = record',
  9688. ' case word of',
  9689. ' 0: (b0, b1: Byte);',
  9690. ' 1: (i: word);',
  9691. ' end;',
  9692. 'begin']);
  9693. SetExpectedPasResolverError('variant record is not supported',
  9694. nXIsNotSupported);
  9695. ConvertProgram;
  9696. end;
  9697. procedure TTestModule.TestRecord_FieldArray;
  9698. begin
  9699. StartProgram(false);
  9700. Add([
  9701. 'type',
  9702. ' TArrInt = array[3..4] of longint;',
  9703. ' TArrArrInt = array[3..4] of longint;',
  9704. ' TRec = record',
  9705. ' a: array of longint;',
  9706. ' s: array[1..2] of longint;',
  9707. ' m: array[1..2,3..4] of longint;',
  9708. ' o: TArrArrInt;',
  9709. ' end;',
  9710. 'begin']);
  9711. ConvertProgram;
  9712. CheckSource('TestRecord_FieldArray',
  9713. LinesToStr([ // statements
  9714. 'rtl.recNewT($mod, "TRec", function () {',
  9715. ' this.a = [];',
  9716. ' this.$new = function () {',
  9717. ' var r = Object.create(this);',
  9718. ' r.s = rtl.arraySetLength(null, 0, 2);',
  9719. ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
  9720. ' r.o = rtl.arraySetLength(null, 0, 2);',
  9721. ' return r;',
  9722. ' };',
  9723. ' this.$eq = function (b) {',
  9724. ' return (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && rtl.arrayEq(this.o, b.o);',
  9725. ' };',
  9726. ' this.$assign = function (s) {',
  9727. ' this.a = s.a;',
  9728. ' this.s = s.s.slice(0);',
  9729. ' this.m = s.m.slice(0);',
  9730. ' this.o = s.o.slice(0);',
  9731. ' return this;',
  9732. ' };',
  9733. '});',
  9734. '']),
  9735. LinesToStr([ // $mod.$main
  9736. '']));
  9737. end;
  9738. procedure TTestModule.TestRecord_Const;
  9739. begin
  9740. StartProgram(false);
  9741. Add([
  9742. 'type',
  9743. ' TArrInt = array[3..4] of longint;',
  9744. ' TPoint = record x,y: longint; end;',
  9745. ' TRec = record',
  9746. ' i: longint;',
  9747. ' a: array of longint;',
  9748. ' s: array[1..2] of longint;',
  9749. ' m: array[1..2,3..4] of longint;',
  9750. ' p: TPoint;',
  9751. ' end;',
  9752. ' TPoints = array of TPoint;',
  9753. 'const',
  9754. ' r: TRec = (',
  9755. ' i:1;',
  9756. ' a:(2,3);',
  9757. ' s:(4,5);',
  9758. ' m:( (11,12), (13,14) );',
  9759. ' p: (x:21; y:22)',
  9760. ' );',
  9761. ' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
  9762. 'begin']);
  9763. ConvertProgram;
  9764. CheckSource('TestRecord_Const',
  9765. LinesToStr([ // statements
  9766. 'rtl.recNewT($mod, "TPoint", function () {',
  9767. ' this.x = 0;',
  9768. ' this.y = 0;',
  9769. ' this.$eq = function (b) {',
  9770. ' return (this.x === b.x) && (this.y === b.y);',
  9771. ' };',
  9772. ' this.$assign = function (s) {',
  9773. ' this.x = s.x;',
  9774. ' this.y = s.y;',
  9775. ' return this;',
  9776. ' };',
  9777. '});',
  9778. 'rtl.recNewT($mod, "TRec", function () {',
  9779. ' this.i = 0;',
  9780. ' this.a = [];',
  9781. ' this.$new = function () {',
  9782. ' var r = Object.create(this);',
  9783. ' r.s = rtl.arraySetLength(null, 0, 2);',
  9784. ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
  9785. ' r.p = $mod.TPoint.$new();',
  9786. ' return r;',
  9787. ' };',
  9788. ' this.$eq = function (b) {',
  9789. ' return (this.i === b.i) && (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && this.p.$eq(b.p);',
  9790. ' };',
  9791. ' this.$assign = function (s) {',
  9792. ' this.i = s.i;',
  9793. ' this.a = s.a;',
  9794. ' this.s = s.s.slice(0);',
  9795. ' this.m = s.m.slice(0);',
  9796. ' this.p.$assign(s.p);',
  9797. ' return this;',
  9798. ' };',
  9799. '});',
  9800. 'this.r = $mod.TRec.$clone({',
  9801. ' i: 1,',
  9802. ' a: [2, 3],',
  9803. ' s: [4, 5],',
  9804. ' m: [[11, 12], [13, 14]],',
  9805. ' p: $mod.TPoint.$clone({',
  9806. ' x: 21,',
  9807. ' y: 22',
  9808. ' })',
  9809. '});',
  9810. 'this.p = [$mod.TPoint.$clone({',
  9811. ' x: 1,',
  9812. ' y: 2',
  9813. '}), $mod.TPoint.$clone({',
  9814. ' x: 3,',
  9815. ' y: 4',
  9816. '})];',
  9817. '']),
  9818. LinesToStr([ // $mod.$main
  9819. '']));
  9820. end;
  9821. procedure TTestModule.TestRecord_TypecastFail;
  9822. begin
  9823. StartProgram(false);
  9824. Add([
  9825. 'type',
  9826. ' TPoint = record x,y: longint; end;',
  9827. ' TRec = record l: longint end;',
  9828. 'var p: TPoint;',
  9829. 'begin',
  9830. ' if TRec(p).l=2 then ;']);
  9831. SetExpectedPasResolverError('Illegal type conversion: "TPoint" to "record TRec"',
  9832. nIllegalTypeConversionTo);
  9833. ConvertProgram;
  9834. end;
  9835. procedure TTestModule.TestRecord_InFunction;
  9836. begin
  9837. StartProgram(false);
  9838. Add([
  9839. 'var TPoint: longint = 3;',
  9840. 'procedure DoIt;',
  9841. 'type',
  9842. ' TPoint = record x,y: longint; end;',
  9843. ' TPoints = array of TPoint;',
  9844. 'var',
  9845. ' r: TPoint;',
  9846. ' p: TPoints;',
  9847. 'begin',
  9848. ' SetLength(p,2);',
  9849. 'end;',
  9850. 'begin']);
  9851. ConvertProgram;
  9852. CheckSource('TestRecord_InFunction',
  9853. LinesToStr([ // statements
  9854. 'this.TPoint = 3;',
  9855. 'var TPoint$1 = rtl.recNewT(null, "", function () {',
  9856. ' this.x = 0;',
  9857. ' this.y = 0;',
  9858. ' this.$eq = function (b) {',
  9859. ' return (this.x === b.x) && (this.y === b.y);',
  9860. ' };',
  9861. ' this.$assign = function (s) {',
  9862. ' this.x = s.x;',
  9863. ' this.y = s.y;',
  9864. ' return this;',
  9865. ' };',
  9866. '});',
  9867. 'this.DoIt = function () {',
  9868. ' var r = TPoint$1.$new();',
  9869. ' var p = [];',
  9870. ' p = rtl.arraySetLength(p, TPoint$1, 2);',
  9871. '};',
  9872. '']),
  9873. LinesToStr([ // $mod.$main
  9874. '']));
  9875. end;
  9876. procedure TTestModule.TestAdvRecord_Function;
  9877. begin
  9878. StartProgram(false);
  9879. Parser.Options:=Parser.Options+[po_cassignments];
  9880. Add([
  9881. '{$modeswitch AdvancedRecords}',
  9882. 'type',
  9883. ' TPoint = record',
  9884. ' x,y: word;',
  9885. ' function Add(const apt: TPoint): TPoint;',
  9886. ' end;',
  9887. 'function TPoint.Add(const apt: TPoint): TPoint;',
  9888. 'begin',
  9889. ' Result:=Self;',
  9890. ' Result.x+=apt.x;',
  9891. ' Result.y:=Result.y+apt.y;',
  9892. ' Self:=apt;',
  9893. 'end;',
  9894. 'var p,q: TPoint;',
  9895. 'begin',
  9896. ' p.add(q);',
  9897. ' p:=default(TPoint);',
  9898. ' p:=q;',
  9899. '']);
  9900. ConvertProgram;
  9901. CheckSource('TestAdvRecord_Function',
  9902. LinesToStr([ // statements
  9903. 'rtl.recNewT($mod, "TPoint", function () {',
  9904. ' this.x = 0;',
  9905. ' this.y = 0;',
  9906. ' this.$eq = function (b) {',
  9907. ' return (this.x === b.x) && (this.y === b.y);',
  9908. ' };',
  9909. ' this.$assign = function (s) {',
  9910. ' this.x = s.x;',
  9911. ' this.y = s.y;',
  9912. ' return this;',
  9913. ' };',
  9914. ' this.Add = function (apt) {',
  9915. ' var Result = $mod.TPoint.$new();',
  9916. ' Result.$assign(this);',
  9917. ' Result.x += apt.x;',
  9918. ' Result.y = Result.y + apt.y;',
  9919. ' this.$assign(apt);',
  9920. ' return Result;',
  9921. ' };',
  9922. '});',
  9923. 'this.p = $mod.TPoint.$new();',
  9924. 'this.q = $mod.TPoint.$new();',
  9925. '']),
  9926. LinesToStr([ // $mod.$main
  9927. '$mod.p.Add($mod.q);',
  9928. '$mod.p.$assign($mod.TPoint.$new());',
  9929. '$mod.p.$assign($mod.q);',
  9930. '']));
  9931. end;
  9932. procedure TTestModule.TestAdvRecord_Property;
  9933. begin
  9934. StartProgram(false);
  9935. Add([
  9936. '{$modeswitch AdvancedRecords}',
  9937. 'type',
  9938. ' TPoint = record',
  9939. ' x,y: word;',
  9940. ' strict private',
  9941. ' function GetSize: longword;',
  9942. ' procedure SetSize(Value: longword);',
  9943. ' public',
  9944. ' property Size: longword read GetSize write SetSize;',
  9945. ' property Left: word read x write y;',
  9946. ' end;',
  9947. 'procedure SetSize(Value: longword); begin end;',// check auto rename
  9948. 'function TPoint.GetSize: longword;',
  9949. 'begin',
  9950. ' x:=y;',
  9951. ' Size:=Size;',
  9952. ' Left:=Left;',
  9953. 'end;',
  9954. 'procedure TPoint.SetSize(Value: longword);',
  9955. 'begin',
  9956. 'end;',
  9957. 'var p,q: TPoint;',
  9958. 'begin',
  9959. ' p.Size:=q.Size;',
  9960. ' p.Left:=q.Left;',
  9961. '']);
  9962. ConvertProgram;
  9963. CheckSource('TestAdvRecord_Property',
  9964. LinesToStr([ // statements
  9965. 'rtl.recNewT($mod, "TPoint", function () {',
  9966. ' this.x = 0;',
  9967. ' this.y = 0;',
  9968. ' this.$eq = function (b) {',
  9969. ' return (this.x === b.x) && (this.y === b.y);',
  9970. ' };',
  9971. ' this.$assign = function (s) {',
  9972. ' this.x = s.x;',
  9973. ' this.y = s.y;',
  9974. ' return this;',
  9975. ' };',
  9976. ' this.GetSize = function () {',
  9977. ' var Result = 0;',
  9978. ' this.x = this.y;',
  9979. ' this.SetSize(this.GetSize());',
  9980. ' this.y = this.x;',
  9981. ' return Result;',
  9982. ' };',
  9983. ' this.SetSize = function (Value) {',
  9984. ' };',
  9985. '});',
  9986. 'this.SetSize = function (Value) {',
  9987. '};',
  9988. 'this.p = $mod.TPoint.$new();',
  9989. 'this.q = $mod.TPoint.$new();',
  9990. '']),
  9991. LinesToStr([ // $mod.$main
  9992. '$mod.p.SetSize($mod.q.GetSize());',
  9993. '$mod.p.y = $mod.q.x;',
  9994. '']));
  9995. end;
  9996. procedure TTestModule.TestAdvRecord_PropertyDefault;
  9997. begin
  9998. StartProgram(false);
  9999. Add([
  10000. '{$modeswitch AdvancedRecords}',
  10001. 'type',
  10002. ' TPoint = record',
  10003. ' strict private',
  10004. ' function GetItems(Index: word): word;',
  10005. ' procedure SetItems(Index: word; Value: word);',
  10006. ' public',
  10007. ' property Items[Index: word]: word read GetItems write SetItems; default;',
  10008. ' end;',
  10009. 'function TPoint.GetItems(Index: word): word;',
  10010. 'begin',
  10011. ' Items[index]:=Items[index];',
  10012. ' self.Items[index]:=self.Items[index];',
  10013. 'end;',
  10014. 'procedure TPoint.SetItems(Index: word; Value: word);',
  10015. 'begin',
  10016. 'end;',
  10017. 'var p: TPoint;',
  10018. 'begin',
  10019. ' p[1]:=p[2];',
  10020. ' p.Items[3]:=p.Items[4];',
  10021. '']);
  10022. ConvertProgram;
  10023. CheckSource('TestAdvRecord_PropertyDefault',
  10024. LinesToStr([ // statements
  10025. 'rtl.recNewT($mod, "TPoint", function () {',
  10026. ' this.$eq = function (b) {',
  10027. ' return true;',
  10028. ' };',
  10029. ' this.$assign = function (s) {',
  10030. ' return this;',
  10031. ' };',
  10032. ' this.GetItems = function (Index) {',
  10033. ' var Result = 0;',
  10034. ' this.SetItems(Index, this.GetItems(Index));',
  10035. ' this.SetItems(Index, this.GetItems(Index));',
  10036. ' return Result;',
  10037. ' };',
  10038. ' this.SetItems = function (Index, Value) {',
  10039. ' };',
  10040. '});',
  10041. 'this.p = $mod.TPoint.$new();',
  10042. '']),
  10043. LinesToStr([ // $mod.$main
  10044. '$mod.p.SetItems(1, $mod.p.GetItems(2));',
  10045. '$mod.p.SetItems(3, $mod.p.GetItems(4));',
  10046. '']));
  10047. end;
  10048. procedure TTestModule.TestAdvRecord_Property_ClassMethod;
  10049. begin
  10050. StartProgram(false);
  10051. Add([
  10052. '{$modeswitch AdvancedRecords}',
  10053. 'type',
  10054. ' TRec = record',
  10055. ' class var Fx: longint;',
  10056. ' class var Fy: longint;',
  10057. ' class function GetInt: longint; static;',
  10058. ' class procedure SetInt(Value: longint); static;',
  10059. ' class procedure DoIt; static;',
  10060. ' class property IntA: longint read Fx write Fy;',
  10061. ' class property IntB: longint read GetInt write SetInt;',
  10062. ' end;',
  10063. 'class function trec.getint: longint;',
  10064. 'begin',
  10065. ' result:=fx;',
  10066. 'end;',
  10067. 'class procedure trec.setint(value: longint);',
  10068. 'begin',
  10069. 'end;',
  10070. 'class procedure trec.doit;',
  10071. 'begin',
  10072. ' IntA:=IntA+1;',
  10073. ' IntB:=IntB+1;',
  10074. 'end;',
  10075. 'var r: trec;',
  10076. 'begin',
  10077. ' trec.inta:=trec.inta+1;',
  10078. ' if trec.intb=2 then;',
  10079. ' trec.intb:=trec.intb+2;',
  10080. ' trec.setint(trec.inta);',
  10081. ' r.inta:=r.inta+1;',
  10082. ' if r.intb=2 then;',
  10083. ' r.intb:=r.intb+2;',
  10084. ' r.setint(r.inta);']);
  10085. ConvertProgram;
  10086. CheckSource('TestAdvRecord_Property_ClassMethod',
  10087. LinesToStr([ // statements
  10088. 'rtl.recNewT($mod, "TRec", function () {',
  10089. ' this.Fx = 0;',
  10090. ' this.Fy = 0;',
  10091. ' this.$eq = function (b) {',
  10092. ' return true;',
  10093. ' };',
  10094. ' this.$assign = function (s) {',
  10095. ' return this;',
  10096. ' };',
  10097. ' this.GetInt = function () {',
  10098. ' var Result = 0;',
  10099. ' Result = this.Fx;',
  10100. ' return Result;',
  10101. ' };',
  10102. ' this.SetInt = function (Value) {',
  10103. ' };',
  10104. ' this.DoIt = function () {',
  10105. ' $mod.TRec.Fy = this.Fx + 1;',
  10106. ' this.SetInt(this.GetInt() + 1);',
  10107. ' };',
  10108. '}, true);',
  10109. 'this.r = $mod.TRec.$new();',
  10110. '']),
  10111. LinesToStr([ // $mod.$main
  10112. '$mod.TRec.Fy = $mod.TRec.Fx + 1;',
  10113. 'if ($mod.TRec.GetInt() === 2) ;',
  10114. '$mod.TRec.SetInt($mod.TRec.GetInt() + 2);',
  10115. '$mod.TRec.SetInt($mod.TRec.Fx);',
  10116. '$mod.TRec.Fy = $mod.r.Fx + 1;',
  10117. 'if ($mod.r.$record.GetInt() === 2) ;',
  10118. '$mod.r.$record.SetInt($mod.r.$record.GetInt() + 2);',
  10119. '$mod.r.$record.SetInt($mod.r.Fx);',
  10120. '']));
  10121. end;
  10122. procedure TTestModule.TestAdvRecord_Const;
  10123. begin
  10124. StartProgram(false);
  10125. Add([
  10126. '{$modeswitch AdvancedRecords}',
  10127. 'type',
  10128. ' TArrInt = array[3..4] of longint;',
  10129. ' TPoint = record',
  10130. ' x,y: longint;',
  10131. ' class var Count: nativeint;',
  10132. ' end;',
  10133. ' TRec = record',
  10134. ' i: longint;',
  10135. ' a: array of longint;',
  10136. ' s: array[1..2] of longint;',
  10137. ' m: array[1..2,3..4] of longint;',
  10138. ' p: TPoint;',
  10139. ' end;',
  10140. ' TPoints = array of TPoint;',
  10141. 'const',
  10142. ' r: TRec = (',
  10143. ' i:1;',
  10144. ' a:(2,3);',
  10145. ' s:(4,5);',
  10146. ' m:( (11,12), (13,14) );',
  10147. ' p: (x:21)',
  10148. ' );',
  10149. ' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
  10150. 'begin']);
  10151. ConvertProgram;
  10152. CheckSource('TestAdvRecord_Const',
  10153. LinesToStr([ // statements
  10154. 'rtl.recNewT($mod, "TPoint", function () {',
  10155. ' this.x = 0;',
  10156. ' this.y = 0;',
  10157. ' this.Count = 0;',
  10158. ' this.$eq = function (b) {',
  10159. ' return (this.x === b.x) && (this.y === b.y);',
  10160. ' };',
  10161. ' this.$assign = function (s) {',
  10162. ' this.x = s.x;',
  10163. ' this.y = s.y;',
  10164. ' return this;',
  10165. ' };',
  10166. '}, true);',
  10167. 'rtl.recNewT($mod, "TRec", function () {',
  10168. ' this.i = 0;',
  10169. ' this.a = [];',
  10170. ' this.$new = function () {',
  10171. ' var r = Object.create(this);',
  10172. ' r.s = rtl.arraySetLength(null, 0, 2);',
  10173. ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
  10174. ' r.p = $mod.TPoint.$new();',
  10175. ' return r;',
  10176. ' };',
  10177. ' this.$eq = function (b) {',
  10178. ' return (this.i === b.i) && (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && this.p.$eq(b.p);',
  10179. ' };',
  10180. ' this.$assign = function (s) {',
  10181. ' this.i = s.i;',
  10182. ' this.a = s.a;',
  10183. ' this.s = s.s.slice(0);',
  10184. ' this.m = s.m.slice(0);',
  10185. ' this.p.$assign(s.p);',
  10186. ' return this;',
  10187. ' };',
  10188. '});',
  10189. 'this.r = $mod.TRec.$clone({',
  10190. ' i: 1,',
  10191. ' a: [2, 3],',
  10192. ' s: [4, 5],',
  10193. ' m: [[11, 12], [13, 14]],',
  10194. ' p: $mod.TPoint.$clone({',
  10195. ' x: 21,',
  10196. ' y: 0',
  10197. ' })',
  10198. '});',
  10199. 'this.p = [$mod.TPoint.$clone({',
  10200. ' x: 1,',
  10201. ' y: 2',
  10202. '}), $mod.TPoint.$clone({',
  10203. ' x: 3,',
  10204. ' y: 4',
  10205. '})];',
  10206. '']),
  10207. LinesToStr([ // $mod.$main
  10208. '']));
  10209. end;
  10210. procedure TTestModule.TestAdvRecord_ExternalField;
  10211. begin
  10212. StartProgram(false);
  10213. Add([
  10214. '{$modeswitch AdvancedRecords}',
  10215. '{$modeswitch externalclass}',
  10216. 'type',
  10217. ' TCar = record',
  10218. ' public',
  10219. ' Intern: longint external name ''$Intern'';',
  10220. ' Intern2: longint external name ''$Intern2'';',
  10221. ' Bracket: longint external name ''["A B"]'';',
  10222. ' procedure DoIt;',
  10223. ' end;',
  10224. 'implementation',
  10225. 'procedure tcar.doit;',
  10226. 'begin',
  10227. ' Intern:=Intern+1;',
  10228. ' Intern2:=Intern2+2;',
  10229. ' Bracket:=Bracket+3;',
  10230. 'end;',
  10231. 'var Rec: TCar = (intern: 11; intern2: 12; bracket: 13);',
  10232. 'begin',
  10233. ' Rec.intern:=Rec.intern+1;',
  10234. ' Rec.intern2:=Rec.intern2+2;',
  10235. ' Rec.Bracket:=Rec.Bracket+3;',
  10236. ' with Rec do begin',
  10237. ' intern:=intern+1;',
  10238. ' intern2:=intern2+2;',
  10239. ' Bracket:=Bracket+3;',
  10240. ' end;']);
  10241. ConvertProgram;
  10242. CheckSource('TestAdvRecord_ExternalField',
  10243. LinesToStr([ // statements
  10244. 'rtl.recNewT($mod, "TCar", function () {',
  10245. ' this.$eq = function (b) {',
  10246. ' return (this.$Intern === b.$Intern) && (this.$Intern2 === b.$Intern2) && (this["A B"] === b["A B"]);',
  10247. ' };',
  10248. ' this.$assign = function (s) {',
  10249. ' this.$Intern = s.$Intern;',
  10250. ' this.$Intern2 = s.$Intern2;',
  10251. ' this["A B"] = s["A B"];',
  10252. ' return this;',
  10253. ' };',
  10254. ' this.DoIt = function () {',
  10255. ' this.$Intern = this.$Intern + 1;',
  10256. ' this.$Intern2 = this.$Intern2 + 2;',
  10257. ' this["A B"] = this["A B"] + 3;',
  10258. ' };',
  10259. '});',
  10260. 'this.Rec = $mod.TCar.$clone({',
  10261. ' $Intern: 11,',
  10262. ' $Intern2: 12,',
  10263. ' "A B": 13',
  10264. '});',
  10265. '']),
  10266. LinesToStr([ // $mod.$main
  10267. '$mod.Rec.$Intern = $mod.Rec.$Intern + 1;',
  10268. '$mod.Rec.$Intern2 = $mod.Rec.$Intern2 + 2;',
  10269. '$mod.Rec["A B"] = $mod.Rec["A B"] + 3;',
  10270. 'var $with1 = $mod.Rec;',
  10271. '$with1.$Intern = $with1.$Intern + 1;',
  10272. '$with1.$Intern2 = $with1.$Intern2 + 2;',
  10273. '$with1["A B"] = $with1["A B"] + 3;',
  10274. '']));
  10275. end;
  10276. procedure TTestModule.TestAdvRecord_SubRecord;
  10277. begin
  10278. StartProgram(false);
  10279. Add([
  10280. '{$modeswitch AdvancedRecords}',
  10281. 'type',
  10282. ' TRec = record',
  10283. ' type',
  10284. ' TPoint = record',
  10285. ' x,y: longint;',
  10286. ' class var Count: nativeint;',
  10287. ' procedure DoIt;',
  10288. ' class procedure DoThat; static;',
  10289. ' end;',
  10290. ' var',
  10291. ' i: longint;',
  10292. ' p: TPoint;',
  10293. ' procedure DoSome;',
  10294. ' end;',
  10295. 'const',
  10296. ' r: TRec = (',
  10297. ' i:1;',
  10298. ' p: (x:21;y:22)',
  10299. ' );',
  10300. 'procedure TRec.DoSome;',
  10301. 'begin',
  10302. ' p.x:=p.y+1;',
  10303. ' p.Count:=p.Count+2;',
  10304. 'end;',
  10305. 'procedure TRec.TPoint.DoIt;',
  10306. 'begin',
  10307. ' Count:=Count+3;',
  10308. 'end;',
  10309. 'class procedure TRec.TPoint.DoThat;',
  10310. 'begin',
  10311. ' Count:=Count+4;',
  10312. 'end;',
  10313. 'begin']);
  10314. ConvertProgram;
  10315. CheckSource('TestAdvRecord_SubRecord',
  10316. LinesToStr([ // statements
  10317. 'rtl.recNewT($mod, "TRec", function () {',
  10318. ' rtl.recNewT(this, "TPoint", function () {',
  10319. ' this.x = 0;',
  10320. ' this.y = 0;',
  10321. ' this.Count = 0;',
  10322. ' this.$eq = function (b) {',
  10323. ' return (this.x === b.x) && (this.y === b.y);',
  10324. ' };',
  10325. ' this.$assign = function (s) {',
  10326. ' this.x = s.x;',
  10327. ' this.y = s.y;',
  10328. ' return this;',
  10329. ' };',
  10330. ' this.DoIt = function () {',
  10331. ' $mod.TRec.TPoint.Count = this.Count + 3;',
  10332. ' };',
  10333. ' this.DoThat = function () {',
  10334. ' $mod.TRec.TPoint.Count = this.Count + 4;',
  10335. ' };',
  10336. ' }, true);',
  10337. ' this.i = 0;',
  10338. ' this.$new = function () {',
  10339. ' var r = Object.create(this);',
  10340. ' r.p = this.TPoint.$new();',
  10341. ' return r;',
  10342. ' };',
  10343. ' this.$eq = function (b) {',
  10344. ' return (this.i === b.i) && this.p.$eq(b.p);',
  10345. ' };',
  10346. ' this.$assign = function (s) {',
  10347. ' this.i = s.i;',
  10348. ' this.p.$assign(s.p);',
  10349. ' return this;',
  10350. ' };',
  10351. ' this.DoSome = function () {',
  10352. ' this.p.x = this.p.y + 1;',
  10353. ' this.TPoint.Count = this.p.Count + 2;',
  10354. ' };',
  10355. '}, true);',
  10356. 'this.r = $mod.TRec.$clone({',
  10357. ' i: 1,',
  10358. ' p: $mod.TRec.TPoint.$clone({',
  10359. ' x: 21,',
  10360. ' y: 22',
  10361. ' })',
  10362. '});',
  10363. '']),
  10364. LinesToStr([ // $mod.$main
  10365. '']));
  10366. end;
  10367. procedure TTestModule.TestAdvRecord_SubClass;
  10368. begin
  10369. StartProgram(false);
  10370. Add([
  10371. '{$modeswitch AdvancedRecords}',
  10372. 'type',
  10373. ' TObject = class end;',
  10374. ' TPoint = record',
  10375. ' type',
  10376. ' TBird = class',
  10377. ' procedure DoIt;',
  10378. ' class procedure Glob;',
  10379. ' end;',
  10380. ' procedure DoIt(b: TBird);',
  10381. ' end;',
  10382. 'procedure TPoint.TBird.DoIt;',
  10383. 'begin',
  10384. ' doit;',
  10385. ' self.doit;',
  10386. ' glob;',
  10387. ' self.glob;',
  10388. 'end;',
  10389. 'class procedure TPoint.TBird.Glob;',
  10390. 'begin',
  10391. ' glob;',
  10392. ' self.glob;',
  10393. 'end;',
  10394. 'procedure TPoint.DoIt(b: TBird);',
  10395. 'begin',
  10396. ' b.doit;',
  10397. ' b.glob;',
  10398. ' TBird.glob;',
  10399. 'end;',
  10400. 'begin',
  10401. '']);
  10402. ConvertProgram;
  10403. CheckSource('TestAdvRecord_SubClass',
  10404. LinesToStr([ // statements
  10405. 'rtl.createClass($mod, "TObject", null, function () {',
  10406. ' this.$init = function () {',
  10407. ' };',
  10408. ' this.$final = function () {',
  10409. ' };',
  10410. '});',
  10411. 'rtl.recNewT($mod, "TPoint", function () {',
  10412. ' rtl.createClass(this, "TBird", $mod.TObject, function () {',
  10413. ' this.DoIt = function () {',
  10414. ' this.DoIt();',
  10415. ' this.DoIt();',
  10416. ' this.$class.Glob();',
  10417. ' this.$class.Glob();',
  10418. ' };',
  10419. ' this.Glob = function () {',
  10420. ' this.Glob();',
  10421. ' this.Glob();',
  10422. ' };',
  10423. ' });',
  10424. ' this.$eq = function (b) {',
  10425. ' return true;',
  10426. ' };',
  10427. ' this.$assign = function (s) {',
  10428. ' return this;',
  10429. ' };',
  10430. ' this.DoIt = function (b) {',
  10431. ' b.DoIt();',
  10432. ' b.$class.Glob();',
  10433. ' this.TBird.Glob();',
  10434. ' };',
  10435. '}, true);',
  10436. '']),
  10437. LinesToStr([ // $mod.$main
  10438. '']));
  10439. end;
  10440. procedure TTestModule.TestAdvRecord_SubInterfaceFail;
  10441. begin
  10442. StartProgram(false);
  10443. Add([
  10444. '{$modeswitch AdvancedRecords}',
  10445. 'type',
  10446. ' IUnknown = interface end;',
  10447. ' TPoint = record',
  10448. ' type IBird = interface end;',
  10449. ' end;',
  10450. 'begin',
  10451. '']);
  10452. SetExpectedPasResolverError('not yet implemented: IBird:TPasClassType [20190105143752] interface inside record',
  10453. nNotYetImplemented);
  10454. ParseProgram;
  10455. end;
  10456. procedure TTestModule.TestAdvRecord_Constructor;
  10457. begin
  10458. StartProgram(false);
  10459. Add([
  10460. '{$modeswitch AdvancedRecords}',
  10461. 'type',
  10462. ' TPoint = record',
  10463. ' x,y: longint;',
  10464. ' constructor Create(ax: longint; ay: longint = -1);',
  10465. ' end;',
  10466. 'constructor tpoint.create(ax,ay: longint);',
  10467. 'begin',
  10468. ' x:=ax;',
  10469. ' self.y:=ay;',
  10470. 'end;',
  10471. 'var r: TPoint;',
  10472. 'begin',
  10473. ' r:=TPoint.Create(1,2);',
  10474. ' r.Create(3);',
  10475. ' r:=r.Create(4);',
  10476. '']);
  10477. ConvertProgram;
  10478. CheckSource('TestAdvRecord_Constructor',
  10479. LinesToStr([ // statements
  10480. 'rtl.recNewT($mod, "TPoint", function () {',
  10481. ' this.x = 0;',
  10482. ' this.y = 0;',
  10483. ' this.$eq = function (b) {',
  10484. ' return (this.x === b.x) && (this.y === b.y);',
  10485. ' };',
  10486. ' this.$assign = function (s) {',
  10487. ' this.x = s.x;',
  10488. ' this.y = s.y;',
  10489. ' return this;',
  10490. ' };',
  10491. ' this.Create = function (ax, ay) {',
  10492. ' this.x = ax;',
  10493. ' this.y = ay;',
  10494. ' return this;',
  10495. ' };',
  10496. '}, true);',
  10497. 'this.r = $mod.TPoint.$new();',
  10498. '']),
  10499. LinesToStr([ // $mod.$main
  10500. '$mod.r.$assign($mod.TPoint.$create("Create", [1, 2]));',
  10501. '$mod.r.Create(3, -1);',
  10502. '$mod.r.$assign($mod.r.Create(4, -1));',
  10503. '']));
  10504. end;
  10505. procedure TTestModule.TestClass_TObjectDefaultConstructor;
  10506. begin
  10507. StartProgram(false);
  10508. Add(['type',
  10509. ' TObject = class',
  10510. ' public',
  10511. ' constructor Create;',
  10512. ' destructor Destroy;',
  10513. ' end;',
  10514. ' TBird = TObject;',
  10515. 'constructor tobject.create;',
  10516. 'begin end;',
  10517. 'destructor tobject.destroy;',
  10518. 'begin end;',
  10519. 'var Obj: tobject;',
  10520. 'begin',
  10521. ' obj:=tobject.create;',
  10522. ' obj:=tobject.create();',
  10523. ' obj:=tbird.create;',
  10524. ' obj:=tbird.create();',
  10525. ' obj:=obj.create();',
  10526. ' obj.destroy;',
  10527. '']);
  10528. ConvertProgram;
  10529. CheckSource('TestClass_TObjectDefaultConstructor',
  10530. LinesToStr([ // statements
  10531. 'rtl.createClass($mod,"TObject",null,function(){',
  10532. ' this.$init = function () {',
  10533. ' };',
  10534. ' this.$final = function () {',
  10535. ' };',
  10536. ' this.Create = function(){',
  10537. ' return this;',
  10538. ' };',
  10539. ' this.Destroy = function(){',
  10540. ' };',
  10541. '});',
  10542. 'this.Obj = null;'
  10543. ]),
  10544. LinesToStr([ // $mod.$main
  10545. '$mod.Obj = $mod.TObject.$create("Create");',
  10546. '$mod.Obj = $mod.TObject.$create("Create");',
  10547. '$mod.Obj = $mod.TObject.$create("Create");',
  10548. '$mod.Obj = $mod.TObject.$create("Create");',
  10549. '$mod.Obj = $mod.Obj.Create();',
  10550. '$mod.Obj.$destroy("Destroy");',
  10551. '']));
  10552. end;
  10553. procedure TTestModule.TestClass_TObjectConstructorWithParams;
  10554. begin
  10555. StartProgram(false);
  10556. Add('type');
  10557. Add(' TObject = class');
  10558. Add(' public');
  10559. Add(' constructor Create(Par: longint);');
  10560. Add(' end;');
  10561. Add('constructor tobject.create(par: longint);');
  10562. Add('begin end;');
  10563. Add('var Obj: tobject;');
  10564. Add('begin');
  10565. Add(' obj:=tobject.create(3);');
  10566. ConvertProgram;
  10567. CheckSource('TestClass_TObjectConstructorWithParams',
  10568. LinesToStr([ // statements
  10569. 'rtl.createClass($mod,"TObject",null,function(){',
  10570. ' this.$init = function () {',
  10571. ' };',
  10572. ' this.$final = function () {',
  10573. ' };',
  10574. ' this.Create = function(Par){',
  10575. ' return this;',
  10576. ' };',
  10577. '});',
  10578. 'this.Obj = null;'
  10579. ]),
  10580. LinesToStr([ // $mod.$main
  10581. '$mod.Obj = $mod.TObject.$create("Create",[3]);'
  10582. ]));
  10583. end;
  10584. procedure TTestModule.TestClass_TObjectConstructorWithDefaultParam;
  10585. begin
  10586. StartProgram(false);
  10587. Add('type');
  10588. Add(' TObject = class');
  10589. Add(' public');
  10590. Add(' constructor Create;');
  10591. Add(' end;');
  10592. Add(' TTest = class(TObject)');
  10593. Add(' public');
  10594. Add(' constructor Create(const Par: longint = 1);');
  10595. Add(' end;');
  10596. Add('constructor tobject.create;');
  10597. Add('begin end;');
  10598. Add('constructor ttest.create(const par: longint);');
  10599. Add('begin end;');
  10600. Add('var t: ttest;');
  10601. Add('begin');
  10602. Add(' t:=ttest.create;');
  10603. Add(' t:=ttest.create(2);');
  10604. ConvertProgram;
  10605. CheckSource('TestClass_TObjectConstructorWithDefaultParam',
  10606. LinesToStr([ // statements
  10607. 'rtl.createClass($mod,"TObject",null,function(){',
  10608. ' this.$init = function () {',
  10609. ' };',
  10610. ' this.$final = function () {',
  10611. ' };',
  10612. ' this.Create = function(){',
  10613. ' return this;',
  10614. ' };',
  10615. '});',
  10616. 'rtl.createClass($mod, "TTest", $mod.TObject, function () {',
  10617. ' this.Create$1 = function (Par) {',
  10618. ' return this;',
  10619. ' };',
  10620. '});',
  10621. 'this.t = null;'
  10622. ]),
  10623. LinesToStr([ // $mod.$main
  10624. '$mod.t = $mod.TTest.$create("Create$1", [1]);',
  10625. '$mod.t = $mod.TTest.$create("Create$1", [2]);'
  10626. ]));
  10627. end;
  10628. procedure TTestModule.TestClass_Var;
  10629. begin
  10630. StartProgram(false);
  10631. Add([
  10632. 'type',
  10633. ' TObject = class',
  10634. ' public',
  10635. ' vI: longint;',
  10636. ' constructor Create(Par: longint);',
  10637. ' end;',
  10638. 'constructor tobject.create(par: longint);',
  10639. 'begin',
  10640. ' vi:=par+3',
  10641. 'end;',
  10642. 'var Obj: tobject;',
  10643. 'begin',
  10644. ' obj:=tobject.create(4);',
  10645. ' obj.vi:=obj.VI+5;']);
  10646. ConvertProgram;
  10647. CheckSource('TestClass_Var',
  10648. LinesToStr([ // statements
  10649. 'rtl.createClass($mod,"TObject",null,function(){',
  10650. ' this.$init = function () {',
  10651. ' this.vI = 0;',
  10652. ' };',
  10653. ' this.$final = function () {',
  10654. ' };',
  10655. ' this.Create = function(Par){',
  10656. ' this.vI = Par+3;',
  10657. ' return this;',
  10658. ' };',
  10659. '});',
  10660. 'this.Obj = null;'
  10661. ]),
  10662. LinesToStr([ // $mod.$main
  10663. '$mod.Obj = $mod.TObject.$create("Create",[4]);',
  10664. '$mod.Obj.vI = $mod.Obj.vI + 5;'
  10665. ]));
  10666. end;
  10667. procedure TTestModule.TestClass_Method;
  10668. begin
  10669. StartProgram(false);
  10670. Add('type');
  10671. Add(' TObject = class');
  10672. Add(' public');
  10673. Add(' vI: longint;');
  10674. Add(' Sub: TObject;');
  10675. Add(' constructor Create;');
  10676. Add(' function GetIt(Par: longint): tobject;');
  10677. Add(' end;');
  10678. Add('constructor tobject.create; begin end;');
  10679. Add('function tobject.getit(par: longint): tobject;');
  10680. Add('begin');
  10681. Add(' Self.vi:=par+3;');
  10682. Add(' Result:=self.sub;');
  10683. Add('end;');
  10684. Add('var Obj: tobject;');
  10685. Add('begin');
  10686. Add(' obj:=tobject.create;');
  10687. Add(' obj.getit(4);');
  10688. Add(' obj.sub.sub:=nil;');
  10689. Add(' obj.sub.getit(5);');
  10690. Add(' obj.sub.getit(6).SUB:=nil;');
  10691. Add(' obj.sub.getit(7).GETIT(8);');
  10692. Add(' obj.sub.getit(9).SuB.getit(10);');
  10693. ConvertProgram;
  10694. CheckSource('TestClass_Method',
  10695. LinesToStr([ // statements
  10696. 'rtl.createClass($mod,"TObject",null,function(){',
  10697. ' this.$init = function () {',
  10698. ' this.vI = 0;',
  10699. ' this.Sub = null;',
  10700. ' };',
  10701. ' this.$final = function () {',
  10702. ' this.Sub = undefined;',
  10703. ' };',
  10704. ' this.Create = function(){',
  10705. ' return this;',
  10706. ' };',
  10707. ' this.GetIt = function(Par){',
  10708. ' var Result = null;',
  10709. ' this.vI = Par + 3;',
  10710. ' Result = this.Sub;',
  10711. ' return Result;',
  10712. ' };',
  10713. '});',
  10714. 'this.Obj = null;'
  10715. ]),
  10716. LinesToStr([ // $mod.$main
  10717. '$mod.Obj = $mod.TObject.$create("Create");',
  10718. '$mod.Obj.GetIt(4);',
  10719. '$mod.Obj.Sub.Sub=null;',
  10720. '$mod.Obj.Sub.GetIt(5);',
  10721. '$mod.Obj.Sub.GetIt(6).Sub=null;',
  10722. '$mod.Obj.Sub.GetIt(7).GetIt(8);',
  10723. '$mod.Obj.Sub.GetIt(9).Sub.GetIt(10);'
  10724. ]));
  10725. end;
  10726. procedure TTestModule.TestClass_Implementation;
  10727. begin
  10728. StartUnit(false);
  10729. Add([
  10730. 'interface',
  10731. 'type',
  10732. ' TObject = class',
  10733. ' constructor Create;',
  10734. ' end;',
  10735. 'implementation',
  10736. 'type',
  10737. ' TIntClass = class',
  10738. ' constructor Create; reintroduce;',
  10739. ' class procedure DoGlob;',
  10740. ' end;',
  10741. 'constructor tintclass.create;',
  10742. 'begin',
  10743. ' inherited;',
  10744. ' inherited create;',
  10745. ' doglob;',
  10746. 'end;',
  10747. 'class procedure tintclass.doglob;',
  10748. 'begin',
  10749. 'end;',
  10750. 'constructor tobject.create;',
  10751. 'var',
  10752. ' iC: tintclass;',
  10753. 'begin',
  10754. ' ic:=tintclass.create;',
  10755. ' tintclass.doglob;',
  10756. ' ic.doglob;',
  10757. 'end;',
  10758. 'initialization',
  10759. ' tintclass.doglob;',
  10760. '']);
  10761. ConvertUnit;
  10762. CheckSource('TestClass_Implementation',
  10763. LinesToStr([ // statements
  10764. 'var $impl = $mod.$impl;',
  10765. 'rtl.createClass($mod, "TObject", null, function () {',
  10766. ' this.$init = function () {',
  10767. ' };',
  10768. ' this.$final = function () {',
  10769. ' };',
  10770. ' this.Create = function () {',
  10771. ' var iC = null;',
  10772. ' iC = $impl.TIntClass.$create("Create$1");',
  10773. ' $impl.TIntClass.DoGlob();',
  10774. ' iC.$class.DoGlob();',
  10775. ' return this;',
  10776. ' };',
  10777. '});',
  10778. '']),
  10779. LinesToStr([ // $mod.$main
  10780. '$impl.TIntClass.DoGlob();',
  10781. '']),
  10782. LinesToStr([
  10783. 'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
  10784. ' this.Create$1 = function () {',
  10785. ' $mod.TObject.Create.apply(this, arguments);',
  10786. ' $mod.TObject.Create.call(this);',
  10787. ' this.$class.DoGlob();',
  10788. ' return this;',
  10789. ' };',
  10790. ' this.DoGlob = function () {',
  10791. ' };',
  10792. '});',
  10793. '']));
  10794. end;
  10795. procedure TTestModule.TestClass_Inheritance;
  10796. begin
  10797. StartProgram(false);
  10798. Add('type');
  10799. Add(' TObject = class');
  10800. Add(' public');
  10801. Add(' constructor Create;');
  10802. Add(' end;');
  10803. Add(' TClassA = class');
  10804. Add(' end;');
  10805. Add(' TClassB = class(TObject)');
  10806. Add(' procedure ProcB;');
  10807. Add(' end;');
  10808. Add('constructor tobject.create; begin end;');
  10809. Add('procedure tclassb.procb; begin end;');
  10810. Add('var');
  10811. Add(' oO: TObject;');
  10812. Add(' oA: TClassA;');
  10813. Add(' oB: TClassB;');
  10814. Add('begin');
  10815. Add(' oO:=tobject.Create;');
  10816. Add(' oA:=tclassa.Create;');
  10817. Add(' ob:=tclassb.Create;');
  10818. Add(' if oo is tclassa then ;');
  10819. Add(' ob:=oo as tclassb;');
  10820. Add(' (oo as tclassb).procb;');
  10821. ConvertProgram;
  10822. CheckSource('TestClass_Inheritance',
  10823. LinesToStr([ // statements
  10824. 'rtl.createClass($mod,"TObject",null,function(){',
  10825. ' this.$init = function () {',
  10826. ' };',
  10827. ' this.$final = function () {',
  10828. ' };',
  10829. ' this.Create = function () {',
  10830. ' return this;',
  10831. ' };',
  10832. '});',
  10833. 'rtl.createClass($mod,"TClassA",$mod.TObject,function(){',
  10834. '});',
  10835. 'rtl.createClass($mod,"TClassB",$mod.TObject,function(){',
  10836. ' this.ProcB = function () {',
  10837. ' };',
  10838. '});',
  10839. 'this.oO = null;',
  10840. 'this.oA = null;',
  10841. 'this.oB = null;'
  10842. ]),
  10843. LinesToStr([ // $mod.$main
  10844. '$mod.oO = $mod.TObject.$create("Create");',
  10845. '$mod.oA = $mod.TClassA.$create("Create");',
  10846. '$mod.oB = $mod.TClassB.$create("Create");',
  10847. 'if ($mod.TClassA.isPrototypeOf($mod.oO));',
  10848. '$mod.oB = rtl.as($mod.oO, $mod.TClassB);',
  10849. 'rtl.as($mod.oO, $mod.TClassB).ProcB();'
  10850. ]));
  10851. end;
  10852. procedure TTestModule.TestClass_TypeAlias;
  10853. begin
  10854. StartProgram(false);
  10855. Add([
  10856. '{$interfaces corba}',
  10857. 'type',
  10858. ' IObject = interface',
  10859. ' end;',
  10860. ' IBird = type IObject;',
  10861. ' TObject = class',
  10862. ' end;',
  10863. ' TBird = type TObject;',
  10864. 'var',
  10865. ' oObj: TObject;',
  10866. ' oBird: TBird;',
  10867. ' IntfObj: IObject;',
  10868. ' IntfBird: IBird;',
  10869. 'begin',
  10870. ' oObj:=oBird;',
  10871. '']);
  10872. ConvertProgram;
  10873. CheckSource('TestClass_TypeAlias',
  10874. LinesToStr([ // statements
  10875. 'rtl.createInterface($mod, "IObject", "{B92D5841-6F2A-306A-8000-000000000000}", [], null);',
  10876. 'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-387B-AE88-F10981585074}", [], $mod.IObject);',
  10877. 'rtl.createClass($mod, "TObject", null, function () {',
  10878. ' this.$init = function () {',
  10879. ' };',
  10880. ' this.$final = function () {',
  10881. ' };',
  10882. '});',
  10883. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  10884. '});',
  10885. 'this.oObj = null;',
  10886. 'this.oBird = null;',
  10887. 'this.IntfObj = null;',
  10888. 'this.IntfBird = null;',
  10889. '']),
  10890. LinesToStr([ // $mod.$main
  10891. '$mod.oObj = $mod.oBird;',
  10892. '']));
  10893. end;
  10894. procedure TTestModule.TestClass_AbstractMethod;
  10895. begin
  10896. StartProgram(false);
  10897. Add('type');
  10898. Add(' TObject = class');
  10899. Add(' public');
  10900. Add(' procedure DoIt; virtual; abstract;');
  10901. Add(' end;');
  10902. Add('begin');
  10903. ConvertProgram;
  10904. CheckSource('TestClass_AbstractMethod',
  10905. LinesToStr([ // statements
  10906. 'rtl.createClass($mod,"TObject",null,function(){',
  10907. ' this.$init = function () {',
  10908. ' };',
  10909. ' this.$final = function () {',
  10910. ' };',
  10911. '});'
  10912. ]),
  10913. LinesToStr([ // this.$main
  10914. ''
  10915. ]));
  10916. end;
  10917. procedure TTestModule.TestClass_CallInherited_ProcNoParams;
  10918. begin
  10919. StartProgram(false);
  10920. Add([
  10921. 'type',
  10922. ' TObject = class',
  10923. ' procedure DoAbstract; virtual; abstract;',
  10924. ' procedure DoVirtual; virtual;',
  10925. ' procedure DoIt;',
  10926. ' end;',
  10927. ' TA = class',
  10928. ' procedure doabstract; override;',
  10929. ' procedure dovirtual; override;',
  10930. ' procedure DoSome;',
  10931. ' end;',
  10932. 'procedure tobject.dovirtual;',
  10933. 'begin',
  10934. ' inherited; // call non existing ancestor -> ignore silently',
  10935. 'end;',
  10936. 'procedure tobject.doit;',
  10937. 'begin',
  10938. 'end;',
  10939. 'procedure ta.doabstract;',
  10940. 'begin',
  10941. ' inherited dovirtual; // call TObject.DoVirtual',
  10942. 'end;',
  10943. 'procedure ta.dovirtual;',
  10944. 'begin',
  10945. ' inherited; // call TObject.DoVirtual',
  10946. ' inherited dovirtual; // call TObject.DoVirtual',
  10947. ' inherited dovirtual(); // call TObject.DoVirtual',
  10948. ' doit;',
  10949. ' doit();',
  10950. 'end;',
  10951. 'procedure ta.dosome;',
  10952. 'begin',
  10953. ' inherited; // call non existing ancestor method -> silently ignore',
  10954. 'end;',
  10955. 'begin']);
  10956. ConvertProgram;
  10957. CheckSource('TestClass_CallInherited_ProcNoParams',
  10958. LinesToStr([ // statements
  10959. 'rtl.createClass($mod,"TObject",null,function(){',
  10960. ' this.$init = function () {',
  10961. ' };',
  10962. ' this.$final = function () {',
  10963. ' };',
  10964. ' this.DoVirtual = function () {',
  10965. ' };',
  10966. ' this.DoIt = function () {',
  10967. ' };',
  10968. '});',
  10969. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  10970. ' this.DoAbstract = function () {',
  10971. ' $mod.TObject.DoVirtual.call(this);',
  10972. ' };',
  10973. ' this.DoVirtual = function () {',
  10974. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  10975. ' $mod.TObject.DoVirtual.call(this);',
  10976. ' $mod.TObject.DoVirtual.call(this);',
  10977. ' this.DoIt();',
  10978. ' this.DoIt();',
  10979. ' };',
  10980. ' this.DoSome = function () {',
  10981. ' };',
  10982. '});'
  10983. ]),
  10984. LinesToStr([ // this.$main
  10985. ''
  10986. ]));
  10987. end;
  10988. procedure TTestModule.TestClass_CallInherited_WithParams;
  10989. begin
  10990. StartProgram(false);
  10991. Add([
  10992. 'type',
  10993. ' TObject = class',
  10994. ' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;',
  10995. ' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;',
  10996. ' procedure DoIt(pA: longint; pB: longint = 0);',
  10997. ' procedure DoIt2(pA: longint = 1; pB: longint = 2);',
  10998. ' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
  10999. ' end;',
  11000. ' TClassA = class',
  11001. ' procedure DoAbstract(pA: longint; pB: longint = 0); override;',
  11002. ' procedure DoVirtual(pA: longint; pB: longint = 0); override;',
  11003. ' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
  11004. ' end;',
  11005. 'procedure tobject.dovirtual(pa: longint; pb: longint = 0);',
  11006. 'begin',
  11007. 'end;',
  11008. 'procedure tobject.doit(pa: longint; pb: longint = 0);',
  11009. 'begin',
  11010. 'end;',
  11011. 'procedure tobject.doit2(pa: longint; pb: longint = 0);',
  11012. 'begin',
  11013. 'end;',
  11014. 'function tobject.getit(pa: longint; pb: longint = 0): longint;',
  11015. 'begin',
  11016. 'end;',
  11017. 'procedure tclassa.doabstract(pa: longint; pb: longint = 0);',
  11018. 'begin',
  11019. ' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
  11020. ' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
  11021. 'end;',
  11022. 'procedure tclassa.dovirtual(pa: longint; pb: longint = 0);',
  11023. 'begin',
  11024. ' inherited; // call TObject.DoVirtual(pA,pB)',
  11025. ' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
  11026. ' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
  11027. ' doit(pa,pb);',
  11028. ' doit(pa);',
  11029. ' doit2(pa);',
  11030. ' doit2;',
  11031. 'end;',
  11032. 'function tclassa.getit(pa: longint; pb: longint = 0): longint;',
  11033. 'begin',
  11034. ' pa:=inherited;',
  11035. 'end;',
  11036. 'begin']);
  11037. ConvertProgram;
  11038. CheckSource('TestClass_CallInherited_WithParams',
  11039. LinesToStr([ // statements
  11040. 'rtl.createClass($mod,"TObject",null,function(){',
  11041. ' this.$init = function () {',
  11042. ' };',
  11043. ' this.$final = function () {',
  11044. ' };',
  11045. ' this.DoVirtual = function (pA,pB) {',
  11046. ' };',
  11047. ' this.DoIt = function (pA,pB) {',
  11048. ' };',
  11049. ' this.DoIt2 = function (pA,pB) {',
  11050. ' };',
  11051. ' this.GetIt = function (pA, pB) {',
  11052. ' var Result = 0;',
  11053. ' return Result;',
  11054. ' };',
  11055. '});',
  11056. 'rtl.createClass($mod, "TClassA", $mod.TObject, function () {',
  11057. ' this.DoAbstract = function (pA,pB) {',
  11058. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  11059. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  11060. ' };',
  11061. ' this.DoVirtual = function (pA,pB) {',
  11062. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  11063. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  11064. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  11065. ' this.DoIt(pA,pB);',
  11066. ' this.DoIt(pA,0);',
  11067. ' this.DoIt2(pA,2);',
  11068. ' this.DoIt2(1,2);',
  11069. ' };',
  11070. ' this.GetIt$1 = function (pA, pB) {',
  11071. ' var Result = 0;',
  11072. ' pA = $mod.TObject.GetIt.apply(this, arguments);',
  11073. ' return Result;',
  11074. ' };',
  11075. '});'
  11076. ]),
  11077. LinesToStr([ // this.$main
  11078. ''
  11079. ]));
  11080. end;
  11081. procedure TTestModule.TestClasS_CallInheritedConstructor;
  11082. begin
  11083. StartProgram(false);
  11084. Add('type');
  11085. Add(' TObject = class');
  11086. Add(' constructor Create; virtual;');
  11087. Add(' constructor CreateWithB(b: boolean);');
  11088. Add(' end;');
  11089. Add(' TA = class');
  11090. Add(' constructor Create; override;');
  11091. Add(' constructor CreateWithC(c: char);');
  11092. Add(' procedure DoIt;');
  11093. Add(' class function DoSome: TObject;');
  11094. Add(' end;');
  11095. Add('constructor tobject.create;');
  11096. Add('begin');
  11097. Add(' inherited; // call non existing ancestor -> ignore silently');
  11098. Add('end;');
  11099. Add('constructor tobject.createwithb(b: boolean);');
  11100. Add('begin');
  11101. Add(' inherited; // call non existing ancestor -> ignore silently');
  11102. Add(' create; // normal call');
  11103. Add('end;');
  11104. Add('constructor ta.create;');
  11105. Add('begin');
  11106. Add(' inherited; // normal call TObject.Create');
  11107. Add(' inherited create; // normal call TObject.Create');
  11108. Add(' inherited createwithb(false); // normal call TObject.CreateWithB');
  11109. Add('end;');
  11110. Add('constructor ta.createwithc(c: char);');
  11111. Add('begin');
  11112. Add(' inherited create; // call TObject.Create');
  11113. Add(' inherited createwithb(true); // call TObject.CreateWithB');
  11114. Add(' doit;');
  11115. Add(' doit();');
  11116. Add(' dosome;');
  11117. Add('end;');
  11118. Add('procedure ta.doit;');
  11119. Add('begin');
  11120. Add(' create; // normal call');
  11121. Add(' createwithb(false); // normal call');
  11122. Add(' createwithc(''c''); // normal call');
  11123. Add('end;');
  11124. Add('class function ta.dosome: TObject;');
  11125. Add('begin');
  11126. Add(' Result:=create; // constructor');
  11127. Add(' Result:=createwithb(true); // constructor');
  11128. Add(' Result:=createwithc(''c''); // constructor');
  11129. Add('end;');
  11130. Add('begin');
  11131. ConvertProgram;
  11132. CheckSource('TestClass_CallInheritedConstructor',
  11133. LinesToStr([ // statements
  11134. 'rtl.createClass($mod,"TObject",null,function(){',
  11135. ' this.$init = function () {',
  11136. ' };',
  11137. ' this.$final = function () {',
  11138. ' };',
  11139. ' this.Create = function () {',
  11140. ' return this;',
  11141. ' };',
  11142. ' this.CreateWithB = function (b) {',
  11143. ' this.Create();',
  11144. ' return this;',
  11145. ' };',
  11146. '});',
  11147. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  11148. ' this.Create = function () {',
  11149. ' $mod.TObject.Create.apply(this, arguments);',
  11150. ' $mod.TObject.Create.call(this);',
  11151. ' $mod.TObject.CreateWithB.call(this, false);',
  11152. ' return this;',
  11153. ' };',
  11154. ' this.CreateWithC = function (c) {',
  11155. ' $mod.TObject.Create.call(this);',
  11156. ' $mod.TObject.CreateWithB.call(this, true);',
  11157. ' this.DoIt();',
  11158. ' this.DoIt();',
  11159. ' this.$class.DoSome();',
  11160. ' return this;',
  11161. ' };',
  11162. ' this.DoIt = function () {',
  11163. ' this.Create();',
  11164. ' this.CreateWithB(false);',
  11165. ' this.CreateWithC("c");',
  11166. ' };',
  11167. ' this.DoSome = function () {',
  11168. ' var Result = null;',
  11169. ' Result = this.$create("Create");',
  11170. ' Result = this.$create("CreateWithB", [true]);',
  11171. ' Result = this.$create("CreateWithC", ["c"]);',
  11172. ' return Result;',
  11173. ' };',
  11174. '});'
  11175. ]),
  11176. LinesToStr([ // this.$main
  11177. ''
  11178. ]));
  11179. end;
  11180. procedure TTestModule.TestClass_ClassVar_Assign;
  11181. begin
  11182. StartProgram(false);
  11183. Add([
  11184. 'type',
  11185. ' TObject = class',
  11186. ' public',
  11187. ' class var vI: longint;',
  11188. ' class var Sub: TObject;',
  11189. ' constructor Create;',
  11190. ' class function GetIt(Par: longint): tobject;',
  11191. ' end;',
  11192. 'constructor tobject.create;',
  11193. 'begin',
  11194. ' vi:=vi+1;',
  11195. ' Self.vi:=Self.vi+1;',
  11196. ' inc(vi);',
  11197. 'end;',
  11198. 'class function tobject.getit(par: longint): tobject;',
  11199. 'begin',
  11200. ' vi:=vi+par;',
  11201. ' Self.vi:=Self.vi+par;',
  11202. ' inc(vi);',
  11203. ' Result:=self.sub;',
  11204. 'end;',
  11205. 'var Obj: tobject;',
  11206. 'begin',
  11207. ' obj:=tobject.create;',
  11208. ' tobject.vi:=3;',
  11209. ' if tobject.vi=4 then ;',
  11210. ' tobject.sub:=nil;',
  11211. ' obj.sub:=nil;',
  11212. ' obj.sub.sub:=nil;']);
  11213. ConvertProgram;
  11214. CheckSource('TestClass_ClassVar_Assign',
  11215. LinesToStr([ // statements
  11216. 'rtl.createClass($mod,"TObject",null,function(){',
  11217. ' this.vI = 0;',
  11218. ' this.Sub = null;',
  11219. ' this.$init = function () {',
  11220. ' };',
  11221. ' this.$final = function () {',
  11222. ' };',
  11223. ' this.Create = function(){',
  11224. ' $mod.TObject.vI = this.vI+1;',
  11225. ' $mod.TObject.vI = this.vI+1;',
  11226. ' $mod.TObject.vI += 1;',
  11227. ' return this;',
  11228. ' };',
  11229. ' this.GetIt = function(Par){',
  11230. ' var Result = null;',
  11231. ' $mod.TObject.vI = this.vI + Par;',
  11232. ' $mod.TObject.vI = this.vI + Par;',
  11233. ' $mod.TObject.vI += 1;',
  11234. ' Result = this.Sub;',
  11235. ' return Result;',
  11236. ' };',
  11237. '});',
  11238. 'this.Obj = null;'
  11239. ]),
  11240. LinesToStr([ // $mod.$main
  11241. '$mod.Obj = $mod.TObject.$create("Create");',
  11242. '$mod.TObject.vI = 3;',
  11243. 'if ($mod.TObject.vI === 4);',
  11244. '$mod.TObject.Sub=null;',
  11245. '$mod.TObject.Sub=null;',
  11246. '$mod.TObject.Sub=null;',
  11247. '']));
  11248. end;
  11249. procedure TTestModule.TestClass_CallClassMethod;
  11250. begin
  11251. StartProgram(false);
  11252. Add('type');
  11253. Add(' TObject = class');
  11254. Add(' public');
  11255. Add(' class var vI: longint;');
  11256. Add(' class var Sub: TObject;');
  11257. Add(' constructor Create;');
  11258. Add(' function GetMore(Par: longint): longint;');
  11259. Add(' class function GetIt(Par: longint): tobject;');
  11260. Add(' end;');
  11261. Add('constructor tobject.create;');
  11262. Add('begin');
  11263. Add(' sub:=getit(3);');
  11264. Add(' vi:=getmore(4);');
  11265. Add(' sub:=Self.getit(5);');
  11266. Add(' vi:=Self.getmore(6);');
  11267. Add('end;');
  11268. Add('function tobject.getmore(par: longint): longint;');
  11269. Add('begin');
  11270. Add(' sub:=getit(11);');
  11271. Add(' vi:=getmore(12);');
  11272. Add(' sub:=self.getit(13);');
  11273. Add(' vi:=self.getmore(14);');
  11274. Add('end;');
  11275. Add('class function tobject.getit(par: longint): tobject;');
  11276. Add('begin');
  11277. Add(' sub:=getit(21);');
  11278. Add(' vi:=sub.getmore(22);');
  11279. Add(' sub:=self.getit(23);');
  11280. Add(' vi:=self.sub.getmore(24);');
  11281. Add('end;');
  11282. Add('var Obj: tobject;');
  11283. Add('begin');
  11284. Add(' obj:=tobject.create;');
  11285. Add(' tobject.getit(5);');
  11286. Add(' obj.getit(6);');
  11287. Add(' obj.sub.getit(7);');
  11288. Add(' obj.sub.getit(8).SUB:=nil;');
  11289. Add(' obj.sub.getit(9).GETIT(10);');
  11290. Add(' obj.sub.getit(11).SuB.getit(12);');
  11291. ConvertProgram;
  11292. CheckSource('TestClass_CallClassMethod',
  11293. LinesToStr([ // statements
  11294. 'rtl.createClass($mod,"TObject",null,function(){',
  11295. ' this.vI = 0;',
  11296. ' this.Sub = null;',
  11297. ' this.$init = function () {',
  11298. ' };',
  11299. ' this.$final = function () {',
  11300. ' };',
  11301. ' this.Create = function(){',
  11302. ' $mod.TObject.Sub = this.$class.GetIt(3);',
  11303. ' $mod.TObject.vI = this.GetMore(4);',
  11304. ' $mod.TObject.Sub = this.$class.GetIt(5);',
  11305. ' $mod.TObject.vI = this.GetMore(6);',
  11306. ' return this;',
  11307. ' };',
  11308. ' this.GetMore = function(Par){',
  11309. ' var Result = 0;',
  11310. ' $mod.TObject.Sub = this.$class.GetIt(11);',
  11311. ' $mod.TObject.vI = this.GetMore(12);',
  11312. ' $mod.TObject.Sub = this.$class.GetIt(13);',
  11313. ' $mod.TObject.vI = this.GetMore(14);',
  11314. ' return Result;',
  11315. ' };',
  11316. ' this.GetIt = function(Par){',
  11317. ' var Result = null;',
  11318. ' $mod.TObject.Sub = this.GetIt(21);',
  11319. ' $mod.TObject.vI = this.Sub.GetMore(22);',
  11320. ' $mod.TObject.Sub = this.GetIt(23);',
  11321. ' $mod.TObject.vI = this.Sub.GetMore(24);',
  11322. ' return Result;',
  11323. ' };',
  11324. '});',
  11325. 'this.Obj = null;'
  11326. ]),
  11327. LinesToStr([ // $mod.$main
  11328. '$mod.Obj = $mod.TObject.$create("Create");',
  11329. '$mod.TObject.GetIt(5);',
  11330. '$mod.Obj.$class.GetIt(6);',
  11331. '$mod.Obj.Sub.$class.GetIt(7);',
  11332. '$mod.TObject.Sub=null;',
  11333. '$mod.Obj.Sub.$class.GetIt(9).$class.GetIt(10);',
  11334. '$mod.Obj.Sub.$class.GetIt(11).Sub.$class.GetIt(12);',
  11335. '']));
  11336. end;
  11337. procedure TTestModule.TestClass_Property;
  11338. begin
  11339. StartProgram(false);
  11340. Add('type');
  11341. Add(' TObject = class');
  11342. Add(' Fx: longint;');
  11343. Add(' Fy: longint;');
  11344. Add(' function GetInt: longint;');
  11345. Add(' procedure SetInt(Value: longint);');
  11346. Add(' procedure DoIt;');
  11347. Add(' property IntA: longint read Fx write Fy;');
  11348. Add(' property IntB: longint read GetInt write SetInt;');
  11349. Add(' end;');
  11350. Add('function tobject.getint: longint;');
  11351. Add('begin');
  11352. Add(' result:=fx;');
  11353. Add('end;');
  11354. Add('procedure tobject.setint(value: longint);');
  11355. Add('begin');
  11356. Add(' if value=fy then exit;');
  11357. Add(' fy:=value;');
  11358. Add('end;');
  11359. Add('procedure tobject.doit;');
  11360. Add('begin');
  11361. Add(' IntA:=IntA+1;');
  11362. Add(' Self.IntA:=Self.IntA+1;');
  11363. Add(' IntB:=IntB+1;');
  11364. Add(' Self.IntB:=Self.IntB+1;');
  11365. Add('end;');
  11366. Add('var Obj: tobject;');
  11367. Add('begin');
  11368. Add(' obj.inta:=obj.inta+1;');
  11369. Add(' if obj.intb=2 then;');
  11370. Add(' obj.intb:=obj.intb+2;');
  11371. Add(' obj.setint(obj.inta);');
  11372. ConvertProgram;
  11373. CheckSource('TestClass_Property',
  11374. LinesToStr([ // statements
  11375. 'rtl.createClass($mod, "TObject", null, function () {',
  11376. ' this.$init = function () {',
  11377. ' this.Fx = 0;',
  11378. ' this.Fy = 0;',
  11379. ' };',
  11380. ' this.$final = function () {',
  11381. ' };',
  11382. ' this.GetInt = function () {',
  11383. ' var Result = 0;',
  11384. ' Result = this.Fx;',
  11385. ' return Result;',
  11386. ' };',
  11387. ' this.SetInt = function (Value) {',
  11388. ' if (Value === this.Fy) return;',
  11389. ' this.Fy = Value;',
  11390. ' };',
  11391. ' this.DoIt = function () {',
  11392. ' this.Fy = this.Fx + 1;',
  11393. ' this.Fy = this.Fx + 1;',
  11394. ' this.SetInt(this.GetInt() + 1);',
  11395. ' this.SetInt(this.GetInt() + 1);',
  11396. ' };',
  11397. '});',
  11398. 'this.Obj = null;'
  11399. ]),
  11400. LinesToStr([ // $mod.$main
  11401. '$mod.Obj.Fy = $mod.Obj.Fx + 1;',
  11402. 'if ($mod.Obj.GetInt() === 2);',
  11403. '$mod.Obj.SetInt($mod.Obj.GetInt() + 2);',
  11404. '$mod.Obj.SetInt($mod.Obj.Fx);'
  11405. ]));
  11406. end;
  11407. procedure TTestModule.TestClass_Property_ClassMethod;
  11408. begin
  11409. StartProgram(false);
  11410. Add([
  11411. 'type',
  11412. ' TObject = class',
  11413. ' class var Fx: longint;',
  11414. ' class var Fy: longint;',
  11415. ' class function GetInt: longint;',
  11416. ' class procedure SetInt(Value: longint);',
  11417. ' end;',
  11418. ' TBird = class',
  11419. ' class procedure DoIt;',
  11420. ' class property IntA: longint read Fx write Fy;',
  11421. ' class property IntB: longint read GetInt write SetInt;',
  11422. ' end;',
  11423. 'class function tobject.getint: longint;',
  11424. 'begin',
  11425. ' result:=fx;',
  11426. 'end;',
  11427. 'class procedure tobject.setint(value: longint);',
  11428. 'begin',
  11429. 'end;',
  11430. 'class procedure tbird.doit;',
  11431. 'begin',
  11432. ' FX:=3;',
  11433. ' IntA:=IntA+1;',
  11434. ' Self.IntA:=Self.IntA+1;',
  11435. ' IntB:=IntB+1;',
  11436. ' Self.IntB:=Self.IntB+1;',
  11437. ' with Self do begin',
  11438. ' FX:=11;',
  11439. ' IntA:=IntA+12;',
  11440. ' IntB:=IntB+13;',
  11441. ' end;',
  11442. 'end;',
  11443. 'var Obj: tbird;',
  11444. 'begin',
  11445. ' tbird.fx:=tbird.fx+1;',
  11446. ' tbird.inta:=tbird.inta+1;',
  11447. ' if tbird.intb=2 then;',
  11448. ' tbird.intb:=tbird.intb+2;',
  11449. ' tbird.setint(tbird.inta);',
  11450. ' obj.inta:=obj.inta+1;',
  11451. ' if obj.intb=2 then;',
  11452. ' obj.intb:=obj.intb+2;',
  11453. ' obj.setint(obj.inta);',
  11454. ' with Tbird do begin',
  11455. ' FX:=FY+1;',
  11456. ' inta:=inta+2;',
  11457. ' intb:=intb+3;',
  11458. ' end;',
  11459. ' with Obj do begin',
  11460. ' FX:=FY+1;',
  11461. ' inta:=inta+2;',
  11462. ' intb:=intb+3;',
  11463. ' end;',
  11464. '']);
  11465. ConvertProgram;
  11466. CheckSource('TestClass_Property_ClassMethod',
  11467. LinesToStr([ // statements
  11468. 'rtl.createClass($mod, "TObject", null, function () {',
  11469. ' this.Fx = 0;',
  11470. ' this.Fy = 0;',
  11471. ' this.$init = function () {',
  11472. ' };',
  11473. ' this.$final = function () {',
  11474. ' };',
  11475. ' this.GetInt = function () {',
  11476. ' var Result = 0;',
  11477. ' Result = this.Fx;',
  11478. ' return Result;',
  11479. ' };',
  11480. ' this.SetInt = function (Value) {',
  11481. ' };',
  11482. '});',
  11483. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  11484. ' this.DoIt = function () {',
  11485. ' $mod.TObject.Fx = 3;',
  11486. ' $mod.TObject.Fy = this.Fx + 1;',
  11487. ' $mod.TObject.Fy = this.Fx + 1;',
  11488. ' this.SetInt(this.GetInt() + 1);',
  11489. ' this.SetInt(this.GetInt() + 1);',
  11490. ' $mod.TObject.Fx = 11;',
  11491. ' $mod.TObject.Fy = this.Fx + 12;',
  11492. ' this.SetInt(this.GetInt() + 13);',
  11493. ' };',
  11494. '});',
  11495. 'this.Obj = null;'
  11496. ]),
  11497. LinesToStr([ // $mod.$main
  11498. '$mod.TObject.Fx = $mod.TBird.Fx + 1;',
  11499. '$mod.TObject.Fy = $mod.TBird.Fx + 1;',
  11500. 'if ($mod.TBird.GetInt() === 2);',
  11501. '$mod.TBird.SetInt($mod.TBird.GetInt() + 2);',
  11502. '$mod.TBird.SetInt($mod.TBird.Fx);',
  11503. '$mod.TObject.Fy = $mod.Obj.Fx + 1;',
  11504. 'if ($mod.Obj.$class.GetInt() === 2);',
  11505. '$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
  11506. '$mod.Obj.$class.SetInt($mod.Obj.Fx);',
  11507. 'var $with1 = $mod.TBird;',
  11508. '$mod.TObject.Fx = $with1.Fy + 1;',
  11509. '$mod.TObject.Fy = $with1.Fx + 2;',
  11510. '$with1.SetInt($with1.GetInt() + 3);',
  11511. 'var $with2 = $mod.Obj;',
  11512. '$mod.TObject.Fx = $with2.Fy + 1;',
  11513. '$mod.TObject.Fy = $with2.Fx + 2;',
  11514. '$with2.SetInt($with2.GetInt() + 3);',
  11515. '']));
  11516. end;
  11517. procedure TTestModule.TestClass_Property_Indexed;
  11518. begin
  11519. StartProgram(false);
  11520. Add('type');
  11521. Add(' TObject = class');
  11522. Add(' FItems: array of longint;');
  11523. Add(' function GetItems(Index: longint): longint;');
  11524. Add(' procedure SetItems(Index: longint; Value: longint);');
  11525. Add(' procedure DoIt;');
  11526. Add(' property Items[Index: longint]: longint read getitems write setitems;');
  11527. Add(' end;');
  11528. Add('function tobject.getitems(index: longint): longint;');
  11529. Add('begin');
  11530. Add(' Result:=fitems[index];');
  11531. Add('end;');
  11532. Add('procedure tobject.setitems(index: longint; value: longint);');
  11533. Add('begin');
  11534. Add(' fitems[index]:=value;');
  11535. Add('end;');
  11536. Add('procedure tobject.doit;');
  11537. Add('begin');
  11538. Add(' items[1]:=2;');
  11539. Add(' items[3]:=items[4];');
  11540. Add(' self.items[5]:=self.items[6];');
  11541. Add(' items[items[7]]:=items[items[8]];');
  11542. Add('end;');
  11543. Add('var Obj: tobject;');
  11544. Add('begin');
  11545. Add(' obj.Items[11]:=obj.Items[12];');
  11546. ConvertProgram;
  11547. CheckSource('TestClass_Property_Indexed',
  11548. LinesToStr([ // statements
  11549. 'rtl.createClass($mod, "TObject", null, function () {',
  11550. ' this.$init = function () {',
  11551. ' this.FItems = [];',
  11552. ' };',
  11553. ' this.$final = function () {',
  11554. ' this.FItems = undefined;',
  11555. ' };',
  11556. ' this.GetItems = function (Index) {',
  11557. ' var Result = 0;',
  11558. ' Result = this.FItems[Index];',
  11559. ' return Result;',
  11560. ' };',
  11561. ' this.SetItems = function (Index, Value) {',
  11562. ' this.FItems[Index] = Value;',
  11563. ' };',
  11564. ' this.DoIt = function () {',
  11565. ' this.SetItems(1, 2);',
  11566. ' this.SetItems(3,this.GetItems(4));',
  11567. ' this.SetItems(5,this.GetItems(6));',
  11568. ' this.SetItems(this.GetItems(7), this.GetItems(this.GetItems(8)));',
  11569. ' };',
  11570. '});',
  11571. 'this.Obj = null;'
  11572. ]),
  11573. LinesToStr([ // $mod.$main
  11574. '$mod.Obj.SetItems(11,$mod.Obj.GetItems(12));'
  11575. ]));
  11576. end;
  11577. procedure TTestModule.TestClass_Property_IndexSpec;
  11578. begin
  11579. StartProgram(false);
  11580. Add([
  11581. 'type',
  11582. ' TEnum = (red, blue);',
  11583. ' TObject = class',
  11584. ' function GetIntBool(Index: longint): boolean; virtual; abstract;',
  11585. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  11586. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  11587. ' procedure SetEnumBool(Index: TEnum; b: boolean); virtual; abstract;',
  11588. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  11589. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  11590. ' property B1: boolean index 1 read GetIntBool write SetIntBool;',
  11591. ' property B2: boolean index TEnum.blue read GetEnumBool write SetEnumBool;',
  11592. ' property B3: boolean index ord(red) read GetIntBool write SetIntBool;',
  11593. ' property I1[A: String]: boolean index ord(blue) read GetStrIntBool write SetStrIntBool;',
  11594. ' end;',
  11595. 'procedure DoIt(b: boolean); begin end;',
  11596. 'var',
  11597. ' o: TObject;',
  11598. 'begin',
  11599. ' o.B1:=o.B1;',
  11600. ' o.B2:=o.B2;',
  11601. ' o.B3:=o.B3;',
  11602. ' o.I1[''a'']:=o.I1[''b''];',
  11603. ' doit(o.b1);',
  11604. ' doit(o.b2);',
  11605. ' doit(o.i1[''c'']);',
  11606. '']);
  11607. ConvertProgram;
  11608. CheckSource('TestClass_Property_IndexSpec',
  11609. LinesToStr([ // statements
  11610. 'this.TEnum = {',
  11611. ' "0": "red",',
  11612. ' red: 0,',
  11613. ' "1": "blue",',
  11614. ' blue: 1',
  11615. '};',
  11616. 'rtl.createClass($mod, "TObject", null, function () {',
  11617. ' this.$init = function () {',
  11618. ' };',
  11619. ' this.$final = function () {',
  11620. ' };',
  11621. '});',
  11622. 'this.DoIt = function (b) {',
  11623. '};',
  11624. 'this.o = null;',
  11625. '']),
  11626. LinesToStr([ // $mod.$main
  11627. '$mod.o.SetIntBool(1, $mod.o.GetIntBool(1));',
  11628. '$mod.o.SetEnumBool($mod.TEnum.blue, $mod.o.GetEnumBool($mod.TEnum.blue));',
  11629. '$mod.o.SetIntBool(0, $mod.o.GetIntBool(0));',
  11630. '$mod.o.SetStrIntBool("a", 1, $mod.o.GetStrIntBool("b", 1));',
  11631. '$mod.DoIt($mod.o.GetIntBool(1));',
  11632. '$mod.DoIt($mod.o.GetEnumBool($mod.TEnum.blue));',
  11633. '$mod.DoIt($mod.o.GetStrIntBool("c", 1));',
  11634. '']));
  11635. end;
  11636. procedure TTestModule.TestClass_PropertyOfTypeArray;
  11637. begin
  11638. StartProgram(false);
  11639. Add('type');
  11640. Add(' TArray = array of longint;');
  11641. Add(' TObject = class');
  11642. Add(' FItems: TArray;');
  11643. Add(' function GetItems: tarray;');
  11644. Add(' procedure SetItems(Value: tarray);');
  11645. Add(' property Items: tarray read getitems write setitems;');
  11646. Add(' end;');
  11647. Add('function tobject.getitems: tarray;');
  11648. Add('begin');
  11649. Add(' Result:=fitems;');
  11650. Add('end;');
  11651. Add('procedure tobject.setitems(value: tarray);');
  11652. Add('begin');
  11653. Add(' fitems:=value;');
  11654. Add(' fitems:=nil;');
  11655. Add(' Items:=nil;');
  11656. Add(' Items:=Items;');
  11657. Add(' Items[1]:=2;');
  11658. Add(' fitems[3]:=Items[4];');
  11659. Add(' Items[5]:=Items[6];');
  11660. Add(' Self.Items[7]:=8;');
  11661. Add(' Self.Items[9]:=Self.Items[10];');
  11662. Add(' Items[Items[11]]:=Items[Items[12]];');
  11663. Add('end;');
  11664. Add('var Obj: tobject;');
  11665. Add('begin');
  11666. Add(' obj.items:=nil;');
  11667. Add(' obj.items:=obj.items;');
  11668. Add(' obj.items[11]:=obj.items[12];');
  11669. ConvertProgram;
  11670. CheckSource('TestClass_PropertyOfTypeArray',
  11671. LinesToStr([ // statements
  11672. 'rtl.createClass($mod, "TObject", null, function () {',
  11673. ' this.$init = function () {',
  11674. ' this.FItems = [];',
  11675. ' };',
  11676. ' this.$final = function () {',
  11677. ' this.FItems = undefined;',
  11678. ' };',
  11679. ' this.GetItems = function () {',
  11680. ' var Result = [];',
  11681. ' Result = this.FItems;',
  11682. ' return Result;',
  11683. ' };',
  11684. ' this.SetItems = function (Value) {',
  11685. ' this.FItems = Value;',
  11686. ' this.FItems = [];',
  11687. ' this.SetItems([]);',
  11688. ' this.SetItems(this.GetItems());',
  11689. ' this.GetItems()[1] = 2;',
  11690. ' this.FItems[3] = this.GetItems()[4];',
  11691. ' this.GetItems()[5] = this.GetItems()[6];',
  11692. ' this.GetItems()[7] = 8;',
  11693. ' this.GetItems()[9] = this.GetItems()[10];',
  11694. ' this.GetItems()[this.GetItems()[11]] = this.GetItems()[this.GetItems()[12]];',
  11695. ' };',
  11696. '});',
  11697. 'this.Obj = null;'
  11698. ]),
  11699. LinesToStr([ // $mod.$main
  11700. '$mod.Obj.SetItems([]);',
  11701. '$mod.Obj.SetItems($mod.Obj.GetItems());',
  11702. '$mod.Obj.GetItems()[11] = $mod.Obj.GetItems()[12];'
  11703. ]));
  11704. end;
  11705. procedure TTestModule.TestClass_PropertyDefault;
  11706. begin
  11707. StartProgram(false);
  11708. Add([
  11709. 'type',
  11710. ' TArray = array of longint;',
  11711. ' TObject = class',
  11712. ' FItems: TArray;',
  11713. ' function GetItems(Index: longint): longint;',
  11714. ' procedure SetItems(Index, Value: longint);',
  11715. ' property Items[Index: longint]: longint read getitems write setitems; default;',
  11716. ' end;',
  11717. 'function tobject.getitems(index: longint): longint;',
  11718. 'begin',
  11719. 'end;',
  11720. 'procedure tobject.setitems(index, value: longint);',
  11721. 'begin',
  11722. ' Self[1]:=2;',
  11723. ' Self[3]:=Self[index];',
  11724. ' Self[index]:=Self[Self[value]];',
  11725. ' Self[Self[4]]:=value;',
  11726. 'end;',
  11727. 'var Obj: tobject;',
  11728. 'begin',
  11729. ' obj[11]:=12;',
  11730. ' obj[13]:=obj[14];',
  11731. ' obj[obj[15]]:=obj[obj[15]];',
  11732. ' TObject(obj)[16]:=TObject(obj)[17];']);
  11733. ConvertProgram;
  11734. CheckSource('TestClass_PropertyDefault',
  11735. LinesToStr([ // statements
  11736. 'rtl.createClass($mod, "TObject", null, function () {',
  11737. ' this.$init = function () {',
  11738. ' this.FItems = [];',
  11739. ' };',
  11740. ' this.$final = function () {',
  11741. ' this.FItems = undefined;',
  11742. ' };',
  11743. ' this.GetItems = function (Index) {',
  11744. ' var Result = 0;',
  11745. ' return Result;',
  11746. ' };',
  11747. ' this.SetItems = function (Index, Value) {',
  11748. ' this.SetItems(1, 2);',
  11749. ' this.SetItems(3, this.GetItems(Index));',
  11750. ' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
  11751. ' this.SetItems(this.GetItems(4), Value);',
  11752. ' };',
  11753. '});',
  11754. 'this.Obj = null;'
  11755. ]),
  11756. LinesToStr([ // $mod.$main
  11757. '$mod.Obj.SetItems(11, 12);',
  11758. '$mod.Obj.SetItems(13, $mod.Obj.GetItems(14));',
  11759. '$mod.Obj.SetItems($mod.Obj.GetItems(15), $mod.Obj.GetItems($mod.Obj.GetItems(15)));',
  11760. '$mod.Obj.SetItems(16, $mod.Obj.GetItems(17));',
  11761. '']));
  11762. end;
  11763. procedure TTestModule.TestClass_PropertyDefault2;
  11764. begin
  11765. StartProgram(false);
  11766. Add([
  11767. 'type',
  11768. ' TObject = class end;',
  11769. ' TAlphaList = class',
  11770. ' function GetAlphas(Index: boolean): Pointer; virtual; abstract;',
  11771. ' procedure SetAlphas(Index: boolean; Value: Pointer); virtual; abstract;',
  11772. ' property Alphas[Index: boolean]: Pointer read getAlphas write setAlphas; default;',
  11773. ' end;',
  11774. ' TBetaList = class',
  11775. ' function GetBetas(Index: longint): Pointer; virtual; abstract;',
  11776. ' procedure SetBetas(Index: longint; Value: Pointer); virtual; abstract;',
  11777. ' property Betas[Index: longint]: Pointer read getBetas write setBetas; default;',
  11778. ' end;',
  11779. ' TBird = class',
  11780. ' procedure DoIt;',
  11781. ' end;',
  11782. 'procedure TBird.DoIt;',
  11783. 'var',
  11784. ' List: TAlphaList;',
  11785. 'begin',
  11786. ' if TBetaList(List[true])[3]=nil then ;',
  11787. ' TBetaList(List[false])[5]:=nil;',
  11788. 'end;',
  11789. 'var',
  11790. ' List: TAlphaList;',
  11791. 'begin',
  11792. ' if TBetaList(List[true])[3]=nil then ;',
  11793. ' TBetaList(List[false])[5]:=nil;',
  11794. '']);
  11795. ConvertProgram;
  11796. CheckSource('TestClass_PropertyDefault2',
  11797. LinesToStr([ // statements
  11798. 'rtl.createClass($mod, "TObject", null, function () {',
  11799. ' this.$init = function () {',
  11800. ' };',
  11801. ' this.$final = function () {',
  11802. ' };',
  11803. '});',
  11804. 'rtl.createClass($mod, "TAlphaList", $mod.TObject, function () {',
  11805. '});',
  11806. 'rtl.createClass($mod, "TBetaList", $mod.TObject, function () {',
  11807. '});',
  11808. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  11809. ' this.DoIt = function () {',
  11810. ' var List = null;',
  11811. ' if (List.GetAlphas(true).GetBetas(3) === null) ;',
  11812. ' List.GetAlphas(false).SetBetas(5, null);',
  11813. ' };',
  11814. '});',
  11815. 'this.List = null;',
  11816. '']),
  11817. LinesToStr([ // $mod.$main
  11818. 'if ($mod.List.GetAlphas(true).GetBetas(3) === null) ;',
  11819. '$mod.List.GetAlphas(false).SetBetas(5, null);',
  11820. '']));
  11821. end;
  11822. procedure TTestModule.TestClass_PropertyOverride;
  11823. begin
  11824. StartProgram(false);
  11825. Add('type');
  11826. Add(' integer = longint;');
  11827. Add(' TObject = class');
  11828. Add(' FItem: integer;');
  11829. Add(' function GetItem: integer; external name ''GetItem'';');
  11830. Add(' procedure SetItem(Value: integer); external name ''SetItem'';');
  11831. Add(' property Item: integer read getitem write setitem;');
  11832. Add(' end;');
  11833. Add(' TCar = class');
  11834. Add(' FBag: integer;');
  11835. Add(' function GetBag: integer; external name ''GetBag'';');
  11836. Add(' property Item read getbag;');
  11837. Add(' end;');
  11838. Add('var');
  11839. Add(' Obj: tobject;');
  11840. Add(' Car: tcar;');
  11841. Add('begin');
  11842. Add(' Obj.Item:=Obj.Item;');
  11843. Add(' Car.Item:=Car.Item;');
  11844. ConvertProgram;
  11845. CheckSource('TestClass_PropertyOverride',
  11846. LinesToStr([ // statements
  11847. 'rtl.createClass($mod, "TObject", null, function () {',
  11848. ' this.$init = function () {',
  11849. ' this.FItem = 0;',
  11850. ' };',
  11851. ' this.$final = function () {',
  11852. ' };',
  11853. '});',
  11854. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  11855. ' this.$init = function () {',
  11856. ' $mod.TObject.$init.call(this);',
  11857. ' this.FBag = 0;',
  11858. ' };',
  11859. '});',
  11860. 'this.Obj = null;',
  11861. 'this.Car = null;',
  11862. '']),
  11863. LinesToStr([ // $mod.$main
  11864. '$mod.Obj.SetItem($mod.Obj.GetItem());',
  11865. '$mod.Car.SetItem($mod.Car.GetBag());',
  11866. '']));
  11867. end;
  11868. procedure TTestModule.TestClass_PropertyIncVisibility;
  11869. begin
  11870. AddModuleWithIntfImplSrc('unit1.pp',
  11871. LinesToStr([
  11872. 'type',
  11873. ' TNumber = longint;',
  11874. ' TInteger = longint;',
  11875. ' TObject = class',
  11876. ' private',
  11877. ' function GetItems(Index: TNumber): TInteger; virtual; abstract;',
  11878. ' procedure SetItems(Index: TInteger; Value: TNumber); virtual; abstract;',
  11879. ' protected',
  11880. ' property Items[Index: TNumber]: longint read GetItems write SetItems;',
  11881. ' end;']),
  11882. LinesToStr([
  11883. '']));
  11884. StartProgram(true);
  11885. Add([
  11886. 'uses unit1;',
  11887. 'type',
  11888. ' TBird = class',
  11889. ' public',
  11890. ' property Items;',
  11891. ' end;',
  11892. 'procedure DoIt(i: TInteger);',
  11893. 'begin',
  11894. 'end;',
  11895. 'var b: TBird;',
  11896. 'begin',
  11897. ' b.Items[1]:=2;',
  11898. ' b.Items[3]:=b.Items[4];',
  11899. ' DoIt(b.Items[5]);',
  11900. '']);
  11901. ConvertProgram;
  11902. CheckSource('TestClass_PropertyIncVisibility',
  11903. LinesToStr([ // statements
  11904. 'rtl.createClass($mod, "TBird", pas.unit1.TObject, function () {',
  11905. '});',
  11906. 'this.DoIt = function (i) {',
  11907. '};',
  11908. 'this.b = null;'
  11909. ]),
  11910. LinesToStr([ // $mod.$main
  11911. '$mod.b.SetItems(1, 2);',
  11912. '$mod.b.SetItems(3, $mod.b.GetItems(4));',
  11913. '$mod.DoIt($mod.b.GetItems(5));'
  11914. ]));
  11915. end;
  11916. procedure TTestModule.TestClass_Assigned;
  11917. begin
  11918. StartProgram(false);
  11919. Add('type');
  11920. Add(' TObject = class');
  11921. Add(' end;');
  11922. Add('var');
  11923. Add(' Obj: tobject;');
  11924. Add(' b: boolean;');
  11925. Add('begin');
  11926. Add(' if Assigned(obj) then ;');
  11927. Add(' b:=Assigned(obj) or false;');
  11928. ConvertProgram;
  11929. CheckSource('TestClass_Assigned',
  11930. LinesToStr([ // statements
  11931. 'rtl.createClass($mod, "TObject", null, function () {',
  11932. ' this.$init = function () {',
  11933. ' };',
  11934. ' this.$final = function () {',
  11935. ' };',
  11936. '});',
  11937. 'this.Obj = null;',
  11938. 'this.b = false;'
  11939. ]),
  11940. LinesToStr([ // $mod.$main
  11941. 'if ($mod.Obj != null);',
  11942. '$mod.b = ($mod.Obj != null) || false;'
  11943. ]));
  11944. end;
  11945. procedure TTestModule.TestClass_WithClassDoCreate;
  11946. begin
  11947. StartProgram(false);
  11948. Add('type');
  11949. Add(' TObject = class');
  11950. Add(' aBool: boolean;');
  11951. Add(' Arr: array of boolean;');
  11952. Add(' constructor Create;');
  11953. Add(' end;');
  11954. Add('constructor TObject.Create; begin end;');
  11955. Add('var');
  11956. Add(' Obj: tobject;');
  11957. Add(' b: boolean;');
  11958. Add('begin');
  11959. Add(' with tobject.create do begin');
  11960. Add(' b:=abool;');
  11961. Add(' abool:=b;');
  11962. Add(' b:=arr[1];');
  11963. Add(' arr[2]:=b;');
  11964. Add(' end;');
  11965. Add(' with tobject do');
  11966. Add(' obj:=create;');
  11967. Add(' with obj do begin');
  11968. Add(' create;');
  11969. Add(' b:=abool;');
  11970. Add(' abool:=b;');
  11971. Add(' b:=arr[3];');
  11972. Add(' arr[4]:=b;');
  11973. Add(' end;');
  11974. ConvertProgram;
  11975. CheckSource('TestClass_WithClassDoCreate',
  11976. LinesToStr([ // statements
  11977. 'rtl.createClass($mod, "TObject", null, function () {',
  11978. ' this.$init = function () {',
  11979. ' this.aBool = false;',
  11980. ' this.Arr = [];',
  11981. ' };',
  11982. ' this.$final = function () {',
  11983. ' this.Arr = undefined;',
  11984. ' };',
  11985. ' this.Create = function () {',
  11986. ' return this;',
  11987. ' };',
  11988. '});',
  11989. 'this.Obj = null;',
  11990. 'this.b = false;'
  11991. ]),
  11992. LinesToStr([ // $mod.$main
  11993. 'var $with1 = $mod.TObject.$create("Create");',
  11994. '$mod.b = $with1.aBool;',
  11995. '$with1.aBool = $mod.b;',
  11996. '$mod.b = $with1.Arr[1];',
  11997. '$with1.Arr[2] = $mod.b;',
  11998. 'var $with2 = $mod.TObject;',
  11999. '$mod.Obj = $with2.$create("Create");',
  12000. 'var $with3 = $mod.Obj;',
  12001. '$with3.Create();',
  12002. '$mod.b = $with3.aBool;',
  12003. '$with3.aBool = $mod.b;',
  12004. '$mod.b = $with3.Arr[3];',
  12005. '$with3.Arr[4] = $mod.b;',
  12006. '']));
  12007. end;
  12008. procedure TTestModule.TestClass_WithClassInstDoProperty;
  12009. begin
  12010. StartProgram(false);
  12011. Add('type');
  12012. Add(' TObject = class');
  12013. Add(' FInt: longint;');
  12014. Add(' constructor Create;');
  12015. Add(' function GetSize: longint;');
  12016. Add(' procedure SetSize(Value: longint);');
  12017. Add(' property Int: longint read FInt write FInt;');
  12018. Add(' property Size: longint read GetSize write SetSize;');
  12019. Add(' end;');
  12020. Add('constructor TObject.Create; begin end;');
  12021. Add('function TObject.GetSize: longint; begin; end;');
  12022. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  12023. Add('var');
  12024. Add(' Obj: tobject;');
  12025. Add(' i: longint;');
  12026. Add('begin');
  12027. Add(' with TObject.Create do begin');
  12028. Add(' i:=int;');
  12029. Add(' int:=i;');
  12030. Add(' i:=size;');
  12031. Add(' size:=i;');
  12032. Add(' end;');
  12033. Add(' with obj do begin');
  12034. Add(' i:=int;');
  12035. Add(' int:=i;');
  12036. Add(' i:=size;');
  12037. Add(' size:=i;');
  12038. Add(' end;');
  12039. ConvertProgram;
  12040. CheckSource('TestClass_WithClassInstDoProperty',
  12041. LinesToStr([ // statements
  12042. 'rtl.createClass($mod, "TObject", null, function () {',
  12043. ' this.$init = function () {',
  12044. ' this.FInt = 0;',
  12045. ' };',
  12046. ' this.$final = function () {',
  12047. ' };',
  12048. ' this.Create = function () {',
  12049. ' return this;',
  12050. ' };',
  12051. ' this.GetSize = function () {',
  12052. ' var Result = 0;',
  12053. ' return Result;',
  12054. ' };',
  12055. ' this.SetSize = function (Value) {',
  12056. ' };',
  12057. '});',
  12058. 'this.Obj = null;',
  12059. 'this.i = 0;'
  12060. ]),
  12061. LinesToStr([ // $mod.$main
  12062. 'var $with1 = $mod.TObject.$create("Create");',
  12063. '$mod.i = $with1.FInt;',
  12064. '$with1.FInt = $mod.i;',
  12065. '$mod.i = $with1.GetSize();',
  12066. '$with1.SetSize($mod.i);',
  12067. 'var $with2 = $mod.Obj;',
  12068. '$mod.i = $with2.FInt;',
  12069. '$with2.FInt = $mod.i;',
  12070. '$mod.i = $with2.GetSize();',
  12071. '$with2.SetSize($mod.i);',
  12072. '']));
  12073. end;
  12074. procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
  12075. begin
  12076. StartProgram(false);
  12077. Add('type');
  12078. Add(' TObject = class');
  12079. Add(' constructor Create;');
  12080. Add(' function GetItems(Index: longint): longint;');
  12081. Add(' procedure SetItems(Index, Value: longint);');
  12082. Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
  12083. Add(' end;');
  12084. Add('constructor TObject.Create; begin end;');
  12085. Add('function tobject.getitems(index: longint): longint; begin; end;');
  12086. Add('procedure tobject.setitems(index, value: longint); begin; end;');
  12087. Add('var');
  12088. Add(' Obj: tobject;');
  12089. Add(' i: longint;');
  12090. Add('begin');
  12091. Add(' with TObject.Create do begin');
  12092. Add(' i:=Items[1];');
  12093. Add(' Items[2]:=i;');
  12094. Add(' end;');
  12095. Add(' with obj do begin');
  12096. Add(' i:=Items[3];');
  12097. Add(' Items[4]:=i;');
  12098. Add(' end;');
  12099. ConvertProgram;
  12100. CheckSource('TestClass_WithClassInstDoPropertyWithParams',
  12101. LinesToStr([ // statements
  12102. 'rtl.createClass($mod, "TObject", null, function () {',
  12103. ' this.$init = function () {',
  12104. ' };',
  12105. ' this.$final = function () {',
  12106. ' };',
  12107. ' this.Create = function () {',
  12108. ' return this;',
  12109. ' };',
  12110. ' this.GetItems = function (Index) {',
  12111. ' var Result = 0;',
  12112. ' return Result;',
  12113. ' };',
  12114. ' this.SetItems = function (Index, Value) {',
  12115. ' };',
  12116. '});',
  12117. 'this.Obj = null;',
  12118. 'this.i = 0;'
  12119. ]),
  12120. LinesToStr([ // $mod.$main
  12121. 'var $with1 = $mod.TObject.$create("Create");',
  12122. '$mod.i = $with1.GetItems(1);',
  12123. '$with1.SetItems(2, $mod.i);',
  12124. 'var $with2 = $mod.Obj;',
  12125. '$mod.i = $with2.GetItems(3);',
  12126. '$with2.SetItems(4, $mod.i);',
  12127. '']));
  12128. end;
  12129. procedure TTestModule.TestClass_WithClassInstDoFunc;
  12130. begin
  12131. StartProgram(false);
  12132. Add('type');
  12133. Add(' TObject = class');
  12134. Add(' constructor Create;');
  12135. Add(' function GetSize: longint;');
  12136. Add(' procedure SetSize(Value: longint);');
  12137. Add(' end;');
  12138. Add('constructor TObject.Create; begin end;');
  12139. Add('function TObject.GetSize: longint; begin; end;');
  12140. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  12141. Add('var');
  12142. Add(' Obj: tobject;');
  12143. Add(' i: longint;');
  12144. Add('begin');
  12145. Add(' with TObject.Create do begin');
  12146. Add(' i:=GetSize;');
  12147. Add(' i:=GetSize();');
  12148. Add(' SetSize(i);');
  12149. Add(' end;');
  12150. Add(' with obj do begin');
  12151. Add(' i:=GetSize;');
  12152. Add(' i:=GetSize();');
  12153. Add(' SetSize(i);');
  12154. Add(' end;');
  12155. ConvertProgram;
  12156. CheckSource('TestClass_WithClassInstDoFunc',
  12157. LinesToStr([ // statements
  12158. 'rtl.createClass($mod, "TObject", null, function () {',
  12159. ' this.$init = function () {',
  12160. ' };',
  12161. ' this.$final = function () {',
  12162. ' };',
  12163. ' this.Create = function () {',
  12164. ' return this;',
  12165. ' };',
  12166. ' this.GetSize = function () {',
  12167. ' var Result = 0;',
  12168. ' return Result;',
  12169. ' };',
  12170. ' this.SetSize = function (Value) {',
  12171. ' };',
  12172. '});',
  12173. 'this.Obj = null;',
  12174. 'this.i = 0;'
  12175. ]),
  12176. LinesToStr([ // $mod.$main
  12177. 'var $with1 = $mod.TObject.$create("Create");',
  12178. '$mod.i = $with1.GetSize();',
  12179. '$mod.i = $with1.GetSize();',
  12180. '$with1.SetSize($mod.i);',
  12181. 'var $with2 = $mod.Obj;',
  12182. '$mod.i = $with2.GetSize();',
  12183. '$mod.i = $with2.GetSize();',
  12184. '$with2.SetSize($mod.i);',
  12185. '']));
  12186. end;
  12187. procedure TTestModule.TestClass_TypeCast;
  12188. begin
  12189. StartProgram(false);
  12190. Add('type');
  12191. Add(' TObject = class');
  12192. Add(' Next: TObject;');
  12193. Add(' constructor Create;');
  12194. Add(' end;');
  12195. Add(' TControl = class(TObject)');
  12196. Add(' Arr: array of TObject;');
  12197. Add(' function GetIt(vI: longint = 0): TObject;');
  12198. Add(' end;');
  12199. Add('constructor tobject.create; begin end;');
  12200. Add('function tcontrol.getit(vi: longint = 0): tobject; begin end;');
  12201. Add('var');
  12202. Add(' Obj: tobject;');
  12203. Add('begin');
  12204. Add(' obj:=tcontrol(obj).next;');
  12205. Add(' tcontrol(obj):=nil;');
  12206. Add(' obj:=tcontrol(obj);');
  12207. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
  12208. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
  12209. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
  12210. Add(' tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
  12211. ConvertProgram;
  12212. CheckSource('TestClass_TypeCast',
  12213. LinesToStr([ // statements
  12214. 'rtl.createClass($mod, "TObject", null, function () {',
  12215. ' this.$init = function () {',
  12216. ' this.Next = null;',
  12217. ' };',
  12218. ' this.$final = function () {',
  12219. ' this.Next = undefined;',
  12220. ' };',
  12221. ' this.Create = function () {',
  12222. ' return this;',
  12223. ' };',
  12224. '});',
  12225. 'rtl.createClass($mod, "TControl", $mod.TObject, function () {',
  12226. ' this.$init = function () {',
  12227. ' $mod.TObject.$init.call(this);',
  12228. ' this.Arr = [];',
  12229. ' };',
  12230. ' this.$final = function () {',
  12231. ' this.Arr = undefined;',
  12232. ' $mod.TObject.$final.call(this);',
  12233. ' };',
  12234. ' this.GetIt = function (vI) {',
  12235. ' var Result = null;',
  12236. ' return Result;',
  12237. ' };',
  12238. '});',
  12239. 'this.Obj = null;'
  12240. ]),
  12241. LinesToStr([ // $mod.$main
  12242. '$mod.Obj = $mod.Obj.Next;',
  12243. '$mod.Obj = null;',
  12244. '$mod.Obj = $mod.Obj;',
  12245. '$mod.Obj = $mod.Obj.GetIt(0);',
  12246. '$mod.Obj = $mod.Obj.GetIt(0);',
  12247. '$mod.Obj = $mod.Obj.GetIt(1);',
  12248. '$mod.Obj = $mod.Obj.GetIt(0).Arr[2];',
  12249. '']));
  12250. end;
  12251. procedure TTestModule.TestClass_TypeCastUntypedParam;
  12252. begin
  12253. StartProgram(false);
  12254. Add('type');
  12255. Add(' TObject = class end;');
  12256. Add('procedure ProcA(var A);');
  12257. Add('begin');
  12258. Add(' TObject(A):=nil;');
  12259. Add(' TObject(A):=TObject(A);');
  12260. Add(' if TObject(A)=nil then ;');
  12261. Add(' if nil=TObject(A) then ;');
  12262. Add('end;');
  12263. Add('procedure ProcB(out A);');
  12264. Add('begin');
  12265. Add(' TObject(A):=nil;');
  12266. Add(' TObject(A):=TObject(A);');
  12267. Add(' if TObject(A)=nil then ;');
  12268. Add(' if nil=TObject(A) then ;');
  12269. Add('end;');
  12270. Add('procedure ProcC(const A);');
  12271. Add('begin');
  12272. Add(' if TObject(A)=nil then ;');
  12273. Add(' if nil=TObject(A) then ;');
  12274. Add('end;');
  12275. Add('var o: TObject;');
  12276. Add('begin');
  12277. Add(' ProcA(o);');
  12278. Add(' ProcB(o);');
  12279. Add(' ProcC(o);');
  12280. ConvertProgram;
  12281. CheckSource('TestClass_TypeCastUntypedParam',
  12282. LinesToStr([ // statements
  12283. 'rtl.createClass($mod, "TObject", null, function () {',
  12284. ' this.$init = function () {',
  12285. ' };',
  12286. ' this.$final = function () {',
  12287. ' };',
  12288. '});',
  12289. 'this.ProcA = function (A) {',
  12290. ' A.set(null);',
  12291. ' A.set(A.get());',
  12292. ' if (A.get() === null);',
  12293. ' if (null === A.get());',
  12294. '};',
  12295. 'this.ProcB = function (A) {',
  12296. ' A.set(null);',
  12297. ' A.set(A.get());',
  12298. ' if (A.get() === null);',
  12299. ' if (null === A.get());',
  12300. '};',
  12301. 'this.ProcC = function (A) {',
  12302. ' if (A === null);',
  12303. ' if (null === A);',
  12304. '};',
  12305. 'this.o = null;',
  12306. '']),
  12307. LinesToStr([ // $mod.$main
  12308. '$mod.ProcA({',
  12309. ' p: $mod,',
  12310. ' get: function () {',
  12311. ' return this.p.o;',
  12312. ' },',
  12313. ' set: function (v) {',
  12314. ' this.p.o = v;',
  12315. ' }',
  12316. '});',
  12317. '$mod.ProcB({',
  12318. ' p: $mod,',
  12319. ' get: function () {',
  12320. ' return this.p.o;',
  12321. ' },',
  12322. ' set: function (v) {',
  12323. ' this.p.o = v;',
  12324. ' }',
  12325. '});',
  12326. '$mod.ProcC($mod.o);',
  12327. '']));
  12328. end;
  12329. procedure TTestModule.TestClass_Overloads;
  12330. begin
  12331. StartProgram(false);
  12332. Add('type');
  12333. Add(' TObject = class');
  12334. Add(' procedure DoIt;');
  12335. Add(' procedure DoIt(vI: longint);');
  12336. Add(' end;');
  12337. Add('procedure TObject.DoIt;');
  12338. Add('begin');
  12339. Add(' DoIt;');
  12340. Add(' DoIt(1);');
  12341. Add('end;');
  12342. Add('procedure TObject.DoIt(vI: longint); begin end;');
  12343. Add('begin');
  12344. ConvertProgram;
  12345. CheckSource('TestClass_Overloads',
  12346. LinesToStr([ // statements
  12347. 'rtl.createClass($mod, "TObject", null, function () {',
  12348. ' this.$init = function () {',
  12349. ' };',
  12350. ' this.$final = function () {',
  12351. ' };',
  12352. ' this.DoIt = function () {',
  12353. ' this.DoIt();',
  12354. ' this.DoIt$1(1);',
  12355. ' };',
  12356. ' this.DoIt$1 = function (vI) {',
  12357. ' };',
  12358. '});',
  12359. '']),
  12360. LinesToStr([ // $mod.$main
  12361. '']));
  12362. end;
  12363. procedure TTestModule.TestClass_OverloadsAncestor;
  12364. begin
  12365. StartProgram(false);
  12366. Add('type');
  12367. Add(' TObject = class;');
  12368. Add(' TObject = class');
  12369. Add(' procedure DoIt(vA: longint);');
  12370. Add(' procedure DoIt(vA, vB: longint);');
  12371. Add(' end;');
  12372. Add(' TCar = class;');
  12373. Add(' TCar = class');
  12374. Add(' procedure DoIt(vA: longint);');
  12375. Add(' procedure DoIt(vA, vB: longint);');
  12376. Add(' end;');
  12377. Add('procedure tobject.doit(va: longint);');
  12378. Add('begin');
  12379. Add(' doit(1);');
  12380. Add(' doit(1,2);');
  12381. Add('end;');
  12382. Add('procedure tobject.doit(va, vb: longint); begin end;');
  12383. Add('procedure tcar.doit(va: longint);');
  12384. Add('begin');
  12385. Add(' doit(1);');
  12386. Add(' doit(1,2);');
  12387. Add(' inherited doit(1);');
  12388. Add(' inherited doit(1,2);');
  12389. Add('end;');
  12390. Add('procedure tcar.doit(va, vb: longint); begin end;');
  12391. Add('begin');
  12392. ConvertProgram;
  12393. CheckSource('TestClass_OverloadsAncestor',
  12394. LinesToStr([ // statements
  12395. 'rtl.createClass($mod, "TObject", null, function () {',
  12396. ' this.$init = function () {',
  12397. ' };',
  12398. ' this.$final = function () {',
  12399. ' };',
  12400. ' this.DoIt = function (vA) {',
  12401. ' this.DoIt(1);',
  12402. ' this.DoIt$1(1,2);',
  12403. ' };',
  12404. ' this.DoIt$1 = function (vA, vB) {',
  12405. ' };',
  12406. '});',
  12407. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  12408. ' this.DoIt$2 = function (vA) {',
  12409. ' this.DoIt$2(1);',
  12410. ' this.DoIt$3(1, 2);',
  12411. ' $mod.TObject.DoIt.call(this, 1);',
  12412. ' $mod.TObject.DoIt$1.call(this, 1, 2);',
  12413. ' };',
  12414. ' this.DoIt$3 = function (vA, vB) {',
  12415. ' };',
  12416. '});',
  12417. '']),
  12418. LinesToStr([ // $mod.$main
  12419. '']));
  12420. end;
  12421. procedure TTestModule.TestClass_OverloadConstructor;
  12422. begin
  12423. StartProgram(false);
  12424. Add('type');
  12425. Add(' TObject = class');
  12426. Add(' constructor Create(vA: longint);');
  12427. Add(' constructor Create(vA, vB: longint);');
  12428. Add(' end;');
  12429. Add(' TCar = class');
  12430. Add(' constructor Create(vA: longint);');
  12431. Add(' constructor Create(vA, vB: longint);');
  12432. Add(' end;');
  12433. Add('constructor tobject.create(va: longint);');
  12434. Add('begin');
  12435. Add(' create(1);');
  12436. Add(' create(1,2);');
  12437. Add('end;');
  12438. Add('constructor tobject.create(va, vb: longint); begin end;');
  12439. Add('constructor tcar.create(va: longint);');
  12440. Add('begin');
  12441. Add(' create(1);');
  12442. Add(' create(1,2);');
  12443. Add(' inherited create(1);');
  12444. Add(' inherited create(1,2);');
  12445. Add('end;');
  12446. Add('constructor tcar.create(va, vb: longint); begin end;');
  12447. Add('begin');
  12448. Add(' tobject.create(1);');
  12449. Add(' tobject.create(1,2);');
  12450. Add(' tcar.create(1);');
  12451. Add(' tcar.create(1,2);');
  12452. ConvertProgram;
  12453. CheckSource('TestClass_OverloadConstructor',
  12454. LinesToStr([ // statements
  12455. 'rtl.createClass($mod, "TObject", null, function () {',
  12456. ' this.$init = function () {',
  12457. ' };',
  12458. ' this.$final = function () {',
  12459. ' };',
  12460. ' this.Create = function (vA) {',
  12461. ' this.Create(1);',
  12462. ' this.Create$1(1,2);',
  12463. ' return this;',
  12464. ' };',
  12465. ' this.Create$1 = function (vA, vB) {',
  12466. ' return this;',
  12467. ' };',
  12468. '});',
  12469. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  12470. ' this.Create$2 = function (vA) {',
  12471. ' this.Create$2(1);',
  12472. ' this.Create$3(1, 2);',
  12473. ' $mod.TObject.Create.call(this, 1);',
  12474. ' $mod.TObject.Create$1.call(this, 1, 2);',
  12475. ' return this;',
  12476. ' };',
  12477. ' this.Create$3 = function (vA, vB) {',
  12478. ' return this;',
  12479. ' };',
  12480. '});',
  12481. '']),
  12482. LinesToStr([ // $mod.$main
  12483. '$mod.TObject.$create("Create", [1]);',
  12484. '$mod.TObject.$create("Create$1", [1, 2]);',
  12485. '$mod.TCar.$create("Create$2", [1]);',
  12486. '$mod.TCar.$create("Create$3", [1, 2]);',
  12487. '']));
  12488. end;
  12489. procedure TTestModule.TestClass_OverloadDelphiOverride;
  12490. begin
  12491. StartProgram(false);
  12492. Add([
  12493. '{$mode delphi}',
  12494. 'type',
  12495. ' TObject = class end;',
  12496. ' TBird = class',
  12497. ' function {#a}GetValue: longint; overload; virtual;',
  12498. ' function {#b}GetValue(AValue: longint): longint; overload; virtual;',
  12499. ' end;',
  12500. ' TEagle = class(TBird)',
  12501. ' function {#c}GetValue: longint; overload; override;',
  12502. ' function {#d}GetValue(AValue: longint): longint; overload; override;',
  12503. ' end;',
  12504. 'function TBird.GetValue: longint;',
  12505. 'begin',
  12506. ' if 3={@a}GetValue then ;',
  12507. ' if 4={@b}GetValue(5) then ;',
  12508. 'end;',
  12509. 'function TBird.GetValue(AValue: longint): longint;',
  12510. 'begin',
  12511. 'end;',
  12512. 'function TEagle.GetValue: longint;',
  12513. 'begin',
  12514. ' if 13={@c}GetValue then ;',
  12515. ' if 14={@d}GetValue(15) then ;',
  12516. ' if 15=inherited {@a}GetValue then ;',
  12517. ' if 16=inherited {@b}GetValue(17) then ;',
  12518. 'end;',
  12519. 'function TEagle.GetValue(AValue: longint): longint;',
  12520. 'begin',
  12521. 'end;',
  12522. 'var',
  12523. ' e: TEagle;',
  12524. 'begin',
  12525. ' if 23=e.{@c}GetValue then ;',
  12526. ' if 24=e.{@d}GetValue(25) then ;']);
  12527. ConvertProgram;
  12528. CheckSource('TestClass_OverloadDelphiOverride',
  12529. LinesToStr([ // statements
  12530. 'rtl.createClass($mod, "TObject", null, function () {',
  12531. ' this.$init = function () {',
  12532. ' };',
  12533. ' this.$final = function () {',
  12534. ' };',
  12535. '});',
  12536. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  12537. ' this.GetValue = function () {',
  12538. ' var Result = 0;',
  12539. ' if (3 === this.GetValue()) ;',
  12540. ' if (4 === this.GetValue$1(5)) ;',
  12541. ' return Result;',
  12542. ' };',
  12543. ' this.GetValue$1 = function (AValue) {',
  12544. ' var Result = 0;',
  12545. ' return Result;',
  12546. ' };',
  12547. '});',
  12548. 'rtl.createClass($mod, "TEagle", $mod.TBird, function () {',
  12549. ' this.GetValue = function () {',
  12550. ' var Result = 0;',
  12551. ' if (13 === this.GetValue()) ;',
  12552. ' if (14 === this.GetValue$1(15)) ;',
  12553. ' if (15 === $mod.TBird.GetValue.call(this)) ;',
  12554. ' if (16 === $mod.TBird.GetValue$1.call(this, 17)) ;',
  12555. ' return Result;',
  12556. ' };',
  12557. ' this.GetValue$1 = function (AValue) {',
  12558. ' var Result = 0;',
  12559. ' return Result;',
  12560. ' };',
  12561. '});',
  12562. 'this.e = null;',
  12563. '']),
  12564. LinesToStr([ // $mod.$main
  12565. 'if (23 === $mod.e.GetValue()) ;',
  12566. 'if (24 === $mod.e.GetValue$1(25)) ;',
  12567. '']));
  12568. end;
  12569. procedure TTestModule.TestClass_ReintroducedVar;
  12570. begin
  12571. StartProgram(false);
  12572. Add('type');
  12573. Add(' TObject = class');
  12574. Add(' strict private');
  12575. Add(' Some: longint;');
  12576. Add(' end;');
  12577. Add(' TMobile = class');
  12578. Add(' strict private');
  12579. Add(' Some: string;');
  12580. Add(' end;');
  12581. Add(' TCar = class(tmobile)');
  12582. Add(' procedure Some;');
  12583. Add(' procedure Some(vA: longint);');
  12584. Add(' end;');
  12585. Add('procedure tcar.some;');
  12586. Add('begin');
  12587. Add(' Some;');
  12588. Add(' Some(1);');
  12589. Add('end;');
  12590. Add('procedure tcar.some(va: longint); begin end;');
  12591. Add('begin');
  12592. ConvertProgram;
  12593. CheckSource('TestClass_ReintroducedVar',
  12594. LinesToStr([ // statements
  12595. 'rtl.createClass($mod, "TObject", null, function () {',
  12596. ' this.$init = function () {',
  12597. ' this.Some = 0;',
  12598. ' };',
  12599. ' this.$final = function () {',
  12600. ' };',
  12601. '});',
  12602. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  12603. ' this.$init = function () {',
  12604. ' $mod.TObject.$init.call(this);',
  12605. ' this.Some$1 = "";',
  12606. ' };',
  12607. '});',
  12608. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  12609. ' this.Some$2 = function () {',
  12610. ' this.Some$2();',
  12611. ' this.Some$3(1);',
  12612. ' };',
  12613. ' this.Some$3 = function (vA) {',
  12614. ' };',
  12615. '});',
  12616. '']),
  12617. LinesToStr([ // $mod.$main
  12618. '']));
  12619. end;
  12620. procedure TTestModule.TestClass_RaiseDescendant;
  12621. begin
  12622. StartProgram(false);
  12623. Add([
  12624. 'type',
  12625. ' TObject = class',
  12626. ' constructor Create(Msg: string);',
  12627. ' end;',
  12628. ' Exception = class',
  12629. ' end;',
  12630. ' EConvertError = class(Exception)',
  12631. ' end;',
  12632. 'constructor TObject.Create(Msg: string); begin end;',
  12633. 'function AssertConv(Msg: string = ''def''): EConvertError; begin end;',
  12634. 'begin',
  12635. ' raise Exception.Create(''Bar1'');',
  12636. ' raise EConvertError.Create(''Bar2'');',
  12637. ' raise AssertConv(''Bar2'');',
  12638. ' raise AssertConv;',
  12639. '']);
  12640. ConvertProgram;
  12641. CheckSource('TestClass_RaiseDescendant',
  12642. LinesToStr([ // statements
  12643. 'rtl.createClass($mod, "TObject", null, function () {',
  12644. ' this.$init = function () {',
  12645. ' };',
  12646. ' this.$final = function () {',
  12647. ' };',
  12648. ' this.Create = function (Msg) {',
  12649. ' return this;',
  12650. ' };',
  12651. '});',
  12652. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  12653. '});',
  12654. 'rtl.createClass($mod, "EConvertError", $mod.Exception, function () {',
  12655. '});',
  12656. 'this.AssertConv = function (Msg) {',
  12657. ' var Result = null;',
  12658. ' return Result;',
  12659. '};',
  12660. '']),
  12661. LinesToStr([ // $mod.$main
  12662. 'throw $mod.Exception.$create("Create",["Bar1"]);',
  12663. 'throw $mod.EConvertError.$create("Create",["Bar2"]);',
  12664. 'throw $mod.AssertConv("Bar2");',
  12665. 'throw $mod.AssertConv("def");',
  12666. '']));
  12667. end;
  12668. procedure TTestModule.TestClass_ExternalMethod;
  12669. begin
  12670. AddModuleWithIntfImplSrc('unit2.pas',
  12671. LinesToStr([
  12672. 'type',
  12673. ' TObject = class',
  12674. ' public',
  12675. ' procedure Intern; external name ''$DoIntern'';',
  12676. ' end;',
  12677. '']),
  12678. LinesToStr([
  12679. '']));
  12680. StartUnit(true);
  12681. Add('interface');
  12682. Add('uses unit2;');
  12683. Add('type');
  12684. Add(' TCar = class(TObject)');
  12685. Add(' public');
  12686. Add(' procedure Intern2; external name ''$DoIntern2'';');
  12687. Add(' procedure DoIt;');
  12688. Add(' end;');
  12689. Add('implementation');
  12690. Add('procedure tcar.doit;');
  12691. Add('begin');
  12692. Add(' Intern;');
  12693. Add(' Intern();');
  12694. Add(' Intern2;');
  12695. Add(' Intern2();');
  12696. Add('end;');
  12697. Add('var Obj: TCar;');
  12698. Add('begin');
  12699. Add(' obj.intern;');
  12700. Add(' obj.intern();');
  12701. Add(' obj.intern2;');
  12702. Add(' obj.intern2();');
  12703. Add(' obj.doit;');
  12704. Add(' obj.doit();');
  12705. Add(' with obj do begin');
  12706. Add(' Intern;');
  12707. Add(' Intern();');
  12708. Add(' Intern2;');
  12709. Add(' Intern2();');
  12710. Add(' end;');
  12711. ConvertUnit;
  12712. CheckSource('TestClass_ExternalMethod',
  12713. LinesToStr([
  12714. 'var $impl = $mod.$impl;',
  12715. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  12716. ' this.DoIt = function () {',
  12717. ' this.$DoIntern();',
  12718. ' this.$DoIntern();',
  12719. ' this.$DoIntern2();',
  12720. ' this.$DoIntern2();',
  12721. ' };',
  12722. ' });',
  12723. '']),
  12724. LinesToStr([ // this.$init
  12725. '$impl.Obj.$DoIntern();',
  12726. '$impl.Obj.$DoIntern();',
  12727. '$impl.Obj.$DoIntern2();',
  12728. '$impl.Obj.$DoIntern2();',
  12729. '$impl.Obj.DoIt();',
  12730. '$impl.Obj.DoIt();',
  12731. 'var $with1 = $impl.Obj;',
  12732. '$with1.$DoIntern();',
  12733. '$with1.$DoIntern();',
  12734. '$with1.$DoIntern2();',
  12735. '$with1.$DoIntern2();',
  12736. '']),
  12737. LinesToStr([ // implementation
  12738. '$impl.Obj = null;',
  12739. '']) );
  12740. end;
  12741. procedure TTestModule.TestClass_ExternalVirtualNameMismatchFail;
  12742. begin
  12743. StartProgram(false);
  12744. Add('type');
  12745. Add(' TObject = class');
  12746. Add(' procedure DoIt; virtual; external name ''Foo'';');
  12747. Add(' end;');
  12748. Add('begin');
  12749. SetExpectedPasResolverError('Virtual method name must match external',
  12750. nVirtualMethodNameMustMatchExternal);
  12751. ConvertProgram;
  12752. end;
  12753. procedure TTestModule.TestClass_ExternalOverrideFail;
  12754. begin
  12755. StartProgram(false);
  12756. Add('type');
  12757. Add(' TObject = class');
  12758. Add(' procedure DoIt; virtual; external name ''DoIt'';');
  12759. Add(' end;');
  12760. Add(' TCar = class');
  12761. Add(' procedure DoIt; override; external name ''DoIt'';');
  12762. Add(' end;');
  12763. Add('begin');
  12764. SetExpectedPasResolverError('Invalid procedure modifier override,external',
  12765. nInvalidXModifierY);
  12766. ConvertProgram;
  12767. end;
  12768. procedure TTestModule.TestClass_ExternalVar;
  12769. begin
  12770. AddModuleWithIntfImplSrc('unit2.pas',
  12771. LinesToStr([
  12772. '{$modeswitch externalclass}',
  12773. 'type',
  12774. ' TObject = class',
  12775. ' public',
  12776. ' Intern: longint external name ''$Intern'';',
  12777. ' Bracket: longint external name ''["A B"]'';',
  12778. ' end;',
  12779. '']),
  12780. LinesToStr([
  12781. '']));
  12782. StartUnit(true);
  12783. Add([
  12784. 'interface',
  12785. 'uses unit2;',
  12786. '{$modeswitch externalclass}',
  12787. 'type',
  12788. ' TCar = class(tobject)',
  12789. ' public',
  12790. ' Intern2: longint external name ''$Intern2'';',
  12791. ' procedure DoIt;',
  12792. ' end;',
  12793. 'implementation',
  12794. 'procedure tcar.doit;',
  12795. 'begin',
  12796. ' Intern:=Intern+1;',
  12797. ' Intern2:=Intern2+2;',
  12798. ' Bracket:=Bracket+3;',
  12799. 'end;',
  12800. 'var Obj: TCar;',
  12801. 'begin',
  12802. ' obj.intern:=obj.intern+1;',
  12803. ' obj.intern2:=obj.intern2+2;',
  12804. ' obj.Bracket:=obj.Bracket+3;',
  12805. ' with obj do begin',
  12806. ' intern:=intern+1;',
  12807. ' intern2:=intern2+2;',
  12808. ' Bracket:=Bracket+3;',
  12809. ' end;']);
  12810. ConvertUnit;
  12811. CheckSource('TestClass_ExternalVar',
  12812. LinesToStr([
  12813. 'var $impl = $mod.$impl;',
  12814. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  12815. ' this.DoIt = function () {',
  12816. ' this.$Intern = this.$Intern + 1;',
  12817. ' this.$Intern2 = this.$Intern2 + 2;',
  12818. ' this["A B"] = this["A B"] + 3;',
  12819. ' };',
  12820. ' });',
  12821. '']),
  12822. LinesToStr([
  12823. '$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
  12824. '$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
  12825. '$impl.Obj["A B"] = $impl.Obj["A B"] + 3;',
  12826. 'var $with1 = $impl.Obj;',
  12827. '$with1.$Intern = $with1.$Intern + 1;',
  12828. '$with1.$Intern2 = $with1.$Intern2 + 2;',
  12829. '$with1["A B"] = $with1["A B"] + 3;',
  12830. '']),
  12831. LinesToStr([ // implementation
  12832. '$impl.Obj = null;',
  12833. '']));
  12834. end;
  12835. procedure TTestModule.TestClass_Const;
  12836. begin
  12837. StartProgram(false);
  12838. Add('type');
  12839. Add(' integer = longint;');
  12840. Add(' TClass = class of TObject;');
  12841. Add(' TObject = class');
  12842. Add(' public');
  12843. Add(' const cI: integer = 3;');
  12844. Add(' procedure DoIt;');
  12845. Add(' class procedure DoMore;');
  12846. Add(' end;');
  12847. Add('implementation');
  12848. Add('procedure tobject.doit;');
  12849. Add('begin');
  12850. Add(' if cI=4 then;');
  12851. Add(' if 5=cI then;');
  12852. Add(' if Self.cI=6 then;');
  12853. Add(' if 7=Self.cI then;');
  12854. Add(' with Self do begin');
  12855. Add(' if cI=11 then;');
  12856. Add(' if 12=cI then;');
  12857. Add(' end;');
  12858. Add('end;');
  12859. Add('class procedure tobject.domore;');
  12860. Add('begin');
  12861. Add(' if cI=8 then;');
  12862. Add(' if Self.cI=9 then;');
  12863. Add(' if 10=cI then;');
  12864. Add(' if 11=Self.cI then;');
  12865. Add(' with Self do begin');
  12866. Add(' if cI=13 then;');
  12867. Add(' if 14=cI then;');
  12868. Add(' end;');
  12869. Add('end;');
  12870. Add('var');
  12871. Add(' Obj: TObject;');
  12872. Add(' Cla: TClass;');
  12873. Add('begin');
  12874. Add(' if TObject.cI=21 then ;');
  12875. Add(' if Obj.cI=22 then ;');
  12876. Add(' if Cla.cI=23 then ;');
  12877. Add(' with obj do if ci=24 then;');
  12878. Add(' with TObject do if ci=25 then;');
  12879. Add(' with Cla do if ci=26 then;');
  12880. ConvertProgram;
  12881. CheckSource('TestClass_Const',
  12882. LinesToStr([
  12883. 'rtl.createClass($mod, "TObject", null, function () {',
  12884. ' this.cI = 3;',
  12885. ' this.$init = function () {',
  12886. ' };',
  12887. ' this.$final = function () {',
  12888. ' };',
  12889. ' this.DoIt = function () {',
  12890. ' if (this.cI === 4) ;',
  12891. ' if (5 === this.cI) ;',
  12892. ' if (this.cI === 6) ;',
  12893. ' if (7 === this.cI) ;',
  12894. ' if (this.cI === 11) ;',
  12895. ' if (12 === this.cI) ;',
  12896. ' };',
  12897. ' this.DoMore = function () {',
  12898. ' if (this.cI === 8) ;',
  12899. ' if (this.cI === 9) ;',
  12900. ' if (10 === this.cI) ;',
  12901. ' if (11 === this.cI) ;',
  12902. ' if (this.cI === 13) ;',
  12903. ' if (14 === this.cI) ;',
  12904. ' };',
  12905. '});',
  12906. 'this.Obj = null;',
  12907. 'this.Cla = null;',
  12908. '']),
  12909. LinesToStr([
  12910. 'if ($mod.TObject.cI === 21) ;',
  12911. 'if ($mod.Obj.cI === 22) ;',
  12912. 'if ($mod.Cla.cI === 23) ;',
  12913. 'var $with1 = $mod.Obj;',
  12914. 'if ($with1.cI === 24) ;',
  12915. 'var $with2 = $mod.TObject;',
  12916. 'if ($with2.cI === 25) ;',
  12917. 'var $with3 = $mod.Cla;',
  12918. 'if ($with3.cI === 26) ;',
  12919. '']));
  12920. end;
  12921. procedure TTestModule.TestClass_LocalVarSelfFail;
  12922. begin
  12923. StartProgram(false);
  12924. Add([
  12925. 'type',
  12926. ' TObject = class',
  12927. ' constructor Create;',
  12928. ' end;',
  12929. 'constructor tobject.create;',
  12930. 'var self: longint;',
  12931. 'begin',
  12932. 'end',
  12933. 'begin',
  12934. '']);
  12935. SetExpectedPasResolverError('Duplicate identifier "self" at (0)',nDuplicateIdentifier);
  12936. ConvertProgram;
  12937. end;
  12938. procedure TTestModule.TestClass_ArgSelfFail;
  12939. begin
  12940. StartProgram(false);
  12941. Add([
  12942. 'type',
  12943. ' TObject = class',
  12944. ' procedure DoIt(Self: longint);',
  12945. ' end;',
  12946. 'procedure tobject.doit(self: longint);',
  12947. 'begin',
  12948. 'end',
  12949. 'begin',
  12950. '']);
  12951. SetExpectedPasResolverError('Duplicate identifier "Self" at test1.pp(5,24)',nDuplicateIdentifier);
  12952. ConvertProgram;
  12953. end;
  12954. procedure TTestModule.TestClass_NestedProcSelf;
  12955. begin
  12956. StartProgram(false);
  12957. Add([
  12958. 'type',
  12959. ' TObject = class',
  12960. ' Key: longint;',
  12961. ' class var State: longint;',
  12962. ' procedure DoIt;',
  12963. ' function GetSize: longint; virtual; abstract;',
  12964. ' procedure SetSize(Value: longint); virtual; abstract;',
  12965. ' property Size: longint read GetSize write SetSize;',
  12966. ' end;',
  12967. 'procedure tobject.doit;',
  12968. ' procedure Sub;',
  12969. ' begin',
  12970. ' key:=key+2;',
  12971. ' self.key:=self.key+3;',
  12972. ' state:=state+4;',
  12973. ' self.state:=self.state+5;',
  12974. ' tobject.state:=tobject.state+6;',
  12975. ' size:=size+7;',
  12976. ' self.size:=self.size+8;',
  12977. ' end;',
  12978. 'begin',
  12979. ' sub;',
  12980. ' key:=key+12;',
  12981. ' self.key:=self.key+13;',
  12982. ' state:=state+14;',
  12983. ' self.state:=self.state+15;',
  12984. ' tobject.state:=tobject.state+16;',
  12985. ' size:=size+17;',
  12986. ' self.size:=self.size+18;',
  12987. 'end;',
  12988. 'begin',
  12989. '']);
  12990. ConvertProgram;
  12991. CheckSource('TestClass_NestedProcSelf',
  12992. LinesToStr([ // statements
  12993. 'rtl.createClass($mod, "TObject", null, function () {',
  12994. ' this.State = 0;',
  12995. ' this.$init = function () {',
  12996. ' this.Key = 0;',
  12997. ' };',
  12998. ' this.$final = function () {',
  12999. ' };',
  13000. ' this.DoIt = function () {',
  13001. ' var $Self = this;',
  13002. ' function Sub() {',
  13003. ' $Self.Key = $Self.Key + 2;',
  13004. ' $Self.Key = $Self.Key + 3;',
  13005. ' $mod.TObject.State = $Self.State + 4;',
  13006. ' $mod.TObject.State = $Self.State + 5;',
  13007. ' $mod.TObject.State = $mod.TObject.State + 6;',
  13008. ' $Self.SetSize($Self.GetSize() + 7);',
  13009. ' $Self.SetSize($Self.GetSize() + 8);',
  13010. ' };',
  13011. ' Sub();',
  13012. ' $Self.Key = $Self.Key + 12;',
  13013. ' $Self.Key = $Self.Key + 13;',
  13014. ' $mod.TObject.State = $Self.State + 14;',
  13015. ' $mod.TObject.State = $Self.State + 15;',
  13016. ' $mod.TObject.State = $mod.TObject.State + 16;',
  13017. ' $Self.SetSize($Self.GetSize() + 17);',
  13018. ' $Self.SetSize($Self.GetSize() + 18);',
  13019. ' };',
  13020. '});',
  13021. '']),
  13022. LinesToStr([ // $mod.$main
  13023. '']));
  13024. end;
  13025. procedure TTestModule.TestClass_NestedProcSelf2;
  13026. begin
  13027. StartProgram(false);
  13028. Add([
  13029. 'type',
  13030. ' TObject = class',
  13031. ' Key: longint;',
  13032. ' class var State: longint;',
  13033. ' function GetSize: longint; virtual; abstract;',
  13034. ' procedure SetSize(Value: longint); virtual; abstract;',
  13035. ' property Size: longint read GetSize write SetSize;',
  13036. ' end;',
  13037. ' TBird = class',
  13038. ' procedure DoIt;',
  13039. ' end;',
  13040. 'procedure tbird.doit;',
  13041. ' procedure Sub;',
  13042. ' begin',
  13043. ' key:=key+2;',
  13044. ' self.key:=self.key+3;',
  13045. ' state:=state+4;',
  13046. ' self.state:=self.state+5;',
  13047. ' tobject.state:=tobject.state+6;',
  13048. ' size:=size+7;',
  13049. ' self.size:=self.size+8;',
  13050. ' end;',
  13051. 'begin',
  13052. ' sub;',
  13053. ' key:=key+12;',
  13054. ' self.key:=self.key+13;',
  13055. ' state:=state+14;',
  13056. ' self.state:=self.state+15;',
  13057. ' tobject.state:=tobject.state+16;',
  13058. ' size:=size+17;',
  13059. ' self.size:=self.size+18;',
  13060. 'end;',
  13061. 'begin',
  13062. '']);
  13063. ConvertProgram;
  13064. CheckSource('TestClass_NestedProcSelf2',
  13065. LinesToStr([ // statements
  13066. 'rtl.createClass($mod, "TObject", null, function () {',
  13067. ' this.State = 0;',
  13068. ' this.$init = function () {',
  13069. ' this.Key = 0;',
  13070. ' };',
  13071. ' this.$final = function () {',
  13072. ' };',
  13073. '});',
  13074. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13075. ' this.DoIt = function () {',
  13076. ' var $Self = this;',
  13077. ' function Sub() {',
  13078. ' $Self.Key = $Self.Key + 2;',
  13079. ' $Self.Key = $Self.Key + 3;',
  13080. ' $mod.TObject.State = $Self.State + 4;',
  13081. ' $mod.TObject.State = $Self.State + 5;',
  13082. ' $mod.TObject.State = $mod.TObject.State + 6;',
  13083. ' $Self.SetSize($Self.GetSize() + 7);',
  13084. ' $Self.SetSize($Self.GetSize() + 8);',
  13085. ' };',
  13086. ' Sub();',
  13087. ' $Self.Key = $Self.Key + 12;',
  13088. ' $Self.Key = $Self.Key + 13;',
  13089. ' $mod.TObject.State = $Self.State + 14;',
  13090. ' $mod.TObject.State = $Self.State + 15;',
  13091. ' $mod.TObject.State = $mod.TObject.State + 16;',
  13092. ' $Self.SetSize($Self.GetSize() + 17);',
  13093. ' $Self.SetSize($Self.GetSize() + 18);',
  13094. ' };',
  13095. '});',
  13096. '']),
  13097. LinesToStr([ // $mod.$main
  13098. '']));
  13099. end;
  13100. procedure TTestModule.TestClass_NestedProcClassSelf;
  13101. begin
  13102. StartProgram(false);
  13103. Add([
  13104. 'type',
  13105. ' TObject = class',
  13106. ' class var State: longint;',
  13107. ' class procedure DoIt;',
  13108. ' class function GetSize: longint; virtual; abstract;',
  13109. ' class procedure SetSize(Value: longint); virtual; abstract;',
  13110. ' class property Size: longint read GetSize write SetSize;',
  13111. ' end;',
  13112. 'class procedure tobject.doit;',
  13113. ' procedure Sub;',
  13114. ' begin',
  13115. ' state:=state+2;',
  13116. ' self.state:=self.state+3;',
  13117. ' tobject.state:=tobject.state+4;',
  13118. ' size:=size+5;',
  13119. ' self.size:=self.size+6;',
  13120. ' tobject.size:=tobject.size+7;',
  13121. ' end;',
  13122. 'begin',
  13123. ' sub;',
  13124. ' state:=state+12;',
  13125. ' self.state:=self.state+13;',
  13126. ' tobject.state:=tobject.state+14;',
  13127. ' size:=size+15;',
  13128. ' self.size:=self.size+16;',
  13129. ' tobject.size:=tobject.size+17;',
  13130. 'end;',
  13131. 'begin',
  13132. '']);
  13133. ConvertProgram;
  13134. CheckSource('TestClass_NestedProcClassSelf',
  13135. LinesToStr([ // statements
  13136. 'rtl.createClass($mod, "TObject", null, function () {',
  13137. ' this.State = 0;',
  13138. ' this.$init = function () {',
  13139. ' };',
  13140. ' this.$final = function () {',
  13141. ' };',
  13142. ' this.DoIt = function () {',
  13143. ' var $Self = this;',
  13144. ' function Sub() {',
  13145. ' $mod.TObject.State = $Self.State + 2;',
  13146. ' $mod.TObject.State = $Self.State + 3;',
  13147. ' $mod.TObject.State = $mod.TObject.State + 4;',
  13148. ' $Self.SetSize($Self.GetSize() + 5);',
  13149. ' $Self.SetSize($Self.GetSize() + 6);',
  13150. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 7);',
  13151. ' };',
  13152. ' Sub();',
  13153. ' $mod.TObject.State = $Self.State + 12;',
  13154. ' $mod.TObject.State = $Self.State + 13;',
  13155. ' $mod.TObject.State = $mod.TObject.State + 14;',
  13156. ' $Self.SetSize($Self.GetSize() + 15);',
  13157. ' $Self.SetSize($Self.GetSize() + 16);',
  13158. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
  13159. ' };',
  13160. '});',
  13161. '']),
  13162. LinesToStr([ // $mod.$main
  13163. '']));
  13164. end;
  13165. procedure TTestModule.TestClass_NestedProcCallInherited;
  13166. begin
  13167. StartProgram(false);
  13168. Add([
  13169. 'type',
  13170. ' TObject = class',
  13171. ' function DoIt(k: boolean): longint; virtual;',
  13172. ' end;',
  13173. ' TBird = class',
  13174. ' function DoIt(k: boolean): longint; override;',
  13175. ' end;',
  13176. 'function tobject.doit(k: boolean): longint;',
  13177. 'begin',
  13178. 'end;',
  13179. 'function tbird.doit(k: boolean): longint;',
  13180. ' procedure Sub;',
  13181. ' begin',
  13182. ' inherited DoIt(true);',
  13183. //' if inherited DoIt(false)=4 then ;',
  13184. ' end;',
  13185. 'begin',
  13186. ' Sub;',
  13187. ' inherited;',
  13188. ' inherited DoIt(true);',
  13189. //' if inherited DoIt(false)=14 then ;',
  13190. 'end;',
  13191. 'begin',
  13192. '']);
  13193. ConvertProgram;
  13194. CheckSource('TestClass_NestedProcCallInherited',
  13195. LinesToStr([ // statements
  13196. 'rtl.createClass($mod, "TObject", null, function () {',
  13197. ' this.$init = function () {',
  13198. ' };',
  13199. ' this.$final = function () {',
  13200. ' };',
  13201. ' this.DoIt = function (k) {',
  13202. ' var Result = 0;',
  13203. ' return Result;',
  13204. ' };',
  13205. '});',
  13206. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13207. ' this.DoIt = function (k) {',
  13208. ' var $Self = this;',
  13209. ' var Result = 0;',
  13210. ' function Sub() {',
  13211. ' $mod.TObject.DoIt.call($Self, true);',
  13212. ' };',
  13213. ' Sub();',
  13214. ' $mod.TObject.DoIt.apply($Self, arguments);',
  13215. ' $mod.TObject.DoIt.call($Self, true);',
  13216. ' return Result;',
  13217. ' };',
  13218. '});',
  13219. '']),
  13220. LinesToStr([ // $mod.$main
  13221. '']));
  13222. end;
  13223. procedure TTestModule.TestClass_TObjectFree;
  13224. begin
  13225. StartProgram(false);
  13226. Add([
  13227. 'type',
  13228. ' TObject = class',
  13229. ' Obj: tobject;',
  13230. ' procedure Free;',
  13231. ' procedure Release;',
  13232. ' end;',
  13233. 'procedure tobject.free;',
  13234. 'begin',
  13235. 'end;',
  13236. 'procedure tobject.release;',
  13237. 'begin',
  13238. ' free;',
  13239. ' if true then free;',
  13240. 'end;',
  13241. 'function DoIt(o: tobject): tobject;',
  13242. 'var l: tobject;',
  13243. 'begin',
  13244. ' o.free;',
  13245. ' o.free();',
  13246. ' l.free;',
  13247. ' l.free();',
  13248. ' o.obj.free;',
  13249. ' o.obj.free();',
  13250. ' with o do obj.free;',
  13251. ' with o do obj.free();',
  13252. ' result.Free;',
  13253. ' result.Free();',
  13254. 'end;',
  13255. 'var o: tobject;',
  13256. ' a: array of tobject;',
  13257. 'begin',
  13258. ' o.free;',
  13259. ' o.obj.free;',
  13260. ' a[1+2].free;',
  13261. '']);
  13262. ConvertProgram;
  13263. CheckSource('TestClass_TObjectFree',
  13264. LinesToStr([ // statements
  13265. 'rtl.createClass($mod, "TObject", null, function () {',
  13266. ' this.$init = function () {',
  13267. ' this.Obj = null;',
  13268. ' };',
  13269. ' this.$final = function () {',
  13270. ' this.Obj = undefined;',
  13271. ' };',
  13272. ' this.Free = function () {',
  13273. ' };',
  13274. ' this.Release = function () {',
  13275. ' this.Free();',
  13276. ' if (true) this.Free();',
  13277. ' };',
  13278. '});',
  13279. 'this.DoIt = function (o) {',
  13280. ' var Result = null;',
  13281. ' var l = null;',
  13282. ' o = rtl.freeLoc(o);',
  13283. ' o = rtl.freeLoc(o);',
  13284. ' l = rtl.freeLoc(l);',
  13285. ' l = rtl.freeLoc(l);',
  13286. ' rtl.free(o, "Obj");',
  13287. ' rtl.free(o, "Obj");',
  13288. ' rtl.free(o, "Obj");',
  13289. ' rtl.free(o, "Obj");',
  13290. ' Result = rtl.freeLoc(Result);',
  13291. ' Result = rtl.freeLoc(Result);',
  13292. ' return Result;',
  13293. '};',
  13294. 'this.o = null;',
  13295. 'this.a = [];',
  13296. '']),
  13297. LinesToStr([ // $mod.$main
  13298. 'rtl.free($mod, "o");',
  13299. 'rtl.free($mod.o, "Obj");',
  13300. 'rtl.free($mod.a, 1 + 2);',
  13301. '']));
  13302. end;
  13303. procedure TTestModule.TestClass_TObjectFreeNewInstance;
  13304. begin
  13305. StartProgram(false);
  13306. Add([
  13307. 'type',
  13308. ' TObject = class',
  13309. ' constructor Create;',
  13310. ' procedure Free;',
  13311. ' end;',
  13312. 'constructor TObject.Create; begin end;',
  13313. 'procedure tobject.free; begin end;',
  13314. 'begin',
  13315. ' with tobject.create do free;',
  13316. '']);
  13317. ConvertProgram;
  13318. CheckSource('TestClass_TObjectFreeNewInstance',
  13319. LinesToStr([ // statements
  13320. 'rtl.createClass($mod, "TObject", null, function () {',
  13321. ' this.$init = function () {',
  13322. ' };',
  13323. ' this.$final = function () {',
  13324. ' };',
  13325. ' this.Create = function () {',
  13326. ' return this;',
  13327. ' };',
  13328. ' this.Free = function () {',
  13329. ' };',
  13330. '});',
  13331. '']),
  13332. LinesToStr([ // $mod.$main
  13333. 'var $with1 = $mod.TObject.$create("Create");',
  13334. '$with1=rtl.freeLoc($with1);',
  13335. '']));
  13336. end;
  13337. procedure TTestModule.TestClass_TObjectFreeLowerCase;
  13338. begin
  13339. StartProgram(false);
  13340. Add([
  13341. 'type',
  13342. ' TObject = class',
  13343. ' destructor Destroy;',
  13344. ' procedure Free;',
  13345. ' end;',
  13346. 'destructor TObject.Destroy; begin end;',
  13347. 'procedure tobject.free; begin end;',
  13348. 'var o: tobject;',
  13349. 'begin',
  13350. ' o.free;',
  13351. '']);
  13352. Converter.UseLowerCase:=true;
  13353. ConvertProgram;
  13354. CheckSource('TestClass_TObjectFreeLowerCase',
  13355. LinesToStr([ // statements
  13356. 'rtl.createClass($mod, "tobject", null, function () {',
  13357. ' this.$init = function () {',
  13358. ' };',
  13359. ' this.$final = function () {',
  13360. ' };',
  13361. ' rtl.tObjectDestroy = "destroy";',
  13362. ' this.destroy = function () {',
  13363. ' };',
  13364. ' this.free = function () {',
  13365. ' };',
  13366. '});',
  13367. 'this.o = null;',
  13368. '']),
  13369. LinesToStr([ // $mod.$main
  13370. 'rtl.free($mod, "o");',
  13371. '']));
  13372. end;
  13373. procedure TTestModule.TestClass_TObjectFreeFunctionFail;
  13374. begin
  13375. StartProgram(false);
  13376. Add([
  13377. 'type',
  13378. ' TObject = class',
  13379. ' procedure Free;',
  13380. ' function GetObj: tobject; virtual; abstract;',
  13381. ' end;',
  13382. 'procedure tobject.free;',
  13383. 'begin',
  13384. 'end;',
  13385. 'var o: tobject;',
  13386. 'begin',
  13387. ' o.getobj.free;',
  13388. '']);
  13389. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  13390. ConvertProgram;
  13391. end;
  13392. procedure TTestModule.TestClass_TObjectFreePropertyFail;
  13393. begin
  13394. StartProgram(false);
  13395. Add([
  13396. 'type',
  13397. ' TObject = class',
  13398. ' procedure Free;',
  13399. ' FObj: TObject;',
  13400. ' property Obj: tobject read FObj write FObj;',
  13401. ' end;',
  13402. 'procedure tobject.free;',
  13403. 'begin',
  13404. 'end;',
  13405. 'var o: tobject;',
  13406. 'begin',
  13407. ' o.obj.free;',
  13408. '']);
  13409. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  13410. ConvertProgram;
  13411. end;
  13412. procedure TTestModule.TestClass_ForIn;
  13413. begin
  13414. StartProgram(false);
  13415. Add([
  13416. 'type',
  13417. ' TObject = class end;',
  13418. ' TItem = TObject;',
  13419. ' TEnumerator = class',
  13420. ' FCurrent: TItem;',
  13421. ' property Current: TItem read FCurrent;',
  13422. ' function MoveNext: boolean;',
  13423. ' end;',
  13424. ' TBird = class',
  13425. ' function GetEnumerator: TEnumerator;',
  13426. ' end;',
  13427. 'function TEnumerator.MoveNext: boolean;',
  13428. 'begin',
  13429. 'end;',
  13430. 'function TBird.GetEnumerator: TEnumerator;',
  13431. 'begin',
  13432. 'end;',
  13433. 'var',
  13434. ' b: TBird;',
  13435. ' i, i2: TItem;',
  13436. 'begin',
  13437. ' for i in b do i2:=i;']);
  13438. ConvertProgram;
  13439. CheckSource('TestClass_ForIn',
  13440. LinesToStr([ // statements
  13441. 'rtl.createClass($mod, "TObject", null, function () {',
  13442. ' this.$init = function () {',
  13443. ' };',
  13444. ' this.$final = function () {',
  13445. ' };',
  13446. '});',
  13447. 'rtl.createClass($mod, "TEnumerator", $mod.TObject, function () {',
  13448. ' this.$init = function () {',
  13449. ' $mod.TObject.$init.call(this);',
  13450. ' this.FCurrent = null;',
  13451. ' };',
  13452. ' this.$final = function () {',
  13453. ' this.FCurrent = undefined;',
  13454. ' $mod.TObject.$final.call(this);',
  13455. ' };',
  13456. ' this.MoveNext = function () {',
  13457. ' var Result = false;',
  13458. ' return Result;',
  13459. ' };',
  13460. '});',
  13461. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13462. ' this.GetEnumerator = function () {',
  13463. ' var Result = null;',
  13464. ' return Result;',
  13465. ' };',
  13466. '});',
  13467. 'this.b = null;',
  13468. 'this.i = null;',
  13469. 'this.i2 = null;'
  13470. ]),
  13471. LinesToStr([ // $mod.$main
  13472. 'var $in1 = $mod.b.GetEnumerator();',
  13473. 'try {',
  13474. ' while ($in1.MoveNext()){',
  13475. ' $mod.i = $in1.FCurrent;',
  13476. ' $mod.i2 = $mod.i;',
  13477. ' }',
  13478. '} finally {',
  13479. ' $in1 = rtl.freeLoc($in1)',
  13480. '};',
  13481. '']));
  13482. end;
  13483. procedure TTestModule.TestClassOf_Create;
  13484. begin
  13485. StartProgram(false);
  13486. Add('type');
  13487. Add(' TObject = class');
  13488. Add(' constructor Create;');
  13489. Add(' end;');
  13490. Add(' TClass = class of TObject;');
  13491. Add('constructor tobject.create; begin end;');
  13492. Add('var');
  13493. Add(' Obj: tobject;');
  13494. Add(' C: tclass;');
  13495. Add('begin');
  13496. Add(' obj:=C.create;');
  13497. Add(' with c do obj:=create;');
  13498. ConvertProgram;
  13499. CheckSource('TestClassOf_Create',
  13500. LinesToStr([ // statements
  13501. 'rtl.createClass($mod, "TObject", null, function () {',
  13502. ' this.$init = function () {',
  13503. ' };',
  13504. ' this.$final = function () {',
  13505. ' };',
  13506. ' this.Create = function () {',
  13507. ' return this;',
  13508. ' };',
  13509. '});',
  13510. 'this.Obj = null;',
  13511. 'this.C = null;'
  13512. ]),
  13513. LinesToStr([ // $mod.$main
  13514. '$mod.Obj = $mod.C.$create("Create");',
  13515. 'var $with1 = $mod.C;',
  13516. '$mod.Obj = $with1.$create("Create");',
  13517. '']));
  13518. end;
  13519. procedure TTestModule.TestClassOf_Call;
  13520. begin
  13521. StartProgram(false);
  13522. Add('type');
  13523. Add(' TObject = class');
  13524. Add(' class procedure DoIt;');
  13525. Add(' end;');
  13526. Add(' TClass = class of TObject;');
  13527. Add('class procedure tobject.doit; begin end;');
  13528. Add('var');
  13529. Add(' C: tclass;');
  13530. Add('begin');
  13531. Add(' c.doit;');
  13532. Add(' with c do doit;');
  13533. ConvertProgram;
  13534. CheckSource('TestClassOf_Call',
  13535. LinesToStr([ // statements
  13536. 'rtl.createClass($mod, "TObject", null, function () {',
  13537. ' this.$init = function () {',
  13538. ' };',
  13539. ' this.$final = function () {',
  13540. ' };',
  13541. ' this.DoIt = function () {',
  13542. ' };',
  13543. '});',
  13544. 'this.C = null;'
  13545. ]),
  13546. LinesToStr([ // $mod.$main
  13547. '$mod.C.DoIt();',
  13548. 'var $with1 = $mod.C;',
  13549. '$with1.DoIt();',
  13550. '']));
  13551. end;
  13552. procedure TTestModule.TestClassOf_Assign;
  13553. begin
  13554. StartProgram(false);
  13555. Add('type');
  13556. Add(' TClass = class of TObject;');
  13557. Add(' TObject = class');
  13558. Add(' ClassType: TClass; ');
  13559. Add(' end;');
  13560. Add('var');
  13561. Add(' Obj: tobject;');
  13562. Add(' C: tclass;');
  13563. Add('begin');
  13564. Add(' c:=nil;');
  13565. Add(' c:=obj.classtype;');
  13566. ConvertProgram;
  13567. CheckSource('TestClassOf_Assign',
  13568. LinesToStr([ // statements
  13569. 'rtl.createClass($mod, "TObject", null, function () {',
  13570. ' this.$init = function () {',
  13571. ' this.ClassType = null;',
  13572. ' };',
  13573. ' this.$final = function () {',
  13574. ' this.ClassType = undefined;',
  13575. ' };',
  13576. '});',
  13577. 'this.Obj = null;',
  13578. 'this.C = null;'
  13579. ]),
  13580. LinesToStr([ // $mod.$main
  13581. '$mod.C = null;',
  13582. '$mod.C = $mod.Obj.ClassType;',
  13583. '']));
  13584. end;
  13585. procedure TTestModule.TestClassOf_Is;
  13586. begin
  13587. StartProgram(false);
  13588. Add('type');
  13589. Add(' TClass = class of TObject;');
  13590. Add(' TObject = class');
  13591. Add(' end;');
  13592. Add(' TCar = class');
  13593. Add(' end;');
  13594. Add(' TCars = class of TCar;');
  13595. Add('var');
  13596. Add(' Obj: tobject;');
  13597. Add(' C: tclass;');
  13598. Add(' Cars: tcars;');
  13599. Add('begin');
  13600. Add(' if c is tcar then ;');
  13601. Add(' if c is tcars then ;');
  13602. ConvertProgram;
  13603. CheckSource('TestClassOf_Is',
  13604. LinesToStr([ // statements
  13605. 'rtl.createClass($mod, "TObject", null, function () {',
  13606. ' this.$init = function () {',
  13607. ' };',
  13608. ' this.$final = function () {',
  13609. ' };',
  13610. '});',
  13611. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  13612. '});',
  13613. 'this.Obj = null;',
  13614. 'this.C = null;',
  13615. 'this.Cars = null;'
  13616. ]),
  13617. LinesToStr([ // $mod.$main
  13618. 'if(rtl.is($mod.C,$mod.TCar));',
  13619. 'if(rtl.is($mod.C,$mod.TCar));',
  13620. '']));
  13621. end;
  13622. procedure TTestModule.TestClassOf_Compare;
  13623. begin
  13624. StartProgram(false);
  13625. Add('type');
  13626. Add(' TClass = class of TObject;');
  13627. Add(' TObject = class');
  13628. Add(' ClassType: TClass; ');
  13629. Add(' end;');
  13630. Add('var');
  13631. Add(' b: boolean;');
  13632. Add(' Obj: tobject;');
  13633. Add(' C: tclass;');
  13634. Add('begin');
  13635. Add(' b:=c=nil;');
  13636. Add(' b:=nil=c;');
  13637. Add(' b:=c=obj.classtype;');
  13638. Add(' b:=obj.classtype=c;');
  13639. Add(' b:=c=TObject;');
  13640. Add(' b:=TObject=c;');
  13641. Add(' b:=c<>nil;');
  13642. Add(' b:=nil<>c;');
  13643. Add(' b:=c<>obj.classtype;');
  13644. Add(' b:=obj.classtype<>c;');
  13645. Add(' b:=c<>TObject;');
  13646. Add(' b:=TObject<>c;');
  13647. ConvertProgram;
  13648. CheckSource('TestClassOf_Compare',
  13649. LinesToStr([ // statements
  13650. 'rtl.createClass($mod, "TObject", null, function () {',
  13651. ' this.$init = function () {',
  13652. ' this.ClassType = null;',
  13653. ' };',
  13654. ' this.$final = function () {',
  13655. ' this.ClassType = undefined;',
  13656. ' };',
  13657. '});',
  13658. 'this.b = false;',
  13659. 'this.Obj = null;',
  13660. 'this.C = null;'
  13661. ]),
  13662. LinesToStr([ // $mod.$main
  13663. '$mod.b = $mod.C === null;',
  13664. '$mod.b = null === $mod.C;',
  13665. '$mod.b = $mod.C === $mod.Obj.ClassType;',
  13666. '$mod.b = $mod.Obj.ClassType === $mod.C;',
  13667. '$mod.b = $mod.C === $mod.TObject;',
  13668. '$mod.b = $mod.TObject === $mod.C;',
  13669. '$mod.b = $mod.C !== null;',
  13670. '$mod.b = null !== $mod.C;',
  13671. '$mod.b = $mod.C !== $mod.Obj.ClassType;',
  13672. '$mod.b = $mod.Obj.ClassType !== $mod.C;',
  13673. '$mod.b = $mod.C !== $mod.TObject;',
  13674. '$mod.b = $mod.TObject !== $mod.C;',
  13675. '']));
  13676. end;
  13677. procedure TTestModule.TestClassOf_ClassVar;
  13678. begin
  13679. StartProgram(false);
  13680. Add('type');
  13681. Add(' TObject = class');
  13682. Add(' class var id: longint;');
  13683. Add(' end;');
  13684. Add(' TClass = class of TObject;');
  13685. Add('var');
  13686. Add(' C: tclass;');
  13687. Add('begin');
  13688. Add(' C.id:=C.id;');
  13689. ConvertProgram;
  13690. CheckSource('TestClassOf_ClassVar',
  13691. LinesToStr([ // statements
  13692. 'rtl.createClass($mod, "TObject", null, function () {',
  13693. ' this.id = 0;',
  13694. ' this.$init = function () {',
  13695. ' };',
  13696. ' this.$final = function () {',
  13697. ' };',
  13698. '});',
  13699. 'this.C = null;'
  13700. ]),
  13701. LinesToStr([ // $mod.$main
  13702. '$mod.TObject.id = $mod.C.id;',
  13703. '']));
  13704. end;
  13705. procedure TTestModule.TestClassOf_ClassMethod;
  13706. begin
  13707. StartProgram(false);
  13708. Add('type');
  13709. Add(' TObject = class');
  13710. Add(' class function DoIt(i: longint = 0): longint;');
  13711. Add(' end;');
  13712. Add(' TClass = class of TObject;');
  13713. Add('class function tobject.doit(i: longint = 0): longint; begin end;');
  13714. Add('var');
  13715. Add(' i: longint;');
  13716. Add(' C: tclass;');
  13717. Add('begin');
  13718. Add(' C.DoIt;');
  13719. Add(' C.DoIt();');
  13720. Add(' i:=C.DoIt;');
  13721. Add(' i:=C.DoIt();');
  13722. ConvertProgram;
  13723. CheckSource('TestClassOf_ClassMethod',
  13724. LinesToStr([ // statements
  13725. 'rtl.createClass($mod, "TObject", null, function () {',
  13726. ' this.$init = function () {',
  13727. ' };',
  13728. ' this.$final = function () {',
  13729. ' };',
  13730. ' this.DoIt = function (i) {',
  13731. ' var Result = 0;',
  13732. ' return Result;',
  13733. ' };',
  13734. '});',
  13735. 'this.i = 0;',
  13736. 'this.C = null;'
  13737. ]),
  13738. LinesToStr([ // $mod.$main
  13739. '$mod.C.DoIt(0);',
  13740. '$mod.C.DoIt(0);',
  13741. '$mod.i = $mod.C.DoIt(0);',
  13742. '$mod.i = $mod.C.DoIt(0);',
  13743. '']));
  13744. end;
  13745. procedure TTestModule.TestClassOf_ClassProperty;
  13746. begin
  13747. StartProgram(false);
  13748. Add([
  13749. 'type',
  13750. ' TObject = class',
  13751. ' class var FA: longint;',
  13752. ' class function GetA: longint;',
  13753. ' class procedure SetA(Value: longint);',
  13754. ' class property pA: longint read fa write fa;',
  13755. ' class property pB: longint read geta write seta;',
  13756. ' end;',
  13757. ' TObjectClass = class of tobject;',
  13758. 'class function tobject.geta: longint; begin end;',
  13759. 'class procedure tobject.seta(value: longint); begin end;',
  13760. 'var',
  13761. ' b: boolean;',
  13762. ' Obj: tobject;',
  13763. ' Cla: tobjectclass;',
  13764. 'begin',
  13765. ' obj.pa:=obj.pa;',
  13766. ' obj.pb:=obj.pb;',
  13767. ' b:=obj.pa=4;',
  13768. ' b:=obj.pb=obj.pb;',
  13769. ' b:=5=obj.pa;',
  13770. ' cla.pa:=6;',
  13771. ' cla.pa:=cla.pa;',
  13772. ' cla.pb:=cla.pb;',
  13773. ' b:=cla.pa=7;',
  13774. ' b:=cla.pb=cla.pb;',
  13775. ' b:=8=cla.pa;',
  13776. ' tobject.pa:=9;',
  13777. ' tobject.pb:=tobject.pb;',
  13778. ' b:=tobject.pa=10;',
  13779. ' b:=11=tobject.pa;',
  13780. '']);
  13781. ConvertProgram;
  13782. CheckSource('TestClassOf_ClassProperty',
  13783. LinesToStr([ // statements
  13784. 'rtl.createClass($mod, "TObject", null, function () {',
  13785. ' this.FA = 0;',
  13786. ' this.$init = function () {',
  13787. ' };',
  13788. ' this.$final = function () {',
  13789. ' };',
  13790. ' this.GetA = function () {',
  13791. ' var Result = 0;',
  13792. ' return Result;',
  13793. ' };',
  13794. ' this.SetA = function (Value) {',
  13795. ' };',
  13796. '});',
  13797. 'this.b = false;',
  13798. 'this.Obj = null;',
  13799. 'this.Cla = null;'
  13800. ]),
  13801. LinesToStr([ // $mod.$main
  13802. '$mod.TObject.FA = $mod.Obj.FA;',
  13803. '$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
  13804. '$mod.b = $mod.Obj.FA === 4;',
  13805. '$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
  13806. '$mod.b = 5 === $mod.Obj.FA;',
  13807. '$mod.TObject.FA = 6;',
  13808. '$mod.TObject.FA = $mod.Cla.FA;',
  13809. '$mod.Cla.SetA($mod.Cla.GetA());',
  13810. '$mod.b = $mod.Cla.FA === 7;',
  13811. '$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
  13812. '$mod.b = 8 === $mod.Cla.FA;',
  13813. '$mod.TObject.FA = 9;',
  13814. '$mod.TObject.SetA($mod.TObject.GetA());',
  13815. '$mod.b = $mod.TObject.FA === 10;',
  13816. '$mod.b = 11 === $mod.TObject.FA;',
  13817. '']));
  13818. end;
  13819. procedure TTestModule.TestClassOf_ClassMethodSelf;
  13820. begin
  13821. StartProgram(false);
  13822. Add('type');
  13823. Add(' TObject = class');
  13824. Add(' class var GlobalId: longint;');
  13825. Add(' class procedure ProcA;');
  13826. Add(' end;');
  13827. Add('class procedure tobject.proca;');
  13828. Add('var b: boolean;');
  13829. Add('begin');
  13830. Add(' b:=self=nil;');
  13831. Add(' b:=self.globalid=3;');
  13832. Add(' b:=4=self.globalid;');
  13833. Add(' self.globalid:=5;');
  13834. Add(' self.proca;');
  13835. Add('end;');
  13836. Add('begin');
  13837. ConvertProgram;
  13838. CheckSource('TestClassOf_ClassMethodSelf',
  13839. LinesToStr([ // statements
  13840. 'rtl.createClass($mod, "TObject", null, function () {',
  13841. ' this.GlobalId = 0;',
  13842. ' this.$init = function () {',
  13843. ' };',
  13844. ' this.$final = function () {',
  13845. ' };',
  13846. ' this.ProcA = function () {',
  13847. ' var b = false;',
  13848. ' b = this === null;',
  13849. ' b = this.GlobalId === 3;',
  13850. ' b = 4 === this.GlobalId;',
  13851. ' $mod.TObject.GlobalId = 5;',
  13852. ' this.ProcA();',
  13853. ' };',
  13854. '});'
  13855. ]),
  13856. LinesToStr([ // $mod.$main
  13857. '']));
  13858. end;
  13859. procedure TTestModule.TestClassOf_TypeCast;
  13860. begin
  13861. StartProgram(false);
  13862. Add('type');
  13863. Add(' TObject = class');
  13864. Add(' class procedure {#TObject_DoIt}DoIt;');
  13865. Add(' end;');
  13866. Add(' TClass = class of TObject;');
  13867. Add(' TMobile = class');
  13868. Add(' class procedure {#TMobile_DoIt}DoIt;');
  13869. Add(' end;');
  13870. Add(' TMobileClass = class of TMobile;');
  13871. Add(' TCar = class(TMobile)');
  13872. Add(' class procedure {#TCar_DoIt}DoIt;');
  13873. Add(' end;');
  13874. Add(' TCarClass = class of TCar;');
  13875. Add('class procedure TObject.DoIt;');
  13876. Add('begin');
  13877. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  13878. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  13879. Add('end;');
  13880. Add('class procedure TMobile.DoIt;');
  13881. Add('begin');
  13882. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  13883. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  13884. Add(' TCarClass(Self).{@TCar_DoIt}DoIt;');
  13885. Add('end;');
  13886. Add('class procedure TCar.DoIt; begin end;');
  13887. Add('var');
  13888. Add(' ObjC: TClass;');
  13889. Add(' MobileC: TMobileClass;');
  13890. Add(' CarC: TCarClass;');
  13891. Add('begin');
  13892. Add(' ObjC.{@TObject_DoIt}DoIt;');
  13893. Add(' MobileC.{@TMobile_DoIt}DoIt;');
  13894. Add(' CarC.{@TCar_DoIt}DoIt;');
  13895. Add(' TClass(ObjC).{@TObject_DoIt}DoIt;');
  13896. Add(' TMobileClass(ObjC).{@TMobile_DoIt}DoIt;');
  13897. Add(' TCarClass(ObjC).{@TCar_DoIt}DoIt;');
  13898. Add(' TClass(MobileC).{@TObject_DoIt}DoIt;');
  13899. Add(' TMobileClass(MobileC).{@TMobile_DoIt}DoIt;');
  13900. Add(' TCarClass(MobileC).{@TCar_DoIt}DoIt;');
  13901. Add(' TClass(CarC).{@TObject_DoIt}DoIt;');
  13902. Add(' TMobileClass(CarC).{@TMobile_DoIt}DoIt;');
  13903. Add(' TCarClass(CarC).{@TCar_DoIt}DoIt;');
  13904. ConvertProgram;
  13905. CheckSource('TestClassOf_TypeCast',
  13906. LinesToStr([ // statements
  13907. 'rtl.createClass($mod, "TObject", null, function () {',
  13908. ' this.$init = function () {',
  13909. ' };',
  13910. ' this.$final = function () {',
  13911. ' };',
  13912. ' this.DoIt = function () {',
  13913. ' this.DoIt();',
  13914. ' this.DoIt$1();',
  13915. ' };',
  13916. '});',
  13917. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  13918. ' this.DoIt$1 = function () {',
  13919. ' this.DoIt();',
  13920. ' this.DoIt$1();',
  13921. ' this.DoIt$2();',
  13922. ' };',
  13923. '});',
  13924. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  13925. ' this.DoIt$2 = function () {',
  13926. ' };',
  13927. '});',
  13928. 'this.ObjC = null;',
  13929. 'this.MobileC = null;',
  13930. 'this.CarC = null;',
  13931. '']),
  13932. LinesToStr([ // $mod.$main
  13933. '$mod.ObjC.DoIt();',
  13934. '$mod.MobileC.DoIt$1();',
  13935. '$mod.CarC.DoIt$2();',
  13936. '$mod.ObjC.DoIt();',
  13937. '$mod.ObjC.DoIt$1();',
  13938. '$mod.ObjC.DoIt$2();',
  13939. '$mod.MobileC.DoIt();',
  13940. '$mod.MobileC.DoIt$1();',
  13941. '$mod.MobileC.DoIt$2();',
  13942. '$mod.CarC.DoIt();',
  13943. '$mod.CarC.DoIt$1();',
  13944. '$mod.CarC.DoIt$2();',
  13945. '']));
  13946. end;
  13947. procedure TTestModule.TestClassOf_ImplicitFunctionCall;
  13948. begin
  13949. StartProgram(false);
  13950. Add('type');
  13951. Add(' TObject = class');
  13952. Add(' function CurNow: longint; ');
  13953. Add(' class function Now: longint; ');
  13954. Add(' end;');
  13955. Add('function TObject.CurNow: longint; begin end;');
  13956. Add('class function TObject.Now: longint; begin end;');
  13957. Add('var');
  13958. Add(' Obj: tobject;');
  13959. Add(' vI: longint;');
  13960. Add('begin');
  13961. Add(' obj.curnow;');
  13962. Add(' vi:=obj.curnow;');
  13963. Add(' tobject.now;');
  13964. Add(' vi:=tobject.now;');
  13965. ConvertProgram;
  13966. CheckSource('TestClassOf_ImplicitFunctionCall',
  13967. LinesToStr([ // statements
  13968. 'rtl.createClass($mod, "TObject", null, function () {',
  13969. ' this.$init = function () {',
  13970. ' };',
  13971. ' this.$final = function () {',
  13972. ' };',
  13973. ' this.CurNow = function () {',
  13974. ' var Result = 0;',
  13975. ' return Result;',
  13976. ' };',
  13977. ' this.Now = function () {',
  13978. ' var Result = 0;',
  13979. ' return Result;',
  13980. ' };',
  13981. '});',
  13982. 'this.Obj = null;',
  13983. 'this.vI = 0;',
  13984. '']),
  13985. LinesToStr([ // $mod.$main
  13986. '$mod.Obj.CurNow();',
  13987. '$mod.vI = $mod.Obj.CurNow();',
  13988. '$mod.TObject.Now();',
  13989. '$mod.vI = $mod.TObject.Now();',
  13990. '']));
  13991. end;
  13992. procedure TTestModule.TestClassOf_Const;
  13993. begin
  13994. StartProgram(false);
  13995. Add([
  13996. 'type',
  13997. ' TObject = class',
  13998. ' end;',
  13999. ' TBird = TObject;',
  14000. ' TBirds = class of TBird;',
  14001. ' TEagles = TBirds;',
  14002. ' THawk = class(TBird);',
  14003. 'const',
  14004. ' Hawk: TEagles = THawk;',
  14005. ' DefaultBirdClasses : Array [1..2] of TEagles = (',
  14006. ' TBird,',
  14007. ' THawk',
  14008. ' );',
  14009. 'begin']);
  14010. ConvertProgram;
  14011. CheckSource('TestClassOf_Const',
  14012. LinesToStr([ // statements
  14013. 'rtl.createClass($mod, "TObject", null, function () {',
  14014. ' this.$init = function () {',
  14015. ' };',
  14016. ' this.$final = function () {',
  14017. ' };',
  14018. '});',
  14019. 'rtl.createClass($mod, "THawk", $mod.TObject, function () {',
  14020. '});',
  14021. 'this.Hawk = $mod.THawk;',
  14022. 'this.DefaultBirdClasses = [$mod.TObject, $mod.THawk];',
  14023. '']),
  14024. LinesToStr([ // $mod.$main
  14025. '']));
  14026. end;
  14027. procedure TTestModule.TestNestedClass_Alias;
  14028. begin
  14029. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14030. StartProgram(false);
  14031. Add([
  14032. 'type',
  14033. ' TObject = class',
  14034. ' type TNested = type longint;',
  14035. ' end;',
  14036. 'type TAlias = type tobject.tnested;',
  14037. 'var i: tobject.tnested = 3;',
  14038. 'var j: TAlias = 4;',
  14039. 'begin',
  14040. ' if typeinfo(TAlias)=nil then ;',
  14041. ' if typeinfo(tobject.tnested)=nil then ;',
  14042. '']);
  14043. ConvertProgram;
  14044. CheckSource('TestNestedClass_Alias',
  14045. LinesToStr([ // statements
  14046. 'rtl.createClass($mod, "TObject", null, function () {',
  14047. ' $mod.$rtti.$inherited("TObject.TNested", rtl.longint, {});',
  14048. ' this.$init = function () {',
  14049. ' };',
  14050. ' this.$final = function () {',
  14051. ' };',
  14052. '});',
  14053. '$mod.$rtti.$inherited("TAlias", $mod.$rtti["TObject.TNested"], {});',
  14054. 'this.i = 3;',
  14055. 'this.j = 4;',
  14056. '']),
  14057. LinesToStr([ // $mod.$main
  14058. 'if ($mod.$rtti["TAlias"] === null) ;',
  14059. 'if ($mod.$rtti["TObject.TNested"] === null) ;',
  14060. '']));
  14061. end;
  14062. procedure TTestModule.TestNestedClass_Record;
  14063. begin
  14064. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14065. StartProgram(false);
  14066. Add([
  14067. 'type',
  14068. ' TObject = class',
  14069. ' type TPoint = record',
  14070. ' x,y: byte;',
  14071. ' end;',
  14072. ' procedure DoIt(t: TPoint);',
  14073. ' end;',
  14074. 'procedure tobject.DoIt(t: TPoint);',
  14075. 'var p: TPoint;',
  14076. 'begin',
  14077. ' t.x:=t.y;',
  14078. ' p:=t;',
  14079. 'end;',
  14080. 'var',
  14081. ' p: tobject.tpoint = (x:2; y:4);',
  14082. ' o: TObject;',
  14083. 'begin',
  14084. ' p:=p;',
  14085. ' o.doit(p);',
  14086. '']);
  14087. ConvertProgram;
  14088. CheckSource('TestNestedClass_Record',
  14089. LinesToStr([ // statements
  14090. 'rtl.createClass($mod, "TObject", null, function () {',
  14091. ' rtl.recNewT(this, "TPoint", function () {',
  14092. ' this.x = 0;',
  14093. ' this.y = 0;',
  14094. ' this.$eq = function (b) {',
  14095. ' return (this.x === b.x) && (this.y === b.y);',
  14096. ' };',
  14097. ' this.$assign = function (s) {',
  14098. ' this.x = s.x;',
  14099. ' this.y = s.y;',
  14100. ' return this;',
  14101. ' };',
  14102. ' var $r = $mod.$rtti.$Record("TObject.TPoint", {});',
  14103. ' $r.addField("x", rtl.byte);',
  14104. ' $r.addField("y", rtl.byte);',
  14105. ' });',
  14106. ' this.$init = function () {',
  14107. ' };',
  14108. ' this.$final = function () {',
  14109. ' };',
  14110. ' this.DoIt = function (t) {',
  14111. ' var p = this.TPoint.$new();',
  14112. ' t.x = t.y;',
  14113. ' p.$assign(t);',
  14114. ' };',
  14115. '});',
  14116. 'this.p = $mod.TObject.TPoint.$clone({',
  14117. ' x: 2,',
  14118. ' y: 4',
  14119. '});',
  14120. 'this.o = null;',
  14121. '']),
  14122. LinesToStr([ // $mod.$main
  14123. '$mod.p.$assign($mod.p);',
  14124. '$mod.o.DoIt($mod.TObject.TPoint.$clone($mod.p));',
  14125. '']));
  14126. end;
  14127. procedure TTestModule.TestNestedClass_Class;
  14128. begin
  14129. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14130. StartProgram(false);
  14131. Add([
  14132. 'type',
  14133. ' TObject = class end;',
  14134. ' TBird = class',
  14135. ' type TLeg = class',
  14136. ' FId: longint;',
  14137. ' constructor Create;',
  14138. ' function Create(i: longint): TLeg;',
  14139. ' end;',
  14140. ' function DoIt(b: TBird): Tleg;',
  14141. ' end;',
  14142. 'constructor tbird.tleg.create;',
  14143. 'begin',
  14144. ' FId:=3;',
  14145. 'end;',
  14146. 'function tbird.tleg.Create(i: longint): TLeg;',
  14147. 'begin',
  14148. ' Create;',
  14149. ' Result:=TLeg.Create;',
  14150. ' Result:=TBird.TLeg.Create;',
  14151. ' Result:=Create(3);',
  14152. ' FId:=i;',
  14153. 'end;',
  14154. 'function tbird.DoIt(b: tbird): tleg;',
  14155. 'begin',
  14156. ' Result.Create;',
  14157. ' Result:=TLeg.Create;',
  14158. ' Result:=TBird.TLeg.Create;',
  14159. ' Result:=Result.Create(3);',
  14160. 'end;',
  14161. 'var',
  14162. ' b: Tbird.tleg;',
  14163. 'begin',
  14164. ' b.Create;',
  14165. ' b:=TBird.TLeg.Create;',
  14166. ' b:=b.Create(3);',
  14167. '']);
  14168. ConvertProgram;
  14169. CheckSource('TestNestedClass_Class',
  14170. LinesToStr([ // statements
  14171. 'rtl.createClass($mod, "TObject", null, function () {',
  14172. ' this.$init = function () {',
  14173. ' };',
  14174. ' this.$final = function () {',
  14175. ' };',
  14176. '});',
  14177. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  14178. ' rtl.createClass(this, "TLeg", $mod.TObject, function () {',
  14179. ' this.$init = function () {',
  14180. ' $mod.TObject.$init.call(this);',
  14181. ' this.FId = 0;',
  14182. ' };',
  14183. ' this.Create = function () {',
  14184. ' this.FId = 3;',
  14185. ' return this;',
  14186. ' };',
  14187. ' this.Create$1 = function (i) {',
  14188. ' var Result = null;',
  14189. ' this.Create();',
  14190. ' Result = $mod.TBird.TLeg.$create("Create");',
  14191. ' Result = $mod.TBird.TLeg.$create("Create");',
  14192. ' Result = this.Create$1(3);',
  14193. ' this.FId = i;',
  14194. ' return Result;',
  14195. ' };',
  14196. ' });',
  14197. ' this.DoIt = function (b) {',
  14198. ' var Result = null;',
  14199. ' Result.Create();',
  14200. ' Result = this.TLeg.$create("Create");',
  14201. ' Result = $mod.TBird.TLeg.$create("Create");',
  14202. ' Result = Result.Create$1(3);',
  14203. ' return Result;',
  14204. ' };',
  14205. '});',
  14206. 'this.b = null;',
  14207. '']),
  14208. LinesToStr([ // $mod.$main
  14209. '$mod.b.Create();',
  14210. '$mod.b = $mod.TBird.TLeg.$create("Create");',
  14211. '$mod.b = $mod.b.Create$1(3);',
  14212. '']));
  14213. end;
  14214. procedure TTestModule.TestExternalClass_Var;
  14215. begin
  14216. StartProgram(false);
  14217. Add([
  14218. '{$modeswitch externalclass}',
  14219. 'type',
  14220. ' TExtA = class external name ''ExtObj''',
  14221. ' Id: longint external name ''$Id'';',
  14222. ' B: longint;',
  14223. ' end;',
  14224. 'var Obj: TExtA;',
  14225. 'begin',
  14226. ' obj.id:=obj.id+1;',
  14227. ' obj.B:=obj.B+1;']);
  14228. ConvertProgram;
  14229. CheckSource('TestExternalClass_Var',
  14230. LinesToStr([ // statements
  14231. 'this.Obj = null;',
  14232. '']),
  14233. LinesToStr([ // $mod.$main
  14234. '$mod.Obj.$Id = $mod.Obj.$Id + 1;',
  14235. '$mod.Obj.B = $mod.Obj.B + 1;',
  14236. '']));
  14237. end;
  14238. procedure TTestModule.TestExternalClass_Const;
  14239. begin
  14240. StartProgram(false);
  14241. Add([
  14242. '{$modeswitch externalclass}',
  14243. 'type',
  14244. ' TExtA = class external name ''ExtObj''',
  14245. ' const Two: longint = 2;',
  14246. ' const Three = 3;',
  14247. ' const Id: longint;',
  14248. ' end;',
  14249. ' TExtB = class external name ''ExtB''',
  14250. ' A: TExtA;',
  14251. ' end;',
  14252. 'var',
  14253. ' A: texta;',
  14254. ' B: textb;',
  14255. ' i: longint;',
  14256. 'begin',
  14257. ' i:=a.two;',
  14258. ' i:=texta.two;',
  14259. ' i:=a.three;',
  14260. ' i:=texta.three;',
  14261. ' i:=a.id;',
  14262. ' i:=texta.id;',
  14263. '']);
  14264. ConvertProgram;
  14265. CheckSource('TestExternalClass_Const',
  14266. LinesToStr([ // statements
  14267. 'this.A = null;',
  14268. 'this.B = null;',
  14269. 'this.i = 0;',
  14270. '']),
  14271. LinesToStr([ // $mod.$main
  14272. '$mod.i = 2;',
  14273. '$mod.i = 2;',
  14274. '$mod.i = 3;',
  14275. '$mod.i = 3;',
  14276. '$mod.i = $mod.A.Id;',
  14277. '$mod.i = ExtObj.Id;',
  14278. '']));
  14279. end;
  14280. procedure TTestModule.TestExternalClass_Dollar;
  14281. begin
  14282. StartProgram(false);
  14283. Add([
  14284. '{$modeswitch externalclass}',
  14285. 'type',
  14286. ' TExtA = class external name ''$''',
  14287. ' Id: longint external name ''$'';',
  14288. ' function Bla(i: longint): longint; external name ''$'';',
  14289. ' end;',
  14290. 'function dollar(k: longint): longint; external name ''$'';',
  14291. 'var Obj: TExtA;',
  14292. 'begin',
  14293. ' dollar(1);',
  14294. ' obj.id:=obj.id+2;',
  14295. ' obj.Bla(3);',
  14296. '']);
  14297. ConvertProgram;
  14298. CheckSource('TestExternalClass_Dollar',
  14299. LinesToStr([ // statements
  14300. 'this.Obj = null;',
  14301. '']),
  14302. LinesToStr([ // $mod.$main
  14303. '$(1);',
  14304. '$mod.Obj.$ = $mod.Obj.$ + 2;',
  14305. '$mod.Obj.$(3);',
  14306. '']));
  14307. end;
  14308. procedure TTestModule.TestExternalClass_DuplicateVarFail;
  14309. begin
  14310. StartProgram(false);
  14311. Add('{$modeswitch externalclass}');
  14312. Add('type');
  14313. Add(' TExtA = class external name ''ExtA''');
  14314. Add(' Id: longint external name ''$Id'';');
  14315. Add(' end;');
  14316. Add(' TExtB = class external ''lib'' name ''ExtB''(TExtA)');
  14317. Add(' Id: longint;');
  14318. Add(' end;');
  14319. Add('begin');
  14320. SetExpectedPasResolverError('Duplicate identifier "Id" at test1.pp(6,5)',nDuplicateIdentifier);
  14321. ConvertProgram;
  14322. end;
  14323. procedure TTestModule.TestExternalClass_Method;
  14324. begin
  14325. StartProgram(false);
  14326. Add('{$modeswitch externalclass}');
  14327. Add('type');
  14328. Add(' TExtA = class external name ''ExtObj''');
  14329. Add(' procedure DoIt(Id: longint = 1); external name ''$Execute'';');
  14330. Add(' procedure DoSome(Id: longint = 1);');
  14331. Add(' end;');
  14332. Add('var Obj: texta;');
  14333. Add('begin');
  14334. Add(' obj.doit;');
  14335. Add(' obj.doit();');
  14336. Add(' obj.doit(2);');
  14337. Add(' with obj do begin');
  14338. Add(' doit;');
  14339. Add(' doit();');
  14340. Add(' doit(3);');
  14341. Add(' end;');
  14342. ConvertProgram;
  14343. CheckSource('TestExternalClass_Method',
  14344. LinesToStr([ // statements
  14345. 'this.Obj = null;',
  14346. '']),
  14347. LinesToStr([ // $mod.$main
  14348. '$mod.Obj.$Execute(1);',
  14349. '$mod.Obj.$Execute(1);',
  14350. '$mod.Obj.$Execute(2);',
  14351. 'var $with1 = $mod.Obj;',
  14352. '$with1.$Execute(1);',
  14353. '$with1.$Execute(1);',
  14354. '$with1.$Execute(3);',
  14355. '']));
  14356. end;
  14357. procedure TTestModule.TestExternalClass_ClassMethod;
  14358. begin
  14359. StartProgram(false);
  14360. Add([
  14361. '{$modeswitch externalclass}',
  14362. 'type',
  14363. ' TExtA = class external name ''ExtObj''',
  14364. ' class procedure DoIt(Id: longint = 1); external name ''$Execute'';',
  14365. ' end;',
  14366. ' TExtB = TExtA;',
  14367. 'begin',
  14368. ' texta.doit;',
  14369. ' texta.doit();',
  14370. ' texta.doit(2);',
  14371. ' with texta do begin',
  14372. ' doit;',
  14373. ' doit();',
  14374. ' doit(3);',
  14375. ' end;',
  14376. ' textb.doit;',
  14377. ' textb.doit();',
  14378. ' textb.doit(4);',
  14379. ' with textb do begin',
  14380. ' doit;',
  14381. ' doit();',
  14382. ' doit(5);',
  14383. ' end;',
  14384. '']);
  14385. ConvertProgram;
  14386. CheckSource('TestExternalClass_ClassMethod',
  14387. LinesToStr([ // statements
  14388. '']),
  14389. LinesToStr([ // $mod.$main
  14390. 'ExtObj.$Execute(1);',
  14391. 'ExtObj.$Execute(1);',
  14392. 'ExtObj.$Execute(2);',
  14393. 'ExtObj.$Execute(1);',
  14394. 'ExtObj.$Execute(1);',
  14395. 'ExtObj.$Execute(3);',
  14396. 'ExtObj.$Execute(1);',
  14397. 'ExtObj.$Execute(1);',
  14398. 'ExtObj.$Execute(4);',
  14399. 'ExtObj.$Execute(1);',
  14400. 'ExtObj.$Execute(1);',
  14401. 'ExtObj.$Execute(5);',
  14402. '']));
  14403. end;
  14404. procedure TTestModule.TestExternalClass_FunctionResultInTypeCast;
  14405. begin
  14406. StartProgram(false);
  14407. Add([
  14408. '{$modeswitch externalclass}',
  14409. 'type',
  14410. ' TBird = class external name ''Array''',
  14411. ' end;',
  14412. 'function GetPtr: Pointer;',
  14413. 'begin',
  14414. 'end;',
  14415. 'procedure Write(const p);',
  14416. 'begin',
  14417. 'end;',
  14418. 'procedure WriteLn; varargs;',
  14419. 'begin',
  14420. 'end;',
  14421. 'begin',
  14422. ' if TBird(GetPtr)=nil then ;',
  14423. ' Write(GetPtr);',
  14424. ' WriteLn(GetPtr);',
  14425. ' Write(TBird(GetPtr));',
  14426. ' WriteLn(TBird(GetPtr));',
  14427. '']);
  14428. ConvertProgram;
  14429. CheckSource('TestFunctionResultInTypeCast',
  14430. LinesToStr([ // statements
  14431. 'this.GetPtr = function () {',
  14432. ' var Result = null;',
  14433. ' return Result;',
  14434. '};',
  14435. 'this.Write = function (p) {',
  14436. '};',
  14437. 'this.WriteLn = function () {',
  14438. '};',
  14439. '']),
  14440. LinesToStr([
  14441. 'if ($mod.GetPtr() === null) ;',
  14442. '$mod.Write($mod.GetPtr());',
  14443. '$mod.WriteLn($mod.GetPtr());',
  14444. '$mod.Write($mod.GetPtr());',
  14445. '$mod.WriteLn($mod.GetPtr());',
  14446. '']));
  14447. end;
  14448. procedure TTestModule.TestExternalClass_NonExternalOverride;
  14449. begin
  14450. StartProgram(false);
  14451. Add('{$modeswitch externalclass}');
  14452. Add('type');
  14453. Add(' TExtA = class external name ''ExtObjA''');
  14454. Add(' procedure ProcA; virtual;');
  14455. Add(' procedure ProcB; virtual;');
  14456. Add(' end;');
  14457. Add(' TExtB = class external name ''ExtObjB'' (TExtA)');
  14458. Add(' end;');
  14459. Add(' TExtC = class (TExtB)');
  14460. Add(' procedure ProcA; override;');
  14461. Add(' end;');
  14462. Add('procedure TExtC.ProcA;');
  14463. Add('begin');
  14464. Add(' ProcA;');
  14465. Add(' Self.ProcA;');
  14466. Add(' ProcB;');
  14467. Add(' Self.ProcB;');
  14468. Add('end;');
  14469. Add('var');
  14470. Add(' A: texta;');
  14471. Add(' B: textb;');
  14472. Add(' C: textc;');
  14473. Add('begin');
  14474. Add(' a.proca;');
  14475. Add(' b.proca;');
  14476. Add(' c.proca;');
  14477. ConvertProgram;
  14478. CheckSource('TestExternalClass_NonExternalOverride',
  14479. LinesToStr([ // statements
  14480. 'rtl.createClassExt($mod, "TExtC", ExtObjB, "", function () {',
  14481. ' this.$init = function () {',
  14482. ' };',
  14483. ' this.$final = function () {',
  14484. ' };',
  14485. ' this.ProcA = function () {',
  14486. ' this.ProcA();',
  14487. ' this.ProcA();',
  14488. ' this.ProcB();',
  14489. ' this.ProcB();',
  14490. ' };',
  14491. '});',
  14492. 'this.A = null;',
  14493. 'this.B = null;',
  14494. 'this.C = null;',
  14495. '']),
  14496. LinesToStr([ // $mod.$main
  14497. '$mod.A.ProcA();',
  14498. '$mod.B.ProcA();',
  14499. '$mod.C.ProcA();',
  14500. '']));
  14501. end;
  14502. procedure TTestModule.TestExternalClass_OverloadHint;
  14503. begin
  14504. StartProgram(false);
  14505. Add([
  14506. '{$modeswitch externalclass}',
  14507. 'type',
  14508. ' TExtA = class external name ''ExtObjA''',
  14509. ' procedure DoIt;',
  14510. ' procedure DoIt(i: longint);',
  14511. ' end;',
  14512. 'begin',
  14513. '']);
  14514. ConvertProgram;
  14515. CheckResolverUnexpectedHints(true);
  14516. CheckSource('TestExternalClass_OverloadHint',
  14517. LinesToStr([ // statements
  14518. '']),
  14519. LinesToStr([ // $mod.$main
  14520. '']));
  14521. end;
  14522. procedure TTestModule.TestExternalClass_SameNamePublishedProperty;
  14523. begin
  14524. StartProgram(false);
  14525. Add([
  14526. '{$modeswitch externalclass}',
  14527. 'type',
  14528. ' JSwiper = class external name ''Swiper''',
  14529. ' constructor New;',
  14530. ' end;',
  14531. ' TObject = class',
  14532. ' private',
  14533. ' FSwiper: JSwiper;',
  14534. ' published',
  14535. ' property Swiper: JSwiper read FSwiper write FSwiper;',
  14536. ' end;',
  14537. 'begin',
  14538. ' JSwiper.new;',
  14539. '']);
  14540. ConvertProgram;
  14541. CheckSource('TestExternalClass_SameNamePublishedProperty',
  14542. LinesToStr([ // statements
  14543. 'rtl.createClass($mod, "TObject", null, function () {',
  14544. ' this.$init = function () {',
  14545. ' this.FSwiper = null;',
  14546. ' };',
  14547. ' this.$final = function () {',
  14548. ' this.FSwiper = undefined;',
  14549. ' };',
  14550. ' var $r = this.$rtti;',
  14551. ' $r.addProperty("Swiper", 0, $mod.$rtti["JSwiper"], "FSwiper", "FSwiper");',
  14552. '});',
  14553. '']),
  14554. LinesToStr([ // $mod.$main
  14555. 'new Swiper();',
  14556. '']));
  14557. end;
  14558. procedure TTestModule.TestExternalClass_Property;
  14559. begin
  14560. StartProgram(false);
  14561. Add([
  14562. '{$modeswitch externalclass}',
  14563. 'type',
  14564. ' TExtA = class external name ''ExtA''',
  14565. ' function getYear: longint;',
  14566. ' procedure setYear(Value: longint);',
  14567. ' property Year: longint read getyear write setyear;',
  14568. ' end;',
  14569. ' TExtB = class (TExtA)',
  14570. ' procedure OtherSetYear(Value: longint);',
  14571. ' property year write othersetyear;',
  14572. ' end;',
  14573. 'procedure textb.othersetyear(value: longint);',
  14574. 'begin',
  14575. ' setYear(Value+4);',
  14576. 'end;',
  14577. 'var',
  14578. ' A: texta;',
  14579. ' B: textb;',
  14580. 'begin',
  14581. ' a.year:=a.year+1;',
  14582. ' b.year:=b.year+2;']);
  14583. ConvertProgram;
  14584. CheckSource('TestExternalClass_NonExternalOverride',
  14585. LinesToStr([ // statements
  14586. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  14587. ' this.$init = function () {',
  14588. ' };',
  14589. ' this.$final = function () {',
  14590. ' };',
  14591. ' this.OtherSetYear = function (Value) {',
  14592. ' this.setYear(Value+4);',
  14593. ' };',
  14594. '});',
  14595. 'this.A = null;',
  14596. 'this.B = null;',
  14597. '']),
  14598. LinesToStr([ // $mod.$main
  14599. '$mod.A.setYear($mod.A.getYear()+1);',
  14600. '$mod.B.OtherSetYear($mod.B.getYear()+2);',
  14601. '']));
  14602. end;
  14603. procedure TTestModule.TestExternalClass_PropertyDate;
  14604. begin
  14605. StartProgram(false);
  14606. Add([
  14607. '{$modeswitch externalclass}',
  14608. 'type',
  14609. ' TExtA = class external name ''ExtA''',
  14610. ' end;',
  14611. ' TExtB = class (TExtA)',
  14612. ' FDate: string;',
  14613. ' property Date: string read FDate write FDate;',
  14614. ' property ExtA: string read FDate write FDate;',
  14615. ' end;',
  14616. ' {$M+}',
  14617. ' TObject = class',
  14618. ' FDate: string;',
  14619. ' published',
  14620. ' property Date: string read FDate write FDate;',
  14621. ' property ExtA: string read FDate write FDate;',
  14622. ' end;',
  14623. 'var',
  14624. ' B: textb;',
  14625. ' o: TObject;',
  14626. 'begin',
  14627. ' b.date:=b.exta;',
  14628. ' o.date:=o.exta;']);
  14629. ConvertProgram;
  14630. CheckSource('TestExternalClass_PropertyDate',
  14631. LinesToStr([ // statements
  14632. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  14633. ' this.$init = function () {',
  14634. ' this.FDate = "";',
  14635. ' };',
  14636. ' this.$final = function () {',
  14637. ' };',
  14638. '});',
  14639. 'rtl.createClass($mod, "TObject", null, function () {',
  14640. ' this.$init = function () {',
  14641. ' this.FDate = "";',
  14642. ' };',
  14643. ' this.$final = function () {',
  14644. ' };',
  14645. ' var $r = this.$rtti;',
  14646. ' $r.addField("FDate", rtl.string);',
  14647. ' $r.addProperty("Date", 0, rtl.string, "FDate", "FDate");',
  14648. ' $r.addProperty("ExtA", 0, rtl.string, "FDate", "FDate");',
  14649. '});',
  14650. 'this.B = null;',
  14651. 'this.o = null;',
  14652. '']),
  14653. LinesToStr([ // $mod.$main
  14654. '$mod.B.FDate = $mod.B.FDate;',
  14655. '$mod.o.FDate = $mod.o.FDate;',
  14656. '']));
  14657. end;
  14658. procedure TTestModule.TestExternalClass_ClassProperty;
  14659. begin
  14660. StartProgram(false);
  14661. Add('{$modeswitch externalclass}');
  14662. Add('type');
  14663. Add(' TExtA = class external name ''ExtA''');
  14664. Add(' class function getYear: longint;');
  14665. Add(' class procedure setYear(Value: longint);');
  14666. Add(' class property Year: longint read getyear write setyear;');
  14667. Add(' end;');
  14668. Add(' TExtB = class (TExtA)');
  14669. Add(' class function GetCentury: longint;');
  14670. Add(' class procedure SetCentury(Value: longint);');
  14671. Add(' class property Century: longint read getcentury write setcentury;');
  14672. Add(' end;');
  14673. Add('class function textb.getcentury: longint;');
  14674. Add('begin');
  14675. Add('end;');
  14676. Add('class procedure textb.setcentury(value: longint);');
  14677. Add('begin');
  14678. Add(' setyear(value+11);');
  14679. Add(' texta.year:=texta.year+12;');
  14680. Add(' year:=year+13;');
  14681. Add(' textb.century:=textb.century+14;');
  14682. Add(' century:=century+15;');
  14683. Add('end;');
  14684. Add('var');
  14685. Add(' A: texta;');
  14686. Add(' B: textb;');
  14687. Add('begin');
  14688. Add(' texta.year:=texta.year+1;');
  14689. Add(' textb.year:=textb.year+2;');
  14690. Add(' TextA.year:=TextA.year+3;');
  14691. Add(' b.year:=b.year+4;');
  14692. Add(' textb.century:=textb.century+5;');
  14693. Add(' b.century:=b.century+6;');
  14694. ConvertProgram;
  14695. CheckSource('TestExternalClass_ClassProperty',
  14696. LinesToStr([ // statements
  14697. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  14698. ' this.$init = function () {',
  14699. ' };',
  14700. ' this.$final = function () {',
  14701. ' };',
  14702. ' this.GetCentury = function () {',
  14703. ' var Result = 0;',
  14704. ' return Result;',
  14705. ' };',
  14706. ' this.SetCentury = function (Value) {',
  14707. ' this.setYear(Value + 11);',
  14708. ' ExtA.setYear(ExtA.getYear() + 12);',
  14709. ' this.setYear(this.getYear() + 13);',
  14710. ' $mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 14);',
  14711. ' this.SetCentury(this.GetCentury() + 15);',
  14712. ' };',
  14713. '});',
  14714. 'this.A = null;',
  14715. 'this.B = null;',
  14716. '']),
  14717. LinesToStr([ // $mod.$main
  14718. 'ExtA.setYear(ExtA.getYear() + 1);',
  14719. '$mod.TExtB.setYear($mod.TExtB.getYear() + 2);',
  14720. 'ExtA.setYear(ExtA.getYear() + 3);',
  14721. '$mod.B.setYear($mod.B.getYear() + 4);',
  14722. '$mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 5);',
  14723. '$mod.B.$class.SetCentury($mod.B.$class.GetCentury() + 6);',
  14724. '']));
  14725. end;
  14726. procedure TTestModule.TestExternalClass_ClassOf;
  14727. begin
  14728. StartProgram(false);
  14729. Add('{$modeswitch externalclass}');
  14730. Add('type');
  14731. Add(' TExtA = class external name ''ExtA''');
  14732. Add(' procedure ProcA; virtual;');
  14733. Add(' procedure ProcB; virtual;');
  14734. Add(' end;');
  14735. Add(' TExtAClass = class of TExtA;');
  14736. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  14737. Add(' end;');
  14738. Add(' TExtBClass = class of TExtB;');
  14739. Add(' TExtC = class (TExtB)');
  14740. Add(' procedure ProcA; override;');
  14741. Add(' end;');
  14742. Add(' TExtCClass = class of TExtC;');
  14743. Add('procedure TExtC.ProcA; begin end;');
  14744. Add('var');
  14745. Add(' A: texta; ClA: TExtAClass;');
  14746. Add(' B: textb; ClB: TExtBClass;');
  14747. Add(' C: textc; ClC: TExtCClass;');
  14748. Add('begin');
  14749. Add(' ClA:=texta;');
  14750. Add(' ClA:=textb;');
  14751. Add(' ClA:=textc;');
  14752. Add(' ClB:=textb;');
  14753. Add(' ClB:=textc;');
  14754. Add(' ClC:=textc;');
  14755. ConvertProgram;
  14756. CheckSource('TestExternalClass_ClassOf',
  14757. LinesToStr([ // statements
  14758. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  14759. ' this.$init = function () {',
  14760. ' };',
  14761. ' this.$final = function () {',
  14762. ' };',
  14763. ' this.ProcA = function () {',
  14764. ' };',
  14765. '});',
  14766. 'this.A = null;',
  14767. 'this.ClA = null;',
  14768. 'this.B = null;',
  14769. 'this.ClB = null;',
  14770. 'this.C = null;',
  14771. 'this.ClC = null;',
  14772. '']),
  14773. LinesToStr([ // $mod.$main
  14774. '$mod.ClA = ExtA;',
  14775. '$mod.ClA = ExtB;',
  14776. '$mod.ClA = $mod.TExtC;',
  14777. '$mod.ClB = ExtB;',
  14778. '$mod.ClB = $mod.TExtC;',
  14779. '$mod.ClC = $mod.TExtC;',
  14780. '']));
  14781. end;
  14782. procedure TTestModule.TestExternalClass_ClassOtherUnit;
  14783. begin
  14784. AddModuleWithIntfImplSrc('unit2.pas',
  14785. LinesToStr([
  14786. '{$modeswitch externalclass}',
  14787. 'type',
  14788. ' TExtA = class external name ''ExtA''',
  14789. ' class var Id: longint;',
  14790. ' end;',
  14791. '']),
  14792. '');
  14793. StartUnit(true);
  14794. Add('interface');
  14795. Add('uses unit2;');
  14796. Add('implementation');
  14797. Add('begin');
  14798. Add(' unit2.texta.id:=unit2.texta.id+1;');
  14799. ConvertUnit;
  14800. CheckSource('TestExternalClass_ClassOtherUnit',
  14801. LinesToStr([
  14802. '']),
  14803. LinesToStr([
  14804. 'ExtA.Id = ExtA.Id + 1;',
  14805. '']));
  14806. end;
  14807. procedure TTestModule.TestExternalClass_Is;
  14808. begin
  14809. StartProgram(false);
  14810. Add('{$modeswitch externalclass}');
  14811. Add('type');
  14812. Add(' TExtA = class external name ''ExtA''');
  14813. Add(' end;');
  14814. Add(' TExtAClass = class of TExtA;');
  14815. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  14816. Add(' end;');
  14817. Add(' TExtBClass = class of TExtB;');
  14818. Add(' TExtC = class (TExtB)');
  14819. Add(' end;');
  14820. Add(' TExtCClass = class of TExtC;');
  14821. Add('var');
  14822. Add(' A: texta; ClA: TExtAClass;');
  14823. Add(' B: textb; ClB: TExtBClass;');
  14824. Add(' C: textc; ClC: TExtCClass;');
  14825. Add('begin');
  14826. Add(' if a is textb then ;');
  14827. Add(' if a is textc then ;');
  14828. Add(' if b is textc then ;');
  14829. Add(' if cla is textb then ;');
  14830. Add(' if cla is textc then ;');
  14831. Add(' if clb is textc then ;');
  14832. ConvertProgram;
  14833. CheckSource('TestExternalClass_Is',
  14834. LinesToStr([ // statements
  14835. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  14836. ' this.$init = function () {',
  14837. ' };',
  14838. ' this.$final = function () {',
  14839. ' };',
  14840. '});',
  14841. 'this.A = null;',
  14842. 'this.ClA = null;',
  14843. 'this.B = null;',
  14844. 'this.ClB = null;',
  14845. 'this.C = null;',
  14846. 'this.ClC = null;',
  14847. '']),
  14848. LinesToStr([ // $mod.$main
  14849. 'if (rtl.isExt($mod.A, ExtB)) ;',
  14850. 'if ($mod.TExtC.isPrototypeOf($mod.A)) ;',
  14851. 'if ($mod.TExtC.isPrototypeOf($mod.B)) ;',
  14852. 'if (rtl.isExt($mod.ClA, ExtB)) ;',
  14853. 'if (rtl.is($mod.ClA, $mod.TExtC)) ;',
  14854. 'if (rtl.is($mod.ClB, $mod.TExtC)) ;',
  14855. '']));
  14856. end;
  14857. procedure TTestModule.TestExternalClass_As;
  14858. begin
  14859. StartProgram(false);
  14860. Add('{$modeswitch externalclass}');
  14861. Add('type');
  14862. Add(' TExtA = class external name ''ExtA''');
  14863. Add(' end;');
  14864. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  14865. Add(' end;');
  14866. Add(' TExtC = class (TExtB)');
  14867. Add(' end;');
  14868. Add('var');
  14869. Add(' A: texta;');
  14870. Add(' B: textb;');
  14871. Add(' C: textc;');
  14872. Add('begin');
  14873. Add(' b:=a as textb;');
  14874. Add(' c:=a as textc;');
  14875. Add(' c:=b as textc;');
  14876. ConvertProgram;
  14877. CheckSource('TestExternalClass_Is',
  14878. LinesToStr([ // statements
  14879. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  14880. ' this.$init = function () {',
  14881. ' };',
  14882. ' this.$final = function () {',
  14883. ' };',
  14884. '});',
  14885. 'this.A = null;',
  14886. 'this.B = null;',
  14887. 'this.C = null;',
  14888. '']),
  14889. LinesToStr([ // $mod.$main
  14890. '$mod.B = rtl.asExt($mod.A, ExtB);',
  14891. '$mod.C = rtl.as($mod.A, $mod.TExtC);',
  14892. '$mod.C = rtl.as($mod.B, $mod.TExtC);',
  14893. '']));
  14894. end;
  14895. procedure TTestModule.TestExternalClass_DestructorFail;
  14896. begin
  14897. StartProgram(false);
  14898. Add('{$modeswitch externalclass}');
  14899. Add('type');
  14900. Add(' TExtA = class external name ''ExtA''');
  14901. Add(' destructor Free;');
  14902. Add(' end;');
  14903. SetExpectedPasResolverError('Pascal element not supported: destructor',
  14904. nPasElementNotSupported);
  14905. ConvertProgram;
  14906. end;
  14907. procedure TTestModule.TestExternalClass_New;
  14908. begin
  14909. StartProgram(false);
  14910. Add('{$modeswitch externalclass}');
  14911. Add('type');
  14912. Add(' TExtA = class external name ''ExtA''');
  14913. Add(' constructor New;');
  14914. Add(' constructor New(i: longint; j: longint = 2);');
  14915. Add(' end;');
  14916. Add('var');
  14917. Add(' A: texta;');
  14918. Add('begin');
  14919. Add(' a:=texta.new;');
  14920. Add(' a:=texta.new();');
  14921. Add(' a:=texta.new(1);');
  14922. Add(' with texta do begin');
  14923. Add(' a:=new;');
  14924. Add(' a:=new();');
  14925. Add(' a:=new(2);');
  14926. Add(' end;');
  14927. Add(' a:=test1.texta.new;');
  14928. Add(' a:=test1.texta.new();');
  14929. Add(' a:=test1.texta.new(3);');
  14930. ConvertProgram;
  14931. CheckSource('TestExternalClass_New',
  14932. LinesToStr([ // statements
  14933. 'this.A = null;',
  14934. '']),
  14935. LinesToStr([ // $mod.$main
  14936. '$mod.A = new ExtA();',
  14937. '$mod.A = new ExtA();',
  14938. '$mod.A = new ExtA(1,2);',
  14939. '$mod.A = new ExtA();',
  14940. '$mod.A = new ExtA();',
  14941. '$mod.A = new ExtA(2,2);',
  14942. '$mod.A = new ExtA();',
  14943. '$mod.A = new ExtA();',
  14944. '$mod.A = new ExtA(3,2);',
  14945. '']));
  14946. end;
  14947. procedure TTestModule.TestExternalClass_ClassOf_New;
  14948. begin
  14949. StartProgram(false);
  14950. Add('{$modeswitch externalclass}');
  14951. Add('type');
  14952. Add(' TExtAClass = class of TExtA;');
  14953. Add(' TExtA = class external name ''ExtA''');
  14954. Add(' C: TExtAClass;');
  14955. Add(' constructor New;');
  14956. Add(' end;');
  14957. Add('var');
  14958. Add(' A: texta;');
  14959. Add(' C: textaclass;');
  14960. Add('begin');
  14961. Add(' a:=c.new;');
  14962. Add(' a:=c.new();');
  14963. Add(' with C do begin');
  14964. Add(' a:=new;');
  14965. Add(' a:=new();');
  14966. Add(' end;');
  14967. Add(' a:=test1.c.new;');
  14968. Add(' a:=test1.c.new();');
  14969. Add(' a:=A.c.new();');
  14970. ConvertProgram;
  14971. CheckSource('TestExternalClass_ClassOf_New',
  14972. LinesToStr([ // statements
  14973. 'this.A = null;',
  14974. 'this.C = null;',
  14975. '']),
  14976. LinesToStr([ // $mod.$main
  14977. '$mod.A = new $mod.C();',
  14978. '$mod.A = new $mod.C();',
  14979. 'var $with1 = $mod.C;',
  14980. '$mod.A = new $with1();',
  14981. '$mod.A = new $with1();',
  14982. '$mod.A = new $mod.C();',
  14983. '$mod.A = new $mod.C();',
  14984. '$mod.A = new $mod.A.C();',
  14985. '']));
  14986. end;
  14987. procedure TTestModule.TestExternalClass_FuncClassOf_New;
  14988. begin
  14989. StartProgram(false);
  14990. Add([
  14991. '{$modeswitch externalclass}',
  14992. 'type',
  14993. ' TExtAClass = class of TExtA;',
  14994. ' TExtA = class external name ''ExtA''',
  14995. ' constructor New;',
  14996. ' end;',
  14997. 'function GetCreator: TExtAClass;',
  14998. 'begin',
  14999. ' Result:=TExtA;',
  15000. 'end;',
  15001. 'var',
  15002. ' A: texta;',
  15003. 'begin',
  15004. ' a:=getcreator.new;',
  15005. ' a:=getcreator().new;',
  15006. ' a:=getcreator().new();',
  15007. ' a:=getcreator.new();',
  15008. ' with getcreator do begin',
  15009. ' a:=new;',
  15010. ' a:=new();',
  15011. ' end;']);
  15012. ConvertProgram;
  15013. CheckSource('TestExternalClass_FuncClassOf_New',
  15014. LinesToStr([ // statements
  15015. 'this.GetCreator = function () {',
  15016. ' var Result = null;',
  15017. ' Result = ExtA;',
  15018. ' return Result;',
  15019. '};',
  15020. 'this.A = null;',
  15021. '']),
  15022. LinesToStr([ // $mod.$main
  15023. '$mod.A = new ($mod.GetCreator())();',
  15024. '$mod.A = new ($mod.GetCreator())();',
  15025. '$mod.A = new ($mod.GetCreator())();',
  15026. '$mod.A = new ($mod.GetCreator())();',
  15027. 'var $with1 = $mod.GetCreator();',
  15028. '$mod.A = new $with1();',
  15029. '$mod.A = new $with1();',
  15030. '']));
  15031. end;
  15032. procedure TTestModule.TestExternalClass_New_PasClassFail;
  15033. begin
  15034. StartProgram(false);
  15035. Add([
  15036. '{$modeswitch externalclass}',
  15037. 'type',
  15038. ' TExtA = class external name ''ExtA''',
  15039. ' constructor New;',
  15040. ' end;',
  15041. ' TBird = class(TExtA)',
  15042. ' end;',
  15043. 'begin',
  15044. ' TBird.new;',
  15045. '']);
  15046. SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
  15047. ConvertProgram;
  15048. end;
  15049. procedure TTestModule.TestExternalClass_New_PasClassBracketsFail;
  15050. begin
  15051. StartProgram(false);
  15052. Add([
  15053. '{$modeswitch externalclass}',
  15054. 'type',
  15055. ' TExtA = class external name ''ExtA''',
  15056. ' constructor New;',
  15057. ' end;',
  15058. ' TBird = class(TExtA)',
  15059. ' end;',
  15060. 'begin',
  15061. ' TBird.new();',
  15062. '']);
  15063. SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
  15064. ConvertProgram;
  15065. end;
  15066. procedure TTestModule.TestExternalClass_LocalConstSameName;
  15067. begin
  15068. StartProgram(false);
  15069. Add('{$modeswitch externalclass}');
  15070. Add('type');
  15071. Add(' TExtA = class external name ''ExtA''');
  15072. Add(' constructor New;');
  15073. Add(' end;');
  15074. Add('function DoIt: longint;');
  15075. Add('const ExtA: longint = 3;');
  15076. Add('begin');
  15077. Add(' Result:=ExtA;');
  15078. Add('end;');
  15079. Add('var');
  15080. Add(' A: texta;');
  15081. Add('begin');
  15082. Add(' a:=texta.new;');
  15083. ConvertProgram;
  15084. CheckSource('TestExternalClass_LocalConstSameName',
  15085. LinesToStr([ // statements
  15086. 'var ExtA$1 = 3;',
  15087. 'this.DoIt = function () {',
  15088. ' var Result = 0;',
  15089. ' Result = ExtA$1;',
  15090. ' return Result;',
  15091. '};',
  15092. 'this.A = null;',
  15093. '']),
  15094. LinesToStr([ // $mod.$main
  15095. '$mod.A = new ExtA();',
  15096. '']));
  15097. end;
  15098. procedure TTestModule.TestExternalClass_ReintroduceOverload;
  15099. begin
  15100. StartProgram(false);
  15101. Add('{$modeswitch externalclass}');
  15102. Add('type');
  15103. Add(' TExtA = class external name ''ExtA''');
  15104. Add(' procedure DoIt;');
  15105. Add(' end;');
  15106. Add(' TMyA = class(TExtA)');
  15107. Add(' procedure DoIt;');
  15108. Add(' end;');
  15109. Add('procedure TMyA.DoIt; begin end;');
  15110. Add('begin');
  15111. ConvertProgram;
  15112. CheckSource('TestExternalClass_ReintroduceOverload',
  15113. LinesToStr([ // statements
  15114. 'rtl.createClassExt($mod, "TMyA", ExtA, "", function () {',
  15115. ' this.$init = function () {',
  15116. ' };',
  15117. ' this.$final = function () {',
  15118. ' };',
  15119. ' this.DoIt$1 = function () {',
  15120. ' };',
  15121. '});',
  15122. '']),
  15123. LinesToStr([ // $mod.$main
  15124. '']));
  15125. end;
  15126. procedure TTestModule.TestExternalClass_Inherited;
  15127. begin
  15128. StartProgram(false);
  15129. Add('{$modeswitch externalclass}');
  15130. Add('type');
  15131. Add(' TExtA = class external name ''ExtA''');
  15132. Add(' procedure DoIt(i: longint = 1); virtual;');
  15133. Add(' procedure DoSome(j: longint = 2);');
  15134. Add(' end;');
  15135. Add(' TExtB = class external name ''ExtB''(TExtA)');
  15136. Add(' end;');
  15137. Add(' TMyC = class(TExtB)');
  15138. Add(' procedure DoIt(i: longint = 1); override;');
  15139. Add(' procedure DoSome(j: longint = 2); reintroduce;');
  15140. Add(' end;');
  15141. Add('procedure TMyC.DoIt(i: longint);');
  15142. Add('begin');
  15143. Add(' inherited;');
  15144. Add(' inherited DoIt;');
  15145. Add(' inherited DoIt();');
  15146. Add(' inherited DoIt(3);');
  15147. Add(' inherited DoSome;');
  15148. Add(' inherited DoSome();');
  15149. Add(' inherited DoSome(4);');
  15150. Add('end;');
  15151. Add('procedure TMyC.DoSome(j: longint);');
  15152. Add('begin');
  15153. Add(' inherited;');
  15154. Add('end;');
  15155. Add('begin');
  15156. ConvertProgram;
  15157. CheckSource('TestExternalClass_ReintroduceOverload',
  15158. LinesToStr([ // statements
  15159. 'rtl.createClassExt($mod, "TMyC", ExtB, "", function () {',
  15160. ' this.$init = function () {',
  15161. ' };',
  15162. ' this.$final = function () {',
  15163. ' };',
  15164. ' this.DoIt = function (i) {',
  15165. ' ExtB.DoIt.apply(this, arguments);',
  15166. ' ExtB.DoIt.call(this, 1);',
  15167. ' ExtB.DoIt.call(this, 1);',
  15168. ' ExtB.DoIt.call(this, 3);',
  15169. ' ExtB.DoSome.call(this, 2);',
  15170. ' ExtB.DoSome.call(this, 2);',
  15171. ' ExtB.DoSome.call(this, 4);',
  15172. ' };',
  15173. ' this.DoSome$1 = function (j) {',
  15174. ' ExtB.DoSome.apply(this, arguments);',
  15175. ' };',
  15176. '});',
  15177. '']),
  15178. LinesToStr([ // $mod.$main
  15179. '']));
  15180. end;
  15181. procedure TTestModule.TestExternalClass_PascalAncestorFail;
  15182. begin
  15183. StartProgram(false);
  15184. Add('{$modeswitch externalclass}');
  15185. Add('type');
  15186. Add(' TObject = class');
  15187. Add(' end;');
  15188. Add(' TExtA = class external name ''ExtA''(TObject)');
  15189. Add(' end;');
  15190. Add('begin');
  15191. SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
  15192. ConvertProgram;
  15193. end;
  15194. procedure TTestModule.TestExternalClass_NewInstance;
  15195. begin
  15196. StartProgram(false);
  15197. Add('{$modeswitch externalclass}');
  15198. Add('type');
  15199. Add(' TExtA = class external name ''ExtA''');
  15200. Add(' end;');
  15201. Add(' TMyB = class(TExtA)');
  15202. Add(' protected');
  15203. Add(' class function NewInstance(fnname: string; const paramarray): TMyB; virtual;');
  15204. Add(' end;');
  15205. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  15206. Add('begin end;');
  15207. Add('begin');
  15208. ConvertProgram;
  15209. CheckSource('TestExternalClass_NewInstance',
  15210. LinesToStr([ // statements
  15211. 'rtl.createClassExt($mod, "TMyB", ExtA, "NewInstance", function () {',
  15212. ' this.$init = function () {',
  15213. ' };',
  15214. ' this.$final = function () {',
  15215. ' };',
  15216. ' this.NewInstance = function (fnname, paramarray) {',
  15217. ' var Result = null;',
  15218. ' return Result;',
  15219. ' };',
  15220. '});',
  15221. '']),
  15222. LinesToStr([ // $mod.$main
  15223. '']));
  15224. end;
  15225. procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
  15226. begin
  15227. StartProgram(false);
  15228. Add('{$modeswitch externalclass}');
  15229. Add('type');
  15230. Add(' TExtA = class external name ''ExtA''');
  15231. Add(' end;');
  15232. Add(' TMyB = class(TExtA)');
  15233. Add(' protected');
  15234. Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
  15235. Add(' end;');
  15236. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  15237. Add('begin end;');
  15238. Add('begin');
  15239. SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
  15240. ConvertProgram;
  15241. end;
  15242. procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
  15243. begin
  15244. StartProgram(false);
  15245. Add('{$modeswitch externalclass}');
  15246. Add('type');
  15247. Add(' TExtA = class external name ''ExtA''');
  15248. Add(' end;');
  15249. Add(' TMyB = class(TExtA)');
  15250. Add(' protected');
  15251. Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
  15252. Add(' end;');
  15253. Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
  15254. Add('begin end;');
  15255. Add('begin');
  15256. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
  15257. nIncompatibleTypeArgNo);
  15258. ConvertProgram;
  15259. end;
  15260. procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
  15261. begin
  15262. StartProgram(false);
  15263. Add('{$modeswitch externalclass}');
  15264. Add('type');
  15265. Add(' TExtA = class external name ''ExtA''');
  15266. Add(' end;');
  15267. Add(' TMyB = class(TExtA)');
  15268. Add(' protected');
  15269. Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
  15270. Add(' end;');
  15271. Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
  15272. Add('begin end;');
  15273. Add('begin');
  15274. SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
  15275. nIncompatibleTypeArgNo);
  15276. ConvertProgram;
  15277. end;
  15278. procedure TTestModule.TestExternalClass_PascalProperty;
  15279. begin
  15280. StartProgram(false);
  15281. Add('{$modeswitch externalclass}');
  15282. Add('type');
  15283. Add(' TJSElement = class;');
  15284. Add(' TJSNotifyEvent = procedure(Sender: TJSElement) of object;');
  15285. Add(' TJSElement = class external name ''ExtA''');
  15286. Add(' end;');
  15287. Add(' TControl = class(TJSElement)');
  15288. Add(' private');
  15289. Add(' FOnClick: TJSNotifyEvent;');
  15290. Add(' property OnClick: TJSNotifyEvent read FOnClick write FOnClick;');
  15291. Add(' procedure Click(Sender: TJSElement);');
  15292. Add(' end;');
  15293. Add('procedure TControl.Click(Sender: TJSElement);');
  15294. Add('begin');
  15295. Add(' OnClick(Self);');
  15296. Add('end;');
  15297. Add('var');
  15298. Add(' Ctrl: TControl;');
  15299. Add('begin');
  15300. Add(' Ctrl.OnClick:[email protected];');
  15301. Add(' Ctrl.OnClick(Ctrl);');
  15302. ConvertProgram;
  15303. CheckSource('TestExternalClass_PascalProperty',
  15304. LinesToStr([ // statements
  15305. 'rtl.createClassExt($mod, "TControl", ExtA, "", function () {',
  15306. ' this.$init = function () {',
  15307. ' this.FOnClick = null;',
  15308. ' };',
  15309. ' this.$final = function () {',
  15310. ' this.FOnClick = undefined;',
  15311. ' };',
  15312. ' this.Click = function (Sender) {',
  15313. ' this.FOnClick(this);',
  15314. ' };',
  15315. '});',
  15316. 'this.Ctrl = null;',
  15317. '']),
  15318. LinesToStr([ // $mod.$main
  15319. '$mod.Ctrl.FOnClick = rtl.createCallback($mod.Ctrl, "Click");',
  15320. '$mod.Ctrl.FOnClick($mod.Ctrl);',
  15321. '']));
  15322. end;
  15323. procedure TTestModule.TestExternalClass_TypeCastToRootClass;
  15324. begin
  15325. StartProgram(false);
  15326. Add([
  15327. '{$modeswitch externalclass}',
  15328. 'type',
  15329. ' IUnknown = interface end;',
  15330. ' TObject = class',
  15331. ' end;',
  15332. ' TChild = class',
  15333. ' end;',
  15334. ' TExtRootA = class external name ''ExtRootA''',
  15335. ' end;',
  15336. ' TExtChildA = class external name ''ExtChildA''(TExtRootA)',
  15337. ' end;',
  15338. ' TExtRootB = class external name ''ExtRootB''',
  15339. ' end;',
  15340. ' TExtChildB = class external name ''ExtChildB''(TExtRootB)',
  15341. ' end;',
  15342. 'var',
  15343. ' Obj: TObject;',
  15344. ' Child: TChild;',
  15345. ' RootA: TExtRootA;',
  15346. ' ChildA: TExtChildA;',
  15347. ' RootB: TExtRootB;',
  15348. ' ChildB: TExtChildB;',
  15349. ' i: IUnknown;',
  15350. 'begin',
  15351. ' obj:=tobject(roota);',
  15352. ' obj:=tobject(childa);',
  15353. ' child:=tchild(tobject(roota));',
  15354. ' roota:=textroota(obj);',
  15355. ' roota:=textroota(child);',
  15356. ' roota:=textroota(rootb);',
  15357. ' roota:=textroota(childb);',
  15358. ' childa:=textchilda(textroota(obj));',
  15359. ' roota:=TExtRootA(i)',
  15360. '']);
  15361. ConvertProgram;
  15362. CheckSource('TestExternalClass_TypeCastToRootClass',
  15363. LinesToStr([ // statements
  15364. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  15365. 'rtl.createClass($mod, "TObject", null, function () {',
  15366. ' this.$init = function () {',
  15367. ' };',
  15368. ' this.$final = function () {',
  15369. ' };',
  15370. '});',
  15371. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  15372. '});',
  15373. 'this.Obj = null;',
  15374. 'this.Child = null;',
  15375. 'this.RootA = null;',
  15376. 'this.ChildA = null;',
  15377. 'this.RootB = null;',
  15378. 'this.ChildB = null;',
  15379. 'this.i = null;',
  15380. '']),
  15381. LinesToStr([ // $mod.$main
  15382. '$mod.Obj = $mod.RootA;',
  15383. '$mod.Obj = $mod.ChildA;',
  15384. '$mod.Child = $mod.RootA;',
  15385. '$mod.RootA = $mod.Obj;',
  15386. '$mod.RootA = $mod.Child;',
  15387. '$mod.RootA = $mod.RootB;',
  15388. '$mod.RootA = $mod.ChildB;',
  15389. '$mod.ChildA = $mod.Obj;',
  15390. '$mod.RootA = $mod.i;',
  15391. '']));
  15392. end;
  15393. procedure TTestModule.TestExternalClass_TypeCastToJSObject;
  15394. begin
  15395. StartProgram(false);
  15396. Add([
  15397. '{$modeswitch externalclass}',
  15398. 'type',
  15399. ' IUnknown = interface end;',
  15400. ' IBird = interface(IUnknown) end;',
  15401. ' TClass = class of TObject;',
  15402. ' TObject = class',
  15403. ' end;',
  15404. ' TChild = class',
  15405. ' end;',
  15406. ' TJSObject = class external name ''Object''',
  15407. ' end;',
  15408. ' TRec = record end;',
  15409. 'var',
  15410. ' Obj: TObject;',
  15411. ' Child: TChild;',
  15412. ' i: IUnknown;',
  15413. ' Bird: IBird;',
  15414. ' j: TJSObject;',
  15415. ' r: TRec;',
  15416. ' c: TClass;',
  15417. 'begin',
  15418. ' j:=tjsobject(IUnknown);',
  15419. ' j:=tjsobject(IBird);',
  15420. ' j:=tjsobject(TObject);',
  15421. ' j:=tjsobject(TChild);',
  15422. ' j:=tjsobject(TRec);',
  15423. ' j:=tjsobject(Obj);',
  15424. ' j:=tjsobject(Child);',
  15425. ' j:=tjsobject(i);',
  15426. ' j:=tjsobject(Bird);',
  15427. ' j:=tjsobject(r);',
  15428. ' j:=tjsobject(c);',
  15429. '']);
  15430. ConvertProgram;
  15431. CheckSource('TestExternalClass_TypeCastToJSObject',
  15432. LinesToStr([ // statements
  15433. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  15434. 'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], $mod.IUnknown);',
  15435. 'rtl.createClass($mod, "TObject", null, function () {',
  15436. ' this.$init = function () {',
  15437. ' };',
  15438. ' this.$final = function () {',
  15439. ' };',
  15440. '});',
  15441. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  15442. '});',
  15443. 'rtl.recNewT($mod, "TRec", function () {',
  15444. ' this.$eq = function (b) {',
  15445. ' return true;',
  15446. ' };',
  15447. ' this.$assign = function (s) {',
  15448. ' return this;',
  15449. ' };',
  15450. '});',
  15451. 'this.Obj = null;',
  15452. 'this.Child = null;',
  15453. 'this.i = null;',
  15454. 'this.Bird = null;',
  15455. 'this.j = null;',
  15456. 'this.r = $mod.TRec.$new();',
  15457. 'this.c = null;',
  15458. '']),
  15459. LinesToStr([ // $mod.$main
  15460. '$mod.j = $mod.IUnknown;',
  15461. '$mod.j = $mod.IBird;',
  15462. '$mod.j = $mod.TObject;',
  15463. '$mod.j = $mod.TChild;',
  15464. '$mod.j = $mod.TRec;',
  15465. '$mod.j = $mod.Obj;',
  15466. '$mod.j = $mod.Child;',
  15467. '$mod.j = $mod.i;',
  15468. '$mod.j = $mod.Bird;',
  15469. '$mod.j = $mod.r;',
  15470. '$mod.j = $mod.c;',
  15471. '']));
  15472. end;
  15473. procedure TTestModule.TestExternalClass_TypeCastStringToExternalString;
  15474. begin
  15475. StartProgram(false);
  15476. Add('{$modeswitch externalclass}');
  15477. Add('type');
  15478. Add(' TJSString = class external name ''String''');
  15479. Add(' class function fromCharCode() : string; varargs;');
  15480. Add(' function anchor(const aName : string) : string;');
  15481. Add(' end;');
  15482. Add('var');
  15483. Add(' s: string;');
  15484. Add('begin');
  15485. Add(' s:=TJSString.fromCharCode(65,66);');
  15486. Add(' s:=TJSString(s).anchor(s);');
  15487. Add(' s:=TJSString(''foo'').anchor(s);');
  15488. ConvertProgram;
  15489. CheckSource('TestExternalClass_TypeCastStringToExternalString',
  15490. LinesToStr([ // statements
  15491. 'this.s = "";',
  15492. '']),
  15493. LinesToStr([ // $mod.$main
  15494. '$mod.s = String.fromCharCode(65, 66);',
  15495. '$mod.s = $mod.s.anchor($mod.s);',
  15496. '$mod.s = "foo".anchor($mod.s);',
  15497. '']));
  15498. end;
  15499. procedure TTestModule.TestExternalClass_TypeCastToJSFunction;
  15500. begin
  15501. StartProgram(false);
  15502. Add([
  15503. '{$modeswitch externalclass}',
  15504. 'type',
  15505. ' TJSObject = class external name ''Object'' end;',
  15506. ' TJSFunction = class external name ''Function''',
  15507. ' function bind(thisArg: TJSObject): TJSFunction; varargs;',
  15508. ' function call(thisArg: TJSObject): JSValue; varargs;',
  15509. ' end;',
  15510. ' TObject = class',
  15511. ' procedure DoIt(i: longint);',
  15512. ' end;',
  15513. ' TFuncInt = function(o: TObject): longint;',
  15514. 'function GetIt(o: TObject): longint;',
  15515. ' procedure Sub; begin end;',
  15516. 'var',
  15517. ' f: TJSFunction;',
  15518. ' fi: TFuncInt;',
  15519. 'begin',
  15520. ' fi:=TFuncInt(f);',
  15521. ' f:=TJSFunction(fi);',
  15522. ' f:=TJSFunction(@GetIt);',
  15523. ' f:=TJSFunction(@GetIt).bind(nil,3);',
  15524. ' f:=TJSFunction(@Sub);',
  15525. ' f:=TJSFunction(@o.doit);',
  15526. ' f:=TJSFunction(fi).bind(nil,4)',
  15527. 'end;',
  15528. 'procedure TObject.DoIt(i: longint);',
  15529. ' procedure Sub; begin end;',
  15530. 'var f: TJSFunction;',
  15531. 'begin',
  15532. ' f:=TJSFunction(@DoIt);',
  15533. ' f:=TJSFunction(@DoIt).bind(nil,13);',
  15534. ' f:=TJSFunction(@Sub);',
  15535. ' f:=TJSFunction(@GetIt);',
  15536. 'end;',
  15537. 'begin']);
  15538. ConvertProgram;
  15539. CheckSource('TestExternalClass_TypeCastToJSFunction',
  15540. LinesToStr([ // statements
  15541. 'rtl.createClass($mod, "TObject", null, function () {',
  15542. ' this.$init = function () {',
  15543. ' };',
  15544. ' this.$final = function () {',
  15545. ' };',
  15546. ' this.DoIt = function (i) {',
  15547. ' var $Self = this;',
  15548. ' function Sub() {',
  15549. ' };',
  15550. ' var f = null;',
  15551. ' f = rtl.createCallback($Self, "DoIt");',
  15552. ' f = rtl.createCallback($Self, "DoIt").bind(null, 13);',
  15553. ' f = Sub;',
  15554. ' f = $mod.GetIt;',
  15555. ' };',
  15556. '});',
  15557. 'this.GetIt = function (o) {',
  15558. ' var Result = 0;',
  15559. ' function Sub() {',
  15560. ' };',
  15561. ' var f = null;',
  15562. ' var fi = null;',
  15563. ' fi = f;',
  15564. ' f = fi;',
  15565. ' f = $mod.GetIt;',
  15566. ' f = $mod.GetIt.bind(null, 3);',
  15567. ' f = Sub;',
  15568. ' f = rtl.createCallback(o, "DoIt");',
  15569. ' f = fi.bind(null, 4);',
  15570. ' return Result;',
  15571. '};',
  15572. '']),
  15573. LinesToStr([ // $mod.$main
  15574. '']));
  15575. end;
  15576. procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
  15577. begin
  15578. StartProgram(false);
  15579. Add('{$modeswitch externalclass}');
  15580. Add('type');
  15581. Add(' TJSString = class external name ''String''');
  15582. Add(' class function fromCharCode() : string; varargs;');
  15583. Add(' end;');
  15584. Add('var');
  15585. Add(' s: string;');
  15586. Add(' sObj: TJSString;');
  15587. Add('begin');
  15588. Add(' s:=sObj.fromCharCode(65,66);');
  15589. SetExpectedPasResolverError('External class instance cannot access static class function fromCharCode',
  15590. nExternalClassInstanceCannotAccessStaticX);
  15591. ConvertProgram;
  15592. end;
  15593. procedure TTestModule.TestExternalClass_BracketAccessor;
  15594. begin
  15595. StartProgram(false);
  15596. Add([
  15597. '{$modeswitch externalclass}',
  15598. 'type',
  15599. ' TJSArray = class external name ''Array2''',
  15600. ' function GetItems(Index: longint): jsvalue; external name ''[]'';',
  15601. ' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
  15602. ' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
  15603. ' end;',
  15604. 'procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);',
  15605. 'begin end;',
  15606. 'var',
  15607. ' Arr: tjsarray;',
  15608. ' s: string;',
  15609. ' i: longint;',
  15610. ' v: jsvalue;',
  15611. 'begin',
  15612. ' v:=arr[0];',
  15613. ' v:=arr.items[1];',
  15614. ' arr[2]:=s;',
  15615. ' arr.items[3]:=s;',
  15616. ' arr[4]:=i;',
  15617. ' arr[5]:=arr[6];',
  15618. ' arr.items[7]:=arr.items[8];',
  15619. ' with arr do items[9]:=items[10];',
  15620. ' doit(arr[7],arr[8],arr[9],arr[10]);',
  15621. ' with arr do begin',
  15622. ' v:=GetItems(14);',
  15623. ' setitems(15,16);',
  15624. ' end;',
  15625. ' v:=test1.arr.items[17];',
  15626. ' test1.arr.items[18]:=v;',
  15627. '']);
  15628. ConvertProgram;
  15629. CheckSource('TestExternalClass_BracketAccessor',
  15630. LinesToStr([ // statements
  15631. 'this.DoIt = function (vI, vJ, vK, vL) {',
  15632. '};',
  15633. 'this.Arr = null;',
  15634. 'this.s = "";',
  15635. 'this.i = 0;',
  15636. 'this.v = undefined;',
  15637. '']),
  15638. LinesToStr([ // $mod.$main
  15639. '$mod.v = $mod.Arr[0];',
  15640. '$mod.v = $mod.Arr[1];',
  15641. '$mod.Arr[2] = $mod.s;',
  15642. '$mod.Arr[3] = $mod.s;',
  15643. '$mod.Arr[4] = $mod.i;',
  15644. '$mod.Arr[5] = $mod.Arr[6];',
  15645. '$mod.Arr[7] = $mod.Arr[8];',
  15646. 'var $with1 = $mod.Arr;',
  15647. '$with1[9] = $with1[10];',
  15648. '$mod.DoIt($mod.Arr[7], $mod.Arr[8], {',
  15649. ' a: 9,',
  15650. ' p: $mod.Arr,',
  15651. ' get: function () {',
  15652. ' return this.p[this.a];',
  15653. ' },',
  15654. ' set: function (v) {',
  15655. ' this.p[this.a] = v;',
  15656. ' }',
  15657. '}, {',
  15658. ' a: 10,',
  15659. ' p: $mod.Arr,',
  15660. ' get: function () {',
  15661. ' return this.p[this.a];',
  15662. ' },',
  15663. ' set: function (v) {',
  15664. ' this.p[this.a] = v;',
  15665. ' }',
  15666. '});',
  15667. 'var $with2 = $mod.Arr;',
  15668. '$mod.v = $with2[14];',
  15669. '$with2[15] = 16;',
  15670. '$mod.v = $mod.Arr[17];',
  15671. '$mod.Arr[18] = $mod.v;',
  15672. '']));
  15673. end;
  15674. procedure TTestModule.TestExternalClass_BracketAccessor_Call;
  15675. begin
  15676. StartProgram(false);
  15677. Add([
  15678. '{$modeswitch externalclass}',
  15679. 'type',
  15680. ' TJSArray = class external name ''Array2''',
  15681. ' function GetItems(Index: longint): jsvalue; external name ''[]'';',
  15682. ' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
  15683. ' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
  15684. ' end;',
  15685. ' TMyArr = class(TJSArray)',
  15686. ' procedure DoIt;',
  15687. ' end;',
  15688. 'procedure tmyarr.DoIt;',
  15689. 'begin',
  15690. ' Items[1]:=Items[2];',
  15691. ' SetItems(3,getItems(4));',
  15692. 'end;',
  15693. 'var',
  15694. ' Arr: tmyarr;',
  15695. ' s: string;',
  15696. ' i: longint;',
  15697. ' v: jsvalue;',
  15698. 'begin',
  15699. ' v:=arr[0];',
  15700. ' v:=arr.items[1];',
  15701. ' arr[2]:=s;',
  15702. ' arr.items[3]:=s;',
  15703. ' arr[4]:=i;',
  15704. ' arr[5]:=arr[6];',
  15705. ' arr.items[7]:=arr.items[8];',
  15706. ' with arr do items[9]:=items[10];',
  15707. ' with arr do begin',
  15708. ' v:=GetItems(14);',
  15709. ' setitems(15,16);',
  15710. ' end;',
  15711. '']);
  15712. ConvertProgram;
  15713. CheckSource('TestExternalClass_BracketAccessor_Call',
  15714. LinesToStr([ // statements
  15715. 'rtl.createClassExt($mod, "TMyArr", Array2, "", function () {',
  15716. ' this.$init = function () {',
  15717. ' };',
  15718. ' this.$final = function () {',
  15719. ' };',
  15720. ' this.DoIt = function () {',
  15721. ' this[1] = this[2];',
  15722. ' this[3] = this[4];',
  15723. ' };',
  15724. '});',
  15725. 'this.Arr = null;',
  15726. 'this.s = "";',
  15727. 'this.i = 0;',
  15728. 'this.v = undefined;',
  15729. '']),
  15730. LinesToStr([ // $mod.$main
  15731. '$mod.v = $mod.Arr[0];',
  15732. '$mod.v = $mod.Arr[1];',
  15733. '$mod.Arr[2] = $mod.s;',
  15734. '$mod.Arr[3] = $mod.s;',
  15735. '$mod.Arr[4] = $mod.i;',
  15736. '$mod.Arr[5] = $mod.Arr[6];',
  15737. '$mod.Arr[7] = $mod.Arr[8];',
  15738. 'var $with1 = $mod.Arr;',
  15739. '$with1[9] = $with1[10];',
  15740. 'var $with2 = $mod.Arr;',
  15741. '$mod.v = $with2[14];',
  15742. '$with2[15] = 16;',
  15743. '']));
  15744. end;
  15745. procedure TTestModule.TestExternalClass_BracketAccessor_2ParamsFail;
  15746. begin
  15747. StartProgram(false);
  15748. Add('{$modeswitch externalclass}');
  15749. Add('type');
  15750. Add(' TJSArray = class external name ''Array2''');
  15751. Add(' function GetItems(Index1, Index2: longint): jsvalue; external name ''[]'';');
  15752. Add(' procedure SetItems(Index1, Index2: longint; Value: jsvalue); external name ''[]'';');
  15753. Add(' property Items[Index1, Index2: longint]: jsvalue read GetItems write SetItems; default;');
  15754. Add(' end;');
  15755. Add('begin');
  15756. SetExpectedPasResolverError(sBracketAccessorOfExternalClassMustHaveOneParameter,
  15757. nBracketAccessorOfExternalClassMustHaveOneParameter);
  15758. ConvertProgram;
  15759. end;
  15760. procedure TTestModule.TestExternalClass_BracketAccessor_ReadOnly;
  15761. begin
  15762. StartProgram(false);
  15763. Add('{$modeswitch externalclass}');
  15764. Add('type');
  15765. Add(' TJSArray = class external name ''Array2''');
  15766. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  15767. Add(' property Items[Index: longint]: jsvalue read GetItems; default;');
  15768. Add(' end;');
  15769. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue);');
  15770. Add('begin end;');
  15771. Add('var');
  15772. Add(' Arr: tjsarray;');
  15773. Add(' v: jsvalue;');
  15774. Add('begin');
  15775. Add(' v:=arr[0];');
  15776. Add(' v:=arr.items[1];');
  15777. Add(' with arr do v:=items[2];');
  15778. Add(' doit(arr[3],arr[4]);');
  15779. ConvertProgram;
  15780. CheckSource('TestExternalClass_BracketAccessor_ReadOnly',
  15781. LinesToStr([ // statements
  15782. 'this.DoIt = function (vI, vJ) {',
  15783. '};',
  15784. 'this.Arr = null;',
  15785. 'this.v = undefined;',
  15786. '']),
  15787. LinesToStr([ // $mod.$main
  15788. '$mod.v = $mod.Arr[0];',
  15789. '$mod.v = $mod.Arr[1];',
  15790. 'var $with1 = $mod.Arr;',
  15791. '$mod.v = $with1[2];',
  15792. '$mod.DoIt($mod.Arr[3], $mod.Arr[4]);',
  15793. '']));
  15794. end;
  15795. procedure TTestModule.TestExternalClass_BracketAccessor_WriteOnly;
  15796. begin
  15797. StartProgram(false);
  15798. Add('{$modeswitch externalclass}');
  15799. Add('type');
  15800. Add(' TJSArray = class external name ''Array2''');
  15801. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  15802. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  15803. Add(' end;');
  15804. Add('var');
  15805. Add(' Arr: tjsarray;');
  15806. Add(' s: string;');
  15807. Add(' i: longint;');
  15808. Add(' v: jsvalue;');
  15809. Add('begin');
  15810. Add(' arr[2]:=s;');
  15811. Add(' arr.items[3]:=s;');
  15812. Add(' arr[4]:=i;');
  15813. Add(' with arr do items[5]:=i;');
  15814. ConvertProgram;
  15815. CheckSource('TestExternalClass_BracketAccessor_WriteOnly',
  15816. LinesToStr([ // statements
  15817. 'this.Arr = null;',
  15818. 'this.s = "";',
  15819. 'this.i = 0;',
  15820. 'this.v = undefined;',
  15821. '']),
  15822. LinesToStr([ // $mod.$main
  15823. '$mod.Arr[2] = $mod.s;',
  15824. '$mod.Arr[3] = $mod.s;',
  15825. '$mod.Arr[4] = $mod.i;',
  15826. 'var $with1 = $mod.Arr;',
  15827. '$with1[5] = $mod.i;',
  15828. '']));
  15829. end;
  15830. procedure TTestModule.TestExternalClass_BracketAccessor_MultiType;
  15831. begin
  15832. StartProgram(false);
  15833. Add('{$modeswitch externalclass}');
  15834. Add('type');
  15835. Add(' TJSArray = class external name ''Array2''');
  15836. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  15837. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  15838. Add(' procedure SetNumbers(Index: longint; Value: longint); external name ''[]'';');
  15839. Add(' property Numbers[Index: longint]: longint write SetNumbers;');
  15840. Add(' end;');
  15841. Add('var');
  15842. Add(' Arr: tjsarray;');
  15843. Add(' s: string;');
  15844. Add(' i: longint;');
  15845. Add(' v: jsvalue;');
  15846. Add('begin');
  15847. Add(' arr[2]:=s;');
  15848. Add(' arr.items[3]:=s;');
  15849. Add(' arr.numbers[4]:=i;');
  15850. Add(' with arr do items[5]:=i;');
  15851. Add(' with arr do numbers[6]:=i;');
  15852. ConvertProgram;
  15853. CheckSource('TestExternalClass_BracketAccessor_MultiType',
  15854. LinesToStr([ // statements
  15855. 'this.Arr = null;',
  15856. 'this.s = "";',
  15857. 'this.i = 0;',
  15858. 'this.v = undefined;',
  15859. '']),
  15860. LinesToStr([ // $mod.$main
  15861. '$mod.Arr[2] = $mod.s;',
  15862. '$mod.Arr[3] = $mod.s;',
  15863. '$mod.Arr[4] = $mod.i;',
  15864. 'var $with1 = $mod.Arr;',
  15865. '$with1[5] = $mod.i;',
  15866. 'var $with2 = $mod.Arr;',
  15867. '$with2[6] = $mod.i;',
  15868. '']));
  15869. end;
  15870. procedure TTestModule.TestExternalClass_BracketAccessor_Index;
  15871. begin
  15872. StartProgram(false);
  15873. Add('{$modeswitch externalclass}');
  15874. Add('type');
  15875. Add(' TJSArray = class external name ''Array2''');
  15876. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  15877. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  15878. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  15879. Add(' end;');
  15880. Add('var');
  15881. Add(' Arr: tjsarray;');
  15882. Add(' i: longint;');
  15883. Add(' IntArr: array of longint;');
  15884. Add(' v: jsvalue;');
  15885. Add('begin');
  15886. Add(' v:=arr.items[i];');
  15887. Add(' arr[longint(v)]:=arr.items[intarr[0]];');
  15888. Add(' arr.items[intarr[1]]:=arr[IntArr[2]];');
  15889. ConvertProgram;
  15890. CheckSource('TestExternalClass_BracketAccessor_Index',
  15891. LinesToStr([ // statements
  15892. 'this.Arr = null;',
  15893. 'this.i = 0;',
  15894. 'this.IntArr = [];',
  15895. 'this.v = undefined;',
  15896. '']),
  15897. LinesToStr([ // $mod.$main
  15898. '$mod.v = $mod.Arr[$mod.i];',
  15899. '$mod.Arr[Math.floor($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
  15900. '$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
  15901. '']));
  15902. end;
  15903. procedure TTestModule.TestExternalClass_ForInJSObject;
  15904. begin
  15905. StartProgram(false);
  15906. Add([
  15907. '{$modeswitch externalclass}',
  15908. 'type',
  15909. ' TJSObject = class external name ''Object''',
  15910. ' end;',
  15911. 'var',
  15912. ' o: TJSObject;',
  15913. ' key: string;',
  15914. 'begin',
  15915. ' for key in o do',
  15916. ' if key=''abc'' then ;',
  15917. '']);
  15918. ConvertProgram;
  15919. CheckSource('TestExternalClass_ForInJSObject',
  15920. LinesToStr([ // statements
  15921. 'this.o = null;',
  15922. 'this.key = "";',
  15923. '']),
  15924. LinesToStr([ // $mod.$main
  15925. 'for ($mod.key in $mod.o) if ($mod.key === "abc") ;',
  15926. '']));
  15927. end;
  15928. procedure TTestModule.TestExternalClass_ForInJSArray;
  15929. begin
  15930. StartProgram(false);
  15931. Add([
  15932. '{$modeswitch externalclass}',
  15933. 'type',
  15934. ' TJSInt8Array = class external name ''Int8Array''',
  15935. ' private',
  15936. ' flength: NativeInt external name ''length'';',
  15937. ' function getValue(Index: NativeInt): shortint; external name ''[]'';',
  15938. ' public',
  15939. ' property values[Index: NativeInt]: Shortint Read getValue; default;',
  15940. ' property Length: NativeInt read flength;',
  15941. ' end;',
  15942. 'var',
  15943. ' a: TJSInt8Array;',
  15944. ' value: shortint;',
  15945. 'begin',
  15946. ' for value in a do',
  15947. ' if value=3 then ;',
  15948. '']);
  15949. ConvertProgram;
  15950. CheckSource('TestExternalClass_ForInJSArray',
  15951. LinesToStr([ // statements
  15952. 'this.a = null;',
  15953. 'this.value = 0;',
  15954. '']),
  15955. LinesToStr([ // $mod.$main
  15956. 'for (var $in1 = $mod.a, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) {',
  15957. ' $mod.value = $in1[$l2];',
  15958. ' if ($mod.value === 3) ;',
  15959. '};',
  15960. '']));
  15961. end;
  15962. procedure TTestModule.TestExternalClass_IncompatibleArgDuplicateIdentifier;
  15963. begin
  15964. AddModuleWithIntfImplSrc('unit2.pas',
  15965. LinesToStr([
  15966. '{$modeswitch externalclass}',
  15967. 'type',
  15968. ' TJSBufferSource = class external name ''BufferSource''',
  15969. ' end;',
  15970. 'procedure DoIt(s: TJSBufferSource); external name ''DoIt'';',
  15971. '']),
  15972. '');
  15973. AddModuleWithIntfImplSrc('unit3.pas',
  15974. LinesToStr([
  15975. '{$modeswitch externalclass}',
  15976. 'type',
  15977. ' TJSBufferSource = class external name ''BufferSource''',
  15978. ' end;',
  15979. '']),
  15980. '');
  15981. StartUnit(true);
  15982. Add([
  15983. 'interface',
  15984. 'uses unit2, unit3;',
  15985. 'procedure DoSome(s: TJSBufferSource);',
  15986. 'implementation',
  15987. 'procedure DoSome(s: TJSBufferSource);',
  15988. 'begin',
  15989. ' DoIt(s);',
  15990. 'end;',
  15991. '']);
  15992. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "unit3.TJSBufferSource", expected "unit2.TJSBufferSource"',
  15993. nIncompatibleTypeArgNo);
  15994. ConvertUnit;
  15995. end;
  15996. procedure TTestModule.TestClassInterface_Corba;
  15997. begin
  15998. StartProgram(false);
  15999. Add([
  16000. '{$interfaces corba}',
  16001. 'type',
  16002. ' IUnknown = interface;',
  16003. ' IUnknown = interface',
  16004. ' [''{00000000-0000-0000-C000-000000000046}'']',
  16005. ' end;',
  16006. ' IInterface = IUnknown;',
  16007. ' IBird = interface(IInterface)',
  16008. ' function GetSize: longint;',
  16009. ' procedure SetSize(i: longint);',
  16010. ' property Size: longint read GetSize write SetSize;',
  16011. ' procedure DoIt(i: longint);',
  16012. ' end;',
  16013. ' TObject = class',
  16014. ' end;',
  16015. ' TBird = class(TObject,IBird)',
  16016. ' function GetSize: longint; virtual; abstract;',
  16017. ' procedure SetSize(i: longint); virtual; abstract;',
  16018. ' procedure DoIt(i: longint); virtual; abstract;',
  16019. ' end;',
  16020. 'var',
  16021. ' BirdIntf: IBird;',
  16022. 'begin',
  16023. ' BirdIntf.Size:=BirdIntf.Size;',
  16024. '']);
  16025. ConvertProgram;
  16026. CheckSource('TestClassInterface_Corba',
  16027. LinesToStr([ // statements
  16028. 'rtl.createInterface($mod, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
  16029. 'rtl.createInterface($mod, "IBird", "{5BD1A53B-69BB-37EE-AF32-BEFB86D85B03}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
  16030. 'rtl.createClass($mod, "TObject", null, function () {',
  16031. ' this.$init = function () {',
  16032. ' };',
  16033. ' this.$final = function () {',
  16034. ' };',
  16035. '});',
  16036. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16037. ' rtl.addIntf(this, $mod.IBird);',
  16038. '});',
  16039. 'this.BirdIntf = null;',
  16040. '']),
  16041. LinesToStr([ // $mod.$main
  16042. ' $mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
  16043. '']));
  16044. end;
  16045. procedure TTestModule.TestClassInterface_ProcExternalFail;
  16046. begin
  16047. StartProgram(false);
  16048. Add([
  16049. '{$interfaces corba}',
  16050. 'type',
  16051. ' IUnknown = interface',
  16052. ' procedure DoIt; external name ''foo'';',
  16053. ' end;',
  16054. 'begin']);
  16055. SetExpectedParserError(
  16056. 'Fields are not allowed in interface at token "Identifier external" in file test1.pp at line 6 column 21',
  16057. nParserNoFieldsAllowed);
  16058. ConvertProgram;
  16059. end;
  16060. procedure TTestModule.TestClassInterface_Overloads;
  16061. begin
  16062. StartProgram(false);
  16063. Add([
  16064. '{$interfaces corba}',
  16065. 'type',
  16066. ' integer = longint;',
  16067. ' IUnknown = interface',
  16068. ' procedure DoIt(i: integer);',
  16069. ' procedure DoIt(s: string);',
  16070. ' end;',
  16071. ' IBird = interface(IUnknown)',
  16072. ' procedure DoIt(b: boolean); overload;',
  16073. ' end;',
  16074. ' TObject = class',
  16075. ' end;',
  16076. ' TBird = class(TObject,IBird)',
  16077. ' procedure DoIt(o: TObject);',
  16078. ' procedure DoIt(s: string);',
  16079. ' procedure DoIt(i: integer);',
  16080. ' procedure DoIt(b: boolean);',
  16081. ' end;',
  16082. 'procedure TBird.DoIt(o: TObject); begin end;',
  16083. 'procedure TBird.DoIt(s: string); begin end;',
  16084. 'procedure TBird.DoIt(i: integer); begin end;',
  16085. 'procedure TBird.DoIt(b: boolean); begin end;',
  16086. 'var',
  16087. ' BirdIntf: IBird;',
  16088. 'begin',
  16089. ' BirdIntf.DoIt(3);',
  16090. ' BirdIntf.DoIt(''abc'');',
  16091. ' BirdIntf.DoIt(true);',
  16092. '']);
  16093. ConvertProgram;
  16094. CheckSource('TestClassInterface_Overloads',
  16095. LinesToStr([ // statements
  16096. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2AE2C59400}", ["DoIt", "DoIt$1"], null);',
  16097. 'rtl.createInterface($mod, "IBird", "{8285DD5E-EA3E-396E-AE88-000B86AABF05}", ["DoIt$2"], $mod.IUnknown);',
  16098. 'rtl.createClass($mod, "TObject", null, function () {',
  16099. ' this.$init = function () {',
  16100. ' };',
  16101. ' this.$final = function () {',
  16102. ' };',
  16103. '});',
  16104. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16105. ' this.DoIt = function (o) {',
  16106. ' };',
  16107. ' this.DoIt$1 = function (s) {',
  16108. ' };',
  16109. ' this.DoIt$2 = function (i) {',
  16110. ' };',
  16111. ' this.DoIt$3 = function (b) {',
  16112. ' };',
  16113. ' rtl.addIntf(this, $mod.IBird, {',
  16114. ' DoIt$2: "DoIt$3",',
  16115. ' DoIt: "DoIt$2"',
  16116. ' });',
  16117. '});',
  16118. 'this.BirdIntf = null;',
  16119. '']),
  16120. LinesToStr([ // $mod.$main
  16121. '$mod.BirdIntf.DoIt(3);',
  16122. '$mod.BirdIntf.DoIt$1("abc");',
  16123. '$mod.BirdIntf.DoIt$2(true);',
  16124. '']));
  16125. end;
  16126. procedure TTestModule.TestClassInterface_DuplicateGUIInIntfListFail;
  16127. begin
  16128. StartProgram(false);
  16129. Add([
  16130. '{$interfaces corba}',
  16131. 'type',
  16132. ' IBird = interface',
  16133. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16134. ' end;',
  16135. ' IDog = interface',
  16136. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16137. ' end;',
  16138. ' TObject = class(IBird,IDog)',
  16139. ' end;',
  16140. 'begin']);
  16141. SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IDog and IBird',
  16142. nDuplicateGUIDXInYZ);
  16143. ConvertProgram;
  16144. end;
  16145. procedure TTestModule.TestClassInterface_DuplicateGUIInAncestorFail;
  16146. begin
  16147. StartProgram(false);
  16148. Add([
  16149. '{$interfaces corba}',
  16150. 'type',
  16151. ' IAnimal = interface',
  16152. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16153. ' end;',
  16154. ' IBird = interface(IAnimal)',
  16155. ' end;',
  16156. ' IHawk = interface(IBird)',
  16157. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16158. ' end;',
  16159. 'begin']);
  16160. SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IHawk and IAnimal',
  16161. nDuplicateGUIDXInYZ);
  16162. ConvertProgram;
  16163. end;
  16164. procedure TTestModule.TestClassInterface_AncestorImpl;
  16165. begin
  16166. StartProgram(false);
  16167. Add([
  16168. '{$interfaces corba}',
  16169. 'type',
  16170. ' integer = longint;',
  16171. ' IUnknown = interface',
  16172. ' procedure DoIt(i: integer);',
  16173. ' end;',
  16174. ' IBird = interface',
  16175. ' procedure Fly(i: integer);',
  16176. ' end;',
  16177. ' TObject = class(IUnknown)',
  16178. ' procedure DoIt(i: integer);',
  16179. ' end;',
  16180. ' TBird = class(IBird)',
  16181. ' procedure Fly(i: integer);',
  16182. ' end;',
  16183. 'procedure TObject.DoIt(i: integer); begin end;',
  16184. 'procedure TBird.Fly(i: integer); begin end;',
  16185. 'begin',
  16186. '']);
  16187. ConvertProgram;
  16188. CheckSource('TestClassInterface_AncestorIntf',
  16189. LinesToStr([ // statements
  16190. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2800000000}", ["DoIt"], null);',
  16191. 'rtl.createInterface($mod, "IBird", "{B92D5841-6264-3AE3-BF20-000000000000}", ["Fly"], null);',
  16192. 'rtl.createClass($mod, "TObject", null, function () {',
  16193. ' this.$init = function () {',
  16194. ' };',
  16195. ' this.$final = function () {',
  16196. ' };',
  16197. ' this.DoIt = function (i) {',
  16198. ' };',
  16199. ' rtl.addIntf(this, $mod.IUnknown);',
  16200. '});',
  16201. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16202. ' this.Fly = function (i) {',
  16203. ' };',
  16204. ' rtl.addIntf(this, $mod.IBird);',
  16205. ' rtl.addIntf(this, $mod.IUnknown);',
  16206. '});',
  16207. '']),
  16208. LinesToStr([ // $mod.$main
  16209. '']));
  16210. end;
  16211. procedure TTestModule.TestClassInterface_ImplReintroduce;
  16212. begin
  16213. StartProgram(false);
  16214. Add([
  16215. '{$interfaces corba}',
  16216. 'type',
  16217. ' integer = longint;',
  16218. ' IBird = interface',
  16219. ' procedure DoIt(i: integer);',
  16220. ' end;',
  16221. ' TObject = class',
  16222. ' procedure DoIt(i: integer);',
  16223. ' end;',
  16224. ' TBird = class(IBird)',
  16225. ' procedure DoIt(i: integer); virtual; reintroduce;',
  16226. ' end;',
  16227. 'procedure TObject.DoIt(i: integer); begin end;',
  16228. 'procedure TBird.DoIt(i: integer); begin end;',
  16229. 'begin',
  16230. '']);
  16231. ConvertProgram;
  16232. CheckSource('TestClassInterface_ImplReintroduce',
  16233. LinesToStr([ // statements
  16234. 'rtl.createInterface($mod, "IBird", "{B92D5841-6264-3AE2-8594-000000000000}", ["DoIt"], null);',
  16235. 'rtl.createClass($mod, "TObject", null, function () {',
  16236. ' this.$init = function () {',
  16237. ' };',
  16238. ' this.$final = function () {',
  16239. ' };',
  16240. ' this.DoIt = function (i) {',
  16241. ' };',
  16242. '});',
  16243. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16244. ' this.DoIt$1 = function (i) {',
  16245. ' };',
  16246. ' rtl.addIntf(this, $mod.IBird, {',
  16247. ' DoIt: "DoIt$1"',
  16248. ' });',
  16249. '});',
  16250. '']),
  16251. LinesToStr([ // $mod.$main
  16252. '']));
  16253. end;
  16254. procedure TTestModule.TestClassInterface_MethodResolution;
  16255. begin
  16256. StartProgram(false);
  16257. Add([
  16258. '{$interfaces corba}',
  16259. 'type',
  16260. ' IUnknown = interface',
  16261. ' procedure Walk(i: longint);',
  16262. ' end;',
  16263. ' IBird = interface(IUnknown)',
  16264. ' procedure Walk(b: boolean); overload;',
  16265. ' procedure Fly(s: string);',
  16266. ' end;',
  16267. ' TObject = class',
  16268. ' end;',
  16269. ' TBird = class(TObject,IBird)',
  16270. ' procedure IBird.Fly = Move;',
  16271. ' procedure IBird.Walk = Hop;',
  16272. ' procedure Hop(i: longint);',
  16273. ' procedure Move(s: string);',
  16274. ' procedure Hop(b: boolean);',
  16275. ' end;',
  16276. 'procedure TBird.Move(s: string); begin end;',
  16277. 'procedure TBird.Hop(i: longint); begin end;',
  16278. 'procedure TBird.Hop(b: boolean); begin end;',
  16279. 'var',
  16280. ' BirdIntf: IBird;',
  16281. 'begin',
  16282. ' BirdIntf.Walk(3);',
  16283. ' BirdIntf.Walk(true);',
  16284. ' BirdIntf.Fly(''abc'');',
  16285. '']);
  16286. ConvertProgram;
  16287. CheckSource('TestClassInterface_MethodResolution',
  16288. LinesToStr([ // statements
  16289. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDD7-23D600000000}", ["Walk"], null);',
  16290. 'rtl.createInterface($mod, "IBird", "{CF8A4986-80F6-396E-AE88-000B86AAE208}", ["Walk$1", "Fly"], $mod.IUnknown);',
  16291. 'rtl.createClass($mod, "TObject", null, function () {',
  16292. ' this.$init = function () {',
  16293. ' };',
  16294. ' this.$final = function () {',
  16295. ' };',
  16296. '});',
  16297. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16298. ' this.Hop = function (i) {',
  16299. ' };',
  16300. ' this.Move = function (s) {',
  16301. ' };',
  16302. ' this.Hop$1 = function (b) {',
  16303. ' };',
  16304. ' rtl.addIntf(this, $mod.IBird, {',
  16305. ' Walk$1: "Hop$1",',
  16306. ' Fly: "Move",',
  16307. ' Walk: "Hop"',
  16308. ' });',
  16309. '});',
  16310. 'this.BirdIntf = null;',
  16311. '']),
  16312. LinesToStr([ // $mod.$main
  16313. '$mod.BirdIntf.Walk(3);',
  16314. '$mod.BirdIntf.Walk$1(true);',
  16315. '$mod.BirdIntf.Fly("abc");',
  16316. '']));
  16317. end;
  16318. procedure TTestModule.TestClassInterface_AncestorMoreInterfaces;
  16319. begin
  16320. StartProgram(false);
  16321. Add([
  16322. '{$interfaces com}',
  16323. 'type',
  16324. ' IUnknown = interface',
  16325. ' function _AddRef: longint;',
  16326. ' procedure Walk;',
  16327. ' end;',
  16328. ' IBird = interface end;',
  16329. ' IDog = interface end;',
  16330. ' TObject = class(IBird,IDog)',
  16331. ' function _AddRef: longint; virtual; abstract;',
  16332. ' procedure Walk; virtual; abstract;',
  16333. ' end;',
  16334. ' TBird = class(IUnknown)',
  16335. ' end;',
  16336. 'begin',
  16337. '']);
  16338. ConvertProgram;
  16339. CheckSource('TestClassInterface_COM_AncestorLess',
  16340. LinesToStr([ // statements
  16341. 'rtl.createInterface($mod, "IUnknown", "{8F2D5841-758A-322B-BDDF-21CD521DD723}", ["_AddRef", "Walk"], null);',
  16342. 'rtl.createInterface($mod, "IBird", "{CCE11D4C-6504-3AEE-AE88-000B86AAE675}", [], $mod.IUnknown);',
  16343. 'rtl.createInterface($mod, "IDog", "{CCE11D4C-6504-3AEE-AE88-000B8E5FC675}", [], $mod.IUnknown);',
  16344. 'rtl.createClass($mod, "TObject", null, function () {',
  16345. ' this.$init = function () {',
  16346. ' };',
  16347. ' this.$final = function () {',
  16348. ' };',
  16349. ' rtl.addIntf(this, $mod.IBird);',
  16350. ' rtl.addIntf(this, $mod.IDog);',
  16351. '});',
  16352. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16353. ' rtl.addIntf(this, $mod.IUnknown);',
  16354. ' rtl.addIntf(this, $mod.IBird);',
  16355. ' rtl.addIntf(this, $mod.IDog);',
  16356. '});',
  16357. '']),
  16358. LinesToStr([ // $mod.$main
  16359. '']));
  16360. end;
  16361. procedure TTestModule.TestClassInterface_MethodOverride;
  16362. begin
  16363. StartProgram(false);
  16364. Add([
  16365. '{$interfaces corba}',
  16366. 'type',
  16367. ' IUnknown = interface',
  16368. ' [''{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}'']',
  16369. ' procedure Go;',
  16370. ' end;',
  16371. ' TObject = class(IUnknown)',
  16372. ' procedure Go; virtual; abstract;',
  16373. ' end;',
  16374. ' TBird = class',
  16375. ' procedure Go; override;',
  16376. ' end;',
  16377. ' TCat = class(TObject)',
  16378. ' procedure Go; override;',
  16379. ' end;',
  16380. ' TDog = class(TObject, IUnknown)',
  16381. ' procedure Go; override;',
  16382. ' end;',
  16383. 'procedure TBird.Go; begin end;',
  16384. 'procedure TCat.Go; begin end;',
  16385. 'procedure TDog.Go; begin end;',
  16386. 'begin',
  16387. '']);
  16388. ConvertProgram;
  16389. CheckSource('TestClassInterface_MethodOverride',
  16390. LinesToStr([ // statements
  16391. 'rtl.createInterface($mod, "IUnknown", "{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}", ["Go"], null);',
  16392. 'rtl.createClass($mod, "TObject", null, function () {',
  16393. ' this.$init = function () {',
  16394. ' };',
  16395. ' this.$final = function () {',
  16396. ' };',
  16397. ' rtl.addIntf(this, $mod.IUnknown);',
  16398. '});',
  16399. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16400. ' this.Go = function () {',
  16401. ' };',
  16402. ' rtl.addIntf(this, $mod.IUnknown);',
  16403. '});',
  16404. 'rtl.createClass($mod, "TCat", $mod.TObject, function () {',
  16405. ' this.Go = function () {',
  16406. ' };',
  16407. ' rtl.addIntf(this, $mod.IUnknown);',
  16408. '});',
  16409. 'rtl.createClass($mod, "TDog", $mod.TObject, function () {',
  16410. ' this.Go = function () {',
  16411. ' };',
  16412. ' rtl.addIntf(this, $mod.IUnknown);',
  16413. '});',
  16414. '']),
  16415. LinesToStr([ // $mod.$main
  16416. '']));
  16417. end;
  16418. procedure TTestModule.TestClassInterface_Corba_Delegation;
  16419. begin
  16420. StartProgram(false);
  16421. Add([
  16422. '{$interfaces corba}',
  16423. 'type',
  16424. ' IUnknown = interface',
  16425. ' end;',
  16426. ' IBird = interface(IUnknown)',
  16427. ' procedure Fly(s: string);',
  16428. ' end;',
  16429. ' IEagle = interface(IBird)',
  16430. ' end;',
  16431. ' IDove = interface(IBird)',
  16432. ' end;',
  16433. ' ISwallow = interface(IBird)',
  16434. ' end;',
  16435. ' TObject = class',
  16436. ' end;',
  16437. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  16438. ' procedure Fly(s: string); virtual; abstract;',
  16439. ' end;',
  16440. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  16441. ' FBirdIntf: IBird;',
  16442. ' property BirdIntf: IBird read FBirdIntf implements IBird;',
  16443. ' function GetEagleIntf: IEagle; virtual; abstract;',
  16444. ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  16445. ' FDoveObj: TBird;',
  16446. ' property DoveObj: TBird read FDoveObj implements IDove;',
  16447. ' function GetSwallowObj: TBird; virtual; abstract;',
  16448. ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  16449. ' end;',
  16450. 'begin',
  16451. '']);
  16452. ConvertProgram;
  16453. CheckSource('TestClassInterface_Delegation',
  16454. LinesToStr([ // statements
  16455. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16456. 'rtl.createInterface($mod, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], $mod.IUnknown);',
  16457. 'rtl.createInterface($mod, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], $mod.IBird);',
  16458. 'rtl.createInterface($mod, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], $mod.IBird);',
  16459. 'rtl.createInterface($mod, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], $mod.IBird);',
  16460. 'rtl.createClass($mod, "TObject", null, function () {',
  16461. ' this.$init = function () {',
  16462. ' };',
  16463. ' this.$final = function () {',
  16464. ' };',
  16465. '});',
  16466. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16467. ' rtl.addIntf(this, $mod.IBird);',
  16468. ' rtl.addIntf(this, $mod.IEagle);',
  16469. ' rtl.addIntf(this, $mod.IDove);',
  16470. ' rtl.addIntf(this, $mod.ISwallow);',
  16471. '});',
  16472. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  16473. ' this.$init = function () {',
  16474. ' $mod.TObject.$init.call(this);',
  16475. ' this.FBirdIntf = null;',
  16476. ' this.FDoveObj = null;',
  16477. ' };',
  16478. ' this.$final = function () {',
  16479. ' this.FBirdIntf = undefined;',
  16480. ' this.FDoveObj = undefined;',
  16481. ' $mod.TObject.$final.call(this);',
  16482. ' };',
  16483. ' this.$intfmaps = {',
  16484. ' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
  16485. ' return this.FBirdIntf;',
  16486. ' },',
  16487. ' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
  16488. ' return this.GetEagleIntf();',
  16489. ' },',
  16490. ' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
  16491. ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
  16492. ' },',
  16493. ' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
  16494. ' return rtl.getIntfT(this.GetSwallowObj(), $mod.ISwallow);',
  16495. ' }',
  16496. ' };',
  16497. '});',
  16498. '']),
  16499. LinesToStr([ // $mod.$main
  16500. '']));
  16501. end;
  16502. procedure TTestModule.TestClassInterface_Corba_DelegationStatic;
  16503. begin
  16504. StartProgram(false);
  16505. Add([
  16506. '{$interfaces corba}',
  16507. 'type',
  16508. ' IUnknown = interface',
  16509. ' end;',
  16510. ' IBird = interface(IUnknown)',
  16511. ' procedure Fly(s: string);',
  16512. ' end;',
  16513. ' IEagle = interface(IBird)',
  16514. ' end;',
  16515. ' IDove = interface(IBird)',
  16516. ' end;',
  16517. ' ISwallow = interface(IBird)',
  16518. ' end;',
  16519. ' TObject = class',
  16520. ' end;',
  16521. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  16522. ' procedure Fly(s: string); virtual; abstract;',
  16523. ' end;',
  16524. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  16525. ' private',
  16526. ' class var FBirdIntf: IBird;',
  16527. ' class var FDoveObj: TBird;',
  16528. ' class function GetEagleIntf: IEagle; virtual; abstract;',
  16529. ' class function GetSwallowObj: TBird; virtual; abstract;',
  16530. ' protected',
  16531. ' class property BirdIntf: IBird read FBirdIntf implements IBird;',
  16532. ' class property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  16533. ' class property DoveObj: TBird read FDoveObj implements IDove;',
  16534. ' class property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  16535. ' end;',
  16536. 'begin',
  16537. '']);
  16538. ConvertProgram;
  16539. CheckSource('TestClassInterface_DelegationStatic',
  16540. LinesToStr([ // statements
  16541. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16542. 'rtl.createInterface($mod, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], $mod.IUnknown);',
  16543. 'rtl.createInterface($mod, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], $mod.IBird);',
  16544. 'rtl.createInterface($mod, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], $mod.IBird);',
  16545. 'rtl.createInterface($mod, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], $mod.IBird);',
  16546. 'rtl.createClass($mod, "TObject", null, function () {',
  16547. ' this.$init = function () {',
  16548. ' };',
  16549. ' this.$final = function () {',
  16550. ' };',
  16551. '});',
  16552. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16553. ' rtl.addIntf(this, $mod.IBird);',
  16554. ' rtl.addIntf(this, $mod.IEagle);',
  16555. ' rtl.addIntf(this, $mod.IDove);',
  16556. ' rtl.addIntf(this, $mod.ISwallow);',
  16557. '});',
  16558. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  16559. ' this.FBirdIntf = null;',
  16560. ' this.FDoveObj = null;',
  16561. ' this.$intfmaps = {',
  16562. ' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
  16563. ' return this.FBirdIntf;',
  16564. ' },',
  16565. ' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
  16566. ' return this.$class.GetEagleIntf();',
  16567. ' },',
  16568. ' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
  16569. ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
  16570. ' },',
  16571. ' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
  16572. ' return rtl.getIntfT(this.$class.GetSwallowObj(), $mod.ISwallow);',
  16573. ' }',
  16574. ' };',
  16575. '});',
  16576. '']),
  16577. LinesToStr([ // $mod.$main
  16578. '']));
  16579. end;
  16580. procedure TTestModule.TestClassInterface_Corba_Operators;
  16581. begin
  16582. StartProgram(false);
  16583. Add([
  16584. '{$interfaces corba}',
  16585. 'type',
  16586. ' IUnknown = interface',
  16587. ' end;',
  16588. ' IBird = interface(IUnknown)',
  16589. ' function GetItems(Index: longint): longint;',
  16590. ' procedure SetItems(Index: longint; Value: longint);',
  16591. ' property Items[Index: longint]: longint read GetItems write SetItems; default;',
  16592. ' end;',
  16593. ' TObject = class',
  16594. ' end;',
  16595. ' TBird = class(TObject,IBird)',
  16596. ' function GetItems(Index: longint): longint; virtual; abstract;',
  16597. ' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
  16598. ' end;',
  16599. 'var',
  16600. ' IntfVar: IBird = nil;',
  16601. ' IntfVar2: IBird;',
  16602. ' ObjVar: TBird;',
  16603. ' v: JSValue;',
  16604. 'begin',
  16605. ' IntfVar:=nil;',
  16606. ' IntfVar[3]:=IntfVar[4];',
  16607. ' if Assigned(IntfVar) then ;',
  16608. ' IntfVar:=IntfVar2;',
  16609. ' IntfVar:=ObjVar;',
  16610. ' if IntfVar=IntfVar2 then ;',
  16611. ' if IntfVar<>IntfVar2 then ;',
  16612. ' if IntfVar is IBird then ;',
  16613. ' if IntfVar is TBird then ;',
  16614. ' if ObjVar is IBird then ;',
  16615. ' IntfVar:=IntfVar2 as IBird;',
  16616. ' ObjVar:=IntfVar2 as TBird;',
  16617. ' IntfVar:=ObjVar as IBird;',
  16618. ' IntfVar:=IBird(IntfVar2);',
  16619. ' ObjVar:=TBird(IntfVar);',
  16620. ' IntfVar:=IBird(ObjVar);',
  16621. ' v:=IntfVar;',
  16622. ' IntfVar:=IBird(v);',
  16623. ' if v is IBird then ;',
  16624. ' v:=JSValue(IntfVar);',
  16625. ' v:=IBird;',
  16626. '']);
  16627. ConvertProgram;
  16628. CheckSource('TestClassInterface_Corba_Operators',
  16629. LinesToStr([ // statements
  16630. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16631. 'rtl.createInterface($mod, "IBird", "{D53FED90-DE59-3202-B1AE-000B87785B08}", ["GetItems", "SetItems"], $mod.IUnknown);',
  16632. 'rtl.createClass($mod, "TObject", null, function () {',
  16633. ' this.$init = function () {',
  16634. ' };',
  16635. ' this.$final = function () {',
  16636. ' };',
  16637. '});',
  16638. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16639. ' rtl.addIntf(this, $mod.IBird);',
  16640. '});',
  16641. 'this.IntfVar = null;',
  16642. 'this.IntfVar2 = null;',
  16643. 'this.ObjVar = null;',
  16644. 'this.v = undefined;',
  16645. '']),
  16646. LinesToStr([ // $mod.$main
  16647. '$mod.IntfVar = null;',
  16648. '$mod.IntfVar.SetItems(3, $mod.IntfVar.GetItems(4));',
  16649. 'if ($mod.IntfVar != null) ;',
  16650. '$mod.IntfVar = $mod.IntfVar2;',
  16651. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar,$mod.IBird);',
  16652. 'if ($mod.IntfVar === $mod.IntfVar2) ;',
  16653. 'if ($mod.IntfVar !== $mod.IntfVar2) ;',
  16654. 'if ($mod.IBird.isPrototypeOf($mod.IntfVar)) ;',
  16655. 'if (rtl.intfIsClass($mod.IntfVar, $mod.TBird)) ;',
  16656. 'if (rtl.getIntfT($mod.ObjVar, $mod.IBird) !== null) ;',
  16657. '$mod.IntfVar = rtl.as($mod.IntfVar2, $mod.IBird);',
  16658. '$mod.ObjVar = rtl.intfAsClass($mod.IntfVar2, $mod.TBird);',
  16659. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
  16660. '$mod.IntfVar = $mod.IntfVar2;',
  16661. '$mod.ObjVar = rtl.intfToClass($mod.IntfVar, $mod.TBird);',
  16662. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
  16663. '$mod.v = $mod.IntfVar;',
  16664. '$mod.IntfVar = rtl.getObject($mod.v);',
  16665. 'if (rtl.isExt($mod.v, $mod.IBird, 1)) ;',
  16666. '$mod.v = rtl.getObject($mod.IntfVar);',
  16667. '$mod.v = $mod.IBird;',
  16668. '']));
  16669. end;
  16670. procedure TTestModule.TestClassInterface_Corba_Args;
  16671. begin
  16672. StartProgram(false);
  16673. Add([
  16674. '{$interfaces corba}',
  16675. 'type',
  16676. ' IUnknown = interface',
  16677. ' end;',
  16678. ' IBird = interface(IUnknown)',
  16679. ' end;',
  16680. ' TObject = class',
  16681. ' end;',
  16682. ' TBird = class(TObject,IBird)',
  16683. ' end;',
  16684. 'procedure DoIt(var u; i: IBird; const j: IBird);',
  16685. 'begin',
  16686. ' DoIt(i,i,i);',
  16687. 'end;',
  16688. 'procedure Change(var i: IBird; out j: IBird);',
  16689. 'begin',
  16690. ' DoIt(i,i,i);',
  16691. ' Change(i,i);',
  16692. 'end;',
  16693. 'var',
  16694. ' i: IBird;',
  16695. ' o: TBird;',
  16696. 'begin',
  16697. ' DoIt(i,i,i);',
  16698. ' Change(i,i);',
  16699. ' DoIt(o,o,o);',
  16700. '']);
  16701. ConvertProgram;
  16702. CheckSource('TestClassInterface_Corba_Args',
  16703. LinesToStr([ // statements
  16704. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16705. 'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], $mod.IUnknown);',
  16706. 'rtl.createClass($mod, "TObject", null, function () {',
  16707. ' this.$init = function () {',
  16708. ' };',
  16709. ' this.$final = function () {',
  16710. ' };',
  16711. '});',
  16712. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16713. ' rtl.addIntf(this, $mod.IBird);',
  16714. '});',
  16715. 'this.DoIt = function (u, i, j) {',
  16716. ' $mod.DoIt({',
  16717. ' get: function () {',
  16718. ' return i;',
  16719. ' },',
  16720. ' set: function (v) {',
  16721. ' i = v;',
  16722. ' }',
  16723. ' }, i, i);',
  16724. '};',
  16725. 'this.Change = function (i, j) {',
  16726. ' $mod.DoIt(i, i.get(), i.get());',
  16727. ' $mod.Change(i, i);',
  16728. '};',
  16729. 'this.i = null;',
  16730. 'this.o = null;',
  16731. '']),
  16732. LinesToStr([ // $mod.$main
  16733. '$mod.DoIt({',
  16734. ' p: $mod,',
  16735. ' get: function () {',
  16736. ' return this.p.i;',
  16737. ' },',
  16738. ' set: function (v) {',
  16739. ' this.p.i = v;',
  16740. ' }',
  16741. '}, $mod.i, $mod.i);',
  16742. '$mod.Change({',
  16743. ' p: $mod,',
  16744. ' get: function () {',
  16745. ' return this.p.i;',
  16746. ' },',
  16747. ' set: function (v) {',
  16748. ' this.p.i = v;',
  16749. ' }',
  16750. '}, {',
  16751. ' p: $mod,',
  16752. ' get: function () {',
  16753. ' return this.p.i;',
  16754. ' },',
  16755. ' set: function (v) {',
  16756. ' this.p.i = v;',
  16757. ' }',
  16758. '});',
  16759. '$mod.DoIt({',
  16760. ' p: $mod,',
  16761. ' get: function () {',
  16762. ' return this.p.o;',
  16763. ' },',
  16764. ' set: function (v) {',
  16765. ' this.p.o = v;',
  16766. ' }',
  16767. '}, rtl.getIntfT($mod.o, $mod.IBird), rtl.getIntfT($mod.o, $mod.IBird));',
  16768. '']));
  16769. end;
  16770. procedure TTestModule.TestClassInterface_Corba_ForIn;
  16771. begin
  16772. StartProgram(false);
  16773. Add([
  16774. '{$interfaces corba}',
  16775. 'type',
  16776. ' IUnknown = interface end;',
  16777. ' TObject = class',
  16778. ' Id: longint;',
  16779. ' end;',
  16780. ' IEnumerator = interface(IUnknown)',
  16781. ' function GetCurrent: TObject;',
  16782. ' function MoveNext: Boolean;',
  16783. ' property Current: TObject read GetCurrent;',
  16784. ' end;',
  16785. ' IEnumerable = interface(IUnknown)',
  16786. ' function GetEnumerator: IEnumerator;',
  16787. ' end;',
  16788. 'var',
  16789. ' o: TObject;',
  16790. ' i: IEnumerable;',
  16791. 'begin',
  16792. ' for o in i do o.Id:=3;',
  16793. '']);
  16794. ConvertProgram;
  16795. CheckSource('TestClassInterface_Corba_ForIn',
  16796. LinesToStr([ // statements
  16797. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16798. 'rtl.createClass($mod, "TObject", null, function () {',
  16799. ' this.$init = function () {',
  16800. ' this.Id = 0;',
  16801. ' };',
  16802. ' this.$final = function () {',
  16803. ' };',
  16804. '});',
  16805. 'rtl.createInterface($mod, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
  16806. 'rtl.createInterface($mod, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], $mod.IUnknown);',
  16807. 'this.o = null;',
  16808. 'this.i = null;',
  16809. '']),
  16810. LinesToStr([ // $mod.$main
  16811. 'var $in1 = $mod.i.GetEnumerator();',
  16812. 'while ($in1.MoveNext()) {',
  16813. ' $mod.o = $in1.GetCurrent();',
  16814. ' $mod.o.Id = 3;',
  16815. '};',
  16816. '']));
  16817. end;
  16818. procedure TTestModule.TestClassInterface_COM_AssignVar;
  16819. begin
  16820. StartProgram(false);
  16821. Add([
  16822. '{$interfaces com}',
  16823. 'type',
  16824. ' IUnknown = interface',
  16825. ' function _AddRef: longint;',
  16826. ' function _Release: longint;',
  16827. ' end;',
  16828. ' TObject = class(IUnknown)',
  16829. ' function _AddRef: longint; virtual; abstract;',
  16830. ' function _Release: longint; virtual; abstract;',
  16831. ' end;',
  16832. 'var',
  16833. ' i: IUnknown;',
  16834. 'procedure DoGlobal(o: TObject);',
  16835. 'begin',
  16836. ' i:=nil;',
  16837. ' i:=o;',
  16838. ' i:=i;',
  16839. 'end;',
  16840. 'procedure DoLocal(o: TObject);',
  16841. 'const k: IUnknown = nil;',
  16842. 'var j: IUnknown;',
  16843. 'begin',
  16844. ' k:=o;',
  16845. ' k:=i;',
  16846. ' j:=o;',
  16847. ' j:=i;',
  16848. 'end;',
  16849. 'var o: TObject;',
  16850. 'begin',
  16851. ' i:=nil;',
  16852. ' i:=o;',
  16853. '']);
  16854. ConvertProgram;
  16855. CheckSource('TestClassInterface_COM_AssignVar',
  16856. LinesToStr([ // statements
  16857. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  16858. 'rtl.createClass($mod, "TObject", null, function () {',
  16859. ' this.$init = function () {',
  16860. ' };',
  16861. ' this.$final = function () {',
  16862. ' };',
  16863. ' rtl.addIntf(this, $mod.IUnknown);',
  16864. '});',
  16865. 'this.i = null;',
  16866. 'this.DoGlobal = function (o) {',
  16867. ' rtl.setIntfP($mod, "i", null);',
  16868. ' rtl.setIntfP($mod, "i", rtl.queryIntfT(o, $mod.IUnknown), true);',
  16869. ' rtl.setIntfP($mod, "i", $mod.i);',
  16870. '};',
  16871. 'var k = null;',
  16872. 'this.DoLocal = function (o) {',
  16873. ' var j = null;',
  16874. ' try{',
  16875. ' k = rtl.setIntfL(k, rtl.queryIntfT(o, $mod.IUnknown), true);',
  16876. ' k = rtl.setIntfL(k, $mod.i);',
  16877. ' j = rtl.setIntfL(j, rtl.queryIntfT(o, $mod.IUnknown), true);',
  16878. ' j = rtl.setIntfL(j, $mod.i);',
  16879. ' }finally{',
  16880. ' rtl._Release(j);',
  16881. ' };',
  16882. '};',
  16883. 'this.o = null;',
  16884. '']),
  16885. LinesToStr([ // $mod.$main
  16886. 'rtl.setIntfP($mod, "i", null);',
  16887. 'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.o, $mod.IUnknown), true);',
  16888. '']));
  16889. end;
  16890. procedure TTestModule.TestClassInterface_COM_AssignArg;
  16891. begin
  16892. StartProgram(false);
  16893. Add([
  16894. '{$interfaces com}',
  16895. 'type',
  16896. ' IUnknown = interface',
  16897. ' function _AddRef: longint;',
  16898. ' function _Release: longint;',
  16899. ' end;',
  16900. ' TObject = class(IUnknown)',
  16901. ' function _AddRef: longint; virtual; abstract;',
  16902. ' function _Release: longint; virtual; abstract;',
  16903. ' end;',
  16904. 'procedure DoDefault(i, j: IUnknown);',
  16905. 'begin',
  16906. ' i:=nil;',
  16907. ' i:=j;',
  16908. 'end;',
  16909. 'begin',
  16910. '']);
  16911. ConvertProgram;
  16912. CheckSource('TestClassInterface_COM_AssignArg',
  16913. LinesToStr([ // statements
  16914. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  16915. 'rtl.createClass($mod, "TObject", null, function () {',
  16916. ' this.$init = function () {',
  16917. ' };',
  16918. ' this.$final = function () {',
  16919. ' };',
  16920. ' rtl.addIntf(this, $mod.IUnknown);',
  16921. '});',
  16922. 'this.DoDefault = function (i, j) {',
  16923. ' rtl._AddRef(i);',
  16924. ' try {',
  16925. ' i = rtl.setIntfL(i, null);',
  16926. ' i = rtl.setIntfL(i, j);',
  16927. ' } finally {',
  16928. ' rtl._Release(i);',
  16929. ' };',
  16930. '};',
  16931. '']),
  16932. LinesToStr([ // $mod.$main
  16933. '']));
  16934. end;
  16935. procedure TTestModule.TestClassInterface_COM_FunctionResult;
  16936. begin
  16937. StartProgram(false);
  16938. Add([
  16939. '{$interfaces com}',
  16940. 'type',
  16941. ' IUnknown = interface',
  16942. ' function _AddRef: longint;',
  16943. ' function _Release: longint;',
  16944. ' end;',
  16945. ' TObject = class(IUnknown)',
  16946. ' function _AddRef: longint; virtual; abstract;',
  16947. ' function _Release: longint; virtual; abstract;',
  16948. ' end;',
  16949. 'function DoDefault(i: IUnknown): IUnknown;',
  16950. 'begin',
  16951. ' Result:=i;',
  16952. ' if Result<>nil then exit;',
  16953. 'end;',
  16954. 'begin',
  16955. '']);
  16956. ConvertProgram;
  16957. CheckSource('TestClassInterface_COM_FunctionResult',
  16958. LinesToStr([ // statements
  16959. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  16960. 'rtl.createClass($mod, "TObject", null, function () {',
  16961. ' this.$init = function () {',
  16962. ' };',
  16963. ' this.$final = function () {',
  16964. ' };',
  16965. ' rtl.addIntf(this, $mod.IUnknown);',
  16966. '});',
  16967. 'this.DoDefault = function (i) {',
  16968. ' var Result = null;',
  16969. ' var $ok = false;',
  16970. ' try {',
  16971. ' Result = rtl.setIntfL(Result, i);',
  16972. ' if(Result !== null){',
  16973. ' $ok = true;',
  16974. ' return Result;',
  16975. ' };',
  16976. ' $ok = true;',
  16977. ' } finally {',
  16978. ' if(!$ok) rtl._Release(Result);',
  16979. ' };',
  16980. ' return Result;',
  16981. '};',
  16982. '']),
  16983. LinesToStr([ // $mod.$main
  16984. '']));
  16985. end;
  16986. procedure TTestModule.TestClassInterface_COM_InheritedFuncResult;
  16987. begin
  16988. StartProgram(false);
  16989. Add([
  16990. '{$interfaces com}',
  16991. 'type',
  16992. ' IUnknown = interface',
  16993. ' function _AddRef: longint;',
  16994. ' function _Release: longint;',
  16995. ' end;',
  16996. ' TObject = class(IUnknown)',
  16997. ' function _AddRef: longint; virtual; abstract;',
  16998. ' function _Release: longint; virtual; abstract;',
  16999. ' function GetIntf: IUnknown; virtual;',
  17000. ' end;',
  17001. ' TMouse = class',
  17002. ' function GetIntf: IUnknown; override;',
  17003. ' end;',
  17004. 'function TObject.GetIntf: IUnknown; begin end;',
  17005. 'function TMouse.GetIntf: IUnknown;',
  17006. 'var i: IUnknown;',
  17007. 'begin',
  17008. ' inherited;',
  17009. ' inherited GetIntf;',
  17010. ' inherited GetIntf();',
  17011. ' Result:=inherited GetIntf;',
  17012. ' Result:=inherited GetIntf();',
  17013. ' i:=inherited GetIntf;',
  17014. ' i:=inherited GetIntf();',
  17015. 'end;',
  17016. 'begin',
  17017. '']);
  17018. ConvertProgram;
  17019. CheckSource('TestClassInterface_COM_InheritedFuncResult',
  17020. LinesToStr([ // statements
  17021. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17022. 'rtl.createClass($mod, "TObject", null, function () {',
  17023. ' this.$init = function () {',
  17024. ' };',
  17025. ' this.$final = function () {',
  17026. ' };',
  17027. ' this.GetIntf = function () {',
  17028. ' var Result = null;',
  17029. ' return Result;',
  17030. ' };',
  17031. ' rtl.addIntf(this, $mod.IUnknown);',
  17032. '});',
  17033. 'rtl.createClass($mod, "TMouse", $mod.TObject, function () {',
  17034. ' this.GetIntf = function () {',
  17035. ' var Result = null;',
  17036. ' var i = null;',
  17037. ' var $ir = rtl.createIntfRefs();',
  17038. ' var $ok = false;',
  17039. ' try {',
  17040. ' $ir.ref(1, $mod.TObject.GetIntf.apply(this, arguments));',
  17041. ' $ir.ref(2, $mod.TObject.GetIntf.call(this));',
  17042. ' $ir.ref(3, $mod.TObject.GetIntf.call(this));',
  17043. ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
  17044. ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
  17045. ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
  17046. ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
  17047. ' $ok = true;',
  17048. ' } finally {',
  17049. ' $ir.free();',
  17050. ' rtl._Release(i);',
  17051. ' if (!$ok) rtl._Release(Result);',
  17052. ' };',
  17053. ' return Result;',
  17054. ' };',
  17055. ' rtl.addIntf(this, $mod.IUnknown);',
  17056. '});',
  17057. '']),
  17058. LinesToStr([ // $mod.$main
  17059. '']));
  17060. end;
  17061. procedure TTestModule.TestClassInterface_COM_IsAsTypeCasts;
  17062. begin
  17063. StartProgram(false);
  17064. Add([
  17065. '{$interfaces com}',
  17066. 'type',
  17067. ' IUnknown = interface',
  17068. ' function _AddRef: longint;',
  17069. ' function _Release: longint;',
  17070. ' end;',
  17071. ' TObject = class(IUnknown)',
  17072. ' function _AddRef: longint; virtual; abstract;',
  17073. ' function _Release: longint; virtual; abstract;',
  17074. ' end;',
  17075. 'procedure DoDefault(i, j: IUnknown; o: TObject);',
  17076. 'begin',
  17077. ' if i is IUnknown then ;',
  17078. ' if o is IUnknown then ;',
  17079. ' if i is TObject then ;',
  17080. ' i:=j as IUnknown;',
  17081. ' i:=o as IUnknown;',
  17082. ' o:=j as TObject;',
  17083. ' i:=IUnknown(j);',
  17084. ' i:=IUnknown(o);',
  17085. ' o:=TObject(i);',
  17086. 'end;',
  17087. 'begin',
  17088. '']);
  17089. ConvertProgram;
  17090. CheckSource('TestClassInterface_COM_IsAsTypeCasts',
  17091. LinesToStr([ // statements
  17092. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17093. 'rtl.createClass($mod, "TObject", null, function () {',
  17094. ' this.$init = function () {',
  17095. ' };',
  17096. ' this.$final = function () {',
  17097. ' };',
  17098. ' rtl.addIntf(this, $mod.IUnknown);',
  17099. '});',
  17100. 'this.DoDefault = function (i, j, o) {',
  17101. ' rtl._AddRef(i);',
  17102. ' try {',
  17103. ' if ($mod.IUnknown.isPrototypeOf(i)) ;',
  17104. ' if (rtl.queryIntfIsT(o, $mod.IUnknown)) ;',
  17105. ' if (rtl.intfIsClass(i, $mod.TObject)) ;',
  17106. ' i = rtl.setIntfL(i, rtl.as(j, $mod.IUnknown));',
  17107. ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
  17108. ' o = rtl.intfAsClass(j, $mod.TObject);',
  17109. ' i = rtl.setIntfL(i, j);',
  17110. ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
  17111. ' o = rtl.intfToClass(i, $mod.TObject);',
  17112. ' } finally {',
  17113. ' rtl._Release(i);',
  17114. ' };',
  17115. '};',
  17116. '']),
  17117. LinesToStr([ // $mod.$main
  17118. '']));
  17119. end;
  17120. procedure TTestModule.TestClassInterface_COM_PassAsArg;
  17121. begin
  17122. StartProgram(false);
  17123. Add([
  17124. '{$interfaces com}',
  17125. 'type',
  17126. ' IUnknown = interface',
  17127. ' function _AddRef: longint;',
  17128. ' function _Release: longint;',
  17129. ' end;',
  17130. ' TObject = class(IUnknown)',
  17131. ' function _AddRef: longint; virtual; abstract;',
  17132. ' function _Release: longint; virtual; abstract;',
  17133. ' end;',
  17134. 'procedure DoIt(v: IUnknown; const j: IUnknown; var k: IUnknown; out l: IUnknown);',
  17135. 'var o: TObject;',
  17136. 'begin',
  17137. ' DoIt(v,v,v,v);',
  17138. ' DoIt(o,o,k,k);',
  17139. 'end;',
  17140. 'procedure DoSome;',
  17141. 'var v: IUnknown;',
  17142. 'begin',
  17143. ' DoIt(v,v,v,v);',
  17144. 'end;',
  17145. 'var i: IUnknown;',
  17146. 'begin',
  17147. ' DoIt(i,i,i,i);',
  17148. '']);
  17149. ConvertProgram;
  17150. CheckSource('TestClassInterface_COM_PassAsArg',
  17151. LinesToStr([ // statements
  17152. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17153. 'rtl.createClass($mod, "TObject", null, function () {',
  17154. ' this.$init = function () {',
  17155. ' };',
  17156. ' this.$final = function () {',
  17157. ' };',
  17158. ' rtl.addIntf(this, $mod.IUnknown);',
  17159. '});',
  17160. 'this.DoIt = function (v, j, k, l) {',
  17161. ' var o = null;',
  17162. ' var $ir = rtl.createIntfRefs();',
  17163. ' rtl._AddRef(v);',
  17164. ' try {',
  17165. ' $mod.DoIt(v, v, {',
  17166. ' get: function () {',
  17167. ' return v;',
  17168. ' },',
  17169. ' set: function (w) {',
  17170. ' v = rtl.setIntfL(v, w);',
  17171. ' }',
  17172. ' }, {',
  17173. ' get: function () {',
  17174. ' return v;',
  17175. ' },',
  17176. ' set: function (w) {',
  17177. ' v = rtl.setIntfL(v, w);',
  17178. ' }',
  17179. ' });',
  17180. ' $mod.DoIt($ir.ref(1, rtl.queryIntfT(o, $mod.IUnknown)), $ir.ref(2, rtl.queryIntfT(o, $mod.IUnknown)), k, k);',
  17181. ' } finally {',
  17182. ' $ir.free();',
  17183. ' rtl._Release(v);',
  17184. ' };',
  17185. '};',
  17186. 'this.DoSome = function () {',
  17187. ' var v = null;',
  17188. ' try {',
  17189. ' $mod.DoIt(v, v, {',
  17190. ' get: function () {',
  17191. ' return v;',
  17192. ' },',
  17193. ' set: function (w) {',
  17194. ' v = rtl.setIntfL(v, w);',
  17195. ' }',
  17196. ' }, {',
  17197. ' get: function () {',
  17198. ' return v;',
  17199. ' },',
  17200. ' set: function (w) {',
  17201. ' v = rtl.setIntfL(v, w);',
  17202. ' }',
  17203. ' });',
  17204. ' } finally {',
  17205. ' rtl._Release(v);',
  17206. ' };',
  17207. '};',
  17208. 'this.i = null;',
  17209. '']),
  17210. LinesToStr([ // $mod.$main
  17211. '$mod.DoIt($mod.i, $mod.i, {',
  17212. ' p: $mod,',
  17213. ' get: function () {',
  17214. ' return this.p.i;',
  17215. ' },',
  17216. ' set: function (v) {',
  17217. ' rtl.setIntfP(this.p, "i", v);',
  17218. ' }',
  17219. '}, {',
  17220. ' p: $mod,',
  17221. ' get: function () {',
  17222. ' return this.p.i;',
  17223. ' },',
  17224. ' set: function (v) {',
  17225. ' rtl.setIntfP(this.p, "i", v);',
  17226. ' }',
  17227. '});',
  17228. '']));
  17229. end;
  17230. procedure TTestModule.TestClassInterface_COM_PassToUntypedParam;
  17231. begin
  17232. StartProgram(false);
  17233. Add([
  17234. '{$interfaces com}',
  17235. 'type',
  17236. ' IUnknown = interface',
  17237. ' function _AddRef: longint;',
  17238. ' function _Release: longint;',
  17239. ' end;',
  17240. ' TObject = class(IUnknown)',
  17241. ' function _AddRef: longint; virtual; abstract;',
  17242. ' function _Release: longint; virtual; abstract;',
  17243. ' end;',
  17244. 'procedure DoIt(out i);',
  17245. 'begin end;',
  17246. 'procedure DoSome;',
  17247. 'var v: IUnknown;',
  17248. 'begin',
  17249. ' DoIt(v);',
  17250. 'end;',
  17251. 'function GetIt: IUnknown;',
  17252. 'begin',
  17253. ' DoIt(Result);',
  17254. 'end;',
  17255. 'var i: IUnknown;',
  17256. 'begin',
  17257. ' DoIt(i);',
  17258. '']);
  17259. ConvertProgram;
  17260. CheckSource('TestClassInterface_COM_PassToUntypedParam',
  17261. LinesToStr([ // statements
  17262. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17263. 'rtl.createClass($mod, "TObject", null, function () {',
  17264. ' this.$init = function () {',
  17265. ' };',
  17266. ' this.$final = function () {',
  17267. ' };',
  17268. ' rtl.addIntf(this, $mod.IUnknown);',
  17269. '});',
  17270. 'this.DoIt = function (i) {',
  17271. '};',
  17272. 'this.DoSome = function () {',
  17273. ' var v = null;',
  17274. ' try {',
  17275. ' $mod.DoIt({',
  17276. ' get: function () {',
  17277. ' return v;',
  17278. ' },',
  17279. ' set: function (w) {',
  17280. ' v = w;',
  17281. ' }',
  17282. ' });',
  17283. ' } finally {',
  17284. ' rtl._Release(v);',
  17285. ' };',
  17286. '};',
  17287. 'this.GetIt = function () {',
  17288. ' var Result = null;',
  17289. ' var $ok = false;',
  17290. ' try {',
  17291. ' $mod.DoIt({',
  17292. ' get: function () {',
  17293. ' return Result;',
  17294. ' },',
  17295. ' set: function (v) {',
  17296. ' Result = v;',
  17297. ' }',
  17298. ' });',
  17299. ' $ok = true;',
  17300. ' } finally {',
  17301. ' if (!$ok) rtl._Release(Result);',
  17302. ' };',
  17303. ' return Result;',
  17304. '};',
  17305. 'this.i = null;',
  17306. '']),
  17307. LinesToStr([ // $mod.$main
  17308. 'try {',
  17309. ' $mod.DoIt({',
  17310. ' p: $mod,',
  17311. ' get: function () {',
  17312. ' return this.p.i;',
  17313. ' },',
  17314. ' set: function (v) {',
  17315. ' this.p.i = v;',
  17316. ' }',
  17317. ' });',
  17318. '} finally {',
  17319. ' rtl._Release($mod.i);',
  17320. '};',
  17321. '']));
  17322. end;
  17323. procedure TTestModule.TestClassInterface_COM_FunctionInExpr;
  17324. begin
  17325. StartProgram(false);
  17326. Add([
  17327. '{$interfaces com}',
  17328. 'type',
  17329. ' IUnknown = interface',
  17330. ' function _AddRef: longint;',
  17331. ' function _Release: longint;',
  17332. ' end;',
  17333. ' TObject = class(IUnknown)',
  17334. ' function _AddRef: longint; virtual; abstract;',
  17335. ' function _Release: longint; virtual; abstract;',
  17336. ' end;',
  17337. 'function GetIt: IUnknown;',
  17338. 'begin',
  17339. 'end;',
  17340. 'procedure DoSome;',
  17341. 'var v: IUnknown;',
  17342. ' i: longint;',
  17343. 'begin',
  17344. ' v:=GetIt;',
  17345. ' v:=GetIt();',
  17346. ' GetIt()._AddRef;',
  17347. ' i:=GetIt()._AddRef;',
  17348. 'end;',
  17349. 'var v: IUnknown;',
  17350. ' i: longint;',
  17351. 'begin',
  17352. ' v:=GetIt;',
  17353. ' v:=GetIt();',
  17354. ' GetIt()._AddRef;',
  17355. ' i:=GetIt()._AddRef;',
  17356. '']);
  17357. ConvertProgram;
  17358. CheckSource('TestClassInterface_COM_FunctionInExpr',
  17359. LinesToStr([ // statements
  17360. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17361. 'rtl.createClass($mod, "TObject", null, function () {',
  17362. ' this.$init = function () {',
  17363. ' };',
  17364. ' this.$final = function () {',
  17365. ' };',
  17366. ' rtl.addIntf(this, $mod.IUnknown);',
  17367. '});',
  17368. 'this.GetIt = function () {',
  17369. ' var Result = null;',
  17370. ' return Result;',
  17371. '};',
  17372. 'this.DoSome = function () {',
  17373. ' var v = null;',
  17374. ' var i = 0;',
  17375. ' var $ir = rtl.createIntfRefs();',
  17376. ' try {',
  17377. ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
  17378. ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
  17379. ' $ir.ref(1, $mod.GetIt())._AddRef();',
  17380. ' i = $ir.ref(2, $mod.GetIt())._AddRef();',
  17381. ' } finally {',
  17382. ' $ir.free();',
  17383. ' rtl._Release(v);',
  17384. ' };',
  17385. '};',
  17386. 'this.v = null;',
  17387. 'this.i = 0;',
  17388. '']),
  17389. LinesToStr([ // $mod.$main
  17390. 'var $ir = rtl.createIntfRefs();',
  17391. 'try {',
  17392. ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
  17393. ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
  17394. ' $ir.ref(1, $mod.GetIt())._AddRef();',
  17395. ' $mod.i = $ir.ref(2, $mod.GetIt())._AddRef();',
  17396. '} finally {',
  17397. ' $ir.free();',
  17398. '};',
  17399. '']));
  17400. end;
  17401. procedure TTestModule.TestClassInterface_COM_Property;
  17402. begin
  17403. StartProgram(false);
  17404. Add([
  17405. '{$interfaces com}',
  17406. 'type',
  17407. ' IUnknown = interface',
  17408. ' function _AddRef: longint;',
  17409. ' function _Release: longint;',
  17410. ' end;',
  17411. ' TObject = class(IUnknown)',
  17412. ' FAnt: IUnknown;',
  17413. ' function _AddRef: longint; virtual; abstract;',
  17414. ' function _Release: longint; virtual; abstract;',
  17415. ' function GetBird: IUnknown; virtual; abstract;',
  17416. ' procedure SetBird(Value: IUnknown); virtual; abstract;',
  17417. ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
  17418. ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
  17419. ' property Ant: IUnknown read FAnt write FAnt;',
  17420. ' property Bird: IUnknown read GetBird write SetBird;',
  17421. ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
  17422. ' end;',
  17423. 'procedure DoIt;',
  17424. 'var',
  17425. ' o: TObject;',
  17426. ' v: IUnknown;',
  17427. 'begin',
  17428. ' v:=o.Ant;',
  17429. ' o.Ant:=v;',
  17430. ' o.Ant:=o.Ant;',
  17431. ' v:=o.Bird;',
  17432. ' o.Bird:=v;',
  17433. ' o.Bird:=o.Bird;',
  17434. ' v:=o.Items[1];',
  17435. ' o.Items[2]:=v;',
  17436. ' o.Items[3]:=o.Items[4];',
  17437. ' v:=o[5];',
  17438. ' o[6]:=v;',
  17439. ' o[7]:=o[8];',
  17440. 'end;',
  17441. 'begin',
  17442. '']);
  17443. ConvertProgram;
  17444. CheckSource('TestClassInterface_COM_Property',
  17445. LinesToStr([ // statements
  17446. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17447. 'rtl.createClass($mod, "TObject", null, function () {',
  17448. ' this.$init = function () {',
  17449. ' this.FAnt = null;',
  17450. ' };',
  17451. ' this.$final = function () {',
  17452. ' this.FAnt = undefined;',
  17453. ' };',
  17454. ' rtl.addIntf(this, $mod.IUnknown);',
  17455. '});',
  17456. 'this.DoIt = function () {',
  17457. ' var o = null;',
  17458. ' var v = null;',
  17459. ' var $ir = rtl.createIntfRefs();',
  17460. ' try {',
  17461. ' v = rtl.setIntfL(v, o.FAnt);',
  17462. ' rtl.setIntfP(o, "FAnt", v);',
  17463. ' rtl.setIntfP(o, "FAnt", o.FAnt);',
  17464. ' v = rtl.setIntfL(v, o.GetBird(), true);',
  17465. ' o.SetBird(v);',
  17466. ' o.SetBird($ir.ref(1, o.GetBird()));',
  17467. ' v = rtl.setIntfL(v, o.GetItems(1), true);',
  17468. ' o.SetItems(2, v);',
  17469. ' o.SetItems(3, $ir.ref(2, o.GetItems(4)));',
  17470. ' v = rtl.setIntfL(v, o.GetItems(5), true);',
  17471. ' o.SetItems(6, v);',
  17472. ' o.SetItems(7, $ir.ref(3, o.GetItems(8)));',
  17473. ' } finally {',
  17474. ' $ir.free();',
  17475. ' rtl._Release(v);',
  17476. ' };',
  17477. '};',
  17478. '']),
  17479. LinesToStr([ // $mod.$main
  17480. '']));
  17481. end;
  17482. procedure TTestModule.TestClassInterface_COM_IntfProperty;
  17483. begin
  17484. StartProgram(false);
  17485. Add([
  17486. '{$interfaces com}',
  17487. 'type',
  17488. ' IUnknown = interface',
  17489. ' function _AddRef: longint;',
  17490. ' function _Release: longint;',
  17491. ' function GetBird: IUnknown;',
  17492. ' procedure SetBird(Value: IUnknown);',
  17493. ' function GetItems(Index: longint): IUnknown;',
  17494. ' procedure SetItems(Index: longint; Value: IUnknown);',
  17495. ' property Bird: IUnknown read GetBird write SetBird;',
  17496. ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
  17497. ' end;',
  17498. ' TObject = class(IUnknown)',
  17499. ' function _AddRef: longint; virtual; abstract;',
  17500. ' function _Release: longint; virtual; abstract;',
  17501. ' function GetBird: IUnknown; virtual; abstract;',
  17502. ' procedure SetBird(Value: IUnknown); virtual; abstract;',
  17503. ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
  17504. ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
  17505. ' end;',
  17506. 'procedure DoIt;',
  17507. 'var',
  17508. ' o: TObject;',
  17509. ' v: IUnknown;',
  17510. 'begin',
  17511. ' v:=v.Items[1];',
  17512. ' v.Items[2]:=v;',
  17513. ' v.Items[3]:=v.Items[4];',
  17514. ' v:=v[5];',
  17515. ' v[6]:=v;',
  17516. ' v[7]:=v[8];',
  17517. ' v[9].Bird.Bird:=v;',
  17518. ' v:=v.Bird[10].Bird',
  17519. 'end;',
  17520. 'begin',
  17521. '']);
  17522. ConvertProgram;
  17523. CheckSource('TestClassInterface_COM_IntfProperty',
  17524. LinesToStr([ // statements
  17525. 'rtl.createInterface($mod, "IUnknown", "{385F5482-571B-338C-8130-4E97F330543B}", [',
  17526. ' "_AddRef",',
  17527. ' "_Release",',
  17528. ' "GetBird",',
  17529. ' "SetBird",',
  17530. ' "GetItems",',
  17531. ' "SetItems"',
  17532. '], null);',
  17533. 'rtl.createClass($mod, "TObject", null, function () {',
  17534. ' this.$init = function () {',
  17535. ' };',
  17536. ' this.$final = function () {',
  17537. ' };',
  17538. ' rtl.addIntf(this, $mod.IUnknown);',
  17539. '});',
  17540. 'this.DoIt = function () {',
  17541. ' var o = null;',
  17542. ' var v = null;',
  17543. ' var $ir = rtl.createIntfRefs();',
  17544. ' try {',
  17545. ' v = rtl.setIntfL(v, v.GetItems(1), true);',
  17546. ' v.SetItems(2, v);',
  17547. ' v.SetItems(3, $ir.ref(1, v.GetItems(4)));',
  17548. ' v = rtl.setIntfL(v, v.GetItems(5), true);',
  17549. ' v.SetItems(6, v);',
  17550. ' v.SetItems(7, $ir.ref(2, v.GetItems(8)));',
  17551. ' $ir.ref(4, $ir.ref(3, v.GetItems(9)).GetBird()).SetBird(v);',
  17552. ' v = rtl.setIntfL(v, $ir.ref(6, $ir.ref(5, v.GetBird()).GetItems(10)).GetBird(), true);',
  17553. ' } finally {',
  17554. ' $ir.free();',
  17555. ' rtl._Release(v);',
  17556. ' };',
  17557. '};',
  17558. '']),
  17559. LinesToStr([ // $mod.$main
  17560. '']));
  17561. end;
  17562. procedure TTestModule.TestClassInterface_COM_Delegation;
  17563. begin
  17564. StartProgram(false);
  17565. Add([
  17566. '{$interfaces com}',
  17567. 'type',
  17568. ' IUnknown = interface',
  17569. ' function _AddRef: longint;',
  17570. ' function _Release: longint;',
  17571. ' end;',
  17572. ' IBird = interface(IUnknown)',
  17573. ' procedure Fly(s: string);',
  17574. ' end;',
  17575. ' IEagle = interface(IBird) end;',
  17576. ' IDove = interface(IBird) end;',
  17577. ' ISwallow = interface(IBird) end;',
  17578. ' TObject = class',
  17579. ' end;',
  17580. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  17581. ' function _AddRef: longint; virtual; abstract;',
  17582. ' function _Release: longint; virtual; abstract;',
  17583. ' procedure Fly(s: string); virtual; abstract;',
  17584. ' end;',
  17585. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  17586. ' function _AddRef: longint; virtual; abstract;',
  17587. ' function _Release: longint; virtual; abstract;',
  17588. ' FBirdIntf: IBird;',
  17589. ' property BirdIntf: IBird read FBirdIntf implements IBird;',
  17590. ' function GetEagleIntf: IEagle; virtual; abstract;',
  17591. ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  17592. ' FDoveObj: TBird;',
  17593. ' property DoveObj: TBird read FDoveObj implements IDove;',
  17594. ' function GetSwallowObj: TBird; virtual; abstract;',
  17595. ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  17596. ' end;',
  17597. 'begin',
  17598. '']);
  17599. ConvertProgram;
  17600. CheckSource('TestClassInterface_COM_Delegation',
  17601. LinesToStr([ // statements
  17602. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17603. 'rtl.createInterface($mod, "IBird", "{CC440C7F-7623-3DEE-AE88-000B86AAF108}", ["Fly"], $mod.IUnknown);',
  17604. 'rtl.createInterface($mod, "IEagle", "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}", [], $mod.IBird);',
  17605. 'rtl.createInterface($mod, "IDove", "{4B6A41C9-B020-3D7C-B688-96D18EF16074}", [], $mod.IBird);',
  17606. 'rtl.createInterface($mod, "ISwallow", "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}", [], $mod.IBird);',
  17607. 'rtl.createClass($mod, "TObject", null, function () {',
  17608. ' this.$init = function () {',
  17609. ' };',
  17610. ' this.$final = function () {',
  17611. ' };',
  17612. '});',
  17613. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  17614. ' rtl.addIntf(this, $mod.IBird);',
  17615. ' rtl.addIntf(this, $mod.IEagle);',
  17616. ' rtl.addIntf(this, $mod.IDove);',
  17617. ' rtl.addIntf(this, $mod.ISwallow);',
  17618. '});',
  17619. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  17620. ' this.$init = function () {',
  17621. ' $mod.TObject.$init.call(this);',
  17622. ' this.FBirdIntf = null;',
  17623. ' this.FDoveObj = null;',
  17624. ' };',
  17625. ' this.$final = function () {',
  17626. ' this.FBirdIntf = undefined;',
  17627. ' this.FDoveObj = undefined;',
  17628. ' $mod.TObject.$final.call(this);',
  17629. ' };',
  17630. ' this.$intfmaps = {',
  17631. ' "{CC440C7F-7623-3DEE-AE88-000B86AAF108}": function () {',
  17632. ' return rtl._AddRef(this.FBirdIntf);',
  17633. ' },',
  17634. ' "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}": function () {',
  17635. ' return this.GetEagleIntf();',
  17636. ' },',
  17637. ' "{4B6A41C9-B020-3D7C-B688-96D18EF16074}": function () {',
  17638. ' return rtl.queryIntfT(this.FDoveObj, $mod.IDove);',
  17639. ' },',
  17640. ' "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}": function () {',
  17641. ' return rtl.queryIntfT(this.GetSwallowObj(), $mod.ISwallow);',
  17642. ' }',
  17643. ' };',
  17644. '});',
  17645. '']),
  17646. LinesToStr([ // $mod.$main
  17647. '']));
  17648. end;
  17649. procedure TTestModule.TestClassInterface_COM_With;
  17650. begin
  17651. StartProgram(false);
  17652. Add([
  17653. '{$interfaces com}',
  17654. 'type',
  17655. ' IUnknown = interface',
  17656. ' function _AddRef: longint;',
  17657. ' function _Release: longint;',
  17658. ' function GetAnt: IUnknown;',
  17659. ' property Ant: IUnknown read GetAnt;',
  17660. ' end;',
  17661. ' TObject = class(IUnknown)',
  17662. ' function _AddRef: longint; virtual; abstract;',
  17663. ' function _Release: longint; virtual; abstract;',
  17664. ' function GetAnt: IUnknown; virtual; abstract;',
  17665. ' property Ant: IUnknown read GetAnt;',
  17666. ' end;',
  17667. 'procedure DoIt;',
  17668. 'var',
  17669. ' i: IUnknown;',
  17670. 'begin',
  17671. ' with i do ',
  17672. ' GetAnt;',
  17673. ' with i.Ant, Ant do ',
  17674. ' GetAnt;',
  17675. 'end;',
  17676. 'begin',
  17677. '']);
  17678. ConvertProgram;
  17679. CheckSource('TestClassInterface_COM_With',
  17680. LinesToStr([ // statements
  17681. 'rtl.createInterface($mod, "IUnknown", "{D7ADB00D-C6B6-39FB-BDDF-21CD521DDFA9}", ["_AddRef", "_Release", "GetAnt"], null);',
  17682. 'rtl.createClass($mod, "TObject", null, function () {',
  17683. ' this.$init = function () {',
  17684. ' };',
  17685. ' this.$final = function () {',
  17686. ' };',
  17687. ' rtl.addIntf(this, $mod.IUnknown);',
  17688. '});',
  17689. 'this.DoIt = function () {',
  17690. ' var i = null;',
  17691. ' var $ir = rtl.createIntfRefs();',
  17692. ' try {',
  17693. ' $ir.ref(1, i.GetAnt());',
  17694. ' var $with1 = $ir.ref(2, i.GetAnt());',
  17695. ' var $with2 = $ir.ref(3, $with1.GetAnt());',
  17696. ' $ir.ref(4, $with2.GetAnt());',
  17697. ' } finally {',
  17698. ' $ir.free();',
  17699. ' };',
  17700. '};',
  17701. '']),
  17702. LinesToStr([ // $mod.$main
  17703. '']));
  17704. end;
  17705. procedure TTestModule.TestClassInterface_COM_ForIn;
  17706. begin
  17707. StartProgram(false);
  17708. Add([
  17709. '{$interfaces com}',
  17710. 'type',
  17711. ' IUnknown = interface end;',
  17712. ' TObject = class',
  17713. ' Id: longint;',
  17714. ' end;',
  17715. ' IEnumerator = interface(IUnknown)',
  17716. ' function GetCurrent: TObject;',
  17717. ' function MoveNext: Boolean;',
  17718. ' property Current: TObject read GetCurrent;',
  17719. ' end;',
  17720. ' IEnumerable = interface(IUnknown)',
  17721. ' function GetEnumerator: IEnumerator;',
  17722. ' end;',
  17723. 'var',
  17724. ' o: TObject;',
  17725. ' i: IEnumerable;',
  17726. 'begin',
  17727. ' for o in i do o.Id:=3;',
  17728. '']);
  17729. ConvertProgram;
  17730. CheckSource('TestClassInterface_COM_ForIn',
  17731. LinesToStr([ // statements
  17732. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  17733. 'rtl.createClass($mod, "TObject", null, function () {',
  17734. ' this.$init = function () {',
  17735. ' this.Id = 0;',
  17736. ' };',
  17737. ' this.$final = function () {',
  17738. ' };',
  17739. '});',
  17740. 'rtl.createInterface($mod, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
  17741. 'rtl.createInterface($mod, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], $mod.IUnknown);',
  17742. 'this.o = null;',
  17743. 'this.i = null;',
  17744. '']),
  17745. LinesToStr([ // $mod.$main
  17746. 'var $in1 = $mod.i.GetEnumerator();',
  17747. 'try {',
  17748. ' while ($in1.MoveNext()) {',
  17749. ' $mod.o = $in1.GetCurrent();',
  17750. ' $mod.o.Id = 3;',
  17751. ' }',
  17752. '} finally {',
  17753. ' rtl._Release($in1)',
  17754. '};',
  17755. '']));
  17756. end;
  17757. procedure TTestModule.TestClassInterface_COM_ArrayOfIntfFail;
  17758. begin
  17759. StartProgram(false);
  17760. Add([
  17761. '{$interfaces com}',
  17762. 'type',
  17763. ' IUnknown = interface',
  17764. ' function _AddRef: longint;',
  17765. ' function _Release: longint;',
  17766. ' end;',
  17767. ' TObject = class',
  17768. ' end;',
  17769. ' TArrOfIntf = array of IUnknown;',
  17770. 'begin',
  17771. '']);
  17772. SetExpectedPasResolverError('Not supported: array of COM-interface',nNotSupportedX);
  17773. ConvertProgram;
  17774. end;
  17775. procedure TTestModule.TestClassInterface_COM_RecordIntfFail;
  17776. begin
  17777. StartProgram(false);
  17778. Add([
  17779. '{$interfaces com}',
  17780. 'type',
  17781. ' IUnknown = interface',
  17782. ' function _AddRef: longint;',
  17783. ' function _Release: longint;',
  17784. ' end;',
  17785. ' TRec = record',
  17786. ' i: IUnknown;',
  17787. ' end;',
  17788. 'begin',
  17789. '']);
  17790. SetExpectedPasResolverError('Not supported: COM-interface as record member',nNotSupportedX);
  17791. ConvertProgram;
  17792. end;
  17793. procedure TTestModule.TestClassInterface_COM_UnitInitialization;
  17794. begin
  17795. StartUnit(false);
  17796. Add([
  17797. '{$interfaces com}',
  17798. 'interface',
  17799. 'implementation',
  17800. 'type',
  17801. ' IUnknown = interface',
  17802. ' function _AddRef: longint;',
  17803. ' end;',
  17804. ' TObject = class(IUnknown)',
  17805. ' function _AddRef: longint;',
  17806. ' end;',
  17807. 'function TObject._AddRef: longint; begin end;',
  17808. 'var i: IUnknown;',
  17809. ' o: TObject;',
  17810. 'initialization',
  17811. ' i:=nil;',
  17812. ' i:=i;',
  17813. ' i:=o;',
  17814. ' if (o as IUnknown)=nil then ;',
  17815. '']);
  17816. ConvertUnit;
  17817. CheckSource('TestClassInterface_COM_UnitInitialization',
  17818. LinesToStr([ // statements
  17819. 'var $impl = $mod.$impl;',
  17820. '']),
  17821. LinesToStr([ // this.$init
  17822. 'var $ir = rtl.createIntfRefs();',
  17823. 'try {',
  17824. ' rtl.setIntfP($impl, "i", null);',
  17825. ' rtl.setIntfP($impl, "i", $impl.i);',
  17826. ' rtl.setIntfP($impl, "i", rtl.queryIntfT($impl.o, $impl.IUnknown), true);',
  17827. ' if ($ir.ref(1, rtl.queryIntfT($impl.o, $impl.IUnknown)) === null) ;',
  17828. '} finally {',
  17829. ' $ir.free();',
  17830. '};',
  17831. '']),
  17832. LinesToStr([ // implementation
  17833. 'rtl.createInterface($impl, "IUnknown", "{B92D5841-758A-322B-BDDF-21CD52180000}", ["_AddRef"], null);',
  17834. 'rtl.createClass($impl, "TObject", null, function () {',
  17835. ' this.$init = function () {',
  17836. ' };',
  17837. ' this.$final = function () {',
  17838. ' };',
  17839. ' this._AddRef = function () {',
  17840. ' var Result = 0;',
  17841. ' return Result;',
  17842. ' };',
  17843. ' rtl.addIntf(this, $impl.IUnknown);',
  17844. '});',
  17845. '$impl.i = null;',
  17846. '$impl.o = null;',
  17847. ''])
  17848. );
  17849. end;
  17850. procedure TTestModule.TestClassInterface_GUID;
  17851. begin
  17852. StartProgram(false);
  17853. Add([
  17854. '{$interfaces corba}',
  17855. 'type',
  17856. ' IUnknown = interface',
  17857. ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
  17858. ' end;',
  17859. ' TObject = class end;',
  17860. ' TGUID = record D1, D2, D3, D4: word; end;',
  17861. ' TAliasGUID = TGUID;',
  17862. ' TGUIDString = type string;',
  17863. ' TAliasGUIDString = TGUIDString;',
  17864. 'procedure DoConstGUIDIt(const g: TAliasGUID); overload;',
  17865. 'begin end;',
  17866. 'procedure DoDefGUID(g: TAliasGUID); overload;',
  17867. 'begin end;',
  17868. 'procedure DoStr(const s: TAliasGUIDString); overload;',
  17869. 'begin end;',
  17870. 'var',
  17871. ' i: IUnknown;',
  17872. ' g: TAliasGUID = ''{d91c9af4-3C93-420F-A303-BF5BA82BFD23}'';',
  17873. ' s: TAliasGUIDString;',
  17874. 'begin',
  17875. ' DoConstGUIDIt(IUnknown);',
  17876. ' DoDefGUID(IUnknown);',
  17877. ' DoStr(IUnknown);',
  17878. ' DoConstGUIDIt(i);',
  17879. ' DoDefGUID(i);',
  17880. ' DoStr(i);',
  17881. ' DoConstGUIDIt(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
  17882. ' DoDefGUID(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
  17883. ' DoStr(g);',
  17884. ' g:=i;',
  17885. ' g:=IUnknown;',
  17886. ' g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
  17887. ' s:=i;',
  17888. ' s:=IUnknown;',
  17889. ' s:=g;',
  17890. ' if g=i then ;',
  17891. ' if i=g then ;',
  17892. ' if g=IUnknown then ;',
  17893. ' if IUnknown=g then ;',
  17894. ' if s=i then ;',
  17895. ' if i=s then ;',
  17896. ' if s=IUnknown then ;',
  17897. ' if IUnknown=s then ;',
  17898. ' if s=g then ;',
  17899. ' if g=s then ;',
  17900. '']);
  17901. ConvertProgram;
  17902. CheckSource('TestClassInterface_GUID',
  17903. LinesToStr([ // statements
  17904. 'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
  17905. 'rtl.createClass($mod, "TObject", null, function () {',
  17906. ' this.$init = function () {',
  17907. ' };',
  17908. ' this.$final = function () {',
  17909. ' };',
  17910. '});',
  17911. 'rtl.recNewT($mod, "TGUID", function () {',
  17912. ' this.D1 = 0;',
  17913. ' this.D2 = 0;',
  17914. ' this.D3 = 0;',
  17915. ' this.D4 = 0;',
  17916. ' this.$eq = function (b) {',
  17917. ' return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
  17918. ' };',
  17919. ' this.$assign = function (s) {',
  17920. ' this.D1 = s.D1;',
  17921. ' this.D2 = s.D2;',
  17922. ' this.D3 = s.D3;',
  17923. ' this.D4 = s.D4;',
  17924. ' return this;',
  17925. ' };',
  17926. '});',
  17927. 'this.DoConstGUIDIt = function (g) {',
  17928. '};',
  17929. 'this.DoDefGUID = function (g) {',
  17930. '};',
  17931. 'this.DoStr = function (s) {',
  17932. '};',
  17933. 'this.i = null;',
  17934. 'this.g = $mod.TGUID.$clone({',
  17935. ' D1: 0xD91C9AF4,',
  17936. ' D2: 0x3C93,',
  17937. ' D3: 0x420F,',
  17938. ' D4: [',
  17939. ' 0xA3,',
  17940. ' 0x03,',
  17941. ' 0xBF,',
  17942. ' 0x5B,',
  17943. ' 0xA8,',
  17944. ' 0x2B,',
  17945. ' 0xFD,',
  17946. ' 0x23',
  17947. ' ]',
  17948. '});',
  17949. 'this.s = "";',
  17950. '']),
  17951. LinesToStr([ // $mod.$main
  17952. '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.IUnknown));',
  17953. '$mod.DoDefGUID($mod.TGUID.$clone(rtl.getIntfGUIDR($mod.IUnknown)));',
  17954. '$mod.DoStr($mod.IUnknown.$guid);',
  17955. '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.i));',
  17956. '$mod.DoDefGUID($mod.TGUID.$clone(rtl.getIntfGUIDR($mod.i)));',
  17957. '$mod.DoStr($mod.i.$guid);',
  17958. '$mod.DoConstGUIDIt(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
  17959. '$mod.DoDefGUID(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
  17960. '$mod.DoStr(rtl.guidrToStr($mod.g));',
  17961. '$mod.g.$assign(rtl.getIntfGUIDR($mod.i));',
  17962. '$mod.g.$assign(rtl.getIntfGUIDR($mod.IUnknown));',
  17963. '$mod.g.$assign({',
  17964. ' D1: 0xD91C9AF4,',
  17965. ' D2: 0x3C93,',
  17966. ' D3: 0x420F,',
  17967. ' D4: [',
  17968. ' 0xA3,',
  17969. ' 0x03,',
  17970. ' 0xBF,',
  17971. ' 0x5B,',
  17972. ' 0xA8,',
  17973. ' 0x2B,',
  17974. ' 0xFD,',
  17975. ' 0x23',
  17976. ' ]',
  17977. '});',
  17978. '$mod.s = $mod.i.$guid;',
  17979. '$mod.s = $mod.IUnknown.$guid;',
  17980. '$mod.s = rtl.guidrToStr($mod.g);',
  17981. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.i))) ;',
  17982. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.i))) ;',
  17983. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.IUnknown))) ;',
  17984. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.IUnknown))) ;',
  17985. 'if ($mod.s === $mod.i.$guid) ;',
  17986. 'if ($mod.i.$guid === $mod.s) ;',
  17987. 'if ($mod.s === $mod.IUnknown.$guid) ;',
  17988. 'if ($mod.IUnknown.$guid === $mod.s) ;',
  17989. 'if ($mod.g.$eq(rtl.createTGUID($mod.s))) ;',
  17990. 'if ($mod.g.$eq(rtl.createTGUID($mod.s))) ;',
  17991. '']));
  17992. end;
  17993. procedure TTestModule.TestClassInterface_GUIDProperty;
  17994. begin
  17995. StartProgram(false);
  17996. Add([
  17997. '{$interfaces corba}',
  17998. 'type',
  17999. ' IUnknown = interface',
  18000. ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
  18001. ' end;',
  18002. ' TGUID = record D1, D2, D3, D4: word; end;',
  18003. ' TAliasGUID = TGUID;',
  18004. ' TGUIDString = type string;',
  18005. ' TAliasGUIDString = TGUIDString;',
  18006. ' TObject = class',
  18007. ' function GetG: TAliasGUID; virtual; abstract;',
  18008. ' procedure SetG(const Value: TAliasGUID); virtual; abstract;',
  18009. ' function GetS: TAliasGUIDString; virtual; abstract;',
  18010. ' procedure SetS(const Value: TAliasGUIDString); virtual; abstract;',
  18011. ' property g: TAliasGUID read GetG write SetG;',
  18012. ' property s: TAliasGUIDString read GetS write SetS;',
  18013. ' end;',
  18014. 'var o: TObject;',
  18015. 'begin',
  18016. ' o.g:=IUnknown;',
  18017. ' o.g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
  18018. ' o.s:=IUnknown;',
  18019. ' o.s:=o.g;',
  18020. '']);
  18021. ConvertProgram;
  18022. CheckSource('TestClassInterface_GUIDProperty',
  18023. LinesToStr([ // statements
  18024. 'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
  18025. 'rtl.recNewT($mod, "TGUID", function () {',
  18026. ' this.D1 = 0;',
  18027. ' this.D2 = 0;',
  18028. ' this.D3 = 0;',
  18029. ' this.D4 = 0;',
  18030. ' this.$eq = function (b) {',
  18031. ' return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
  18032. ' };',
  18033. ' this.$assign = function (s) {',
  18034. ' this.D1 = s.D1;',
  18035. ' this.D2 = s.D2;',
  18036. ' this.D3 = s.D3;',
  18037. ' this.D4 = s.D4;',
  18038. ' return this;',
  18039. ' };',
  18040. '});',
  18041. 'rtl.createClass($mod, "TObject", null, function () {',
  18042. ' this.$init = function () {',
  18043. ' };',
  18044. ' this.$final = function () {',
  18045. ' };',
  18046. '});',
  18047. 'this.o = null;',
  18048. '']),
  18049. LinesToStr([ // $mod.$main
  18050. '$mod.o.SetG(rtl.getIntfGUIDR($mod.IUnknown));',
  18051. '$mod.o.SetG({',
  18052. ' D1: 0xD91C9AF4,',
  18053. ' D2: 0x3C93,',
  18054. ' D3: 0x420F,',
  18055. ' D4: [',
  18056. ' 0xA3,',
  18057. ' 0x03,',
  18058. ' 0xBF,',
  18059. ' 0x5B,',
  18060. ' 0xA8,',
  18061. ' 0x2B,',
  18062. ' 0xFD,',
  18063. ' 0x23',
  18064. ' ]',
  18065. '});',
  18066. '$mod.o.SetS($mod.IUnknown.$guid);',
  18067. '$mod.o.SetS(rtl.guidrToStr($mod.o.GetG()));',
  18068. '']));
  18069. end;
  18070. procedure TTestModule.TestClassHelper_ClassVar;
  18071. begin
  18072. StartProgram(false);
  18073. Add([
  18074. 'type',
  18075. ' TObject = class',
  18076. ' end;',
  18077. ' THelper = class helper for TObject',
  18078. ' const',
  18079. ' One = 1;',
  18080. ' Two: word = 2;',
  18081. ' class var',
  18082. ' Glob: word;',
  18083. ' function Foo(w: word): word;',
  18084. ' class function Bar(w: word): word;',
  18085. ' end;',
  18086. 'function THelper.foo(w: word): word;',
  18087. 'begin',
  18088. ' Result:=w;',
  18089. ' Two:=One+w;',
  18090. ' Glob:=Glob;',
  18091. ' Result:=Self.Glob;',
  18092. ' Self.Glob:=Self.Glob;',
  18093. ' with Self do Glob:=Glob;',
  18094. 'end;',
  18095. 'class function THelper.bar(w: word): word;',
  18096. 'begin',
  18097. ' Result:=w;',
  18098. ' Two:=One;',
  18099. ' Glob:=Glob;',
  18100. ' Self.Glob:=Self.Glob;',
  18101. ' with Self do Glob:=Glob;',
  18102. 'end;',
  18103. 'var o: TObject;',
  18104. 'begin',
  18105. ' tobject.two:=tobject.one;',
  18106. ' tobject.Glob:=tobject.Glob;',
  18107. ' with tobject do begin',
  18108. ' two:=one;',
  18109. ' Glob:=Glob;',
  18110. ' end;',
  18111. ' o.two:=o.one;',
  18112. ' o.Glob:=o.Glob;',
  18113. ' with o do begin',
  18114. ' two:=one;',
  18115. ' Glob:=Glob;',
  18116. ' end;',
  18117. '']);
  18118. ConvertProgram;
  18119. CheckSource('TestClassHelper',
  18120. LinesToStr([ // statements
  18121. 'rtl.createClass($mod, "TObject", null, function () {',
  18122. ' this.$init = function () {',
  18123. ' };',
  18124. ' this.$final = function () {',
  18125. ' };',
  18126. '});',
  18127. 'rtl.createHelper($mod, "THelper", null, function () {',
  18128. ' this.One = 1;',
  18129. ' this.Two = 2;',
  18130. ' this.Glob = 0;',
  18131. ' this.Foo = function (w) {',
  18132. ' var Result = 0;',
  18133. ' Result = w;',
  18134. ' $mod.THelper.Two = 1 + w;',
  18135. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18136. ' Result = $mod.THelper.Glob;',
  18137. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18138. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18139. ' return Result;',
  18140. ' };',
  18141. ' this.Bar = function (w) {',
  18142. ' var Result = 0;',
  18143. ' Result = w;',
  18144. ' $mod.THelper.Two = 1;',
  18145. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18146. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18147. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18148. ' return Result;',
  18149. ' };',
  18150. '});',
  18151. 'this.o = null;',
  18152. '']),
  18153. LinesToStr([ // $mod.$main
  18154. '$mod.THelper.Two = 1;',
  18155. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18156. 'var $with1 = $mod.TObject;',
  18157. '$mod.THelper.Two = 1;',
  18158. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18159. '$mod.THelper.Two = 1;',
  18160. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18161. 'var $with2 = $mod.o;',
  18162. '$mod.THelper.Two = 1;',
  18163. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18164. '']));
  18165. end;
  18166. procedure TTestModule.TestClassHelper_Method_AccessInstanceFields;
  18167. begin
  18168. StartProgram(false);
  18169. Add([
  18170. 'type',
  18171. ' TObject = class',
  18172. ' FSize: word;',
  18173. ' property Size: word read FSize write FSize;',
  18174. ' end;',
  18175. ' THelper = class helper for TObject',
  18176. ' function Foo(w: word = 1): word;',
  18177. ' end;',
  18178. 'function THelper.foo(w: word): word;',
  18179. 'begin',
  18180. ' Result:=Size;',
  18181. ' Size:=Size+2;',
  18182. ' Self.Size:=Self.Size+3;',
  18183. ' FSize:=FSize+4;',
  18184. ' Self.FSize:=Self.FSize+5;',
  18185. ' with Self do begin',
  18186. ' Size:=Size+6;',
  18187. ' FSize:=FSize+7;',
  18188. ' FSize:=FSize+8;',
  18189. ' end;',
  18190. 'end;',
  18191. 'begin',
  18192. '']);
  18193. ConvertProgram;
  18194. CheckSource('TestClassHelper_Method_AccessInstanceFields',
  18195. LinesToStr([ // statements
  18196. 'rtl.createClass($mod, "TObject", null, function () {',
  18197. ' this.$init = function () {',
  18198. ' this.FSize = 0;',
  18199. ' };',
  18200. ' this.$final = function () {',
  18201. ' };',
  18202. '});',
  18203. 'rtl.createHelper($mod, "THelper", null, function () {',
  18204. ' this.Foo = function (w) {',
  18205. ' var Result = 0;',
  18206. ' Result = this.FSize;',
  18207. ' this.FSize = this.FSize + 2;',
  18208. ' this.FSize = this.FSize + 3;',
  18209. ' this.FSize = this.FSize + 4;',
  18210. ' this.FSize = this.FSize + 5;',
  18211. ' this.FSize = this.FSize + 6;',
  18212. ' this.FSize = this.FSize + 7;',
  18213. ' this.FSize = this.FSize + 8;',
  18214. ' return Result;',
  18215. ' };',
  18216. '});',
  18217. '']),
  18218. LinesToStr([ // $mod.$main
  18219. '']));
  18220. end;
  18221. procedure TTestModule.TestClassHelper_Method_Call;
  18222. begin
  18223. StartProgram(false);
  18224. Add([
  18225. 'type',
  18226. ' TObject = class',
  18227. ' procedure Run(w: word = 10);',
  18228. ' end;',
  18229. ' THelper = class helper for TObject',
  18230. ' function Foo(w: word = 1): word;',
  18231. ' end;',
  18232. 'procedure TObject.Run(w: word);',
  18233. 'begin',
  18234. ' Foo;',
  18235. ' Foo();',
  18236. ' Foo(2);',
  18237. ' Self.Foo;',
  18238. ' Self.Foo();',
  18239. ' Self.Foo(3);',
  18240. ' with Self do begin',
  18241. ' Foo;',
  18242. ' Foo();',
  18243. ' Foo(4);',
  18244. ' end;',
  18245. 'end;',
  18246. 'function THelper.foo(w: word): word;',
  18247. 'begin',
  18248. ' Run;',
  18249. ' Run();',
  18250. ' Run(11);',
  18251. ' Foo;',
  18252. ' Foo();',
  18253. ' Foo(12);',
  18254. ' Self.Foo;',
  18255. ' Self.Foo();',
  18256. ' Self.Foo(13);',
  18257. ' with Self do begin',
  18258. ' Foo;',
  18259. ' Foo();',
  18260. ' Foo(14);',
  18261. ' end;',
  18262. 'end;',
  18263. 'var Obj: TObject;',
  18264. 'begin',
  18265. ' obj.Foo;',
  18266. ' obj.Foo();',
  18267. ' obj.Foo(21);',
  18268. ' with obj do begin',
  18269. ' Foo;',
  18270. ' Foo();',
  18271. ' Foo(22);',
  18272. ' end;',
  18273. '']);
  18274. ConvertProgram;
  18275. CheckSource('TestClassHelper_Method_Call',
  18276. LinesToStr([ // statements
  18277. 'rtl.createClass($mod, "TObject", null, function () {',
  18278. ' this.$init = function () {',
  18279. ' };',
  18280. ' this.$final = function () {',
  18281. ' };',
  18282. ' this.Run = function (w) {',
  18283. ' $mod.THelper.Foo.apply(this, 1);',
  18284. ' $mod.THelper.Foo.apply(this, 1);',
  18285. ' $mod.THelper.Foo.apply(this, 2);',
  18286. ' $mod.THelper.Foo.apply(this, 1);',
  18287. ' $mod.THelper.Foo.apply(this, 1);',
  18288. ' $mod.THelper.Foo.apply(this, 3);',
  18289. ' $mod.THelper.Foo.apply(this, 1);',
  18290. ' $mod.THelper.Foo.apply(this, 1);',
  18291. ' $mod.THelper.Foo.apply(this, 4);',
  18292. ' };',
  18293. '});',
  18294. 'rtl.createHelper($mod, "THelper", null, function () {',
  18295. ' this.Foo = function (w) {',
  18296. ' var Result = 0;',
  18297. ' this.Run(10);',
  18298. ' this.Run(10);',
  18299. ' this.Run(11);',
  18300. ' $mod.THelper.Foo.apply(this, 1);',
  18301. ' $mod.THelper.Foo.apply(this, 1);',
  18302. ' $mod.THelper.Foo.apply(this, 12);',
  18303. ' $mod.THelper.Foo.apply(this, 1);',
  18304. ' $mod.THelper.Foo.apply(this, 1);',
  18305. ' $mod.THelper.Foo.apply(this, 13);',
  18306. ' $mod.THelper.Foo.apply(this, 1);',
  18307. ' $mod.THelper.Foo.apply(this, 1);',
  18308. ' $mod.THelper.Foo.apply(this, 14);',
  18309. ' return Result;',
  18310. ' };',
  18311. '});',
  18312. 'this.Obj = null;',
  18313. '']),
  18314. LinesToStr([ // $mod.$main
  18315. '$mod.THelper.Foo.apply($mod.Obj, 1);',
  18316. '$mod.THelper.Foo.apply($mod.Obj, 1);',
  18317. '$mod.THelper.Foo.apply($mod.Obj, 21);',
  18318. 'var $with1 = $mod.Obj;',
  18319. '$mod.THelper.Foo.apply($with1, 1);',
  18320. '$mod.THelper.Foo.apply($with1, 1);',
  18321. '$mod.THelper.Foo.apply($with1, 22);',
  18322. '']));
  18323. end;
  18324. procedure TTestModule.TestClassHelper_Method_Nested_Call;
  18325. begin
  18326. StartProgram(false);
  18327. Add([
  18328. 'type',
  18329. ' TObject = class',
  18330. ' procedure Run(w: word = 10);',
  18331. ' end;',
  18332. ' THelper = class helper for TObject',
  18333. ' function Foo(w: word = 1): word;',
  18334. ' end;',
  18335. 'procedure TObject.Run(w: word);',
  18336. ' procedure Sub(Self: TObject);',
  18337. ' begin',
  18338. ' Foo;',
  18339. ' Foo();',
  18340. ' Self.Foo;',
  18341. ' Self.Foo();',
  18342. ' with Self do begin',
  18343. ' Foo;',
  18344. ' Foo();',
  18345. ' end;',
  18346. ' end;',
  18347. 'begin',
  18348. 'end;',
  18349. 'function THelper.foo(w: word): word;',
  18350. ' procedure Sub(Self: TObject);',
  18351. ' begin',
  18352. ' Run;',
  18353. ' Run();',
  18354. ' Foo;',
  18355. ' Foo();',
  18356. ' Self.Foo;',
  18357. ' Self.Foo();',
  18358. ' with Self do begin',
  18359. ' Foo;',
  18360. ' Foo();',
  18361. ' end;',
  18362. ' end;',
  18363. 'begin',
  18364. 'end;',
  18365. 'begin',
  18366. '']);
  18367. ConvertProgram;
  18368. CheckSource('TestClassHelper_Method_Nested_Call',
  18369. LinesToStr([ // statements
  18370. 'rtl.createClass($mod, "TObject", null, function () {',
  18371. ' this.$init = function () {',
  18372. ' };',
  18373. ' this.$final = function () {',
  18374. ' };',
  18375. ' this.Run = function (w) {',
  18376. ' var $Self = this;',
  18377. ' function Sub(Self) {',
  18378. ' $mod.THelper.Foo.apply($Self, 1);',
  18379. ' $mod.THelper.Foo.apply($Self, 1);',
  18380. ' $mod.THelper.Foo.apply(Self, 1);',
  18381. ' $mod.THelper.Foo.apply(Self, 1);',
  18382. ' $mod.THelper.Foo.apply(Self, 1);',
  18383. ' $mod.THelper.Foo.apply($Self, 1);',
  18384. ' };',
  18385. ' };',
  18386. '});',
  18387. 'rtl.createHelper($mod, "THelper", null, function () {',
  18388. ' this.Foo = function (w) {',
  18389. ' var $Self = this;',
  18390. ' var Result = 0;',
  18391. ' function Sub(Self) {',
  18392. ' $Self.Run(10);',
  18393. ' $Self.Run(10);',
  18394. ' $mod.THelper.Foo.apply($Self, 1);',
  18395. ' $mod.THelper.Foo.apply($Self, 1);',
  18396. ' $mod.THelper.Foo.apply(Self, 1);',
  18397. ' $mod.THelper.Foo.apply(Self, 1);',
  18398. ' $mod.THelper.Foo.apply(Self, 1);',
  18399. ' $mod.THelper.Foo.apply($Self, 1);',
  18400. ' };',
  18401. ' return Result;',
  18402. ' };',
  18403. '});',
  18404. '']),
  18405. LinesToStr([ // $mod.$main
  18406. '']));
  18407. end;
  18408. procedure TTestModule.TestClassHelper_ClassMethod_Call;
  18409. begin
  18410. StartProgram(false);
  18411. Add([
  18412. 'type',
  18413. ' TObject = class',
  18414. ' class procedure Run(w: word = 10);',
  18415. ' end;',
  18416. ' THelper = class helper for TObject',
  18417. ' class function Foo(w: word = 1): word;',
  18418. ' end;',
  18419. 'class procedure TObject.Run(w: word);',
  18420. 'begin',
  18421. ' Foo;',
  18422. ' Foo();',
  18423. ' Self.Foo;',
  18424. ' Self.Foo();',
  18425. ' with Self do begin',
  18426. ' Foo;',
  18427. ' Foo();',
  18428. ' end;',
  18429. 'end;',
  18430. 'class function THelper.foo(w: word): word;',
  18431. 'begin',
  18432. ' Run;',
  18433. ' Run();',
  18434. ' Foo;',
  18435. ' Foo();',
  18436. ' Self.Foo;',
  18437. ' Self.Foo();',
  18438. ' with Self do begin',
  18439. ' Foo;',
  18440. ' Foo();',
  18441. ' end;',
  18442. 'end;',
  18443. 'var',
  18444. ' Obj: TObject;',
  18445. 'begin',
  18446. ' obj.Foo;',
  18447. ' obj.Foo();',
  18448. ' with obj do begin',
  18449. ' Foo;',
  18450. ' Foo();',
  18451. ' end;',
  18452. ' tobject.Foo;',
  18453. ' tobject.Foo();',
  18454. ' with tobject do begin',
  18455. ' Foo;',
  18456. ' Foo();',
  18457. ' end;',
  18458. '']);
  18459. ConvertProgram;
  18460. CheckSource('TestClassHelper_ClassMethod_Call',
  18461. LinesToStr([ // statements
  18462. 'rtl.createClass($mod, "TObject", null, function () {',
  18463. ' this.$init = function () {',
  18464. ' };',
  18465. ' this.$final = function () {',
  18466. ' };',
  18467. ' this.Run = function (w) {',
  18468. ' $mod.THelper.Foo.apply(this, 1);',
  18469. ' $mod.THelper.Foo.apply(this, 1);',
  18470. ' $mod.THelper.Foo.apply(this, 1);',
  18471. ' $mod.THelper.Foo.apply(this, 1);',
  18472. ' $mod.THelper.Foo.apply(this, 1);',
  18473. ' $mod.THelper.Foo.apply(this, 1);',
  18474. ' };',
  18475. '});',
  18476. 'rtl.createHelper($mod, "THelper", null, function () {',
  18477. ' this.Foo = function (w) {',
  18478. ' var Result = 0;',
  18479. ' this.Run(10);',
  18480. ' this.Run(10);',
  18481. ' $mod.THelper.Foo.apply(this, 1);',
  18482. ' $mod.THelper.Foo.apply(this, 1);',
  18483. ' $mod.THelper.Foo.apply(this, 1);',
  18484. ' $mod.THelper.Foo.apply(this, 1);',
  18485. ' $mod.THelper.Foo.apply(this, 1);',
  18486. ' $mod.THelper.Foo.apply(this, 1);',
  18487. ' return Result;',
  18488. ' };',
  18489. '});',
  18490. 'this.Obj = null;',
  18491. '']),
  18492. LinesToStr([ // $mod.$main
  18493. '$mod.THelper.Foo.apply($mod.Obj.$class, 1);',
  18494. '$mod.THelper.Foo.apply($mod.Obj.$class, 1);',
  18495. 'var $with1 = $mod.Obj;',
  18496. '$mod.THelper.Foo.apply($with1.$class, 1);',
  18497. '$mod.THelper.Foo.apply($with1.$class, 1);',
  18498. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18499. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18500. 'var $with2 = $mod.TObject;',
  18501. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18502. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18503. '']));
  18504. end;
  18505. procedure TTestModule.TestClassHelper_ClassOf;
  18506. begin
  18507. StartProgram(false);
  18508. Add([
  18509. 'type',
  18510. ' TObject = class',
  18511. ' end;',
  18512. ' TClass = class of TObject;',
  18513. ' THelper = class helper for TObject',
  18514. ' class function Foo(w: word = 1): word;',
  18515. ' end;',
  18516. 'class function THelper.foo(w: word): word;',
  18517. 'begin',
  18518. 'end;',
  18519. 'var',
  18520. ' c: TClass;',
  18521. 'begin',
  18522. ' c.Foo;',
  18523. ' c.Foo();',
  18524. ' with c do begin',
  18525. ' Foo;',
  18526. ' Foo();',
  18527. ' end;',
  18528. '']);
  18529. ConvertProgram;
  18530. CheckSource('TestClassHelper_ClassOf',
  18531. LinesToStr([ // statements
  18532. 'rtl.createClass($mod, "TObject", null, function () {',
  18533. ' this.$init = function () {',
  18534. ' };',
  18535. ' this.$final = function () {',
  18536. ' };',
  18537. '});',
  18538. 'rtl.createHelper($mod, "THelper", null, function () {',
  18539. ' this.Foo = function (w) {',
  18540. ' var Result = 0;',
  18541. ' return Result;',
  18542. ' };',
  18543. '});',
  18544. 'this.c = null;',
  18545. '']),
  18546. LinesToStr([ // $mod.$main
  18547. '$mod.THelper.Foo.apply($mod.c, 1);',
  18548. '$mod.THelper.Foo.apply($mod.c, 1);',
  18549. 'var $with1 = $mod.c;',
  18550. '$mod.THelper.Foo.apply($with1, 1);',
  18551. '$mod.THelper.Foo.apply($with1, 1);',
  18552. '']));
  18553. end;
  18554. procedure TTestModule.TestClassHelper_MethodRefObjFPC;
  18555. begin
  18556. StartProgram(false);
  18557. Add([
  18558. '{$mode objfpc}',
  18559. 'type',
  18560. ' TObject = class',
  18561. ' procedure DoIt;',
  18562. ' end;',
  18563. ' THelper = class helper for TObject',
  18564. ' procedure Fly(w: word = 1);',
  18565. ' class procedure Glide(w: word = 1);',
  18566. ' class procedure Run(w: word = 1); static;',
  18567. ' end;',
  18568. ' TFly = procedure(w: word) of object;',
  18569. ' TGlide = TFly;',
  18570. ' TRun = procedure(w: word);',
  18571. 'var',
  18572. ' f: TFly;',
  18573. ' g: TGlide;',
  18574. ' r: TRun;',
  18575. 'procedure TObject.DoIt;',
  18576. 'begin',
  18577. ' f:=@fly;',
  18578. ' g:=@glide;',
  18579. ' r:=@run;',
  18580. ' f:[email protected];',
  18581. ' g:[email protected];',
  18582. ' r:[email protected];',
  18583. ' with self do begin',
  18584. ' f:=@fly;',
  18585. ' g:=@glide;',
  18586. ' r:=@run;',
  18587. ' end;',
  18588. 'end;',
  18589. 'procedure THelper.fly(w: word);',
  18590. 'begin',
  18591. ' f:=@fly;',
  18592. ' g:=@glide;',
  18593. ' r:=@run;',
  18594. 'end;',
  18595. 'class procedure THelper.glide(w: word);',
  18596. 'begin',
  18597. ' g:=@glide;',
  18598. ' r:=@run;',
  18599. 'end;',
  18600. 'class procedure THelper.run(w: word);',
  18601. 'begin',
  18602. ' g:=@glide;',
  18603. ' r:=@run;',
  18604. 'end;',
  18605. 'var',
  18606. ' Obj: TObject;',
  18607. 'begin',
  18608. ' f:[email protected];',
  18609. ' g:[email protected];',
  18610. ' r:[email protected];',
  18611. ' with obj do begin',
  18612. ' f:=@fly;',
  18613. ' g:=@glide;',
  18614. ' r:=@run;',
  18615. ' end;',
  18616. ' g:[email protected];',
  18617. ' r:[email protected];',
  18618. ' with tobject do begin',
  18619. ' g:=@glide;',
  18620. ' r:=@run;',
  18621. ' end;',
  18622. '']);
  18623. ConvertProgram;
  18624. CheckSource('TestClassHelper_MethodRefObjFPC',
  18625. LinesToStr([ // statements
  18626. 'rtl.createClass($mod, "TObject", null, function () {',
  18627. ' this.$init = function () {',
  18628. ' };',
  18629. ' this.$final = function () {',
  18630. ' };',
  18631. ' this.DoIt = function () {',
  18632. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18633. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18634. ' $mod.r = $mod.THelper.Run;',
  18635. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18636. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18637. ' $mod.r = $mod.THelper.Run;',
  18638. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18639. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18640. ' $mod.r = $mod.THelper.Run;',
  18641. ' };',
  18642. '});',
  18643. 'rtl.createHelper($mod, "THelper", null, function () {',
  18644. ' this.Fly = function (w) {',
  18645. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18646. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18647. ' $mod.r = $mod.THelper.Run;',
  18648. ' };',
  18649. ' this.Glide = function (w) {',
  18650. ' $mod.g = rtl.createCallback(this, $mod.THelper.Glide);',
  18651. ' $mod.r = $mod.THelper.Run;',
  18652. ' };',
  18653. ' this.Run = function (w) {',
  18654. ' $mod.g = rtl.createCallback($mod.THelper, $mod.THelper.Glide);',
  18655. ' $mod.r = $mod.THelper.Run;',
  18656. ' };',
  18657. '});',
  18658. 'this.f = null;',
  18659. 'this.g = null;',
  18660. 'this.r = null;',
  18661. 'this.Obj = null;',
  18662. '']),
  18663. LinesToStr([ // $mod.$main
  18664. '$mod.f = rtl.createCallback($mod.Obj, $mod.THelper.Fly);',
  18665. '$mod.g = rtl.createCallback($mod.Obj.$class, $mod.THelper.Glide);',
  18666. '$mod.r = $mod.THelper.Run;',
  18667. 'var $with1 = $mod.Obj;',
  18668. '$mod.f = rtl.createCallback($with1, $mod.THelper.Fly);',
  18669. '$mod.g = rtl.createCallback($with1.$class, $mod.THelper.Glide);',
  18670. '$mod.r = $mod.THelper.Run;',
  18671. '$mod.g = rtl.createCallback($mod.TObject, $mod.THelper.Glide);',
  18672. '$mod.r = $mod.THelper.Run;',
  18673. 'var $with2 = $mod.TObject;',
  18674. '$mod.g = rtl.createCallback($with2, $mod.THelper.Glide);',
  18675. '$mod.r = $mod.THelper.Run;',
  18676. '']));
  18677. end;
  18678. procedure TTestModule.TestClassHelper_Constructor;
  18679. begin
  18680. StartProgram(false);
  18681. Add([
  18682. 'type',
  18683. ' TObject = class',
  18684. ' constructor Create;',
  18685. ' end;',
  18686. ' TClass = class of TObject;',
  18687. ' THelper = class helper for TObject',
  18688. ' constructor NewHlp(w: word);',
  18689. ' end;',
  18690. 'var',
  18691. ' obj: TObject;',
  18692. ' c: TClass;',
  18693. 'constructor TObject.Create;',
  18694. 'begin',
  18695. ' NewHlp(2);', // normal call
  18696. ' tobject.NewHlp(3);', // new instance
  18697. ' c.newhlp(4);', // new instance
  18698. 'end;',
  18699. 'constructor THelper.NewHlp(w: word);',
  18700. 'begin',
  18701. ' create;', // normal call
  18702. ' tobject.create;', // new instance
  18703. ' NewHlp(2);', // normal call
  18704. ' tobject.NewHlp(3);', // new instance
  18705. ' c.newhlp(4);', // new instance
  18706. 'end;',
  18707. 'begin',
  18708. ' obj.newhlp(2);', // normal call
  18709. ' with Obj do newhlp(12);', // normal call
  18710. ' tobject.newhlp(3);', // new instance
  18711. ' with tobject do newhlp(13);', // new instance
  18712. ' c.newhlp(4);', // new instance
  18713. ' with c do newhlp(14);', // new instance
  18714. '']);
  18715. ConvertProgram;
  18716. CheckSource('TestClassHelper_Constructor',
  18717. LinesToStr([ // statements
  18718. 'rtl.createClass($mod, "TObject", null, function () {',
  18719. ' this.$init = function () {',
  18720. ' };',
  18721. ' this.$final = function () {',
  18722. ' };',
  18723. ' this.Create = function () {',
  18724. ' $mod.THelper.NewHlp.apply(this, 2);',
  18725. ' $mod.TObject.$create($mod.THelper.NewHlp, [3]);',
  18726. ' $mod.c.$create($mod.THelper.NewHlp, [4]);',
  18727. ' return this;',
  18728. ' };',
  18729. '});',
  18730. 'rtl.createHelper($mod, "THelper", null, function () {',
  18731. ' this.NewHlp = function (w) {',
  18732. ' this.Create();',
  18733. ' $mod.TObject.$create("Create");',
  18734. ' $mod.THelper.NewHlp.apply(this, 2);',
  18735. ' $mod.TObject.$create($mod.THelper.NewHlp, [3]);',
  18736. ' $mod.c.$create($mod.THelper.NewHlp, [4]);',
  18737. ' return this;',
  18738. ' };',
  18739. '});',
  18740. 'this.obj = null;',
  18741. 'this.c = null;',
  18742. '']),
  18743. LinesToStr([ // $mod.$main
  18744. '$mod.THelper.NewHlp.apply($mod.obj, 2);',
  18745. 'var $with1 = $mod.obj;',
  18746. '$mod.THelper.NewHlp.apply($with1, 12);',
  18747. '$mod.TObject.$create($mod.THelper.NewHlp, [3]);',
  18748. 'var $with2 = $mod.TObject;',
  18749. '$with2.$create($mod.THelper.NewHlp, [13]);',
  18750. '$mod.c.$create($mod.THelper.NewHlp, [4]);',
  18751. 'var $with3 = $mod.c;',
  18752. '$with3.$create($mod.THelper.NewHlp, [14]);',
  18753. '']));
  18754. end;
  18755. procedure TTestModule.TestProcType;
  18756. begin
  18757. StartProgram(false);
  18758. Add([
  18759. 'type',
  18760. ' TProcInt = procedure(vI: longint = 1);',
  18761. 'procedure DoIt(vJ: longint);',
  18762. 'begin end;',
  18763. 'var',
  18764. ' b: boolean;',
  18765. ' vP, vQ: tprocint;',
  18766. 'begin',
  18767. ' vp:=nil;',
  18768. ' vp:=vp;',
  18769. ' vp:=@doit;',
  18770. ' vp;',
  18771. ' vp();',
  18772. ' vp(2);',
  18773. ' b:=vp=nil;',
  18774. ' b:=nil=vp;',
  18775. ' b:=vp=vq;',
  18776. ' b:=vp=@doit;',
  18777. ' b:=@doit=vp;',
  18778. ' b:=vp<>nil;',
  18779. ' b:=nil<>vp;',
  18780. ' b:=vp<>vq;',
  18781. ' b:=vp<>@doit;',
  18782. ' b:=@doit<>vp;',
  18783. ' b:=Assigned(vp);',
  18784. ' if Assigned(vp) then ;']);
  18785. ConvertProgram;
  18786. CheckSource('TestProcType',
  18787. LinesToStr([ // statements
  18788. 'this.DoIt = function(vJ) {',
  18789. '};',
  18790. 'this.b = false;',
  18791. 'this.vP = null;',
  18792. 'this.vQ = null;'
  18793. ]),
  18794. LinesToStr([ // $mod.$main
  18795. '$mod.vP = null;',
  18796. '$mod.vP = $mod.vP;',
  18797. '$mod.vP = $mod.DoIt;',
  18798. '$mod.vP(1);',
  18799. '$mod.vP(1);',
  18800. '$mod.vP(2);',
  18801. '$mod.b = $mod.vP === null;',
  18802. '$mod.b = null === $mod.vP;',
  18803. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  18804. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  18805. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  18806. '$mod.b = $mod.vP !== null;',
  18807. '$mod.b = null !== $mod.vP;',
  18808. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  18809. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  18810. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  18811. '$mod.b = $mod.vP != null;',
  18812. 'if ($mod.vP != null) ;',
  18813. '']));
  18814. end;
  18815. procedure TTestModule.TestProcType_Arg;
  18816. begin
  18817. StartProgram(false);
  18818. Add([
  18819. 'type',
  18820. ' TProcInt = procedure(vI: longint = 1);',
  18821. 'procedure DoIt(vJ: longint); begin end;',
  18822. 'procedure DoSome(vP, vQ: TProcInt);',
  18823. 'var',
  18824. ' b: boolean;',
  18825. 'begin',
  18826. ' vp:=nil;',
  18827. ' vp:=vp;',
  18828. ' vp:=@doit;',
  18829. ' vp;',
  18830. ' vp();',
  18831. ' vp(2);',
  18832. ' b:=vp=nil;',
  18833. ' b:=nil=vp;',
  18834. ' b:=vp=vq;',
  18835. ' b:=vp=@doit;',
  18836. ' b:=@doit=vp;',
  18837. ' b:=vp<>nil;',
  18838. ' b:=nil<>vp;',
  18839. ' b:=vp<>vq;',
  18840. ' b:=vp<>@doit;',
  18841. ' b:=@doit<>vp;',
  18842. ' b:=Assigned(vp);',
  18843. ' if Assigned(vp) then ;',
  18844. 'end;',
  18845. 'begin',
  18846. ' DoSome(@DoIt,nil);']);
  18847. ConvertProgram;
  18848. CheckSource('TestProcType_Arg',
  18849. LinesToStr([ // statements
  18850. 'this.DoIt = function(vJ) {',
  18851. '};',
  18852. 'this.DoSome = function(vP, vQ) {',
  18853. ' var b = false;',
  18854. ' vP = null;',
  18855. ' vP = vP;',
  18856. ' vP = $mod.DoIt;',
  18857. ' vP(1);',
  18858. ' vP(1);',
  18859. ' vP(2);',
  18860. ' b = vP === null;',
  18861. ' b = null === vP;',
  18862. ' b = rtl.eqCallback(vP,vQ);',
  18863. ' b = rtl.eqCallback(vP, $mod.DoIt);',
  18864. ' b = rtl.eqCallback($mod.DoIt, vP);',
  18865. ' b = vP !== null;',
  18866. ' b = null !== vP;',
  18867. ' b = !rtl.eqCallback(vP, vQ);',
  18868. ' b = !rtl.eqCallback(vP, $mod.DoIt);',
  18869. ' b = !rtl.eqCallback($mod.DoIt, vP);',
  18870. ' b = vP != null;',
  18871. ' if (vP != null) ;',
  18872. '};',
  18873. '']),
  18874. LinesToStr([ // $mod.$main
  18875. '$mod.DoSome($mod.DoIt,null);',
  18876. '']));
  18877. end;
  18878. procedure TTestModule.TestProcType_FunctionFPC;
  18879. begin
  18880. StartProgram(false);
  18881. Add('type');
  18882. Add(' TFuncInt = function(vA: longint = 1): longint;');
  18883. Add('function DoIt(vI: longint): longint;');
  18884. Add('begin end;');
  18885. Add('var');
  18886. Add(' b: boolean;');
  18887. Add(' vP, vQ: tfuncint;');
  18888. Add('begin');
  18889. Add(' vp:=nil;');
  18890. Add(' vp:=vp;');
  18891. Add(' vp:=@doit;'); // ok in fpc and delphi
  18892. //Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  18893. Add(' vp;'); // ok in fpc and delphi
  18894. Add(' vp();');
  18895. Add(' vp(2);');
  18896. Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  18897. Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  18898. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  18899. Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  18900. Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  18901. //Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  18902. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  18903. Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  18904. Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  18905. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  18906. Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  18907. Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  18908. //Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  18909. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  18910. Add(' b:=Assigned(vp);');
  18911. //Add(' doit(vp);'); // illegal in fpc, ok in delphi
  18912. Add(' doit(vp());'); // ok in fpc and delphi
  18913. Add(' doit(vp(2));'); // ok in fpc and delphi
  18914. ConvertProgram;
  18915. CheckSource('TestProcType_FunctionFPC',
  18916. LinesToStr([ // statements
  18917. 'this.DoIt = function(vI) {',
  18918. ' var Result = 0;',
  18919. ' return Result;',
  18920. '};',
  18921. 'this.b = false;',
  18922. 'this.vP = null;',
  18923. 'this.vQ = null;'
  18924. ]),
  18925. LinesToStr([ // $mod.$main
  18926. '$mod.vP = null;',
  18927. '$mod.vP = $mod.vP;',
  18928. '$mod.vP = $mod.DoIt;',
  18929. '$mod.vP(1);',
  18930. '$mod.vP(1);',
  18931. '$mod.vP(2);',
  18932. '$mod.b = $mod.vP === null;',
  18933. '$mod.b = null === $mod.vP;',
  18934. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  18935. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  18936. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  18937. '$mod.b = 4 === $mod.vP(1);',
  18938. '$mod.b = $mod.vP !== null;',
  18939. '$mod.b = null !== $mod.vP;',
  18940. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  18941. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  18942. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  18943. '$mod.b = 6 !== $mod.vP(1);',
  18944. '$mod.b = $mod.vP != null;',
  18945. '$mod.DoIt($mod.vP(1));',
  18946. '$mod.DoIt($mod.vP(2));',
  18947. '']));
  18948. end;
  18949. procedure TTestModule.TestProcType_FunctionDelphi;
  18950. begin
  18951. StartProgram(false);
  18952. Add('{$mode Delphi}');
  18953. Add('type');
  18954. Add(' TFuncInt = function(vA: longint = 1): longint;');
  18955. Add('function DoIt(vI: longint): longint;');
  18956. Add('begin end;');
  18957. Add('var');
  18958. Add(' b: boolean;');
  18959. Add(' vP, vQ: tfuncint;');
  18960. Add('begin');
  18961. Add(' vp:=nil;');
  18962. Add(' vp:=vp;');
  18963. Add(' vp:=@doit;'); // ok in fpc and delphi
  18964. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  18965. Add(' vp;'); // ok in fpc and delphi
  18966. Add(' vp();');
  18967. Add(' vp(2);');
  18968. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  18969. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  18970. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  18971. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  18972. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  18973. Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  18974. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  18975. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  18976. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  18977. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  18978. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  18979. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  18980. Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  18981. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  18982. Add(' b:=Assigned(vp);');
  18983. Add(' doit(vp);'); // illegal in fpc, ok in delphi
  18984. Add(' doit(vp());'); // ok in fpc and delphi
  18985. Add(' doit(vp(2));'); // ok in fpc and delphi *)
  18986. ConvertProgram;
  18987. CheckSource('TestProcType_FunctionDelphi',
  18988. LinesToStr([ // statements
  18989. 'this.DoIt = function(vI) {',
  18990. ' var Result = 0;',
  18991. ' return Result;',
  18992. '};',
  18993. 'this.b = false;',
  18994. 'this.vP = null;',
  18995. 'this.vQ = null;'
  18996. ]),
  18997. LinesToStr([ // $mod.$main
  18998. '$mod.vP = null;',
  18999. '$mod.vP = $mod.vP;',
  19000. '$mod.vP = $mod.DoIt;',
  19001. '$mod.vP = $mod.DoIt;',
  19002. '$mod.vP(1);',
  19003. '$mod.vP(1);',
  19004. '$mod.vP(2);',
  19005. '$mod.b = $mod.vP(1) === $mod.vQ(1);',
  19006. '$mod.b = $mod.vP(1) === 3;',
  19007. '$mod.b = 4 === $mod.vP(1);',
  19008. '$mod.b = $mod.vP(1) !== $mod.vQ(1);',
  19009. '$mod.b = $mod.vP(1) !== 5;',
  19010. '$mod.b = 6 !== $mod.vP(1);',
  19011. '$mod.b = $mod.vP != null;',
  19012. '$mod.DoIt($mod.vP(1));',
  19013. '$mod.DoIt($mod.vP(1));',
  19014. '$mod.DoIt($mod.vP(2));',
  19015. '']));
  19016. end;
  19017. procedure TTestModule.TestProcType_ProcedureDelphi;
  19018. begin
  19019. StartProgram(false);
  19020. Add('{$mode Delphi}');
  19021. Add('type');
  19022. Add(' TProc = procedure;');
  19023. Add('procedure DoIt;');
  19024. Add('begin end;');
  19025. Add('var');
  19026. Add(' b: boolean;');
  19027. Add(' vP, vQ: tproc;');
  19028. Add('begin');
  19029. Add(' vp:=nil;');
  19030. Add(' vp:=vp;');
  19031. Add(' vp:=vq;');
  19032. 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
  19033. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  19034. //Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
  19035. Add(' vp;'); // ok in fpc and delphi
  19036. Add(' vp();');
  19037. // equal
  19038. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  19039. Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
  19040. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  19041. Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
  19042. Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
  19043. //Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  19044. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  19045. Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
  19046. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  19047. Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
  19048. // unequal
  19049. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  19050. Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
  19051. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  19052. Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
  19053. //Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  19054. Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
  19055. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  19056. Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
  19057. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  19058. Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
  19059. Add(' b:=Assigned(vp);');
  19060. ConvertProgram;
  19061. CheckSource('TestProcType_ProcedureDelphi',
  19062. LinesToStr([ // statements
  19063. 'this.DoIt = function() {',
  19064. '};',
  19065. 'this.b = false;',
  19066. 'this.vP = null;',
  19067. 'this.vQ = null;'
  19068. ]),
  19069. LinesToStr([ // $mod.$main
  19070. '$mod.vP = null;',
  19071. '$mod.vP = $mod.vP;',
  19072. '$mod.vP = $mod.vQ;',
  19073. '$mod.vP = $mod.DoIt;',
  19074. '$mod.vP = $mod.DoIt;',
  19075. '$mod.vP();',
  19076. '$mod.vP();',
  19077. '$mod.b = $mod.vP === null;',
  19078. '$mod.b = null === $mod.vP;',
  19079. '$mod.b = rtl.eqCallback($mod.vP, $mod.vQ);',
  19080. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  19081. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  19082. '$mod.b = $mod.vP !== null;',
  19083. '$mod.b = null !== $mod.vP;',
  19084. '$mod.b = !rtl.eqCallback($mod.vP, $mod.vQ);',
  19085. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  19086. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  19087. '$mod.b = $mod.vP != null;',
  19088. '']));
  19089. end;
  19090. procedure TTestModule.TestProcType_AsParam;
  19091. begin
  19092. StartProgram(false);
  19093. Add('type');
  19094. Add(' TFuncInt = function(vA: longint = 1): longint;');
  19095. Add('procedure DoIt(vG: tfuncint; const vH: tfuncint; var vI: tfuncint);');
  19096. Add('var vJ: tfuncint;');
  19097. Add('begin');
  19098. Add(' vg:=vg;');
  19099. Add(' vj:=vh;');
  19100. Add(' vi:=vi;');
  19101. Add(' doit(vg,vg,vg);');
  19102. Add(' doit(vh,vh,vj);');
  19103. Add(' doit(vi,vi,vi);');
  19104. Add(' doit(vj,vj,vj);');
  19105. Add('end;');
  19106. Add('var i: tfuncint;');
  19107. Add('begin');
  19108. Add(' doit(i,i,i);');
  19109. ConvertProgram;
  19110. CheckSource('TestProcType_AsParam',
  19111. LinesToStr([ // statements
  19112. 'this.DoIt = function (vG,vH,vI) {',
  19113. ' var vJ = null;',
  19114. ' vG = vG;',
  19115. ' vJ = vH;',
  19116. ' vI.set(vI.get());',
  19117. ' $mod.DoIt(vG, vG, {',
  19118. ' get: function () {',
  19119. ' return vG;',
  19120. ' },',
  19121. ' set: function (v) {',
  19122. ' vG = v;',
  19123. ' }',
  19124. ' });',
  19125. ' $mod.DoIt(vH, vH, {',
  19126. ' get: function () {',
  19127. ' return vJ;',
  19128. ' },',
  19129. ' set: function (v) {',
  19130. ' vJ = v;',
  19131. ' }',
  19132. ' });',
  19133. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  19134. ' $mod.DoIt(vJ, vJ, {',
  19135. ' get: function () {',
  19136. ' return vJ;',
  19137. ' },',
  19138. ' set: function (v) {',
  19139. ' vJ = v;',
  19140. ' }',
  19141. ' });',
  19142. '};',
  19143. 'this.i = null;'
  19144. ]),
  19145. LinesToStr([
  19146. '$mod.DoIt($mod.i,$mod.i,{',
  19147. ' p: $mod,',
  19148. ' get: function () {',
  19149. ' return this.p.i;',
  19150. ' },',
  19151. ' set: function (v) {',
  19152. ' this.p.i = v;',
  19153. ' }',
  19154. '});'
  19155. ]));
  19156. end;
  19157. procedure TTestModule.TestProcType_MethodFPC;
  19158. begin
  19159. StartProgram(false);
  19160. Add('type');
  19161. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19162. Add(' TObject = class');
  19163. Add(' function DoIt(vA: longint = 1): longint;');
  19164. Add(' end;');
  19165. Add('function TObject.DoIt(vA: longint = 1): longint;');
  19166. Add('begin');
  19167. Add('end;');
  19168. Add('var');
  19169. Add(' Obj: TObject;');
  19170. Add(' vP: tfuncint;');
  19171. Add(' b: boolean;');
  19172. Add('begin');
  19173. Add(' vp:[email protected];'); // ok in fpc and delphi
  19174. //Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  19175. Add(' vp;'); // ok in fpc and delphi
  19176. Add(' vp();');
  19177. Add(' vp(2);');
  19178. Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  19179. Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  19180. Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  19181. Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  19182. ConvertProgram;
  19183. CheckSource('TestProcType_MethodFPC',
  19184. LinesToStr([ // statements
  19185. 'rtl.createClass($mod, "TObject", null, function () {',
  19186. ' this.$init = function () {',
  19187. ' };',
  19188. ' this.$final = function () {',
  19189. ' };',
  19190. ' this.DoIt = function (vA) {',
  19191. ' var Result = 0;',
  19192. ' return Result;',
  19193. ' };',
  19194. '});',
  19195. 'this.Obj = null;',
  19196. 'this.vP = null;',
  19197. 'this.b = false;'
  19198. ]),
  19199. LinesToStr([
  19200. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  19201. '$mod.vP(1);',
  19202. '$mod.vP(1);',
  19203. '$mod.vP(2);',
  19204. '$mod.b = rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  19205. '$mod.b = rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  19206. '$mod.b = !rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  19207. '$mod.b = !rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  19208. '']));
  19209. end;
  19210. procedure TTestModule.TestProcType_MethodDelphi;
  19211. begin
  19212. StartProgram(false);
  19213. Add('{$mode delphi}');
  19214. Add('type');
  19215. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19216. Add(' TObject = class');
  19217. Add(' function DoIt(vA: longint = 1): longint;');
  19218. Add(' end;');
  19219. Add('function TObject.DoIt(vA: longint = 1): longint;');
  19220. Add('begin');
  19221. Add('end;');
  19222. Add('var');
  19223. Add(' Obj: TObject;');
  19224. Add(' vP: tfuncint;');
  19225. Add(' b: boolean;');
  19226. Add('begin');
  19227. Add(' vp:[email protected];'); // ok in fpc and delphi
  19228. Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  19229. Add(' vp;'); // ok in fpc and delphi
  19230. Add(' vp();');
  19231. Add(' vp(2);');
  19232. //Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  19233. //Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  19234. //Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  19235. //Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  19236. ConvertProgram;
  19237. CheckSource('TestProcType_MethodDelphi',
  19238. LinesToStr([ // statements
  19239. 'rtl.createClass($mod, "TObject", null, function () {',
  19240. ' this.$init = function () {',
  19241. ' };',
  19242. ' this.$final = function () {',
  19243. ' };',
  19244. ' this.DoIt = function (vA) {',
  19245. ' var Result = 0;',
  19246. ' return Result;',
  19247. ' };',
  19248. '});',
  19249. 'this.Obj = null;',
  19250. 'this.vP = null;',
  19251. 'this.b = false;'
  19252. ]),
  19253. LinesToStr([
  19254. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  19255. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  19256. '$mod.vP(1);',
  19257. '$mod.vP(1);',
  19258. '$mod.vP(2);',
  19259. '']));
  19260. end;
  19261. procedure TTestModule.TestProcType_PropertyFPC;
  19262. begin
  19263. StartProgram(false);
  19264. Add('type');
  19265. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19266. Add(' TObject = class');
  19267. Add(' FOnFoo: TFuncInt;');
  19268. Add(' function DoIt(vA: longint = 1): longint;');
  19269. Add(' function GetFoo: TFuncInt;');
  19270. Add(' procedure SetFoo(const Value: TFuncInt);');
  19271. Add(' function GetEvents(Index: longint): TFuncInt;');
  19272. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  19273. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  19274. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  19275. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  19276. Add(' end;');
  19277. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  19278. Add('function tobject.getfoo: tfuncint; begin end;');
  19279. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  19280. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  19281. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  19282. Add('var');
  19283. Add(' Obj: TObject;');
  19284. Add(' vP: tfuncint;');
  19285. Add(' b: boolean;');
  19286. Add('begin');
  19287. Add(' obj.onfoo:=nil;');
  19288. Add(' obj.onbar:=nil;');
  19289. Add(' obj.events[1]:=nil;');
  19290. Add(' obj.onfoo:=obj.onfoo;');
  19291. Add(' obj.onbar:=obj.onbar;');
  19292. Add(' obj.events[2]:=obj.events[3];');
  19293. Add(' obj.onfoo:[email protected];');
  19294. Add(' obj.onbar:[email protected];');
  19295. Add(' obj.events[4]:[email protected];');
  19296. //Add(' obj.onfoo:=obj.doit;'); // delphi
  19297. //Add(' obj.onbar:=obj.doit;'); // delphi
  19298. //Add(' obj.events[4]:=obj.doit;'); // delphi
  19299. Add(' obj.onfoo;');
  19300. Add(' obj.onbar;');
  19301. //Add(' obj.events[5];'); ToDo in pasresolver
  19302. Add(' obj.onfoo();');
  19303. Add(' obj.onbar();');
  19304. Add(' obj.events[6]();');
  19305. Add(' b:=obj.onfoo=nil;');
  19306. Add(' b:=obj.onbar=nil;');
  19307. Add(' b:=obj.events[7]=nil;');
  19308. Add(' b:=obj.onfoo<>nil;');
  19309. Add(' b:=obj.onbar<>nil;');
  19310. Add(' b:=obj.events[8]<>nil;');
  19311. Add(' b:=obj.onfoo=vp;');
  19312. Add(' b:=obj.onbar=vp;');
  19313. Add(' b:=obj.events[9]=vp;');
  19314. Add(' b:=obj.onfoo=obj.onfoo;');
  19315. Add(' b:=obj.onbar=obj.onfoo;');
  19316. Add(' b:=obj.events[10]=obj.onfoo;');
  19317. Add(' b:=obj.onfoo<>obj.onfoo;');
  19318. Add(' b:=obj.onbar<>obj.onfoo;');
  19319. Add(' b:=obj.events[11]<>obj.onfoo;');
  19320. Add(' b:[email protected];');
  19321. Add(' b:[email protected];');
  19322. Add(' b:=obj.events[12][email protected];');
  19323. Add(' b:=obj.onfoo<>@obj.doit;');
  19324. Add(' b:=obj.onbar<>@obj.doit;');
  19325. Add(' b:=obj.events[12]<>@obj.doit;');
  19326. Add(' b:=Assigned(obj.onfoo);');
  19327. Add(' b:=Assigned(obj.onbar);');
  19328. Add(' b:=Assigned(obj.events[13]);');
  19329. ConvertProgram;
  19330. CheckSource('TestProcType_PropertyFPC',
  19331. LinesToStr([ // statements
  19332. 'rtl.createClass($mod, "TObject", null, function () {',
  19333. ' this.$init = function () {',
  19334. ' this.FOnFoo = null;',
  19335. ' };',
  19336. ' this.$final = function () {',
  19337. ' this.FOnFoo = undefined;',
  19338. ' };',
  19339. ' this.DoIt = function (vA) {',
  19340. ' var Result = 0;',
  19341. ' return Result;',
  19342. ' };',
  19343. 'this.GetFoo = function () {',
  19344. ' var Result = null;',
  19345. ' return Result;',
  19346. '};',
  19347. 'this.SetFoo = function (Value) {',
  19348. '};',
  19349. 'this.GetEvents = function (Index) {',
  19350. ' var Result = null;',
  19351. ' return Result;',
  19352. '};',
  19353. 'this.SetEvents = function (Index, Value) {',
  19354. '};',
  19355. '});',
  19356. 'this.Obj = null;',
  19357. 'this.vP = null;',
  19358. 'this.b = false;'
  19359. ]),
  19360. LinesToStr([
  19361. '$mod.Obj.FOnFoo = null;',
  19362. '$mod.Obj.SetFoo(null);',
  19363. '$mod.Obj.SetEvents(1, null);',
  19364. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  19365. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  19366. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  19367. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  19368. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  19369. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  19370. '$mod.Obj.FOnFoo(1);',
  19371. '$mod.Obj.GetFoo();',
  19372. '$mod.Obj.FOnFoo(1);',
  19373. '$mod.Obj.GetFoo()(1);',
  19374. '$mod.Obj.GetEvents(6)(1);',
  19375. '$mod.b = $mod.Obj.FOnFoo === null;',
  19376. '$mod.b = $mod.Obj.GetFoo() === null;',
  19377. '$mod.b = $mod.Obj.GetEvents(7) === null;',
  19378. '$mod.b = $mod.Obj.FOnFoo !== null;',
  19379. '$mod.b = $mod.Obj.GetFoo() !== null;',
  19380. '$mod.b = $mod.Obj.GetEvents(8) !== null;',
  19381. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.vP);',
  19382. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.vP);',
  19383. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(9), $mod.vP);',
  19384. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  19385. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  19386. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(10), $mod.Obj.FOnFoo);',
  19387. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  19388. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  19389. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(11), $mod.Obj.FOnFoo);',
  19390. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  19391. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  19392. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  19393. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  19394. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  19395. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  19396. '$mod.b = $mod.Obj.FOnFoo != null;',
  19397. '$mod.b = $mod.Obj.GetFoo() != null;',
  19398. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  19399. '']));
  19400. end;
  19401. procedure TTestModule.TestProcType_PropertyDelphi;
  19402. begin
  19403. StartProgram(false);
  19404. Add('{$mode delphi}');
  19405. Add('type');
  19406. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19407. Add(' TObject = class');
  19408. Add(' FOnFoo: TFuncInt;');
  19409. Add(' function DoIt(vA: longint = 1): longint;');
  19410. Add(' function GetFoo: TFuncInt;');
  19411. Add(' procedure SetFoo(const Value: TFuncInt);');
  19412. Add(' function GetEvents(Index: longint): TFuncInt;');
  19413. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  19414. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  19415. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  19416. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  19417. Add(' end;');
  19418. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  19419. Add('function tobject.getfoo: tfuncint; begin end;');
  19420. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  19421. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  19422. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  19423. Add('var');
  19424. Add(' Obj: TObject;');
  19425. Add(' vP: tfuncint;');
  19426. Add(' b: boolean;');
  19427. Add('begin');
  19428. Add(' obj.onfoo:=nil;');
  19429. Add(' obj.onbar:=nil;');
  19430. Add(' obj.events[1]:=nil;');
  19431. Add(' obj.onfoo:=obj.onfoo;');
  19432. Add(' obj.onbar:=obj.onbar;');
  19433. Add(' obj.events[2]:=obj.events[3];');
  19434. Add(' obj.onfoo:[email protected];');
  19435. Add(' obj.onbar:[email protected];');
  19436. Add(' obj.events[4]:[email protected];');
  19437. Add(' obj.onfoo:=obj.doit;'); // delphi
  19438. Add(' obj.onbar:=obj.doit;'); // delphi
  19439. Add(' obj.events[4]:=obj.doit;'); // delphi
  19440. Add(' obj.onfoo;');
  19441. Add(' obj.onbar;');
  19442. //Add(' obj.events[5];'); ToDo in pasresolver
  19443. Add(' obj.onfoo();');
  19444. Add(' obj.onbar();');
  19445. Add(' obj.events[6]();');
  19446. //Add(' b:=obj.onfoo=nil;'); // fpc
  19447. //Add(' b:=obj.onbar=nil;'); // fpc
  19448. //Add(' b:=obj.events[7]=nil;'); // fpc
  19449. //Add(' b:=obj.onfoo<>nil;'); // fpc
  19450. //Add(' b:=obj.onbar<>nil;'); // fpc
  19451. //Add(' b:=obj.events[8]<>nil;'); // fpc
  19452. Add(' b:=obj.onfoo=vp;');
  19453. Add(' b:=obj.onbar=vp;');
  19454. //Add(' b:=obj.events[9]=vp;'); ToDo in pasresolver
  19455. Add(' b:=obj.onfoo=obj.onfoo;');
  19456. Add(' b:=obj.onbar=obj.onfoo;');
  19457. //Add(' b:=obj.events[10]=obj.onfoo;'); // ToDo in pasresolver
  19458. Add(' b:=obj.onfoo<>obj.onfoo;');
  19459. Add(' b:=obj.onbar<>obj.onfoo;');
  19460. //Add(' b:=obj.events[11]<>obj.onfoo;'); // ToDo in pasresolver
  19461. //Add(' b:[email protected];'); // fpc
  19462. //Add(' b:[email protected];'); // fpc
  19463. //Add(' b:=obj.events[12][email protected];'); // fpc
  19464. //Add(' b:=obj.onfoo<>@obj.doit;'); // fpc
  19465. //Add(' b:=obj.onbar<>@obj.doit;'); // fpc
  19466. //Add(' b:=obj.events[12]<>@obj.doit;'); // fpc
  19467. Add(' b:=Assigned(obj.onfoo);');
  19468. Add(' b:=Assigned(obj.onbar);');
  19469. Add(' b:=Assigned(obj.events[13]);');
  19470. ConvertProgram;
  19471. CheckSource('TestProcType_PropertyDelphi',
  19472. LinesToStr([ // statements
  19473. 'rtl.createClass($mod, "TObject", null, function () {',
  19474. ' this.$init = function () {',
  19475. ' this.FOnFoo = null;',
  19476. ' };',
  19477. ' this.$final = function () {',
  19478. ' this.FOnFoo = undefined;',
  19479. ' };',
  19480. ' this.DoIt = function (vA) {',
  19481. ' var Result = 0;',
  19482. ' return Result;',
  19483. ' };',
  19484. 'this.GetFoo = function () {',
  19485. ' var Result = null;',
  19486. ' return Result;',
  19487. '};',
  19488. 'this.SetFoo = function (Value) {',
  19489. '};',
  19490. 'this.GetEvents = function (Index) {',
  19491. ' var Result = null;',
  19492. ' return Result;',
  19493. '};',
  19494. 'this.SetEvents = function (Index, Value) {',
  19495. '};',
  19496. '});',
  19497. 'this.Obj = null;',
  19498. 'this.vP = null;',
  19499. 'this.b = false;'
  19500. ]),
  19501. LinesToStr([
  19502. '$mod.Obj.FOnFoo = null;',
  19503. '$mod.Obj.SetFoo(null);',
  19504. '$mod.Obj.SetEvents(1, null);',
  19505. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  19506. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  19507. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  19508. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  19509. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  19510. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  19511. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  19512. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  19513. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  19514. '$mod.Obj.FOnFoo(1);',
  19515. '$mod.Obj.GetFoo();',
  19516. '$mod.Obj.FOnFoo(1);',
  19517. '$mod.Obj.GetFoo()(1);',
  19518. '$mod.Obj.GetEvents(6)(1);',
  19519. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.vP(1);',
  19520. '$mod.b = $mod.Obj.GetFoo() === $mod.vP(1);',
  19521. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.Obj.FOnFoo(1);',
  19522. '$mod.b = $mod.Obj.GetFoo() === $mod.Obj.FOnFoo(1);',
  19523. '$mod.b = $mod.Obj.FOnFoo(1) !== $mod.Obj.FOnFoo(1);',
  19524. '$mod.b = $mod.Obj.GetFoo() !== $mod.Obj.FOnFoo(1);',
  19525. '$mod.b = $mod.Obj.FOnFoo != null;',
  19526. '$mod.b = $mod.Obj.GetFoo() != null;',
  19527. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  19528. '']));
  19529. end;
  19530. procedure TTestModule.TestProcType_WithClassInstDoPropertyFPC;
  19531. begin
  19532. StartProgram(false);
  19533. Add('type');
  19534. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19535. Add(' TObject = class');
  19536. Add(' FOnFoo: TFuncInt;');
  19537. Add(' function DoIt(vA: longint = 1): longint;');
  19538. Add(' function GetFoo: TFuncInt;');
  19539. Add(' procedure SetFoo(const Value: TFuncInt);');
  19540. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  19541. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  19542. Add(' end;');
  19543. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  19544. Add('function tobject.getfoo: tfuncint; begin end;');
  19545. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  19546. Add('var');
  19547. Add(' Obj: TObject;');
  19548. Add(' vP: tfuncint;');
  19549. Add(' b: boolean;');
  19550. Add('begin');
  19551. Add('with obj do begin');
  19552. Add(' fonfoo:=nil;');
  19553. Add(' onfoo:=nil;');
  19554. Add(' onbar:=nil;');
  19555. Add(' fonfoo:=fonfoo;');
  19556. Add(' onfoo:=onfoo;');
  19557. Add(' onbar:=onbar;');
  19558. Add(' fonfoo:=@doit;');
  19559. Add(' onfoo:=@doit;');
  19560. Add(' onbar:=@doit;');
  19561. //Add(' fonfoo:=doit;'); // delphi
  19562. //Add(' onfoo:=doit;'); // delphi
  19563. //Add(' onbar:=doit;'); // delphi
  19564. Add(' fonfoo;');
  19565. Add(' onfoo;');
  19566. Add(' onbar;');
  19567. Add(' fonfoo();');
  19568. Add(' onfoo();');
  19569. Add(' onbar();');
  19570. Add(' b:=fonfoo=nil;');
  19571. Add(' b:=onfoo=nil;');
  19572. Add(' b:=onbar=nil;');
  19573. Add(' b:=fonfoo<>nil;');
  19574. Add(' b:=onfoo<>nil;');
  19575. Add(' b:=onbar<>nil;');
  19576. Add(' b:=fonfoo=vp;');
  19577. Add(' b:=onfoo=vp;');
  19578. Add(' b:=onbar=vp;');
  19579. Add(' b:=fonfoo=fonfoo;');
  19580. Add(' b:=onfoo=onfoo;');
  19581. Add(' b:=onbar=onfoo;');
  19582. Add(' b:=fonfoo<>fonfoo;');
  19583. Add(' b:=onfoo<>onfoo;');
  19584. Add(' b:=onbar<>onfoo;');
  19585. Add(' b:=fonfoo=@doit;');
  19586. Add(' b:=onfoo=@doit;');
  19587. Add(' b:=onbar=@doit;');
  19588. Add(' b:=fonfoo<>@doit;');
  19589. Add(' b:=onfoo<>@doit;');
  19590. Add(' b:=onbar<>@doit;');
  19591. Add(' b:=Assigned(fonfoo);');
  19592. Add(' b:=Assigned(onfoo);');
  19593. Add(' b:=Assigned(onbar);');
  19594. Add('end;');
  19595. ConvertProgram;
  19596. CheckSource('TestProcType_WithClassInstDoPropertyFPC',
  19597. LinesToStr([ // statements
  19598. 'rtl.createClass($mod, "TObject", null, function () {',
  19599. ' this.$init = function () {',
  19600. ' this.FOnFoo = null;',
  19601. ' };',
  19602. ' this.$final = function () {',
  19603. ' this.FOnFoo = undefined;',
  19604. ' };',
  19605. ' this.DoIt = function (vA) {',
  19606. ' var Result = 0;',
  19607. ' return Result;',
  19608. ' };',
  19609. ' this.GetFoo = function () {',
  19610. ' var Result = null;',
  19611. ' return Result;',
  19612. ' };',
  19613. ' this.SetFoo = function (Value) {',
  19614. ' };',
  19615. '});',
  19616. 'this.Obj = null;',
  19617. 'this.vP = null;',
  19618. 'this.b = false;'
  19619. ]),
  19620. LinesToStr([
  19621. 'var $with1 = $mod.Obj;',
  19622. '$with1.FOnFoo = null;',
  19623. '$with1.FOnFoo = null;',
  19624. '$with1.SetFoo(null);',
  19625. '$with1.FOnFoo = $with1.FOnFoo;',
  19626. '$with1.FOnFoo = $with1.FOnFoo;',
  19627. '$with1.SetFoo($with1.GetFoo());',
  19628. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  19629. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  19630. '$with1.SetFoo(rtl.createCallback($with1, "DoIt"));',
  19631. '$with1.FOnFoo(1);',
  19632. '$with1.FOnFoo(1);',
  19633. '$with1.GetFoo();',
  19634. '$with1.FOnFoo(1);',
  19635. '$with1.FOnFoo(1);',
  19636. '$with1.GetFoo()(1);',
  19637. '$mod.b = $with1.FOnFoo === null;',
  19638. '$mod.b = $with1.FOnFoo === null;',
  19639. '$mod.b = $with1.GetFoo() === null;',
  19640. '$mod.b = $with1.FOnFoo !== null;',
  19641. '$mod.b = $with1.FOnFoo !== null;',
  19642. '$mod.b = $with1.GetFoo() !== null;',
  19643. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  19644. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  19645. '$mod.b = rtl.eqCallback($with1.GetFoo(), $mod.vP);',
  19646. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  19647. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  19648. '$mod.b = rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  19649. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  19650. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  19651. '$mod.b = !rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  19652. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  19653. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  19654. '$mod.b = rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  19655. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  19656. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  19657. '$mod.b = !rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  19658. '$mod.b = $with1.FOnFoo != null;',
  19659. '$mod.b = $with1.FOnFoo != null;',
  19660. '$mod.b = $with1.GetFoo() != null;',
  19661. '']));
  19662. end;
  19663. procedure TTestModule.TestProcType_Nested;
  19664. begin
  19665. StartProgram(false);
  19666. Add([
  19667. 'type',
  19668. ' TProcInt = procedure(vI: longint = 1);',
  19669. 'procedure DoIt(vJ: longint);',
  19670. 'var aProc: TProcInt;',
  19671. ' b: boolean;',
  19672. ' procedure Sub(vK: longint);',
  19673. ' var aSub: TProcInt;',
  19674. ' procedure SubSub(vK: longint);',
  19675. ' var aSubSub: TProcInt;',
  19676. ' begin;',
  19677. ' aProc:=@DoIt;',
  19678. ' aSub:=@DoIt;',
  19679. ' aSubSub:=@DoIt;',
  19680. ' aProc:=@Sub;',
  19681. ' aSub:=@Sub;',
  19682. ' aSubSub:=@Sub;',
  19683. ' aProc:=@SubSub;',
  19684. ' aSub:=@SubSub;',
  19685. ' aSubSub:=@SubSub;',
  19686. ' end;',
  19687. ' begin;',
  19688. ' end;',
  19689. 'begin;',
  19690. ' aProc:=@Sub;',
  19691. ' b:=aProc=@Sub;',
  19692. ' b:=@Sub=aProc;',
  19693. 'end;',
  19694. 'begin',
  19695. '']);
  19696. ConvertProgram;
  19697. CheckSource('TestProcType_Nested',
  19698. LinesToStr([ // statements
  19699. 'this.DoIt = function (vJ) {',
  19700. ' var aProc = null;',
  19701. ' var b = false;',
  19702. ' function Sub(vK) {',
  19703. ' var aSub = null;',
  19704. ' function SubSub(vK) {',
  19705. ' var aSubSub = null;',
  19706. ' aProc = $mod.DoIt;',
  19707. ' aSub = $mod.DoIt;',
  19708. ' aSubSub = $mod.DoIt;',
  19709. ' aProc = Sub;',
  19710. ' aSub = Sub;',
  19711. ' aSubSub = Sub;',
  19712. ' aProc = SubSub;',
  19713. ' aSub = SubSub;',
  19714. ' aSubSub = SubSub;',
  19715. ' };',
  19716. ' };',
  19717. ' aProc = Sub;',
  19718. ' b = rtl.eqCallback(aProc, Sub);',
  19719. ' b = rtl.eqCallback(Sub, aProc);',
  19720. '};',
  19721. '']),
  19722. LinesToStr([ // $mod.$main
  19723. '']));
  19724. end;
  19725. procedure TTestModule.TestProcType_NestedOfObject;
  19726. begin
  19727. StartProgram(false);
  19728. Add([
  19729. 'type',
  19730. ' TProcInt = procedure(vI: longint = 1) of object;',
  19731. ' TObject = class',
  19732. ' procedure DoIt(vJ: longint);',
  19733. ' end;',
  19734. 'procedure TObject.DoIt(vJ: longint);',
  19735. 'var aProc: TProcInt;',
  19736. ' b: boolean;',
  19737. ' procedure Sub(vK: longint);',
  19738. ' var aSub: TProcInt;',
  19739. ' procedure SubSub(vK: longint);',
  19740. ' var aSubSub: TProcInt;',
  19741. ' begin;',
  19742. ' aProc:=@DoIt;',
  19743. ' aSub:=@DoIt;',
  19744. ' aSubSub:=@DoIt;',
  19745. ' aProc:=@Sub;',
  19746. ' aSub:=@Sub;',
  19747. ' aSubSub:=@Sub;',
  19748. ' aProc:=@SubSub;',
  19749. ' aSub:=@SubSub;',
  19750. ' aSubSub:=@SubSub;',
  19751. ' end;',
  19752. ' begin;',
  19753. ' end;',
  19754. 'begin;',
  19755. ' aProc:=@Sub;',
  19756. ' b:=aProc=@Sub;',
  19757. ' b:=@Sub=aProc;',
  19758. 'end;',
  19759. 'begin',
  19760. '']);
  19761. ConvertProgram;
  19762. CheckSource('TestProcType_Nested',
  19763. LinesToStr([ // statements
  19764. 'rtl.createClass($mod, "TObject", null, function () {',
  19765. ' this.$init = function () {',
  19766. ' };',
  19767. ' this.$final = function () {',
  19768. ' };',
  19769. ' this.DoIt = function (vJ) {',
  19770. ' var $Self = this;',
  19771. ' var aProc = null;',
  19772. ' var b = false;',
  19773. ' function Sub(vK) {',
  19774. ' var aSub = null;',
  19775. ' function SubSub(vK) {',
  19776. ' var aSubSub = null;',
  19777. ' aProc = rtl.createCallback($Self, "DoIt");',
  19778. ' aSub = rtl.createCallback($Self, "DoIt");',
  19779. ' aSubSub = rtl.createCallback($Self, "DoIt");',
  19780. ' aProc = Sub;',
  19781. ' aSub = Sub;',
  19782. ' aSubSub = Sub;',
  19783. ' aProc = SubSub;',
  19784. ' aSub = SubSub;',
  19785. ' aSubSub = SubSub;',
  19786. ' };',
  19787. ' };',
  19788. ' aProc = Sub;',
  19789. ' b = rtl.eqCallback(aProc, Sub);',
  19790. ' b = rtl.eqCallback(Sub, aProc);',
  19791. ' };',
  19792. '});',
  19793. '']),
  19794. LinesToStr([ // $mod.$main
  19795. '']));
  19796. end;
  19797. procedure TTestModule.TestProcType_ReferenceToProc;
  19798. begin
  19799. StartProgram(false);
  19800. Add([
  19801. 'type',
  19802. ' TProcRef = reference to procedure(i: longint = 0);',
  19803. ' TFuncRef = reference to function(i: longint = 0): longint;',
  19804. 'var',
  19805. ' p: TProcRef;',
  19806. ' f: TFuncRef;',
  19807. 'procedure DoIt(i: longint);',
  19808. 'begin',
  19809. 'end;',
  19810. 'function GetIt(i: longint): longint;',
  19811. 'begin',
  19812. ' p:=@DoIt;',
  19813. ' f:=@GetIt;',
  19814. ' f;',
  19815. ' f();',
  19816. ' f(1);',
  19817. 'end;',
  19818. 'begin',
  19819. ' p:=@DoIt;',
  19820. ' f:=@GetIt;',
  19821. ' f;',
  19822. ' f();',
  19823. ' f(1);',
  19824. ' p:=TProcRef(f);',
  19825. '']);
  19826. ConvertProgram;
  19827. CheckSource('TestProcType_ReferenceToProc',
  19828. LinesToStr([ // statements
  19829. 'this.p = null;',
  19830. 'this.f = null;',
  19831. 'this.DoIt = function (i) {',
  19832. '};',
  19833. 'this.GetIt = function (i) {',
  19834. ' var Result = 0;',
  19835. ' $mod.p = $mod.DoIt;',
  19836. ' $mod.f = $mod.GetIt;',
  19837. ' $mod.f(0);',
  19838. ' $mod.f(0);',
  19839. ' $mod.f(1);',
  19840. ' return Result;',
  19841. '};',
  19842. '']),
  19843. LinesToStr([ // $mod.$main
  19844. '$mod.p = $mod.DoIt;',
  19845. '$mod.f = $mod.GetIt;',
  19846. '$mod.f(0);',
  19847. '$mod.f(0);',
  19848. '$mod.f(1);',
  19849. '$mod.p = $mod.f;',
  19850. '']));
  19851. end;
  19852. procedure TTestModule.TestProcType_ReferenceToMethod;
  19853. begin
  19854. StartProgram(false);
  19855. Add([
  19856. 'type',
  19857. ' TFuncRef = reference to function(i: longint = 5): longint;',
  19858. ' TObject = class',
  19859. ' function Grow(s: longint): longint;',
  19860. ' end;',
  19861. 'var',
  19862. ' f: tfuncref;',
  19863. 'function tobject.grow(s: longint): longint;',
  19864. ' function GrowSub(i: longint): longint;',
  19865. ' begin',
  19866. ' f:=@grow;',
  19867. ' f:=@growsub;',
  19868. ' end;',
  19869. 'begin',
  19870. ' f:=@grow;',
  19871. ' f:=@growsub;',
  19872. 'end;',
  19873. 'begin',
  19874. '']);
  19875. ConvertProgram;
  19876. CheckSource('TestProcType_ReferenceToMethod',
  19877. LinesToStr([ // statements
  19878. 'rtl.createClass($mod, "TObject", null, function () {',
  19879. ' this.$init = function () {',
  19880. ' };',
  19881. ' this.$final = function () {',
  19882. ' };',
  19883. ' this.Grow = function (s) {',
  19884. ' var $Self = this;',
  19885. ' var Result = 0;',
  19886. ' function GrowSub(i) {',
  19887. ' var Result = 0;',
  19888. ' $mod.f = rtl.createCallback($Self, "Grow");',
  19889. ' $mod.f = GrowSub;',
  19890. ' return Result;',
  19891. ' };',
  19892. ' $mod.f = rtl.createCallback($Self, "Grow");',
  19893. ' $mod.f = GrowSub;',
  19894. ' return Result;',
  19895. ' };',
  19896. '});',
  19897. 'this.f = null;',
  19898. '']),
  19899. LinesToStr([ // $mod.$main
  19900. '']));
  19901. end;
  19902. procedure TTestModule.TestProcType_Typecast;
  19903. begin
  19904. StartProgram(false);
  19905. Add([
  19906. 'type',
  19907. ' TNotifyEvent = procedure(Sender: Pointer) of object;',
  19908. ' TEvent = procedure of object;',
  19909. ' TGetter = function:longint of object;',
  19910. ' TProcA = procedure(i: longint);',
  19911. ' TFuncB = function(i, j: longint): longint;',
  19912. 'procedure DoIt(); varargs; begin end;',
  19913. 'var',
  19914. ' Notify: tnotifyevent;',
  19915. ' Event: tevent;',
  19916. ' Getter: tgetter;',
  19917. ' ProcA: tproca;',
  19918. ' FuncB: tfuncb;',
  19919. ' p: pointer;',
  19920. 'begin',
  19921. ' notify:=tnotifyevent(event);',
  19922. ' event:=tevent(event);',
  19923. ' event:=tevent(notify);',
  19924. ' event:=tevent(getter);',
  19925. ' event:=tevent(proca);',
  19926. ' proca:=tproca(funcb);',
  19927. ' funcb:=tfuncb(funcb);',
  19928. ' funcb:=tfuncb(proca);',
  19929. ' funcb:=tfuncb(getter);',
  19930. ' proca:=tproca(p);',
  19931. ' funcb:=tfuncb(p);',
  19932. ' getter:=tgetter(p);',
  19933. ' p:=pointer(notify);',
  19934. ' p:=notify;',
  19935. ' p:=pointer(proca);',
  19936. ' p:=proca;',
  19937. ' p:=pointer(funcb);',
  19938. ' p:=funcb;',
  19939. ' doit(Pointer(notify),pointer(event),pointer(proca));',
  19940. '']);
  19941. ConvertProgram;
  19942. CheckSource('TestProcType_Typecast',
  19943. LinesToStr([ // statements
  19944. 'this.DoIt = function () {',
  19945. '};',
  19946. 'this.Notify = null;',
  19947. 'this.Event = null;',
  19948. 'this.Getter = null;',
  19949. 'this.ProcA = null;',
  19950. 'this.FuncB = null;',
  19951. 'this.p = null;',
  19952. '']),
  19953. LinesToStr([ // $mod.$main
  19954. '$mod.Notify = $mod.Event;',
  19955. '$mod.Event = $mod.Event;',
  19956. '$mod.Event = $mod.Notify;',
  19957. '$mod.Event = $mod.Getter;',
  19958. '$mod.Event = $mod.ProcA;',
  19959. '$mod.ProcA = $mod.FuncB;',
  19960. '$mod.FuncB = $mod.FuncB;',
  19961. '$mod.FuncB = $mod.ProcA;',
  19962. '$mod.FuncB = $mod.Getter;',
  19963. '$mod.ProcA = $mod.p;',
  19964. '$mod.FuncB = $mod.p;',
  19965. '$mod.Getter = $mod.p;',
  19966. '$mod.p = $mod.Notify;',
  19967. '$mod.p = $mod.Notify;',
  19968. '$mod.p = $mod.ProcA;',
  19969. '$mod.p = $mod.ProcA;',
  19970. '$mod.p = $mod.FuncB;',
  19971. '$mod.p = $mod.FuncB;',
  19972. '$mod.DoIt($mod.Notify, $mod.Event, $mod.ProcA);',
  19973. '']));
  19974. end;
  19975. procedure TTestModule.TestProcType_PassProcToUntyped;
  19976. begin
  19977. StartProgram(false);
  19978. Add([
  19979. 'type',
  19980. ' TEvent = procedure of object;',
  19981. ' TFunc = function: longint;',
  19982. 'procedure DoIt(); varargs; begin end;',
  19983. 'procedure DoSome(const a; var b; p: pointer); begin end;',
  19984. 'var',
  19985. ' Event: tevent;',
  19986. ' Func: TFunc;',
  19987. 'begin',
  19988. ' doit(event,func);',
  19989. ' dosome(event,event,event);',
  19990. ' dosome(func,func,func);',
  19991. '']);
  19992. ConvertProgram;
  19993. CheckSource('TestProcType_PassProcToUntyped',
  19994. LinesToStr([ // statements
  19995. 'this.DoIt = function () {',
  19996. '};',
  19997. 'this.DoSome = function (a, b, p) {',
  19998. '};',
  19999. 'this.Event = null;',
  20000. 'this.Func = null;',
  20001. '']),
  20002. LinesToStr([ // $mod.$main
  20003. '$mod.DoIt($mod.Event, $mod.Func);',
  20004. '$mod.DoSome($mod.Event, {',
  20005. ' p: $mod,',
  20006. ' get: function () {',
  20007. ' return this.p.Event;',
  20008. ' },',
  20009. ' set: function (v) {',
  20010. ' this.p.Event = v;',
  20011. ' }',
  20012. '}, $mod.Event);',
  20013. '$mod.DoSome($mod.Func, {',
  20014. ' p: $mod,',
  20015. ' get: function () {',
  20016. ' return this.p.Func;',
  20017. ' },',
  20018. ' set: function (v) {',
  20019. ' this.p.Func = v;',
  20020. ' }',
  20021. '}, $mod.Func);',
  20022. '']));
  20023. end;
  20024. procedure TTestModule.TestProcType_PassProcToArray;
  20025. begin
  20026. StartProgram(false);
  20027. Add([
  20028. 'type',
  20029. ' TFunc = function: longint;',
  20030. ' TArrFunc = array of TFunc;',
  20031. 'procedure DoIt(Arr: TArrFunc); begin end;',
  20032. 'function GetIt: longint; begin end;',
  20033. 'var',
  20034. ' Func: tfunc;',
  20035. 'begin',
  20036. ' doit([]);',
  20037. ' doit([@GetIt]);',
  20038. ' doit([Func]);',
  20039. '']);
  20040. ConvertProgram;
  20041. CheckSource('TestProcType_PassProcToArray',
  20042. LinesToStr([ // statements
  20043. 'this.DoIt = function (Arr) {',
  20044. '};',
  20045. 'this.GetIt = function () {',
  20046. ' var Result = 0;',
  20047. ' return Result;',
  20048. '};',
  20049. 'this.Func = null;',
  20050. '']),
  20051. LinesToStr([ // $mod.$main
  20052. '$mod.DoIt([]);',
  20053. '$mod.DoIt([$mod.GetIt]);',
  20054. '$mod.DoIt([$mod.Func]);',
  20055. '']));
  20056. end;
  20057. procedure TTestModule.TestPointer;
  20058. begin
  20059. StartProgram(false);
  20060. Add(['type',
  20061. ' TObject = class end;',
  20062. ' TClass = class of TObject;',
  20063. ' TArrInt = array of longint;',
  20064. 'const',
  20065. ' n = nil;',
  20066. 'var',
  20067. ' v: jsvalue;',
  20068. ' Obj: tobject;',
  20069. ' C: tclass;',
  20070. ' a: tarrint;',
  20071. ' p: Pointer = nil;',
  20072. ' s: string;',
  20073. 'begin',
  20074. ' p:=p;',
  20075. ' p:=nil;',
  20076. ' if p=nil then;',
  20077. ' if nil=p then;',
  20078. ' if Assigned(p) then;',
  20079. ' p:=Pointer(v);',
  20080. ' p:=obj;',
  20081. ' p:=c;',
  20082. ' p:=a;',
  20083. ' p:=tobject;',
  20084. ' obj:=TObject(p);',
  20085. ' c:=TClass(p);',
  20086. ' a:=TArrInt(p);',
  20087. ' p:=n;',
  20088. ' p:=Pointer(a);',
  20089. ' p:=pointer(s);',
  20090. ' s:=string(p);',
  20091. '']);
  20092. ConvertProgram;
  20093. CheckSource('TestPointer',
  20094. LinesToStr([ // statements
  20095. 'rtl.createClass($mod, "TObject", null, function () {',
  20096. ' this.$init = function () {',
  20097. ' };',
  20098. ' this.$final = function () {',
  20099. ' };',
  20100. '});',
  20101. 'this.n = null;',
  20102. 'this.v = undefined;',
  20103. 'this.Obj = null;',
  20104. 'this.C = null;',
  20105. 'this.a = [];',
  20106. 'this.p = null;',
  20107. 'this.s = "";',
  20108. '']),
  20109. LinesToStr([ // $mod.$main
  20110. '$mod.p = $mod.p;',
  20111. '$mod.p = null;',
  20112. 'if ($mod.p === null) ;',
  20113. 'if (null === $mod.p) ;',
  20114. 'if ($mod.p != null) ;',
  20115. '$mod.p = $mod.v;',
  20116. '$mod.p = $mod.Obj;',
  20117. '$mod.p = $mod.C;',
  20118. '$mod.p = $mod.a;',
  20119. '$mod.p = $mod.TObject;',
  20120. '$mod.Obj = $mod.p;',
  20121. '$mod.C = $mod.p;',
  20122. '$mod.a = $mod.p;',
  20123. '$mod.p = null;',
  20124. '$mod.p = $mod.a;',
  20125. '$mod.p = $mod.s;',
  20126. '$mod.s = $mod.p;',
  20127. '']));
  20128. end;
  20129. procedure TTestModule.TestPointer_Proc;
  20130. begin
  20131. StartProgram(false);
  20132. Add('type');
  20133. Add(' TObject = class');
  20134. Add(' procedure DoIt; virtual; abstract;');
  20135. Add(' end;');
  20136. Add('procedure DoSome; begin end;');
  20137. Add('var');
  20138. Add(' o: TObject;');
  20139. Add(' p: Pointer;');
  20140. Add('begin');
  20141. Add(' p:=@DoSome;');
  20142. Add(' p:[email protected];');
  20143. ConvertProgram;
  20144. CheckSource('TestPointer_Proc',
  20145. LinesToStr([ // statements
  20146. 'rtl.createClass($mod, "TObject", null, function () {',
  20147. ' this.$init = function () {',
  20148. ' };',
  20149. ' this.$final = function () {',
  20150. ' };',
  20151. '});',
  20152. 'this.DoSome = function () {',
  20153. '};',
  20154. 'this.o = null;',
  20155. 'this.p = null;',
  20156. '']),
  20157. LinesToStr([ // $mod.$main
  20158. '$mod.p = $mod.DoSome;',
  20159. '$mod.p = rtl.createCallback($mod.o, "DoIt");',
  20160. '']));
  20161. end;
  20162. procedure TTestModule.TestPointer_AssignRecordFail;
  20163. begin
  20164. StartProgram(false);
  20165. Add('type');
  20166. Add(' TRec = record end;');
  20167. Add('var');
  20168. Add(' p: Pointer;');
  20169. Add(' r: TRec;');
  20170. Add('begin');
  20171. Add(' p:=r;');
  20172. SetExpectedPasResolverError('Incompatible types: got "TRec" expected "Pointer"',
  20173. nIncompatibleTypesGotExpected);
  20174. ConvertProgram;
  20175. end;
  20176. procedure TTestModule.TestPointer_AssignStaticArrayFail;
  20177. begin
  20178. StartProgram(false);
  20179. Add('type');
  20180. Add(' TArr = array[boolean] of longint;');
  20181. Add('var');
  20182. Add(' p: Pointer;');
  20183. Add(' a: TArr;');
  20184. Add('begin');
  20185. Add(' p:=a;');
  20186. SetExpectedPasResolverError('Incompatible types: got "TArr" expected "Pointer"',
  20187. nIncompatibleTypesGotExpected);
  20188. ConvertProgram;
  20189. end;
  20190. procedure TTestModule.TestPointer_TypeCastJSValueToPointer;
  20191. begin
  20192. StartProgram(false);
  20193. Add([
  20194. 'procedure DoIt(args: array of jsvalue); begin end;',
  20195. 'procedure DoAll; varargs; begin end;',
  20196. 'var',
  20197. ' v: jsvalue;',
  20198. 'begin',
  20199. ' DoIt([pointer(v)]);',
  20200. ' DoAll(pointer(v));',
  20201. '']);
  20202. ConvertProgram;
  20203. CheckSource('TestPointer_TypeCastJSValueToPointer',
  20204. LinesToStr([ // statements
  20205. 'this.DoIt = function (args) {',
  20206. '};',
  20207. 'this.DoAll = function () {',
  20208. '};',
  20209. 'this.v = undefined;',
  20210. '']),
  20211. LinesToStr([ // $mod.$main
  20212. '$mod.DoIt([$mod.v]);',
  20213. '$mod.DoAll($mod.v);',
  20214. '']));
  20215. end;
  20216. procedure TTestModule.TestPointer_NonRecordFail;
  20217. begin
  20218. StartProgram(false);
  20219. Add([
  20220. 'type',
  20221. ' p = ^longint;',
  20222. 'begin',
  20223. '']);
  20224. SetExpectedPasResolverError('Not supported: pointer of Longint',nNotSupportedX);
  20225. ConvertProgram;
  20226. end;
  20227. procedure TTestModule.TestPointer_AnonymousArgTypeFail;
  20228. begin
  20229. StartProgram(false);
  20230. Add([
  20231. 'procedure DoIt(p: ^longint); begin end;',
  20232. 'begin',
  20233. '']);
  20234. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  20235. ConvertProgram;
  20236. end;
  20237. procedure TTestModule.TestPointer_AnonymousVarTypeFail;
  20238. begin
  20239. StartProgram(false);
  20240. Add([
  20241. 'var p: ^longint;',
  20242. 'begin',
  20243. '']);
  20244. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  20245. ConvertProgram;
  20246. end;
  20247. procedure TTestModule.TestPointer_AnonymousResultTypeFail;
  20248. begin
  20249. StartProgram(false);
  20250. Add([
  20251. 'function DoIt: ^longint; begin end;',
  20252. 'begin',
  20253. '']);
  20254. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  20255. ConvertProgram;
  20256. end;
  20257. procedure TTestModule.TestPointer_AddrOperatorFail;
  20258. begin
  20259. StartProgram(false);
  20260. Add([
  20261. 'var i: longint;',
  20262. 'begin',
  20263. ' if @i=nil then ;',
  20264. '']);
  20265. SetExpectedConverterError('illegal qualifier "@" in front of "i:Longint"',nIllegalQualifierInFrontOf);
  20266. ConvertProgram;
  20267. end;
  20268. procedure TTestModule.TestPointer_ArrayParamsFail;
  20269. begin
  20270. StartProgram(false);
  20271. Add([
  20272. 'var',
  20273. ' p: Pointer;',
  20274. 'begin',
  20275. ' p:=p[1];',
  20276. '']);
  20277. SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter);
  20278. ConvertProgram;
  20279. end;
  20280. procedure TTestModule.TestPointer_PointerAddFail;
  20281. begin
  20282. StartProgram(false);
  20283. Add([
  20284. 'var',
  20285. ' p: Pointer;',
  20286. 'begin',
  20287. ' p:=p+1;',
  20288. '']);
  20289. SetExpectedPasResolverError('Operator is not overloaded: "Pointer" + "Longint"',nOperatorIsNotOverloadedAOpB);
  20290. ConvertProgram;
  20291. end;
  20292. procedure TTestModule.TestPointer_IncPointerFail;
  20293. begin
  20294. StartProgram(false);
  20295. Add([
  20296. 'var',
  20297. ' p: Pointer;',
  20298. 'begin',
  20299. ' inc(p,1);',
  20300. '']);
  20301. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Pointer", expected "integer"',
  20302. nIncompatibleTypeArgNo);
  20303. ConvertProgram;
  20304. end;
  20305. procedure TTestModule.TestPointer_Record;
  20306. begin
  20307. StartProgram(false);
  20308. Add([
  20309. 'type',
  20310. ' TRec = record x: longint; end;',
  20311. ' PRec = ^TRec;',
  20312. 'var',
  20313. ' r: TRec;',
  20314. ' p: PRec;',
  20315. ' q: ^TRec;',
  20316. ' Ptr: pointer;',
  20317. 'begin',
  20318. ' new(p);',
  20319. ' p:=@r;',
  20320. ' r:=p^;',
  20321. ' r.x:=p^.x;',
  20322. ' p^.x:=r.x;',
  20323. ' if p^.x=3 then ;',
  20324. ' if 4=p^.x then ;',
  20325. ' dispose(p);',
  20326. ' new(q);',
  20327. ' dispose(q);',
  20328. ' Ptr:=p;',
  20329. ' p:=PRec(ptr);',
  20330. '']);
  20331. ConvertProgram;
  20332. CheckSource('TestPointer_Record',
  20333. LinesToStr([ // statements
  20334. 'rtl.recNewT($mod, "TRec", function () {',
  20335. ' this.x = 0;',
  20336. ' this.$eq = function (b) {',
  20337. ' return this.x === b.x;',
  20338. ' };',
  20339. ' this.$assign = function (s) {',
  20340. ' this.x = s.x;',
  20341. ' return this;',
  20342. ' };',
  20343. '});',
  20344. 'this.r = $mod.TRec.$new();',
  20345. 'this.p = null;',
  20346. 'this.q = null;',
  20347. 'this.Ptr = null;',
  20348. '']),
  20349. LinesToStr([ // $mod.$main
  20350. '$mod.p = $mod.TRec.$new();',
  20351. '$mod.p = $mod.r;',
  20352. '$mod.r.$assign($mod.p);',
  20353. '$mod.r.x = $mod.p.x;',
  20354. '$mod.p.x = $mod.r.x;',
  20355. 'if ($mod.p.x === 3) ;',
  20356. 'if (4 === $mod.p.x) ;',
  20357. '$mod.p = null;',
  20358. '$mod.q = $mod.TRec.$new();',
  20359. '$mod.q = null;',
  20360. '$mod.Ptr = $mod.p;',
  20361. '$mod.p = $mod.Ptr;',
  20362. '']));
  20363. end;
  20364. procedure TTestModule.TestPointer_RecordArg;
  20365. begin
  20366. StartProgram(false);
  20367. Add([
  20368. '{$modeswitch autoderef}',
  20369. 'type',
  20370. ' TRec = record x: longint; end;',
  20371. ' PRec = ^TRec;',
  20372. 'function DoIt(const a: PRec; var b: PRec; out c: PRec): TRec;',
  20373. 'begin',
  20374. ' a.x:=a.x;',
  20375. ' a^.x:=a^.x;',
  20376. ' with a^ do',
  20377. ' x:=x;',
  20378. 'end;',
  20379. 'function GetIt(p: PRec): PRec;',
  20380. 'begin',
  20381. ' p.x:=p.x;',
  20382. ' p^.x:=p^.x;',
  20383. ' with p^ do',
  20384. ' x:=x;',
  20385. 'end;',
  20386. 'var',
  20387. ' r: TRec;',
  20388. ' p: PRec;',
  20389. 'begin',
  20390. ' p:=GetIt(p);',
  20391. ' p^:=GetIt(@r)^;',
  20392. ' DoIt(p,p,p);',
  20393. ' DoIt(@r,p,p);',
  20394. '']);
  20395. ConvertProgram;
  20396. CheckSource('TestPointer_Record',
  20397. LinesToStr([ // statements
  20398. 'rtl.recNewT($mod, "TRec", function () {',
  20399. ' this.x = 0;',
  20400. ' this.$eq = function (b) {',
  20401. ' return this.x === b.x;',
  20402. ' };',
  20403. ' this.$assign = function (s) {',
  20404. ' this.x = s.x;',
  20405. ' return this;',
  20406. ' };',
  20407. '});',
  20408. 'this.DoIt = function (a, b, c) {',
  20409. ' var Result = $mod.TRec.$new();',
  20410. ' a.x = a.x;',
  20411. ' a.x = a.x;',
  20412. ' a.x = a.x;',
  20413. ' return Result;',
  20414. '};',
  20415. 'this.GetIt = function (p) {',
  20416. ' var Result = null;',
  20417. ' p.x = p.x;',
  20418. ' p.x = p.x;',
  20419. ' p.x = p.x;',
  20420. ' return Result;',
  20421. '};',
  20422. 'this.r = $mod.TRec.$new();',
  20423. 'this.p = null;',
  20424. '']),
  20425. LinesToStr([ // $mod.$main
  20426. '$mod.p = $mod.GetIt($mod.p);',
  20427. '$mod.p.$assign($mod.GetIt($mod.r));',
  20428. '$mod.DoIt($mod.p, {',
  20429. ' p: $mod,',
  20430. ' get: function () {',
  20431. ' return this.p.p;',
  20432. ' },',
  20433. ' set: function (v) {',
  20434. ' this.p.p = v;',
  20435. ' }',
  20436. '}, {',
  20437. ' p: $mod,',
  20438. ' get: function () {',
  20439. ' return this.p.p;',
  20440. ' },',
  20441. ' set: function (v) {',
  20442. ' this.p.p = v;',
  20443. ' }',
  20444. '});',
  20445. '$mod.DoIt($mod.r, {',
  20446. ' p: $mod,',
  20447. ' get: function () {',
  20448. ' return this.p.p;',
  20449. ' },',
  20450. ' set: function (v) {',
  20451. ' this.p.p = v;',
  20452. ' }',
  20453. '}, {',
  20454. ' p: $mod,',
  20455. ' get: function () {',
  20456. ' return this.p.p;',
  20457. ' },',
  20458. ' set: function (v) {',
  20459. ' this.p.p = v;',
  20460. ' }',
  20461. '});',
  20462. '']));
  20463. end;
  20464. procedure TTestModule.TestJSValue_AssignToJSValue;
  20465. begin
  20466. StartProgram(false);
  20467. Add('var');
  20468. Add(' v: jsvalue;');
  20469. Add(' i: longint;');
  20470. Add(' s: string;');
  20471. Add(' b: boolean;');
  20472. Add(' d: double;');
  20473. Add(' p: pointer;');
  20474. Add('begin');
  20475. Add(' v:=v;');
  20476. Add(' v:=1;');
  20477. Add(' v:=i;');
  20478. Add(' v:='''';');
  20479. Add(' v:=''c'';');
  20480. Add(' v:=''foo'';');
  20481. Add(' v:=s;');
  20482. Add(' v:=false;');
  20483. Add(' v:=true;');
  20484. Add(' v:=b;');
  20485. Add(' v:=0.1;');
  20486. Add(' v:=d;');
  20487. Add(' v:=nil;');
  20488. Add(' v:=p;');
  20489. ConvertProgram;
  20490. CheckSource('TestJSValue_AssignToJSValue',
  20491. LinesToStr([ // statements
  20492. 'this.v = undefined;',
  20493. 'this.i = 0;',
  20494. 'this.s = "";',
  20495. 'this.b = false;',
  20496. 'this.d = 0.0;',
  20497. 'this.p = null;',
  20498. '']),
  20499. LinesToStr([ // $mod.$main
  20500. '$mod.v = $mod.v;',
  20501. '$mod.v = 1;',
  20502. '$mod.v = $mod.i;',
  20503. '$mod.v = "";',
  20504. '$mod.v = "c";',
  20505. '$mod.v = "foo";',
  20506. '$mod.v = $mod.s;',
  20507. '$mod.v = false;',
  20508. '$mod.v = true;',
  20509. '$mod.v = $mod.b;',
  20510. '$mod.v = 0.1;',
  20511. '$mod.v = $mod.d;',
  20512. '$mod.v = null;',
  20513. '$mod.v = $mod.p;',
  20514. '']));
  20515. end;
  20516. procedure TTestModule.TestJSValue_TypeCastToBaseType;
  20517. begin
  20518. StartProgram(false);
  20519. Add('type');
  20520. Add(' integer = longint;');
  20521. Add(' TYesNo = boolean;');
  20522. Add(' TFloat = double;');
  20523. Add(' TCaption = string;');
  20524. Add(' TChar = char;');
  20525. Add('var');
  20526. Add(' v: jsvalue;');
  20527. Add(' i: integer;');
  20528. Add(' s: TCaption;');
  20529. Add(' b: TYesNo;');
  20530. Add(' d: TFloat;');
  20531. Add(' c: char;');
  20532. Add('begin');
  20533. Add(' i:=longint(v);');
  20534. Add(' i:=integer(v);');
  20535. Add(' s:=string(v);');
  20536. Add(' s:=TCaption(v);');
  20537. Add(' b:=boolean(v);');
  20538. Add(' b:=TYesNo(v);');
  20539. Add(' d:=double(v);');
  20540. Add(' d:=TFloat(v);');
  20541. Add(' c:=char(v);');
  20542. Add(' c:=TChar(v);');
  20543. ConvertProgram;
  20544. CheckSource('TestJSValue_TypeCastToBaseType',
  20545. LinesToStr([ // statements
  20546. 'this.v = undefined;',
  20547. 'this.i = 0;',
  20548. 'this.s = "";',
  20549. 'this.b = false;',
  20550. 'this.d = 0.0;',
  20551. 'this.c = "";',
  20552. '']),
  20553. LinesToStr([ // $mod.$main
  20554. '$mod.i = Math.floor($mod.v);',
  20555. '$mod.i = Math.floor($mod.v);',
  20556. '$mod.s = "" + $mod.v;',
  20557. '$mod.s = "" + $mod.v;',
  20558. '$mod.b = !($mod.v == false);',
  20559. '$mod.b = !($mod.v == false);',
  20560. '$mod.d = rtl.getNumber($mod.v);',
  20561. '$mod.d = rtl.getNumber($mod.v);',
  20562. '$mod.c = rtl.getChar($mod.v);',
  20563. '$mod.c = rtl.getChar($mod.v);',
  20564. '']));
  20565. end;
  20566. procedure TTestModule.TestJSValue_Equal;
  20567. begin
  20568. StartProgram(false);
  20569. Add('type');
  20570. Add(' integer = longint;');
  20571. Add(' TYesNo = boolean;');
  20572. Add(' TFloat = double;');
  20573. Add(' TCaption = string;');
  20574. Add(' TChar = char;');
  20575. Add(' TMulti = JSValue;');
  20576. Add('var');
  20577. Add(' v: jsvalue;');
  20578. Add(' i: integer;');
  20579. Add(' s: TCaption;');
  20580. Add(' b: TYesNo;');
  20581. Add(' d: TFloat;');
  20582. Add(' c: char;');
  20583. Add(' m: TMulti;');
  20584. Add('begin');
  20585. Add(' b:=v=v;');
  20586. Add(' b:=v<>v;');
  20587. Add(' b:=v=1;');
  20588. Add(' b:=v<>1;');
  20589. Add(' b:=2=v;');
  20590. Add(' b:=2<>v;');
  20591. Add(' b:=v=i;');
  20592. Add(' b:=i=v;');
  20593. Add(' b:=v=nil;');
  20594. Add(' b:=nil=v;');
  20595. Add(' b:=v=false;');
  20596. Add(' b:=true=v;');
  20597. Add(' b:=v=b;');
  20598. Add(' b:=b=v;');
  20599. Add(' b:=v=s;');
  20600. Add(' b:=s=v;');
  20601. Add(' b:=v=''foo'';');
  20602. Add(' b:=''''=v;');
  20603. Add(' b:=v=d;');
  20604. Add(' b:=d=v;');
  20605. Add(' b:=v=3.4;');
  20606. Add(' b:=5.6=v;');
  20607. Add(' b:=v=c;');
  20608. Add(' b:=c=v;');
  20609. Add(' b:=m=m;');
  20610. Add(' b:=v=m;');
  20611. Add(' b:=m=v;');
  20612. ConvertProgram;
  20613. CheckSource('TestJSValue_Equal',
  20614. LinesToStr([ // statements
  20615. 'this.v = undefined;',
  20616. 'this.i = 0;',
  20617. 'this.s = "";',
  20618. 'this.b = false;',
  20619. 'this.d = 0.0;',
  20620. 'this.c = "";',
  20621. 'this.m = undefined;',
  20622. '']),
  20623. LinesToStr([ // $mod.$main
  20624. '$mod.b = $mod.v == $mod.v;',
  20625. '$mod.b = $mod.v != $mod.v;',
  20626. '$mod.b = $mod.v == 1;',
  20627. '$mod.b = $mod.v != 1;',
  20628. '$mod.b = 2 == $mod.v;',
  20629. '$mod.b = 2 != $mod.v;',
  20630. '$mod.b = $mod.v == $mod.i;',
  20631. '$mod.b = $mod.i == $mod.v;',
  20632. '$mod.b = $mod.v == null;',
  20633. '$mod.b = null == $mod.v;',
  20634. '$mod.b = $mod.v == false;',
  20635. '$mod.b = true == $mod.v;',
  20636. '$mod.b = $mod.v == $mod.b;',
  20637. '$mod.b = $mod.b == $mod.v;',
  20638. '$mod.b = $mod.v == $mod.s;',
  20639. '$mod.b = $mod.s == $mod.v;',
  20640. '$mod.b = $mod.v == "foo";',
  20641. '$mod.b = "" == $mod.v;',
  20642. '$mod.b = $mod.v == $mod.d;',
  20643. '$mod.b = $mod.d == $mod.v;',
  20644. '$mod.b = $mod.v == 3.4;',
  20645. '$mod.b = 5.6 == $mod.v;',
  20646. '$mod.b = $mod.v == $mod.c;',
  20647. '$mod.b = $mod.c == $mod.v;',
  20648. '$mod.b = $mod.m == $mod.m;',
  20649. '$mod.b = $mod.v == $mod.m;',
  20650. '$mod.b = $mod.m == $mod.v;',
  20651. '']));
  20652. end;
  20653. procedure TTestModule.TestJSValue_If;
  20654. begin
  20655. StartProgram(false);
  20656. Add([
  20657. 'var',
  20658. ' v: jsvalue;',
  20659. 'begin',
  20660. ' if v then ;',
  20661. ' while v do ;',
  20662. ' repeat until v;',
  20663. '']);
  20664. ConvertProgram;
  20665. CheckSource('TestJSValue_If',
  20666. LinesToStr([ // statements
  20667. 'this.v = undefined;',
  20668. '']),
  20669. LinesToStr([ // $mod.$main
  20670. 'if ($mod.v) ;',
  20671. 'while($mod.v){',
  20672. '};',
  20673. 'do{',
  20674. '} while(!$mod.v);',
  20675. '']));
  20676. end;
  20677. procedure TTestModule.TestJSValue_Not;
  20678. begin
  20679. StartProgram(false);
  20680. Add([
  20681. 'var',
  20682. ' v: jsvalue;',
  20683. ' b: boolean;',
  20684. 'begin',
  20685. ' b:=not v;',
  20686. ' if not v then ;',
  20687. ' while not v do ;',
  20688. ' repeat until not v;',
  20689. '']);
  20690. ConvertProgram;
  20691. CheckSource('TestJSValue_If',
  20692. LinesToStr([ // statements
  20693. 'this.v = undefined;',
  20694. 'this.b = false;',
  20695. '']),
  20696. LinesToStr([ // $mod.$main
  20697. '$mod.b=!$mod.v;',
  20698. 'if (!$mod.v) ;',
  20699. 'while(!$mod.v){',
  20700. '};',
  20701. 'do{',
  20702. '} while($mod.v);',
  20703. '']));
  20704. end;
  20705. procedure TTestModule.TestJSValue_Enum;
  20706. begin
  20707. StartProgram(false);
  20708. Add('type');
  20709. Add(' TColor = (red, blue);');
  20710. Add(' TRedBlue = TColor;');
  20711. Add('var');
  20712. Add(' v: jsvalue;');
  20713. Add(' e: TColor;');
  20714. Add('begin');
  20715. Add(' v:=e;');
  20716. Add(' v:=TColor(e);');
  20717. Add(' v:=TRedBlue(e);');
  20718. Add(' e:=TColor(v);');
  20719. Add(' e:=TRedBlue(v);');
  20720. ConvertProgram;
  20721. CheckSource('TestJSValue_Enum',
  20722. LinesToStr([ // statements
  20723. 'this.TColor = {',
  20724. ' "0": "red",',
  20725. ' red: 0,',
  20726. ' "1": "blue",',
  20727. ' blue: 1',
  20728. '};',
  20729. 'this.v = undefined;',
  20730. 'this.e = 0;',
  20731. '']),
  20732. LinesToStr([ // $mod.$main
  20733. '$mod.v = $mod.e;',
  20734. '$mod.v = $mod.e;',
  20735. '$mod.v = $mod.e;',
  20736. '$mod.e = $mod.v;',
  20737. '$mod.e = $mod.v;',
  20738. '']));
  20739. end;
  20740. procedure TTestModule.TestJSValue_ClassInstance;
  20741. begin
  20742. StartProgram(false);
  20743. Add([
  20744. 'type',
  20745. ' TObject = class',
  20746. ' end;',
  20747. ' TBirdObject = TObject;',
  20748. 'var',
  20749. ' v: jsvalue;',
  20750. ' o: TObject;',
  20751. 'begin',
  20752. ' v:=o;',
  20753. ' v:=TObject(o);',
  20754. ' v:=TBirdObject(o);',
  20755. ' o:=TObject(v);',
  20756. ' o:=TBirdObject(v);',
  20757. ' if v is TObject then ;',
  20758. '']);
  20759. ConvertProgram;
  20760. CheckSource('TestJSValue_ClassInstance',
  20761. LinesToStr([ // statements
  20762. 'rtl.createClass($mod, "TObject", null, function () {',
  20763. ' this.$init = function () {',
  20764. ' };',
  20765. ' this.$final = function () {',
  20766. ' };',
  20767. '});',
  20768. 'this.v = undefined;',
  20769. 'this.o = null;',
  20770. '']),
  20771. LinesToStr([ // $mod.$main
  20772. '$mod.v = $mod.o;',
  20773. '$mod.v = $mod.o;',
  20774. '$mod.v = $mod.o;',
  20775. '$mod.o = rtl.getObject($mod.v);',
  20776. '$mod.o = rtl.getObject($mod.v);',
  20777. 'if (rtl.isExt($mod.v, $mod.TObject, 1)) ;',
  20778. '']));
  20779. end;
  20780. procedure TTestModule.TestJSValue_ClassOf;
  20781. begin
  20782. StartProgram(false);
  20783. Add([
  20784. 'type',
  20785. ' TClass = class of TObject;',
  20786. ' TObject = class',
  20787. ' end;',
  20788. ' TBirds = class of TBird;',
  20789. ' TBird = class(TObject) end;',
  20790. 'var',
  20791. ' v: jsvalue;',
  20792. ' c: TClass;',
  20793. 'begin',
  20794. ' v:=c;',
  20795. ' v:=TObject;',
  20796. ' v:=TClass(c);',
  20797. ' v:=TBirds(c);',
  20798. ' c:=TClass(v);',
  20799. ' c:=TBirds(v);',
  20800. ' if v is TClass then ;',
  20801. '']);
  20802. ConvertProgram;
  20803. CheckSource('TestJSValue_ClassOf',
  20804. LinesToStr([ // statements
  20805. 'rtl.createClass($mod, "TObject", null, function () {',
  20806. ' this.$init = function () {',
  20807. ' };',
  20808. ' this.$final = function () {',
  20809. ' };',
  20810. '});',
  20811. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  20812. '});',
  20813. 'this.v = undefined;',
  20814. 'this.c = null;',
  20815. '']),
  20816. LinesToStr([ // $mod.$main
  20817. '$mod.v = $mod.c;',
  20818. '$mod.v = $mod.TObject;',
  20819. '$mod.v = $mod.c;',
  20820. '$mod.v = $mod.c;',
  20821. '$mod.c = rtl.getObject($mod.v);',
  20822. '$mod.c = rtl.getObject($mod.v);',
  20823. 'if (rtl.isExt($mod.v, $mod.TObject, 2)) ;',
  20824. '']));
  20825. end;
  20826. procedure TTestModule.TestJSValue_ArrayOfJSValue;
  20827. begin
  20828. StartProgram(false);
  20829. Add([
  20830. 'type',
  20831. ' integer = longint;',
  20832. ' TArray = array of JSValue;',
  20833. ' TArrgh = tarray;',
  20834. ' TArrInt = array of integer;',
  20835. 'var',
  20836. ' v: jsvalue;',
  20837. ' TheArray: tarray = (1,''2'');',
  20838. ' Arr: tarrgh;',
  20839. ' i: integer;',
  20840. ' ArrInt: tarrint;',
  20841. 'begin',
  20842. ' arr:=thearray;',
  20843. ' thearray:=arr;',
  20844. ' setlength(arr,2);',
  20845. ' setlength(thearray,3);',
  20846. ' arr[4]:=v;',
  20847. ' arr[5]:=length(thearray);',
  20848. ' arr[6]:=nil;',
  20849. ' arr[7]:=thearray[8];',
  20850. ' arr[low(arr)]:=high(thearray);',
  20851. ' arr:=arrint;',
  20852. ' arrInt:=tarrint(arr);',
  20853. ' if TheArray = nil then ;',
  20854. ' if nil = TheArray then ;',
  20855. ' if TheArray <> nil then ;',
  20856. ' if nil <> TheArray then ;',
  20857. '']);
  20858. ConvertProgram;
  20859. CheckSource('TestJSValue_ArrayOfJSValue',
  20860. LinesToStr([ // statements
  20861. 'this.v = undefined;',
  20862. 'this.TheArray = [1, "2"];',
  20863. 'this.Arr = [];',
  20864. 'this.i = 0;',
  20865. 'this.ArrInt = [];',
  20866. '']),
  20867. LinesToStr([ // $mod.$main
  20868. '$mod.Arr = $mod.TheArray;',
  20869. '$mod.TheArray = $mod.Arr;',
  20870. '$mod.Arr = rtl.arraySetLength($mod.Arr,undefined,2);',
  20871. '$mod.TheArray = rtl.arraySetLength($mod.TheArray,undefined,3);',
  20872. '$mod.Arr[4] = $mod.v;',
  20873. '$mod.Arr[5] = rtl.length($mod.TheArray);',
  20874. '$mod.Arr[6] = null;',
  20875. '$mod.Arr[7] = $mod.TheArray[8];',
  20876. '$mod.Arr[0] = rtl.length($mod.TheArray) - 1;',
  20877. '$mod.Arr = $mod.ArrInt;',
  20878. '$mod.ArrInt = $mod.Arr;',
  20879. 'if (rtl.length($mod.TheArray) === 0) ;',
  20880. 'if (rtl.length($mod.TheArray) === 0) ;',
  20881. 'if (rtl.length($mod.TheArray) > 0) ;',
  20882. 'if (rtl.length($mod.TheArray) > 0) ;',
  20883. '']));
  20884. end;
  20885. procedure TTestModule.TestJSValue_ArrayLit;
  20886. begin
  20887. StartProgram(false);
  20888. Add([
  20889. 'type',
  20890. ' TFlag = (big,small);',
  20891. ' TArray = array of JSValue;',
  20892. ' TObject = class end;',
  20893. ' TClass = class of TObject;',
  20894. 'var',
  20895. ' v: jsvalue;',
  20896. ' a: TArray;',
  20897. ' o: TObject;',
  20898. 'begin',
  20899. ' a:=[];',
  20900. ' a:=[1];',
  20901. ' a:=[1,2];',
  20902. ' a:=[big];',
  20903. ' a:=[1,big];',
  20904. ' a:=[o,nil];',
  20905. '']);
  20906. ConvertProgram;
  20907. CheckSource('TestJSValue_ArrayLit',
  20908. LinesToStr([ // statements
  20909. 'this.TFlag = {',
  20910. ' "0": "big",',
  20911. ' big: 0,',
  20912. ' "1": "small",',
  20913. ' small: 1',
  20914. '};',
  20915. 'rtl.createClass($mod, "TObject", null, function () {',
  20916. ' this.$init = function () {',
  20917. ' };',
  20918. ' this.$final = function () {',
  20919. ' };',
  20920. '});',
  20921. 'this.v = undefined;',
  20922. 'this.a = [];',
  20923. 'this.o = null;',
  20924. '']),
  20925. LinesToStr([ // $mod.$main
  20926. '$mod.a = [];',
  20927. '$mod.a = [1];',
  20928. '$mod.a = [1, 2];',
  20929. '$mod.a = [$mod.TFlag.big];',
  20930. '$mod.a = [1, $mod.TFlag.big];',
  20931. '$mod.a = [$mod.o, null];',
  20932. '']));
  20933. end;
  20934. procedure TTestModule.TestJSValue_Params;
  20935. begin
  20936. StartProgram(false);
  20937. Add('type');
  20938. Add(' integer = longint;');
  20939. Add(' TYesNo = boolean;');
  20940. Add(' TFloat = double;');
  20941. Add(' TCaption = string;');
  20942. Add(' TChar = char;');
  20943. Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
  20944. Add('var');
  20945. Add(' l: jsvalue;');
  20946. Add('begin');
  20947. Add(' a:=a;');
  20948. Add(' l:=b;');
  20949. Add(' c:=c;');
  20950. Add(' d:=d;');
  20951. Add(' Result:=l;');
  20952. Add('end;');
  20953. Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
  20954. Add('var');
  20955. Add(' v: jsvalue;');
  20956. Add(' i: integer;');
  20957. Add(' b: TYesNo;');
  20958. Add(' d: TFloat;');
  20959. Add(' s: TCaption;');
  20960. Add(' c: TChar;');
  20961. Add('begin');
  20962. Add(' v:=doit(v,v,v,v);');
  20963. Add(' i:=integer(dosome(i,i));');
  20964. Add(' b:=TYesNo(dosome(b,b));');
  20965. Add(' d:=TFloat(dosome(d,d));');
  20966. Add(' s:=TCaption(dosome(s,s));');
  20967. Add(' c:=TChar(dosome(c,c));');
  20968. ConvertProgram;
  20969. CheckSource('TestJSValue_Params',
  20970. LinesToStr([ // statements
  20971. 'this.DoIt = function (a, b, c, d) {',
  20972. ' var Result = undefined;',
  20973. ' var l = undefined;',
  20974. ' a = a;',
  20975. ' l = b;',
  20976. ' c.set(c.get());',
  20977. ' d.set(d.get());',
  20978. ' Result = l;',
  20979. ' return Result;',
  20980. '};',
  20981. 'this.DoSome = function (a, b) {',
  20982. ' var Result = undefined;',
  20983. ' return Result;',
  20984. '};',
  20985. 'this.v = undefined;',
  20986. 'this.i = 0;',
  20987. 'this.b = false;',
  20988. 'this.d = 0.0;',
  20989. 'this.s = "";',
  20990. 'this.c = "";',
  20991. '']),
  20992. LinesToStr([ // $mod.$main
  20993. '$mod.v = $mod.DoIt($mod.v, $mod.v, {',
  20994. ' p: $mod,',
  20995. ' get: function () {',
  20996. ' return this.p.v;',
  20997. ' },',
  20998. ' set: function (v) {',
  20999. ' this.p.v = v;',
  21000. ' }',
  21001. '}, {',
  21002. ' p: $mod,',
  21003. ' get: function () {',
  21004. ' return this.p.v;',
  21005. ' },',
  21006. ' set: function (v) {',
  21007. ' this.p.v = v;',
  21008. ' }',
  21009. '});',
  21010. '$mod.i = Math.floor($mod.DoSome($mod.i, $mod.i));',
  21011. '$mod.b = !($mod.DoSome($mod.b, $mod.b) == false);',
  21012. '$mod.d = rtl.getNumber($mod.DoSome($mod.d, $mod.d));',
  21013. '$mod.s = "" + $mod.DoSome($mod.s, $mod.s);',
  21014. '$mod.c = rtl.getChar($mod.DoSome($mod.c, $mod.c));',
  21015. '']));
  21016. end;
  21017. procedure TTestModule.TestJSValue_UntypedParam;
  21018. begin
  21019. StartProgram(false);
  21020. Add('function DoIt(const a; var b; out c): jsvalue;');
  21021. Add('begin');
  21022. Add(' Result:=a;');
  21023. Add(' Result:=b;');
  21024. Add(' Result:=c;');
  21025. Add(' b:=Result;');
  21026. Add(' c:=Result;');
  21027. Add('end;');
  21028. Add('var i: longint;');
  21029. Add('begin');
  21030. Add(' doit(i,i,i);');
  21031. ConvertProgram;
  21032. CheckSource('TestJSValue_UntypedParam',
  21033. LinesToStr([ // statements
  21034. 'this.DoIt = function (a, b, c) {',
  21035. ' var Result = undefined;',
  21036. ' Result = a;',
  21037. ' Result = b.get();',
  21038. ' Result = c.get();',
  21039. ' b.set(Result);',
  21040. ' c.set(Result);',
  21041. ' return Result;',
  21042. '};',
  21043. 'this.i = 0;',
  21044. '']),
  21045. LinesToStr([ // $mod.$main
  21046. '$mod.DoIt($mod.i, {',
  21047. ' p: $mod,',
  21048. ' get: function () {',
  21049. ' return this.p.i;',
  21050. ' },',
  21051. ' set: function (v) {',
  21052. ' this.p.i = v;',
  21053. ' }',
  21054. '}, {',
  21055. ' p: $mod,',
  21056. ' get: function () {',
  21057. ' return this.p.i;',
  21058. ' },',
  21059. ' set: function (v) {',
  21060. ' this.p.i = v;',
  21061. ' }',
  21062. '});',
  21063. '']));
  21064. end;
  21065. procedure TTestModule.TestJSValue_FuncResultType;
  21066. begin
  21067. StartProgram(false);
  21068. Add('type');
  21069. Add(' integer = longint;');
  21070. Add(' TJSValueArray = array of JSValue;');
  21071. Add(' TListSortCompare = function(Item1, Item2: JSValue): Integer;');
  21072. Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
  21073. Add('begin');
  21074. Add(' while Compare(P,aList[0])>0 do ;');
  21075. Add('end;');
  21076. Add('var');
  21077. Add(' Compare: TListSortCompare;');
  21078. Add(' V: JSValue;');
  21079. Add(' i: integer;');
  21080. Add('begin');
  21081. Add(' if Compare(V,V)>0 then ;');
  21082. Add(' if Compare(i,i)>1 then ;');
  21083. Add(' if Compare(nil,false)>2 then ;');
  21084. Add(' if Compare(1,true)>3 then ;');
  21085. ConvertProgram;
  21086. CheckSource('TestJSValue_UntypedParam',
  21087. LinesToStr([ // statements
  21088. 'this.Sort = function (P, aList, Compare) {',
  21089. ' while (Compare(P, aList[0]) > 0) {',
  21090. ' };',
  21091. '};',
  21092. 'this.Compare = null;',
  21093. 'this.V = undefined;',
  21094. 'this.i = 0;',
  21095. '']),
  21096. LinesToStr([ // $mod.$main
  21097. 'if ($mod.Compare($mod.V, $mod.V) > 0) ;',
  21098. 'if ($mod.Compare($mod.i, $mod.i) > 1) ;',
  21099. 'if ($mod.Compare(null, false) > 2) ;',
  21100. 'if ($mod.Compare(1, true) > 3) ;',
  21101. '']));
  21102. end;
  21103. procedure TTestModule.TestJSValue_ProcType_Assign;
  21104. begin
  21105. StartProgram(false);
  21106. Add('type');
  21107. Add(' integer = longint;');
  21108. Add(' TObject = class');
  21109. Add(' class function GetGlob: integer;');
  21110. Add(' function Getter: integer;');
  21111. Add(' end;');
  21112. Add('class function TObject.GetGlob: integer;');
  21113. Add('var v1: jsvalue;');
  21114. Add('begin');
  21115. Add(' v1:=@GetGlob;');
  21116. Add(' v1:[email protected];');
  21117. Add('end;');
  21118. Add('function TObject.Getter: integer;');
  21119. Add('var v2: jsvalue;');
  21120. Add('begin');
  21121. Add(' v2:=@Getter;');
  21122. Add(' v2:[email protected];');
  21123. Add(' v2:=@GetGlob;');
  21124. Add(' v2:[email protected];');
  21125. Add('end;');
  21126. Add('function GetIt(i: integer): integer;');
  21127. Add('var v3: jsvalue;');
  21128. Add('begin');
  21129. Add(' v3:=@GetIt;');
  21130. Add('end;');
  21131. Add('var');
  21132. Add(' V: JSValue;');
  21133. Add(' o: TObject;');
  21134. Add('begin');
  21135. Add(' v:=@GetIt;');
  21136. Add(' v:[email protected];');
  21137. Add(' v:[email protected];');
  21138. ConvertProgram;
  21139. CheckSource('TestJSValue_ProcType_Assign',
  21140. LinesToStr([ // statements
  21141. 'rtl.createClass($mod, "TObject", null, function () {',
  21142. ' this.$init = function () {',
  21143. ' };',
  21144. ' this.$final = function () {',
  21145. ' };',
  21146. ' this.GetGlob = function () {',
  21147. ' var Result = 0;',
  21148. ' var v1 = undefined;',
  21149. ' v1 = rtl.createCallback(this, "GetGlob");',
  21150. ' v1 = rtl.createCallback(this, "GetGlob");',
  21151. ' return Result;',
  21152. ' };',
  21153. ' this.Getter = function () {',
  21154. ' var Result = 0;',
  21155. ' var v2 = undefined;',
  21156. ' v2 = rtl.createCallback(this, "Getter");',
  21157. ' v2 = rtl.createCallback(this, "Getter");',
  21158. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  21159. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  21160. ' return Result;',
  21161. ' };',
  21162. '});',
  21163. 'this.GetIt = function (i) {',
  21164. ' var Result = 0;',
  21165. ' var v3 = undefined;',
  21166. ' v3 = $mod.GetIt;',
  21167. ' return Result;',
  21168. '};',
  21169. 'this.V = undefined;',
  21170. 'this.o = null;',
  21171. '']),
  21172. LinesToStr([ // $mod.$main
  21173. '$mod.V = $mod.GetIt;',
  21174. '$mod.V = rtl.createCallback($mod.o, "Getter");',
  21175. '$mod.V = rtl.createCallback($mod.o.$class, "GetGlob");',
  21176. '']));
  21177. end;
  21178. procedure TTestModule.TestJSValue_ProcType_Equal;
  21179. begin
  21180. StartProgram(false);
  21181. Add('type');
  21182. Add(' integer = longint;');
  21183. Add(' TObject = class');
  21184. Add(' class function GetGlob: integer;');
  21185. Add(' function Getter: integer;');
  21186. Add(' end;');
  21187. Add('class function TObject.GetGlob: integer;');
  21188. Add('var v1: jsvalue;');
  21189. Add('begin');
  21190. Add(' if v1=@GetGlob then;');
  21191. Add(' if [email protected] then ;');
  21192. Add('end;');
  21193. Add('function TObject.Getter: integer;');
  21194. Add('var v2: jsvalue;');
  21195. Add('begin');
  21196. Add(' if v2=@Getter then;');
  21197. Add(' if [email protected] then ;');
  21198. Add(' if v2=@GetGlob then;');
  21199. Add(' if [email protected] then;');
  21200. Add('end;');
  21201. Add('function GetIt(i: integer): integer;');
  21202. Add('var v3: jsvalue;');
  21203. Add('begin');
  21204. Add(' if v3=@GetIt then;');
  21205. Add('end;');
  21206. Add('var');
  21207. Add(' V: JSValue;');
  21208. Add(' o: TObject;');
  21209. Add('begin');
  21210. Add(' if v=@GetIt then;');
  21211. Add(' if [email protected] then;');
  21212. Add(' if [email protected] then;');
  21213. Add(' if @GetIt=v then;');
  21214. Add(' if @o.Getter=v then;');
  21215. Add(' if @o.GetGlob=v then;');
  21216. ConvertProgram;
  21217. CheckSource('TestJSValue_ProcType_Equal',
  21218. LinesToStr([ // statements
  21219. 'rtl.createClass($mod, "TObject", null, function () {',
  21220. ' this.$init = function () {',
  21221. ' };',
  21222. ' this.$final = function () {',
  21223. ' };',
  21224. ' this.GetGlob = function () {',
  21225. ' var Result = 0;',
  21226. ' var v1 = undefined;',
  21227. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  21228. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  21229. ' return Result;',
  21230. ' };',
  21231. ' this.Getter = function () {',
  21232. ' var Result = 0;',
  21233. ' var v2 = undefined;',
  21234. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  21235. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  21236. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  21237. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  21238. ' return Result;',
  21239. ' };',
  21240. '});',
  21241. 'this.GetIt = function (i) {',
  21242. ' var Result = 0;',
  21243. ' var v3 = undefined;',
  21244. ' if (rtl.eqCallback(v3, $mod.GetIt)) ;',
  21245. ' return Result;',
  21246. '};',
  21247. 'this.V = undefined;',
  21248. 'this.o = null;',
  21249. '']),
  21250. LinesToStr([ // $mod.$main
  21251. 'if (rtl.eqCallback($mod.V, $mod.GetIt)) ;',
  21252. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o, "Getter"))) ;',
  21253. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o.$class, "GetGlob"))) ;',
  21254. 'if (rtl.eqCallback($mod.GetIt, $mod.V)) ;',
  21255. 'if (rtl.eqCallback(rtl.createCallback($mod.o, "Getter"), $mod.V)) ;',
  21256. 'if (rtl.eqCallback(rtl.createCallback($mod.o.$class, "GetGlob"), $mod.V)) ;',
  21257. '']));
  21258. end;
  21259. procedure TTestModule.TestJSValue_ProcType_Param;
  21260. begin
  21261. StartProgram(false);
  21262. Add([
  21263. 'type',
  21264. ' variant = jsvalue;',
  21265. ' TArrVariant = array of variant;',
  21266. ' TArrVar2 = TArrVariant;',
  21267. ' TFuncInt = function: longint;',
  21268. 'function GetIt: longint;',
  21269. 'begin',
  21270. 'end;',
  21271. 'procedure DoIt(p: jsvalue; Arr: TArrVar2);',
  21272. 'var v: variant;',
  21273. 'begin',
  21274. ' v:=arr[1];',
  21275. 'end;',
  21276. 'var s: string;',
  21277. 'begin',
  21278. ' DoIt(GetIt,[]);',
  21279. ' DoIt(@GetIt,[]);',
  21280. ' DoIt(1,[s,GetIt]);',
  21281. ' DoIt(1,[s,@GetIt]);',
  21282. '']);
  21283. ConvertProgram;
  21284. CheckSource('TestJSValue_ProcType_Param',
  21285. LinesToStr([ // statements
  21286. 'this.GetIt = function () {',
  21287. ' var Result = 0;',
  21288. ' return Result;',
  21289. '};',
  21290. 'this.DoIt = function (p, Arr) {',
  21291. ' var v = undefined;',
  21292. ' v = Arr[1];',
  21293. '};',
  21294. 'this.s = "";',
  21295. '']),
  21296. LinesToStr([ // $mod.$main
  21297. '$mod.DoIt($mod.GetIt(), []);',
  21298. '$mod.DoIt($mod.GetIt, []);',
  21299. '$mod.DoIt(1, [$mod.s, $mod.GetIt()]);',
  21300. '$mod.DoIt(1, [$mod.s, $mod.GetIt]);',
  21301. '']));
  21302. end;
  21303. procedure TTestModule.TestJSValue_AssignToPointerFail;
  21304. begin
  21305. StartProgram(false);
  21306. Add([
  21307. 'var',
  21308. ' v: JSValue;',
  21309. ' p: Pointer;',
  21310. 'begin',
  21311. ' p:=v;',
  21312. '']);
  21313. SetExpectedPasResolverError('Incompatible types: got "JSValue" expected "Pointer"',
  21314. nIncompatibleTypesGotExpected);
  21315. ConvertProgram;
  21316. end;
  21317. procedure TTestModule.TestJSValue_OverloadDouble;
  21318. begin
  21319. StartProgram(false);
  21320. Add([
  21321. 'type',
  21322. ' integer = longint;',
  21323. ' tdatetime = double;',
  21324. 'procedure DoIt(d: double); begin end;',
  21325. 'procedure DoIt(v: jsvalue); begin end;',
  21326. 'var',
  21327. ' d: double;',
  21328. ' dt: tdatetime;',
  21329. ' i: integer;',
  21330. ' b: byte;',
  21331. ' shi: shortint;',
  21332. ' w: word;',
  21333. ' smi: smallint;',
  21334. ' lw: longword;',
  21335. ' li: longint;',
  21336. ' ni: nativeint;',
  21337. ' nu: nativeuint;',
  21338. 'begin',
  21339. ' DoIt(d);',
  21340. ' DoIt(dt);',
  21341. ' DoIt(i);',
  21342. ' DoIt(b);',
  21343. ' DoIt(shi);',
  21344. ' DoIt(w);',
  21345. ' DoIt(smi);',
  21346. ' DoIt(lw);',
  21347. ' DoIt(li);',
  21348. ' DoIt(ni);',
  21349. ' DoIt(nu);',
  21350. '']);
  21351. ConvertProgram;
  21352. CheckSource('TestJSValue_OverloadDouble',
  21353. LinesToStr([ // statements
  21354. 'this.DoIt = function (d) {',
  21355. '};',
  21356. 'this.DoIt$1 = function (v) {',
  21357. '};',
  21358. 'this.d = 0.0;',
  21359. 'this.dt = 0.0;',
  21360. 'this.i = 0;',
  21361. 'this.b = 0;',
  21362. 'this.shi = 0;',
  21363. 'this.w = 0;',
  21364. 'this.smi = 0;',
  21365. 'this.lw = 0;',
  21366. 'this.li = 0;',
  21367. 'this.ni = 0;',
  21368. 'this.nu = 0;',
  21369. '']),
  21370. LinesToStr([ // $mod.$main
  21371. '$mod.DoIt($mod.d);',
  21372. '$mod.DoIt($mod.dt);',
  21373. '$mod.DoIt$1($mod.i);',
  21374. '$mod.DoIt$1($mod.b);',
  21375. '$mod.DoIt$1($mod.shi);',
  21376. '$mod.DoIt$1($mod.w);',
  21377. '$mod.DoIt$1($mod.smi);',
  21378. '$mod.DoIt$1($mod.lw);',
  21379. '$mod.DoIt$1($mod.li);',
  21380. '$mod.DoIt$1($mod.ni);',
  21381. '$mod.DoIt$1($mod.nu);',
  21382. '']));
  21383. end;
  21384. procedure TTestModule.TestJSValue_OverloadNativeInt;
  21385. begin
  21386. StartProgram(false);
  21387. Add([
  21388. 'type',
  21389. ' integer = longint;',
  21390. ' int53 = nativeint;',
  21391. ' tdatetime = double;',
  21392. 'procedure DoIt(n: nativeint); begin end;',
  21393. 'procedure DoIt(v: jsvalue); begin end;',
  21394. 'var',
  21395. ' d: double;',
  21396. ' dt: tdatetime;',
  21397. ' i: integer;',
  21398. ' b: byte;',
  21399. ' shi: shortint;',
  21400. ' w: word;',
  21401. ' smi: smallint;',
  21402. ' lw: longword;',
  21403. ' li: longint;',
  21404. ' ni: nativeint;',
  21405. ' nu: nativeuint;',
  21406. 'begin',
  21407. ' DoIt(d);',
  21408. ' DoIt(dt);',
  21409. ' DoIt(i);',
  21410. ' DoIt(b);',
  21411. ' DoIt(shi);',
  21412. ' DoIt(w);',
  21413. ' DoIt(smi);',
  21414. ' DoIt(lw);',
  21415. ' DoIt(li);',
  21416. ' DoIt(ni);',
  21417. ' DoIt(nu);',
  21418. '']);
  21419. ConvertProgram;
  21420. CheckSource('TestJSValue_OverloadNativeInt',
  21421. LinesToStr([ // statements
  21422. 'this.DoIt = function (n) {',
  21423. '};',
  21424. 'this.DoIt$1 = function (v) {',
  21425. '};',
  21426. 'this.d = 0.0;',
  21427. 'this.dt = 0.0;',
  21428. 'this.i = 0;',
  21429. 'this.b = 0;',
  21430. 'this.shi = 0;',
  21431. 'this.w = 0;',
  21432. 'this.smi = 0;',
  21433. 'this.lw = 0;',
  21434. 'this.li = 0;',
  21435. 'this.ni = 0;',
  21436. 'this.nu = 0;',
  21437. '']),
  21438. LinesToStr([ // $mod.$main
  21439. '$mod.DoIt$1($mod.d);',
  21440. '$mod.DoIt$1($mod.dt);',
  21441. '$mod.DoIt($mod.i);',
  21442. '$mod.DoIt($mod.b);',
  21443. '$mod.DoIt($mod.shi);',
  21444. '$mod.DoIt($mod.w);',
  21445. '$mod.DoIt($mod.smi);',
  21446. '$mod.DoIt($mod.lw);',
  21447. '$mod.DoIt($mod.li);',
  21448. '$mod.DoIt($mod.ni);',
  21449. '$mod.DoIt($mod.nu);',
  21450. '']));
  21451. end;
  21452. procedure TTestModule.TestJSValue_OverloadWord;
  21453. begin
  21454. StartProgram(false);
  21455. Add([
  21456. 'type',
  21457. ' integer = longint;',
  21458. ' int53 = nativeint;',
  21459. ' tdatetime = double;',
  21460. 'procedure DoIt(w: word); begin end;',
  21461. 'procedure DoIt(v: jsvalue); begin end;',
  21462. 'var',
  21463. ' d: double;',
  21464. ' dt: tdatetime;',
  21465. ' i: integer;',
  21466. ' b: byte;',
  21467. ' shi: shortint;',
  21468. ' w: word;',
  21469. ' smi: smallint;',
  21470. ' lw: longword;',
  21471. ' li: longint;',
  21472. ' ni: nativeint;',
  21473. ' nu: nativeuint;',
  21474. 'begin',
  21475. ' DoIt(d);',
  21476. ' DoIt(dt);',
  21477. ' DoIt(i);',
  21478. ' DoIt(b);',
  21479. ' DoIt(shi);',
  21480. ' DoIt(w);',
  21481. ' DoIt(smi);',
  21482. ' DoIt(lw);',
  21483. ' DoIt(li);',
  21484. ' DoIt(ni);',
  21485. ' DoIt(nu);',
  21486. '']);
  21487. ConvertProgram;
  21488. CheckSource('TestJSValue_OverloadWord',
  21489. LinesToStr([ // statements
  21490. 'this.DoIt = function (w) {',
  21491. '};',
  21492. 'this.DoIt$1 = function (v) {',
  21493. '};',
  21494. 'this.d = 0.0;',
  21495. 'this.dt = 0.0;',
  21496. 'this.i = 0;',
  21497. 'this.b = 0;',
  21498. 'this.shi = 0;',
  21499. 'this.w = 0;',
  21500. 'this.smi = 0;',
  21501. 'this.lw = 0;',
  21502. 'this.li = 0;',
  21503. 'this.ni = 0;',
  21504. 'this.nu = 0;',
  21505. '']),
  21506. LinesToStr([ // $mod.$main
  21507. '$mod.DoIt$1($mod.d);',
  21508. '$mod.DoIt$1($mod.dt);',
  21509. '$mod.DoIt$1($mod.i);',
  21510. '$mod.DoIt($mod.b);',
  21511. '$mod.DoIt($mod.shi);',
  21512. '$mod.DoIt($mod.w);',
  21513. '$mod.DoIt$1($mod.smi);',
  21514. '$mod.DoIt$1($mod.lw);',
  21515. '$mod.DoIt$1($mod.li);',
  21516. '$mod.DoIt$1($mod.ni);',
  21517. '$mod.DoIt$1($mod.nu);',
  21518. '']));
  21519. end;
  21520. procedure TTestModule.TestJSValue_OverloadString;
  21521. begin
  21522. StartProgram(false);
  21523. Add([
  21524. 'type',
  21525. ' uni = string;',
  21526. ' WChar = char;',
  21527. 'procedure DoIt(s: string); begin end;',
  21528. 'procedure DoIt(v: jsvalue); begin end;',
  21529. 'var',
  21530. ' s: string;',
  21531. ' c: char;',
  21532. ' u: uni;',
  21533. 'begin',
  21534. ' DoIt(s);',
  21535. ' DoIt(c);',
  21536. ' DoIt(u);',
  21537. '']);
  21538. ConvertProgram;
  21539. CheckSource('TestJSValue_OverloadString',
  21540. LinesToStr([ // statements
  21541. 'this.DoIt = function (s) {',
  21542. '};',
  21543. 'this.DoIt$1 = function (v) {',
  21544. '};',
  21545. 'this.s = "";',
  21546. 'this.c = "";',
  21547. 'this.u = "";',
  21548. '']),
  21549. LinesToStr([ // $mod.$main
  21550. '$mod.DoIt($mod.s);',
  21551. '$mod.DoIt($mod.c);',
  21552. '$mod.DoIt($mod.u);',
  21553. '']));
  21554. end;
  21555. procedure TTestModule.TestJSValue_OverloadChar;
  21556. begin
  21557. StartProgram(false);
  21558. Add([
  21559. 'type',
  21560. ' uni = string;',
  21561. ' WChar = char;',
  21562. 'procedure DoIt(c: char); begin end;',
  21563. 'procedure DoIt(v: jsvalue); begin end;',
  21564. 'var',
  21565. ' s: string;',
  21566. ' c: char;',
  21567. ' u: uni;',
  21568. 'begin',
  21569. ' DoIt(s);',
  21570. ' DoIt(c);',
  21571. ' DoIt(u);',
  21572. '']);
  21573. ConvertProgram;
  21574. CheckSource('TestJSValue_OverloadChar',
  21575. LinesToStr([ // statements
  21576. 'this.DoIt = function (c) {',
  21577. '};',
  21578. 'this.DoIt$1 = function (v) {',
  21579. '};',
  21580. 'this.s = "";',
  21581. 'this.c = "";',
  21582. 'this.u = "";',
  21583. '']),
  21584. LinesToStr([ // $mod.$main
  21585. '$mod.DoIt$1($mod.s);',
  21586. '$mod.DoIt($mod.c);',
  21587. '$mod.DoIt$1($mod.u);',
  21588. '']));
  21589. end;
  21590. procedure TTestModule.TestJSValue_OverloadPointer;
  21591. begin
  21592. StartProgram(false);
  21593. Add([
  21594. 'type',
  21595. ' TObject = class end;',
  21596. 'procedure DoIt(p: pointer); begin end;',
  21597. 'procedure DoIt(v: jsvalue); begin end;',
  21598. 'var',
  21599. ' o: TObject;',
  21600. 'begin',
  21601. ' DoIt(o);',
  21602. '']);
  21603. ConvertProgram;
  21604. CheckSource('TestJSValue_OverloadPointer',
  21605. LinesToStr([ // statements
  21606. 'rtl.createClass($mod, "TObject", null, function () {',
  21607. ' this.$init = function () {',
  21608. ' };',
  21609. ' this.$final = function () {',
  21610. ' };',
  21611. '});',
  21612. 'this.DoIt = function (p) {',
  21613. '};',
  21614. 'this.DoIt$1 = function (v) {',
  21615. '};',
  21616. 'this.o = null;',
  21617. '']),
  21618. LinesToStr([ // $mod.$main
  21619. '$mod.DoIt($mod.o);',
  21620. '']));
  21621. end;
  21622. procedure TTestModule.TestJSValue_ForIn;
  21623. begin
  21624. StartProgram(false);
  21625. Add([
  21626. 'var',
  21627. ' v: JSValue;',
  21628. ' key: string;',
  21629. 'begin',
  21630. ' for key in v do begin',
  21631. ' if key=''abc'' then ;',
  21632. ' end;',
  21633. '']);
  21634. ConvertProgram;
  21635. CheckSource('TestJSValue_ForIn',
  21636. LinesToStr([ // statements
  21637. 'this.v = undefined;',
  21638. 'this.key = "";',
  21639. '']),
  21640. LinesToStr([ // $mod.$main
  21641. 'for ($mod.key in $mod.v) {',
  21642. ' if ($mod.key === "abc") ;',
  21643. '};',
  21644. '']));
  21645. end;
  21646. procedure TTestModule.TestRTTI_IntRange;
  21647. begin
  21648. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21649. StartProgram(false);
  21650. Add([
  21651. '{$modeswitch externalclass}',
  21652. 'type',
  21653. ' TTypeInfo = class external name ''rtl.tTypeInfo''',
  21654. ' end;',
  21655. ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
  21656. ' end;',
  21657. ' TGraphicsColor = -$7FFFFFFF-1..$7FFFFFFF;',
  21658. ' TColor = type TGraphicsColor;',
  21659. 'var',
  21660. ' p: TTypeInfo;',
  21661. 'begin',
  21662. ' p:=typeinfo(TGraphicsColor);',
  21663. ' p:=typeinfo(TColor);',
  21664. '']);
  21665. ConvertProgram;
  21666. CheckSource('TestRTTI_IntRange',
  21667. LinesToStr([ // statements
  21668. '$mod.$rtti.$Int("TGraphicsColor", {',
  21669. ' minvalue: -2147483648,',
  21670. ' maxvalue: 2147483647,',
  21671. ' ordtype: 4',
  21672. '});',
  21673. '$mod.$rtti.$inherited("TColor", $mod.$rtti["TGraphicsColor"], {});',
  21674. 'this.p = null;',
  21675. '']),
  21676. LinesToStr([ // $mod.$main
  21677. '$mod.p = $mod.$rtti["TGraphicsColor"];',
  21678. '$mod.p = $mod.$rtti["TColor"];',
  21679. '']));
  21680. end;
  21681. procedure TTestModule.TestRTTI_Double;
  21682. begin
  21683. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21684. StartProgram(false);
  21685. Add([
  21686. '{$modeswitch externalclass}',
  21687. 'type',
  21688. ' TTypeInfo = class external name ''rtl.tTypeInfo''',
  21689. ' end;',
  21690. ' TFloat = type double;',
  21691. 'var',
  21692. ' p: TTypeInfo;',
  21693. 'begin',
  21694. ' p:=typeinfo(double);',
  21695. ' p:=typeinfo(TFloat);',
  21696. '']);
  21697. ConvertProgram;
  21698. CheckSource('TestRTTI_Double',
  21699. LinesToStr([ // statements
  21700. '$mod.$rtti.$inherited("TFloat", rtl.double, {});',
  21701. 'this.p = null;',
  21702. '']),
  21703. LinesToStr([ // $mod.$main
  21704. '$mod.p = rtl.double;',
  21705. '$mod.p = $mod.$rtti["TFloat"];',
  21706. '']));
  21707. end;
  21708. procedure TTestModule.TestRTTI_ProcType;
  21709. begin
  21710. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21711. StartProgram(false);
  21712. Add('type');
  21713. Add(' TProcA = procedure;');
  21714. Add(' TMethodB = procedure of object;');
  21715. Add(' TProcC = procedure; varargs;');
  21716. Add(' TProcD = procedure(i: longint; const j: string; var c: char; out d: double);');
  21717. Add(' TProcE = function: nativeint;');
  21718. Add(' TProcF = function(const p: TProcA): nativeuint;');
  21719. Add('var p: pointer;');
  21720. Add('begin');
  21721. Add(' p:=typeinfo(tproca);');
  21722. ConvertProgram;
  21723. CheckSource('TestRTTI_ProcType',
  21724. LinesToStr([ // statements
  21725. '$mod.$rtti.$ProcVar("TProcA", {',
  21726. ' procsig: rtl.newTIProcSig(null)',
  21727. '});',
  21728. '$mod.$rtti.$MethodVar("TMethodB", {',
  21729. ' procsig: rtl.newTIProcSig(null),',
  21730. ' methodkind: 0',
  21731. '});',
  21732. '$mod.$rtti.$ProcVar("TProcC", {',
  21733. ' procsig: rtl.newTIProcSig(null, 2)',
  21734. '});',
  21735. '$mod.$rtti.$ProcVar("TProcD", {',
  21736. ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
  21737. '});',
  21738. '$mod.$rtti.$ProcVar("TProcE", {',
  21739. ' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
  21740. '});',
  21741. '$mod.$rtti.$ProcVar("TProcF", {',
  21742. ' procsig: rtl.newTIProcSig([["p", $mod.$rtti["TProcA"], 2]], rtl.nativeuint)',
  21743. '});',
  21744. 'this.p = null;',
  21745. '']),
  21746. LinesToStr([ // $mod.$main
  21747. '$mod.p = $mod.$rtti["TProcA"];',
  21748. '']));
  21749. end;
  21750. procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
  21751. begin
  21752. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21753. AddModuleWithIntfImplSrc('unit2.pas',
  21754. LinesToStr([
  21755. 'type',
  21756. ' TObject = class end;'
  21757. ]),
  21758. '');
  21759. StartUnit(true);
  21760. Add('interface');
  21761. Add('uses unit2;');
  21762. Add('type');
  21763. Add(' TProcA = function(o: tobject): tobject;');
  21764. Add('implementation');
  21765. Add('type');
  21766. Add(' TProcB = function(o: tobject): tobject;');
  21767. Add('var p: Pointer;');
  21768. Add('initialization');
  21769. Add(' p:=typeinfo(tproca);');
  21770. Add(' p:=typeinfo(tprocb);');
  21771. ConvertUnit;
  21772. CheckSource('TestRTTI_ProcType_ArgFromOtherUnit',
  21773. LinesToStr([ // statements
  21774. 'var $impl = $mod.$impl;',
  21775. '$mod.$rtti.$ProcVar("TProcA", {',
  21776. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  21777. '});',
  21778. '']),
  21779. LinesToStr([ // this.$init
  21780. '$impl.p = $mod.$rtti["TProcA"];',
  21781. '$impl.p = $mod.$rtti["TProcB"];',
  21782. '']),
  21783. LinesToStr([ // implementation
  21784. '$mod.$rtti.$ProcVar("TProcB", {',
  21785. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  21786. '});',
  21787. '$impl.p = null;',
  21788. '']) );
  21789. end;
  21790. procedure TTestModule.TestRTTI_EnumAndSetType;
  21791. begin
  21792. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21793. StartProgram(false);
  21794. Add('type');
  21795. Add(' TFlag = (light,dark);');
  21796. Add(' TFlags = set of TFlag;');
  21797. Add(' TProc = function(f: TFlags): TFlag;');
  21798. Add('var p: pointer;');
  21799. Add('begin');
  21800. Add(' p:=typeinfo(tflag);');
  21801. Add(' p:=typeinfo(tflags);');
  21802. ConvertProgram;
  21803. CheckSource('TestRTTI_EnumAndType',
  21804. LinesToStr([ // statements
  21805. 'this.TFlag = {',
  21806. ' "0": "light",',
  21807. ' light: 0,',
  21808. ' "1": "dark",',
  21809. ' dark: 1',
  21810. '};',
  21811. '$mod.$rtti.$Enum("TFlag", {',
  21812. ' minvalue: 0,',
  21813. ' maxvalue: 1,',
  21814. ' ordtype: 1,',
  21815. ' enumtype: this.TFlag',
  21816. '});',
  21817. '$mod.$rtti.$Set("TFlags", {',
  21818. ' comptype: $mod.$rtti["TFlag"]',
  21819. '});',
  21820. '$mod.$rtti.$ProcVar("TProc", {',
  21821. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TFlags"]]], $mod.$rtti["TFlag"])',
  21822. '});',
  21823. 'this.p = null;',
  21824. '']),
  21825. LinesToStr([ // $mod.$main
  21826. '$mod.p = $mod.$rtti["TFlag"];',
  21827. '$mod.p = $mod.$rtti["TFlags"];',
  21828. '']));
  21829. end;
  21830. procedure TTestModule.TestRTTI_EnumRange;
  21831. begin
  21832. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21833. StartProgram(false);
  21834. Add([
  21835. 'type',
  21836. ' TCol = (red,green,blue);',
  21837. ' TColRg = green..blue;',
  21838. ' TSetOfColRg = set of TColRg;',
  21839. 'var p: pointer;',
  21840. 'begin',
  21841. ' p:=typeinfo(tcolrg);',
  21842. ' p:=typeinfo(tsetofcolrg);',
  21843. '']);
  21844. ConvertProgram;
  21845. end;
  21846. procedure TTestModule.TestRTTI_AnonymousEnumType;
  21847. begin
  21848. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21849. StartProgram(false);
  21850. Add('type');
  21851. Add(' TFlags = set of (red, green);');
  21852. Add('var');
  21853. Add(' f: TFlags;');
  21854. Add('begin');
  21855. Add(' Include(f,red);');
  21856. ConvertProgram;
  21857. CheckSource('TestRTTI_AnonymousEnumType',
  21858. LinesToStr([ // statements
  21859. 'this.TFlags$a = {',
  21860. ' "0": "red",',
  21861. ' red: 0,',
  21862. ' "1": "green",',
  21863. ' green: 1',
  21864. '};',
  21865. '$mod.$rtti.$Enum("TFlags$a", {',
  21866. ' minvalue: 0,',
  21867. ' maxvalue: 1,',
  21868. ' ordtype: 1,',
  21869. ' enumtype: this.TFlags$a',
  21870. '});',
  21871. '$mod.$rtti.$Set("TFlags", {',
  21872. ' comptype: $mod.$rtti["TFlags$a"]',
  21873. '});',
  21874. 'this.f = {};',
  21875. '']),
  21876. LinesToStr([
  21877. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  21878. '']));
  21879. end;
  21880. procedure TTestModule.TestRTTI_StaticArray;
  21881. begin
  21882. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21883. StartProgram(false);
  21884. Add('type');
  21885. Add(' TFlag = (light,dark);');
  21886. Add(' TFlagNames = array[TFlag] of string;');
  21887. Add(' TBoolNames = array[boolean] of string;');
  21888. Add(' TByteArray = array[1..32768] of byte;');
  21889. Add(' TProc = function(f: TBoolNames): TFlagNames;');
  21890. Add('var p: pointer;');
  21891. Add('begin');
  21892. Add(' p:=typeinfo(TFlagNames);');
  21893. Add(' p:=typeinfo(TBoolNames);');
  21894. ConvertProgram;
  21895. CheckSource('TestRTTI_StaticArray',
  21896. LinesToStr([ // statements
  21897. 'this.TFlag = {',
  21898. ' "0": "light",',
  21899. ' light: 0,',
  21900. ' "1": "dark",',
  21901. ' dark: 1',
  21902. '};',
  21903. '$mod.$rtti.$Enum("TFlag", {',
  21904. ' minvalue: 0,',
  21905. ' maxvalue: 1,',
  21906. ' ordtype: 1,',
  21907. ' enumtype: this.TFlag',
  21908. '});',
  21909. '$mod.$rtti.$StaticArray("TFlagNames", {',
  21910. ' dims: [2],',
  21911. ' eltype: rtl.string',
  21912. '});',
  21913. '$mod.$rtti.$StaticArray("TBoolNames", {',
  21914. ' dims: [2],',
  21915. ' eltype: rtl.string',
  21916. '});',
  21917. '$mod.$rtti.$StaticArray("TByteArray", {',
  21918. ' dims: [32768],',
  21919. ' eltype: rtl.byte',
  21920. '});',
  21921. '$mod.$rtti.$ProcVar("TProc", {',
  21922. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TBoolNames"]]], $mod.$rtti["TFlagNames"])',
  21923. '});',
  21924. 'this.p = null;',
  21925. '']),
  21926. LinesToStr([ // $mod.$main
  21927. '$mod.p = $mod.$rtti["TFlagNames"];',
  21928. '$mod.p = $mod.$rtti["TBoolNames"];',
  21929. '']));
  21930. end;
  21931. procedure TTestModule.TestRTTI_DynArray;
  21932. begin
  21933. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21934. StartProgram(false);
  21935. Add('type');
  21936. Add(' TArrStr = array of string;');
  21937. Add(' TArr2Dim = array of tarrstr;');
  21938. Add(' TProc = function(f: TArrStr): TArr2Dim;');
  21939. Add('var p: pointer;');
  21940. Add('begin');
  21941. Add(' p:=typeinfo(tarrstr);');
  21942. Add(' p:=typeinfo(tarr2dim);');
  21943. ConvertProgram;
  21944. CheckSource('TestRTTI_DynArray',
  21945. LinesToStr([ // statements
  21946. '$mod.$rtti.$DynArray("TArrStr", {',
  21947. ' eltype: rtl.string',
  21948. '});',
  21949. '$mod.$rtti.$DynArray("TArr2Dim", {',
  21950. ' eltype: $mod.$rtti["TArrStr"]',
  21951. '});',
  21952. '$mod.$rtti.$ProcVar("TProc", {',
  21953. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TArrStr"]]], $mod.$rtti["TArr2Dim"])',
  21954. '});',
  21955. 'this.p = null;',
  21956. '']),
  21957. LinesToStr([ // $mod.$main
  21958. '$mod.p = $mod.$rtti["TArrStr"];',
  21959. '$mod.p = $mod.$rtti["TArr2Dim"];',
  21960. '']));
  21961. end;
  21962. procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
  21963. begin
  21964. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21965. StartProgram(false);
  21966. Add('type');
  21967. Add(' TArr = array of array of longint;');
  21968. Add('var a: TArr;');
  21969. Add('begin');
  21970. ConvertProgram;
  21971. CheckSource('TestRTTI_ArrayNestedAnonymous',
  21972. LinesToStr([ // statements
  21973. '$mod.$rtti.$DynArray("TArr$a", {',
  21974. ' eltype: rtl.longint',
  21975. '});',
  21976. '$mod.$rtti.$DynArray("TArr", {',
  21977. ' eltype: $mod.$rtti["TArr$a"]',
  21978. '});',
  21979. 'this.a = [];',
  21980. '']),
  21981. LinesToStr([ // $mod.$main
  21982. ]));
  21983. end;
  21984. procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
  21985. begin
  21986. Converter.Options:=Converter.Options-[coNoTypeInfo];
  21987. StartProgram(false);
  21988. Add('type');
  21989. Add(' TObject = class');
  21990. Add(' published');
  21991. Add(' procedure Proc; virtual; abstract;');
  21992. Add(' procedure Proc(Sender: tobject); virtual; abstract;');
  21993. Add(' end;');
  21994. Add('begin');
  21995. SetExpectedPasResolverError('Duplicate identifier "Proc" at test1.pp(6,19)',
  21996. nDuplicateIdentifier);
  21997. ConvertProgram;
  21998. end;
  21999. procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
  22000. begin
  22001. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22002. StartProgram(false);
  22003. Add('type');
  22004. Add(' TObject = class');
  22005. Add(' published');
  22006. Add(' procedure Proc; external name ''foo'';');
  22007. Add(' end;');
  22008. Add('begin');
  22009. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  22010. nPublishedNameMustMatchExternal);
  22011. ConvertProgram;
  22012. end;
  22013. procedure TTestModule.TestRTTI_PublishedClassPropertyFail;
  22014. begin
  22015. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22016. StartProgram(false);
  22017. Add('type');
  22018. Add(' TObject = class');
  22019. Add(' class var FA: longint;');
  22020. Add(' published');
  22021. Add(' class property A: longint read FA;');
  22022. Add(' end;');
  22023. Add('begin');
  22024. SetExpectedPasResolverError('Invalid published property modifier "class"',
  22025. nInvalidXModifierY);
  22026. ConvertProgram;
  22027. end;
  22028. procedure TTestModule.TestRTTI_PublishedClassFieldFail;
  22029. begin
  22030. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22031. StartProgram(false);
  22032. Add('type');
  22033. Add(' TObject = class');
  22034. Add(' published');
  22035. Add(' class var FA: longint;');
  22036. Add(' end;');
  22037. Add('begin');
  22038. SetExpectedPasResolverError(sSymbolCannotBePublished,
  22039. nSymbolCannotBePublished);
  22040. ConvertProgram;
  22041. end;
  22042. procedure TTestModule.TestRTTI_PublishedFieldExternalFail;
  22043. begin
  22044. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22045. StartProgram(false);
  22046. Add('{$modeswitch externalclass}');
  22047. Add('type');
  22048. Add(' TObject = class');
  22049. Add(' published');
  22050. Add(' V: longint; external name ''foo'';');
  22051. Add(' end;');
  22052. Add('begin');
  22053. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  22054. nPublishedNameMustMatchExternal);
  22055. ConvertProgram;
  22056. end;
  22057. procedure TTestModule.TestRTTI_Class_Field;
  22058. begin
  22059. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22060. StartProgram(false);
  22061. Add('{$modeswitch externalclass}');
  22062. Add('type');
  22063. Add(' TObject = class');
  22064. Add(' private');
  22065. Add(' FPropA: string;');
  22066. Add(' published');
  22067. Add(' VarLI: longint;');
  22068. Add(' VarC: char;');
  22069. Add(' VarS: string;');
  22070. Add(' VarD: double;');
  22071. Add(' VarB: boolean;');
  22072. Add(' VarLW: longword;');
  22073. Add(' VarSmI: smallint;');
  22074. Add(' VarW: word;');
  22075. Add(' VarShI: shortint;');
  22076. Add(' VarBy: byte;');
  22077. Add(' VarExt: longint external name ''VarExt'';');
  22078. Add(' end;');
  22079. Add('var p: pointer;');
  22080. Add(' Obj: tobject;');
  22081. Add('begin');
  22082. Add(' p:=typeinfo(tobject);');
  22083. Add(' p:=typeinfo(p);');
  22084. Add(' p:=typeinfo(obj);');
  22085. ConvertProgram;
  22086. CheckSource('TestRTTI_Class_Field',
  22087. LinesToStr([ // statements
  22088. 'rtl.createClass($mod, "TObject", null, function () {',
  22089. ' this.$init = function () {',
  22090. ' this.FPropA = "";',
  22091. ' this.VarLI = 0;',
  22092. ' this.VarC = "";',
  22093. ' this.VarS = "";',
  22094. ' this.VarD = 0.0;',
  22095. ' this.VarB = false;',
  22096. ' this.VarLW = 0;',
  22097. ' this.VarSmI = 0;',
  22098. ' this.VarW = 0;',
  22099. ' this.VarShI = 0;',
  22100. ' this.VarBy = 0;',
  22101. ' };',
  22102. ' this.$final = function () {',
  22103. ' };',
  22104. ' var $r = this.$rtti;',
  22105. ' $r.addField("VarLI", rtl.longint);',
  22106. ' $r.addField("VarC", rtl.char);',
  22107. ' $r.addField("VarS", rtl.string);',
  22108. ' $r.addField("VarD", rtl.double);',
  22109. ' $r.addField("VarB", rtl.boolean);',
  22110. ' $r.addField("VarLW", rtl.longword);',
  22111. ' $r.addField("VarSmI", rtl.smallint);',
  22112. ' $r.addField("VarW", rtl.word);',
  22113. ' $r.addField("VarShI", rtl.shortint);',
  22114. ' $r.addField("VarBy", rtl.byte);',
  22115. ' $r.addField("VarExt", rtl.longint);',
  22116. '});',
  22117. 'this.p = null;',
  22118. 'this.Obj = null;',
  22119. '']),
  22120. LinesToStr([ // $mod.$main
  22121. '$mod.p = $mod.$rtti["TObject"];',
  22122. '$mod.p = rtl.pointer;',
  22123. '$mod.p = $mod.Obj.$rtti;',
  22124. '']));
  22125. end;
  22126. procedure TTestModule.TestRTTI_Class_Method;
  22127. begin
  22128. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22129. StartProgram(false);
  22130. Add('type');
  22131. Add(' TObject = class');
  22132. Add(' private');
  22133. Add(' procedure Internal; external name ''$intern'';');
  22134. Add(' published');
  22135. Add(' procedure Click; virtual; abstract;');
  22136. Add(' procedure Notify(Sender: TObject); virtual; abstract;');
  22137. Add(' function GetNotify: boolean; external name ''GetNotify'';');
  22138. Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
  22139. Add(' end;');
  22140. Add('begin');
  22141. ConvertProgram;
  22142. CheckSource('TestRTTI_Class_Method',
  22143. LinesToStr([ // statements
  22144. 'rtl.createClass($mod, "TObject", null, function () {',
  22145. ' this.$init = function () {',
  22146. ' };',
  22147. ' this.$final = function () {',
  22148. ' };',
  22149. ' var $r = this.$rtti;',
  22150. ' $r.addMethod("Click", 0, null);',
  22151. ' $r.addMethod("Notify", 0, [["Sender", $r]]);',
  22152. ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
  22153. ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
  22154. ' flags: 2',
  22155. ' });',
  22156. '});',
  22157. '']),
  22158. LinesToStr([ // $mod.$main
  22159. '']));
  22160. end;
  22161. procedure TTestModule.TestRTTI_Class_MethodArgFlags;
  22162. begin
  22163. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22164. StartProgram(false);
  22165. Add('type');
  22166. Add(' TObject = class');
  22167. Add(' published');
  22168. Add(' procedure OpenArray(const Args: array of string); virtual; abstract;');
  22169. Add(' procedure ByRef(var Value: longint; out Item: longint); virtual; abstract;');
  22170. Add(' procedure Untyped(var Value; out Item); virtual; abstract;');
  22171. Add(' end;');
  22172. Add('begin');
  22173. ConvertProgram;
  22174. CheckSource('TestRTTI_Class_MethodOpenArray',
  22175. LinesToStr([ // statements
  22176. 'rtl.createClass($mod, "TObject", null, function () {',
  22177. ' this.$init = function () {',
  22178. ' };',
  22179. ' this.$final = function () {',
  22180. ' };',
  22181. ' var $r = this.$rtti;',
  22182. '$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
  22183. '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
  22184. '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
  22185. '});',
  22186. '']),
  22187. LinesToStr([ // $mod.$main
  22188. '']));
  22189. end;
  22190. procedure TTestModule.TestRTTI_Class_Property;
  22191. begin
  22192. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22193. StartProgram(false);
  22194. Add('{$modeswitch externalclass}');
  22195. Add('type');
  22196. Add(' TObject = class');
  22197. Add(' private');
  22198. Add(' FColor: longint;');
  22199. Add(' FColorStored: boolean;');
  22200. Add(' procedure SetColor(Value: longint); virtual; abstract;');
  22201. Add(' function GetColor: longint; virtual; abstract;');
  22202. Add(' function GetColorStored: boolean; virtual; abstract;');
  22203. Add(' FExtSize: longint external name ''$extSize'';');
  22204. Add(' FExtSizeStored: boolean external name ''$extSizeStored'';');
  22205. Add(' procedure SetExtSize(Value: longint); external name ''$setSize'';');
  22206. Add(' function GetExtSize: longint; external name ''$getSize'';');
  22207. Add(' function GetExtSizeStored: boolean; external name ''$getExtSizeStored'';');
  22208. Add(' published');
  22209. Add(' property ColorA: longint read FColor;');
  22210. Add(' property ColorB: longint write FColor;');
  22211. Add(' property ColorC: longint read GetColor write SetColor;');
  22212. Add(' property ColorD: longint read FColor write FColor stored FColorStored;');
  22213. Add(' property ExtSizeA: longint read FExtSize write FExtSize;');
  22214. Add(' property ExtSizeB: longint read GetExtSize write SetExtSize stored FExtSizeStored;');
  22215. Add(' property ExtSizeC: longint read FExtSize write FExtSize stored GetExtSizeStored;');
  22216. Add(' end;');
  22217. Add('begin');
  22218. ConvertProgram;
  22219. CheckSource('TestRTTI_Class_Property',
  22220. LinesToStr([ // statements
  22221. 'rtl.createClass($mod, "TObject", null, function () {',
  22222. ' this.$init = function () {',
  22223. ' this.FColor = 0;',
  22224. ' this.FColorStored = false;',
  22225. ' };',
  22226. ' this.$final = function () {',
  22227. ' };',
  22228. ' var $r = this.$rtti;',
  22229. ' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
  22230. ' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
  22231. ' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
  22232. ' $r.addProperty(',
  22233. ' "ColorD",',
  22234. ' 8,',
  22235. ' rtl.longint,',
  22236. ' "FColor",',
  22237. ' "FColor",',
  22238. ' {',
  22239. ' stored: "FColorStored"',
  22240. ' }',
  22241. ' );',
  22242. ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
  22243. ' $r.addProperty(',
  22244. ' "ExtSizeB",',
  22245. ' 11,',
  22246. ' rtl.longint,',
  22247. ' "$getSize",',
  22248. ' "$setSize",',
  22249. ' {',
  22250. ' stored: "$extSizeStored"',
  22251. ' }',
  22252. ' );',
  22253. ' $r.addProperty(',
  22254. ' "ExtSizeC",',
  22255. ' 12,',
  22256. ' rtl.longint,',
  22257. ' "$extSize",',
  22258. ' "$extSize",',
  22259. ' {',
  22260. ' stored: "$getExtSizeStored"',
  22261. ' }',
  22262. ' );',
  22263. '});',
  22264. '']),
  22265. LinesToStr([ // $mod.$main
  22266. '']));
  22267. end;
  22268. procedure TTestModule.TestRTTI_Class_PropertyParams;
  22269. begin
  22270. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22271. StartProgram(false);
  22272. Add('{$modeswitch externalclass}');
  22273. Add('type');
  22274. Add(' integer = longint;');
  22275. Add(' TObject = class');
  22276. Add(' private');
  22277. Add(' function GetItems(i: integer): tobject; virtual; abstract;');
  22278. Add(' procedure SetItems(i: integer; value: tobject); virtual; abstract;');
  22279. Add(' function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
  22280. Add(' procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
  22281. Add(' published');
  22282. Add(' property Items[Index: integer]: tobject read getitems write setitems;');
  22283. Add(' property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
  22284. Add(' end;');
  22285. Add('begin');
  22286. ConvertProgram;
  22287. CheckSource('TestRTTI_Class_PropertyParams',
  22288. LinesToStr([ // statements
  22289. 'rtl.createClass($mod, "TObject", null, function () {',
  22290. ' this.$init = function () {',
  22291. ' };',
  22292. ' this.$final = function () {',
  22293. ' };',
  22294. ' var $r = this.$rtti;',
  22295. ' $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
  22296. ' $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
  22297. '});',
  22298. '']),
  22299. LinesToStr([ // $mod.$main
  22300. '']));
  22301. end;
  22302. procedure TTestModule.TestRTTI_Class_OtherUnit_TypeAlias;
  22303. begin
  22304. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22305. AddModuleWithIntfImplSrc('unit1.pas',
  22306. 'type TColor = -5..5;',
  22307. '');
  22308. StartProgram(true);
  22309. Add([
  22310. 'uses unit1;',
  22311. 'type',
  22312. ' TColorAlias = TColor;',
  22313. ' TColorTypeAlias = type TColor;',
  22314. ' TObject = class',
  22315. ' private',
  22316. ' fColor: TColor;',
  22317. ' fAlias: TColorAlias;',
  22318. ' fTypeAlias: TColorTypeAlias;',
  22319. ' published',
  22320. ' property Color: TColor read fcolor;',
  22321. ' property Alias: TColorAlias read falias;',
  22322. ' property TypeAlias: TColorTypeAlias read ftypealias;',
  22323. ' end;',
  22324. 'begin',
  22325. '']);
  22326. ConvertProgram;
  22327. CheckSource('TestRTTI_Class_OtherUnit_TypeAlias',
  22328. LinesToStr([ // statements
  22329. '$mod.$rtti.$inherited("TColorTypeAlias", pas.unit1.$rtti["TColor"], {});',
  22330. 'rtl.createClass($mod, "TObject", null, function () {',
  22331. ' this.$init = function () {',
  22332. ' this.fColor = 0;',
  22333. ' this.fAlias = 0;',
  22334. ' this.fTypeAlias = 0;',
  22335. ' };',
  22336. ' this.$final = function () {',
  22337. ' };',
  22338. ' var $r = this.$rtti;',
  22339. ' $r.addProperty("Color", 0, pas.unit1.$rtti["TColor"], "fColor", "");',
  22340. ' $r.addProperty("Alias", 0, pas.unit1.$rtti["TColor"], "fAlias", "");',
  22341. ' $r.addProperty("TypeAlias", 0, $mod.$rtti["TColorTypeAlias"], "fTypeAlias", "");',
  22342. '});',
  22343. '']),
  22344. LinesToStr([ // $mod.$main
  22345. '']));
  22346. end;
  22347. procedure TTestModule.TestRTTI_Class_OmitRTTI;
  22348. begin
  22349. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22350. StartProgram(false);
  22351. Add([
  22352. '{$modeswitch omitrtti}',
  22353. 'type',
  22354. ' TObject = class',
  22355. ' private',
  22356. ' FA: byte;',
  22357. ' published',
  22358. ' property A: byte read FA write FA;',
  22359. ' end;',
  22360. 'begin']);
  22361. ConvertProgram;
  22362. CheckSource('TestRTTI_Class_OmitRTTI',
  22363. LinesToStr([ // statements
  22364. 'rtl.createClass($mod, "TObject", null, function () {',
  22365. ' this.$init = function () {',
  22366. ' this.FA = 0;',
  22367. ' };',
  22368. ' this.$final = function () {',
  22369. ' };',
  22370. '});',
  22371. '']),
  22372. LinesToStr([ // $mod.$main
  22373. '']));
  22374. end;
  22375. procedure TTestModule.TestRTTI_IndexModifier;
  22376. begin
  22377. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22378. StartProgram(false);
  22379. Add([
  22380. 'type',
  22381. ' TEnum = (red, blue);',
  22382. ' TObject = class',
  22383. ' FB: boolean;',
  22384. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  22385. ' function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
  22386. ' procedure SetBoolBool(Index: boolean; b: boolean); virtual; abstract;',
  22387. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  22388. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  22389. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  22390. ' published',
  22391. ' property B1: boolean index 1 read FB write SetIntBool;',
  22392. ' property B2: boolean index TEnum.blue read GetEnumBool write FB;',
  22393. ' property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
  22394. ' end;',
  22395. 'begin']);
  22396. ConvertProgram;
  22397. CheckSource('TestRTTI_IndexModifier',
  22398. LinesToStr([ // statements
  22399. 'this.TEnum = {',
  22400. ' "0": "red",',
  22401. ' red: 0,',
  22402. ' "1": "blue",',
  22403. ' blue: 1',
  22404. '};',
  22405. '$mod.$rtti.$Enum("TEnum", {',
  22406. ' minvalue: 0,',
  22407. ' maxvalue: 1,',
  22408. ' ordtype: 1,',
  22409. ' enumtype: this.TEnum',
  22410. '});',
  22411. 'rtl.createClass($mod, "TObject", null, function () {',
  22412. ' this.$init = function () {',
  22413. ' this.FB = false;',
  22414. ' };',
  22415. ' this.$final = function () {',
  22416. ' };',
  22417. ' var $r = this.$rtti;',
  22418. ' $r.addProperty(',
  22419. ' "B1",',
  22420. ' 18,',
  22421. ' rtl.boolean,',
  22422. ' "FB",',
  22423. ' "SetIntBool",',
  22424. ' {',
  22425. ' index: 1',
  22426. ' }',
  22427. ' );',
  22428. ' $r.addProperty(',
  22429. ' "B2",',
  22430. ' 17,',
  22431. ' rtl.boolean,',
  22432. ' "GetEnumBool",',
  22433. ' "FB",',
  22434. ' {',
  22435. ' index: $mod.TEnum.blue',
  22436. ' }',
  22437. ' );',
  22438. ' $r.addProperty(',
  22439. ' "I1",',
  22440. ' 19,',
  22441. ' rtl.boolean,',
  22442. ' "GetStrIntBool",',
  22443. ' "SetStrIntBool",',
  22444. ' {',
  22445. ' index: 2',
  22446. ' }',
  22447. ' );',
  22448. '});',
  22449. '']),
  22450. LinesToStr([ // $mod.$main
  22451. '']));
  22452. end;
  22453. procedure TTestModule.TestRTTI_StoredModifier;
  22454. begin
  22455. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22456. StartProgram(false);
  22457. Add([
  22458. 'const',
  22459. ' ConstB = true;',
  22460. 'type',
  22461. ' TObject = class',
  22462. ' private',
  22463. ' FB: boolean;',
  22464. ' function IsBStored: boolean; virtual; abstract;',
  22465. ' published',
  22466. ' property BoolA: boolean read FB stored true;',
  22467. ' property BoolB: boolean read FB stored false;',
  22468. ' property BoolC: boolean read FB stored FB;',
  22469. ' property BoolD: boolean read FB stored ConstB;',
  22470. ' property BoolE: boolean read FB stored IsBStored;',
  22471. ' end;',
  22472. 'begin']);
  22473. ConvertProgram;
  22474. CheckSource('TestRTTI_StoredModifier',
  22475. LinesToStr([ // statements
  22476. 'this.ConstB = true;',
  22477. 'rtl.createClass($mod, "TObject", null, function () {',
  22478. ' this.$init = function () {',
  22479. ' this.FB = false;',
  22480. ' };',
  22481. ' this.$final = function () {',
  22482. ' };',
  22483. ' var $r = this.$rtti;',
  22484. ' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
  22485. ' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
  22486. ' $r.addProperty(',
  22487. ' "BoolC",',
  22488. ' 8,',
  22489. ' rtl.boolean,',
  22490. ' "FB",',
  22491. ' "",',
  22492. ' {',
  22493. ' stored: "FB"',
  22494. ' }',
  22495. ' );',
  22496. ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
  22497. ' $r.addProperty(',
  22498. ' "BoolE",',
  22499. ' 12,',
  22500. ' rtl.boolean,',
  22501. ' "FB",',
  22502. ' "",',
  22503. ' {',
  22504. ' stored: "IsBStored"',
  22505. ' }',
  22506. ' );',
  22507. '});',
  22508. '']),
  22509. LinesToStr([ // $mod.$main
  22510. '']));
  22511. end;
  22512. procedure TTestModule.TestRTTI_DefaultValue;
  22513. begin
  22514. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22515. StartProgram(false);
  22516. Add([
  22517. 'type',
  22518. ' TEnum = (red, blue);',
  22519. 'const',
  22520. ' CB = true or false;',
  22521. ' CI = 1+2;',
  22522. 'type',
  22523. ' TObject = class',
  22524. ' FB: boolean;',
  22525. ' FI: longint;',
  22526. ' FE: TEnum;',
  22527. ' published',
  22528. ' property B1: boolean read FB default true;',
  22529. ' property B2: boolean read FB default CB;',
  22530. ' property B3: boolean read FB default test1.cb;',
  22531. ' property I1: longint read FI default 2;',
  22532. ' property I2: longint read FI default CI;',
  22533. ' property E1: TEnum read FE default red;',
  22534. ' property E2: TEnum read FE default TEnum.blue;',
  22535. ' end;',
  22536. 'begin']);
  22537. ConvertProgram;
  22538. CheckSource('TestRTTI_DefaultValue',
  22539. LinesToStr([ // statements
  22540. 'this.TEnum = {',
  22541. ' "0": "red",',
  22542. ' red: 0,',
  22543. ' "1": "blue",',
  22544. ' blue: 1',
  22545. '};',
  22546. '$mod.$rtti.$Enum("TEnum", {',
  22547. ' minvalue: 0,',
  22548. ' maxvalue: 1,',
  22549. ' ordtype: 1,',
  22550. ' enumtype: this.TEnum',
  22551. '});',
  22552. 'this.CB = true || false;',
  22553. 'this.CI = 1 + 2;',
  22554. 'rtl.createClass($mod, "TObject", null, function () {',
  22555. ' this.$init = function () {',
  22556. ' this.FB = false;',
  22557. ' this.FI = 0;',
  22558. ' this.FE = 0;',
  22559. ' };',
  22560. ' this.$final = function () {',
  22561. ' };',
  22562. ' var $r = this.$rtti;',
  22563. ' $r.addProperty(',
  22564. ' "B1",',
  22565. ' 0,',
  22566. ' rtl.boolean,',
  22567. ' "FB",',
  22568. ' "",',
  22569. ' {',
  22570. ' Default: true',
  22571. ' }',
  22572. ' );',
  22573. ' $r.addProperty(',
  22574. ' "B2",',
  22575. ' 0,',
  22576. ' rtl.boolean,',
  22577. ' "FB",',
  22578. ' "",',
  22579. ' {',
  22580. ' Default: true',
  22581. ' }',
  22582. ' );',
  22583. ' $r.addProperty(',
  22584. ' "B3",',
  22585. ' 0,',
  22586. ' rtl.boolean,',
  22587. ' "FB",',
  22588. ' "",',
  22589. ' {',
  22590. ' Default: true',
  22591. ' }',
  22592. ' );',
  22593. ' $r.addProperty(',
  22594. ' "I1",',
  22595. ' 0,',
  22596. ' rtl.longint,',
  22597. ' "FI",',
  22598. ' "",',
  22599. ' {',
  22600. ' Default: 2',
  22601. ' }',
  22602. ' );',
  22603. ' $r.addProperty(',
  22604. ' "I2",',
  22605. ' 0,',
  22606. ' rtl.longint,',
  22607. ' "FI",',
  22608. ' "",',
  22609. ' {',
  22610. ' Default: 3',
  22611. ' }',
  22612. ' );',
  22613. ' $r.addProperty(',
  22614. ' "E1",',
  22615. ' 0,',
  22616. ' $mod.$rtti["TEnum"],',
  22617. ' "FE",',
  22618. ' "",',
  22619. ' {',
  22620. ' Default: $mod.TEnum.red',
  22621. ' }',
  22622. ' );',
  22623. ' $r.addProperty(',
  22624. ' "E2",',
  22625. ' 0,',
  22626. ' $mod.$rtti["TEnum"],',
  22627. ' "FE",',
  22628. ' "",',
  22629. ' {',
  22630. ' Default: $mod.TEnum.blue',
  22631. ' }',
  22632. ' );',
  22633. '});',
  22634. '']),
  22635. LinesToStr([ // $mod.$main
  22636. '']));
  22637. end;
  22638. procedure TTestModule.TestRTTI_DefaultValueSet;
  22639. begin
  22640. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22641. StartProgram(false);
  22642. Add([
  22643. 'type',
  22644. ' TEnum = (red, blue);',
  22645. ' TSet = set of TEnum;',
  22646. 'const',
  22647. ' CSet = [red,blue];',
  22648. 'type',
  22649. ' TObject = class',
  22650. ' FSet: TSet;',
  22651. ' published',
  22652. ' property Set1: TSet read FSet default [];',
  22653. ' property Set2: TSet read FSet default [red];',
  22654. ' property Set3: TSet read FSet default [red,blue];',
  22655. ' property Set4: TSet read FSet default CSet;',
  22656. ' end;',
  22657. 'begin']);
  22658. ConvertProgram;
  22659. CheckSource('TestRTTI_DefaultValueSet',
  22660. LinesToStr([ // statements
  22661. 'this.TEnum = {',
  22662. ' "0": "red",',
  22663. ' red: 0,',
  22664. ' "1": "blue",',
  22665. ' blue: 1',
  22666. '};',
  22667. '$mod.$rtti.$Enum("TEnum", {',
  22668. ' minvalue: 0,',
  22669. ' maxvalue: 1,',
  22670. ' ordtype: 1,',
  22671. ' enumtype: this.TEnum',
  22672. '});',
  22673. '$mod.$rtti.$Set("TSet", {',
  22674. ' comptype: $mod.$rtti["TEnum"]',
  22675. '});',
  22676. 'this.CSet = rtl.createSet($mod.TEnum.red, $mod.TEnum.blue);',
  22677. 'rtl.createClass($mod, "TObject", null, function () {',
  22678. ' this.$init = function () {',
  22679. ' this.FSet = {};',
  22680. ' };',
  22681. ' this.$final = function () {',
  22682. ' this.FSet = undefined;',
  22683. ' };',
  22684. ' var $r = this.$rtti;',
  22685. ' $r.addProperty(',
  22686. ' "Set1",',
  22687. ' 0,',
  22688. ' $mod.$rtti["TSet"],',
  22689. ' "FSet",',
  22690. ' "",',
  22691. ' {',
  22692. ' Default: {}',
  22693. ' }',
  22694. ' );',
  22695. ' $r.addProperty(',
  22696. ' "Set2",',
  22697. ' 0,',
  22698. ' $mod.$rtti["TSet"],',
  22699. ' "FSet",',
  22700. ' "",',
  22701. ' {',
  22702. ' Default: rtl.createSet($mod.TEnum.red)',
  22703. ' }',
  22704. ' );',
  22705. ' $r.addProperty(',
  22706. ' "Set3",',
  22707. ' 0,',
  22708. ' $mod.$rtti["TSet"],',
  22709. ' "FSet",',
  22710. ' "",',
  22711. ' {',
  22712. ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
  22713. ' }',
  22714. ' );',
  22715. ' $r.addProperty(',
  22716. ' "Set4",',
  22717. ' 0,',
  22718. ' $mod.$rtti["TSet"],',
  22719. ' "FSet",',
  22720. ' "",',
  22721. ' {',
  22722. ' Default: $mod.CSet',
  22723. ' }',
  22724. ' );',
  22725. '});',
  22726. '']),
  22727. LinesToStr([ // $mod.$main
  22728. '']));
  22729. end;
  22730. procedure TTestModule.TestRTTI_DefaultValueRangeType;
  22731. begin
  22732. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22733. StartProgram(false);
  22734. Add([
  22735. 'type',
  22736. ' TRg = -1..1;',
  22737. 'const',
  22738. ' l = low(TRg);',
  22739. ' h = high(TRg);',
  22740. 'type',
  22741. ' TObject = class',
  22742. ' FV: TRg;',
  22743. ' published',
  22744. ' property V1: TRg read FV default -1;',
  22745. ' end;',
  22746. 'begin']);
  22747. ConvertProgram;
  22748. CheckSource('TestRTTI_DefaultValueRangeType',
  22749. LinesToStr([ // statements
  22750. '$mod.$rtti.$Int("TRg", {',
  22751. ' minvalue: -1,',
  22752. ' maxvalue: 1,',
  22753. ' ordtype: 0',
  22754. '});',
  22755. 'this.l = -1;',
  22756. 'this.h = 1;',
  22757. 'rtl.createClass($mod, "TObject", null, function () {',
  22758. ' this.$init = function () {',
  22759. ' this.FV = 0;',
  22760. ' };',
  22761. ' this.$final = function () {',
  22762. ' };',
  22763. ' var $r = this.$rtti;',
  22764. ' $r.addProperty(',
  22765. ' "V1",',
  22766. ' 0,',
  22767. ' $mod.$rtti["TRg"],',
  22768. ' "FV",',
  22769. ' "",',
  22770. ' {',
  22771. ' Default: -1',
  22772. ' }',
  22773. ' );',
  22774. '});',
  22775. '']),
  22776. LinesToStr([ // $mod.$main
  22777. '']));
  22778. end;
  22779. procedure TTestModule.TestRTTI_DefaultValueInherit;
  22780. begin
  22781. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22782. StartProgram(false);
  22783. Add([
  22784. 'type',
  22785. ' TObject = class',
  22786. ' FA, FB: byte;',
  22787. ' property A: byte read FA default 1;',
  22788. ' property B: byte read FB default 2;',
  22789. ' end;',
  22790. ' TBird = class',
  22791. ' published',
  22792. ' property A;',
  22793. ' property B nodefault;',
  22794. ' end;',
  22795. 'begin']);
  22796. ConvertProgram;
  22797. CheckSource('TestRTTI_DefaultValueInherit',
  22798. LinesToStr([ // statements
  22799. 'rtl.createClass($mod, "TObject", null, function () {',
  22800. ' this.$init = function () {',
  22801. ' this.FA = 0;',
  22802. ' this.FB = 0;',
  22803. ' };',
  22804. ' this.$final = function () {',
  22805. ' };',
  22806. '});',
  22807. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  22808. ' var $r = this.$rtti;',
  22809. ' $r.addProperty(',
  22810. ' "A",',
  22811. ' 0,',
  22812. ' rtl.byte,',
  22813. ' "FA",',
  22814. ' "",',
  22815. ' {',
  22816. ' Default: 1',
  22817. ' }',
  22818. ' );',
  22819. ' $r.addProperty("B", 0, rtl.byte, "FB", "");',
  22820. '});',
  22821. '']),
  22822. LinesToStr([ // $mod.$main
  22823. '']));
  22824. end;
  22825. procedure TTestModule.TestRTTI_OverrideMethod;
  22826. begin
  22827. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22828. StartProgram(false);
  22829. Add('type');
  22830. Add(' TObject = class');
  22831. Add(' published');
  22832. Add(' procedure DoIt; virtual; abstract;');
  22833. Add(' end;');
  22834. Add(' TSky = class');
  22835. Add(' published');
  22836. Add(' procedure DoIt; override;');
  22837. Add(' end;');
  22838. Add('procedure TSky.DoIt; begin end;');
  22839. Add('begin');
  22840. ConvertProgram;
  22841. CheckSource('TestRTTI_OverrideMethod',
  22842. LinesToStr([ // statements
  22843. 'rtl.createClass($mod, "TObject", null, function () {',
  22844. ' this.$init = function () {',
  22845. ' };',
  22846. ' this.$final = function () {',
  22847. ' };',
  22848. ' var $r = this.$rtti;',
  22849. ' $r.addMethod("DoIt", 0, null);',
  22850. '});',
  22851. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  22852. ' this.DoIt = function () {',
  22853. ' };',
  22854. '});',
  22855. '']),
  22856. LinesToStr([ // $mod.$main
  22857. '']));
  22858. end;
  22859. procedure TTestModule.TestRTTI_OverloadProperty;
  22860. begin
  22861. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22862. StartProgram(false);
  22863. Add('type');
  22864. Add(' TObject = class');
  22865. Add(' protected');
  22866. Add(' FFlag: longint;');
  22867. Add(' published');
  22868. Add(' property Flag: longint read fflag;');
  22869. Add(' end;');
  22870. Add(' TSky = class');
  22871. Add(' published');
  22872. Add(' property FLAG: longint write fflag;');
  22873. Add(' end;');
  22874. Add('begin');
  22875. ConvertProgram;
  22876. CheckSource('TestRTTI_OverrideMethod',
  22877. LinesToStr([ // statements
  22878. 'rtl.createClass($mod, "TObject", null, function () {',
  22879. ' this.$init = function () {',
  22880. ' this.FFlag = 0;',
  22881. ' };',
  22882. ' this.$final = function () {',
  22883. ' };',
  22884. ' var $r = this.$rtti;',
  22885. ' $r.addProperty("Flag", 0, rtl.longint, "FFlag", "");',
  22886. '});',
  22887. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  22888. ' var $r = this.$rtti;',
  22889. ' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
  22890. '});',
  22891. '']),
  22892. LinesToStr([ // $mod.$main
  22893. '']));
  22894. end;
  22895. procedure TTestModule.TestRTTI_ClassForward;
  22896. begin
  22897. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22898. StartProgram(false);
  22899. Add('type');
  22900. Add(' TObject = class end;');
  22901. Add(' tbridge = class;');
  22902. Add(' TProc = function: tbridge;');
  22903. Add(' TOger = class');
  22904. Add(' published');
  22905. Add(' FBridge: tbridge;');
  22906. Add(' procedure SetBridge(Value: tbridge); virtual; abstract;');
  22907. Add(' property Bridge: tbridge read fbridge write setbridge;');
  22908. Add(' end;');
  22909. Add(' TBridge = class');
  22910. Add(' FOger: toger;');
  22911. Add(' end;');
  22912. Add('var p: Pointer;');
  22913. Add(' b: tbridge;');
  22914. Add('begin');
  22915. Add(' p:=typeinfo(tbridge);');
  22916. Add(' p:=typeinfo(b);');
  22917. ConvertProgram;
  22918. CheckSource('TestRTTI_ClassForward',
  22919. LinesToStr([ // statements
  22920. 'rtl.createClass($mod, "TObject", null, function () {',
  22921. ' this.$init = function () {',
  22922. ' };',
  22923. ' this.$final = function () {',
  22924. ' };',
  22925. '});',
  22926. '$mod.$rtti.$Class("TBridge");',
  22927. '$mod.$rtti.$ProcVar("TProc", {',
  22928. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TBridge"])',
  22929. '});',
  22930. 'rtl.createClass($mod, "TOger", $mod.TObject, function () {',
  22931. ' this.$init = function () {',
  22932. ' $mod.TObject.$init.call(this);',
  22933. ' this.FBridge = null;',
  22934. ' };',
  22935. ' this.$final = function () {',
  22936. ' this.FBridge = undefined;',
  22937. ' $mod.TObject.$final.call(this);',
  22938. ' };',
  22939. ' var $r = this.$rtti;',
  22940. ' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
  22941. ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
  22942. ' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
  22943. '});',
  22944. 'rtl.createClass($mod, "TBridge", $mod.TObject, function () {',
  22945. ' this.$init = function () {',
  22946. ' $mod.TObject.$init.call(this);',
  22947. ' this.FOger = null;',
  22948. ' };',
  22949. ' this.$final = function () {',
  22950. ' this.FOger = undefined;',
  22951. ' $mod.TObject.$final.call(this);',
  22952. ' };',
  22953. '});',
  22954. 'this.p = null;',
  22955. 'this.b = null;',
  22956. '']),
  22957. LinesToStr([ // $mod.$main
  22958. '$mod.p = $mod.$rtti["TBridge"];',
  22959. '$mod.p = $mod.b.$rtti;',
  22960. '']));
  22961. end;
  22962. procedure TTestModule.TestRTTI_ClassOf;
  22963. begin
  22964. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22965. StartProgram(false);
  22966. Add('type');
  22967. Add(' TClass = class of tobject;');
  22968. Add(' TProcA = function: TClass;');
  22969. Add(' TObject = class');
  22970. Add(' published');
  22971. Add(' C: tclass;');
  22972. Add(' end;');
  22973. Add(' tfox = class;');
  22974. Add(' TBird = class end;');
  22975. Add(' TBirds = class of tbird;');
  22976. Add(' TFox = class end;');
  22977. Add(' TFoxes = class of tfox;');
  22978. Add(' TCows = class of TCow;');
  22979. Add(' TCow = class;');
  22980. Add(' TCow = class end;');
  22981. Add('begin');
  22982. ConvertProgram;
  22983. CheckSource('TestRTTI_ClassOf',
  22984. LinesToStr([ // statements
  22985. '$mod.$rtti.$Class("TObject");',
  22986. '$mod.$rtti.$ClassRef("TClass", {',
  22987. ' instancetype: $mod.$rtti["TObject"]',
  22988. '});',
  22989. '$mod.$rtti.$ProcVar("TProcA", {',
  22990. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TClass"])',
  22991. '});',
  22992. 'rtl.createClass($mod, "TObject", null, function () {',
  22993. ' this.$init = function () {',
  22994. ' this.C = null;',
  22995. ' };',
  22996. ' this.$final = function () {',
  22997. ' this.C = undefined;',
  22998. ' };',
  22999. ' var $r = this.$rtti;',
  23000. ' $r.addField("C", $mod.$rtti["TClass"]);',
  23001. '});',
  23002. '$mod.$rtti.$Class("TFox");',
  23003. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  23004. '});',
  23005. '$mod.$rtti.$ClassRef("TBirds", {',
  23006. ' instancetype: $mod.$rtti["TBird"]',
  23007. '});',
  23008. 'rtl.createClass($mod, "TFox", $mod.TObject, function () {',
  23009. '});',
  23010. '$mod.$rtti.$ClassRef("TFoxes", {',
  23011. ' instancetype: $mod.$rtti["TFox"]',
  23012. '});',
  23013. '$mod.$rtti.$Class("TCow");',
  23014. '$mod.$rtti.$ClassRef("TCows", {',
  23015. ' instancetype: $mod.$rtti["TCow"]',
  23016. '});',
  23017. 'rtl.createClass($mod, "TCow", $mod.TObject, function () {',
  23018. '});',
  23019. '']),
  23020. LinesToStr([ // $mod.$main
  23021. '']));
  23022. end;
  23023. procedure TTestModule.TestRTTI_Record;
  23024. begin
  23025. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23026. StartProgram(false);
  23027. Add('type');
  23028. Add(' integer = longint;');
  23029. Add(' TPoint = record');
  23030. Add(' x,y: integer;');
  23031. Add(' end;');
  23032. Add('var p: pointer;');
  23033. Add(' r: tpoint;');
  23034. Add('begin');
  23035. Add(' p:=typeinfo(tpoint);');
  23036. Add(' p:=typeinfo(r);');
  23037. Add(' p:=typeinfo(r.x);');
  23038. ConvertProgram;
  23039. CheckSource('TestRTTI_Record',
  23040. LinesToStr([ // statements
  23041. 'rtl.recNewT($mod, "TPoint", function () {',
  23042. ' this.x = 0;',
  23043. ' this.y = 0;',
  23044. ' this.$eq = function (b) {',
  23045. ' return (this.x === b.x) && (this.y === b.y);',
  23046. ' };',
  23047. ' this.$assign = function (s) {',
  23048. ' this.x = s.x;',
  23049. ' this.y = s.y;',
  23050. ' return this;',
  23051. ' };',
  23052. ' var $r = $mod.$rtti.$Record("TPoint", {});',
  23053. ' $r.addField("x", rtl.longint);',
  23054. ' $r.addField("y", rtl.longint);',
  23055. '});',
  23056. 'this.p = null;',
  23057. 'this.r = $mod.TPoint.$new();',
  23058. '']),
  23059. LinesToStr([ // $mod.$main
  23060. '$mod.p = $mod.$rtti["TPoint"];',
  23061. '$mod.p = $mod.$rtti["TPoint"];',
  23062. '$mod.p = rtl.longint;',
  23063. '']));
  23064. end;
  23065. procedure TTestModule.TestRTTI_RecordAnonymousArray;
  23066. begin
  23067. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23068. StartProgram(false);
  23069. Add('type');
  23070. Add(' TFloatRec = record');
  23071. Add(' d: array of char;');
  23072. // Add(' i: array of array of longint;');
  23073. Add(' end;');
  23074. Add('var p: pointer;');
  23075. Add(' r: tfloatrec;');
  23076. Add('begin');
  23077. Add(' p:=typeinfo(tfloatrec);');
  23078. Add(' p:=typeinfo(r);');
  23079. Add(' p:=typeinfo(r.d);');
  23080. ConvertProgram;
  23081. CheckSource('TestRTTI_Record',
  23082. LinesToStr([ // statements
  23083. 'rtl.recNewT($mod, "TFloatRec", function () {',
  23084. ' this.d = [];',
  23085. ' this.$eq = function (b) {',
  23086. ' return this.d === b.d;',
  23087. ' };',
  23088. ' this.$assign = function (s) {',
  23089. ' this.d = s.d;',
  23090. ' return this;',
  23091. ' };',
  23092. ' $mod.$rtti.$DynArray("TFloatRec.d$a", {',
  23093. ' eltype: rtl.char',
  23094. ' });',
  23095. ' var $r = $mod.$rtti.$Record("TFloatRec", {});',
  23096. ' $r.addField("d", $mod.$rtti["TFloatRec.d$a"]);',
  23097. '});',
  23098. 'this.p = null;',
  23099. 'this.r = $mod.TFloatRec.$new();',
  23100. '']),
  23101. LinesToStr([ // $mod.$main
  23102. '$mod.p = $mod.$rtti["TFloatRec"];',
  23103. '$mod.p = $mod.$rtti["TFloatRec"];',
  23104. '$mod.p = $mod.$rtti["TFloatRec.d$a"];',
  23105. '']));
  23106. end;
  23107. procedure TTestModule.TestRTTI_LocalTypes;
  23108. begin
  23109. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23110. StartProgram(false);
  23111. Add([
  23112. 'procedure DoIt;',
  23113. 'type',
  23114. ' integer = longint;',
  23115. ' TPoint = record',
  23116. ' x,y: integer;',
  23117. ' end;',
  23118. 'var p: TPoint;',
  23119. 'begin',
  23120. 'end;',
  23121. 'begin']);
  23122. ConvertProgram;
  23123. CheckSource('TestRTTI_LocalTypes',
  23124. LinesToStr([ // statements
  23125. 'var TPoint = rtl.recNewT(null, "", function () {',
  23126. ' this.x = 0;',
  23127. ' this.y = 0;',
  23128. ' this.$eq = function (b) {',
  23129. ' return (this.x === b.x) && (this.y === b.y);',
  23130. ' };',
  23131. ' this.$assign = function (s) {',
  23132. ' this.x = s.x;',
  23133. ' this.y = s.y;',
  23134. ' return this;',
  23135. ' };',
  23136. '});',
  23137. 'this.DoIt = function () {',
  23138. ' var p = TPoint.$new();',
  23139. '};',
  23140. '']),
  23141. LinesToStr([ // $mod.$main
  23142. '']));
  23143. end;
  23144. procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
  23145. begin
  23146. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23147. StartProgram(false);
  23148. Add([
  23149. 'type',
  23150. ' TCaption = string;',
  23151. ' TYesNo = boolean;',
  23152. ' TLetter = char;',
  23153. ' TFloat = double;',
  23154. ' TPtr = pointer;',
  23155. ' TShortInt = shortint;',
  23156. ' TByte = byte;',
  23157. ' TSmallInt = smallint;',
  23158. ' TWord = word;',
  23159. ' TInt32 = longint;',
  23160. ' TDWord = longword;',
  23161. ' TValue = jsvalue;',
  23162. 'var p: TPtr;',
  23163. 'begin',
  23164. ' p:=typeinfo(string);',
  23165. ' p:=typeinfo(tcaption);',
  23166. ' p:=typeinfo(boolean);',
  23167. ' p:=typeinfo(tyesno);',
  23168. ' p:=typeinfo(char);',
  23169. ' p:=typeinfo(tletter);',
  23170. ' p:=typeinfo(double);',
  23171. ' p:=typeinfo(tfloat);',
  23172. ' p:=typeinfo(pointer);',
  23173. ' p:=typeinfo(tptr);',
  23174. ' p:=typeinfo(shortint);',
  23175. ' p:=typeinfo(tshortint);',
  23176. ' p:=typeinfo(byte);',
  23177. ' p:=typeinfo(tbyte);',
  23178. ' p:=typeinfo(smallint);',
  23179. ' p:=typeinfo(tsmallint);',
  23180. ' p:=typeinfo(word);',
  23181. ' p:=typeinfo(tword);',
  23182. ' p:=typeinfo(longword);',
  23183. ' p:=typeinfo(tdword);',
  23184. ' p:=typeinfo(jsvalue);',
  23185. ' p:=typeinfo(tvalue);',
  23186. '']);
  23187. ConvertProgram;
  23188. CheckSource('TestRTTI_TypeInfo_BaseTypes',
  23189. LinesToStr([ // statements
  23190. 'this.p = null;',
  23191. '']),
  23192. LinesToStr([ // $mod.$main
  23193. '$mod.p = rtl.string;',
  23194. '$mod.p = rtl.string;',
  23195. '$mod.p = rtl.boolean;',
  23196. '$mod.p = rtl.boolean;',
  23197. '$mod.p = rtl.char;',
  23198. '$mod.p = rtl.char;',
  23199. '$mod.p = rtl.double;',
  23200. '$mod.p = rtl.double;',
  23201. '$mod.p = rtl.pointer;',
  23202. '$mod.p = rtl.pointer;',
  23203. '$mod.p = rtl.shortint;',
  23204. '$mod.p = rtl.shortint;',
  23205. '$mod.p = rtl.byte;',
  23206. '$mod.p = rtl.byte;',
  23207. '$mod.p = rtl.smallint;',
  23208. '$mod.p = rtl.smallint;',
  23209. '$mod.p = rtl.word;',
  23210. '$mod.p = rtl.word;',
  23211. '$mod.p = rtl.longword;',
  23212. '$mod.p = rtl.longword;',
  23213. '$mod.p = rtl.jsvalue;',
  23214. '$mod.p = rtl.jsvalue;',
  23215. '']));
  23216. end;
  23217. procedure TTestModule.TestRTTI_TypeInfo_Type_BaseTypes;
  23218. begin
  23219. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23220. StartProgram(false);
  23221. Add([
  23222. 'type',
  23223. ' TCaption = type string;',
  23224. ' TYesNo = type boolean;',
  23225. ' TLetter = type char;',
  23226. ' TFloat = type double;',
  23227. ' TPtr = type pointer;',
  23228. ' TShortInt = type shortint;',
  23229. ' TByte = type byte;',
  23230. ' TSmallInt = type smallint;',
  23231. ' TWord = type word;',
  23232. ' TInt32 = type longint;',
  23233. ' TDWord = type longword;',
  23234. ' TValue = type jsvalue;',
  23235. ' TAliasValue = type TValue;',
  23236. 'var',
  23237. ' p: TPtr;',
  23238. ' a: TAliasValue;',
  23239. 'begin',
  23240. ' p:=typeinfo(tcaption);',
  23241. ' p:=typeinfo(tyesno);',
  23242. ' p:=typeinfo(tletter);',
  23243. ' p:=typeinfo(tfloat);',
  23244. ' p:=typeinfo(tptr);',
  23245. ' p:=typeinfo(tshortint);',
  23246. ' p:=typeinfo(tbyte);',
  23247. ' p:=typeinfo(tsmallint);',
  23248. ' p:=typeinfo(tword);',
  23249. ' p:=typeinfo(tdword);',
  23250. ' p:=typeinfo(tvalue);',
  23251. ' p:=typeinfo(taliasvalue);',
  23252. ' p:=typeinfo(a);',
  23253. '']);
  23254. ConvertProgram;
  23255. CheckSource('TestRTTI_TypeInfo_Type_BaseTypes',
  23256. LinesToStr([ // statements
  23257. '$mod.$rtti.$inherited("TCaption", rtl.string, {});',
  23258. '$mod.$rtti.$inherited("TYesNo", rtl.boolean, {});',
  23259. '$mod.$rtti.$inherited("TLetter", rtl.char, {});',
  23260. '$mod.$rtti.$inherited("TFloat", rtl.double, {});',
  23261. '$mod.$rtti.$inherited("TPtr", rtl.pointer, {});',
  23262. '$mod.$rtti.$inherited("TShortInt", rtl.shortint, {});',
  23263. '$mod.$rtti.$inherited("TByte", rtl.byte, {});',
  23264. '$mod.$rtti.$inherited("TSmallInt", rtl.smallint, {});',
  23265. '$mod.$rtti.$inherited("TWord", rtl.word, {});',
  23266. '$mod.$rtti.$inherited("TInt32", rtl.longint, {});',
  23267. '$mod.$rtti.$inherited("TDWord", rtl.longword, {});',
  23268. '$mod.$rtti.$inherited("TValue", rtl.jsvalue, {});',
  23269. '$mod.$rtti.$inherited("TAliasValue", $mod.$rtti["TValue"], {});',
  23270. 'this.p = null;',
  23271. 'this.a = undefined;',
  23272. '']),
  23273. LinesToStr([ // $mod.$main
  23274. '$mod.p = $mod.$rtti["TCaption"];',
  23275. '$mod.p = $mod.$rtti["TYesNo"];',
  23276. '$mod.p = $mod.$rtti["TLetter"];',
  23277. '$mod.p = $mod.$rtti["TFloat"];',
  23278. '$mod.p = $mod.$rtti["TPtr"];',
  23279. '$mod.p = $mod.$rtti["TShortInt"];',
  23280. '$mod.p = $mod.$rtti["TByte"];',
  23281. '$mod.p = $mod.$rtti["TSmallInt"];',
  23282. '$mod.p = $mod.$rtti["TWord"];',
  23283. '$mod.p = $mod.$rtti["TDWord"];',
  23284. '$mod.p = $mod.$rtti["TValue"];',
  23285. '$mod.p = $mod.$rtti["TAliasValue"];',
  23286. '$mod.p = $mod.$rtti["TAliasValue"];',
  23287. '']));
  23288. end;
  23289. procedure TTestModule.TestRTTI_TypeInfo_LocalFail;
  23290. begin
  23291. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23292. StartProgram(false);
  23293. Add('procedure DoIt;');
  23294. Add('type');
  23295. Add(' integer = longint;');
  23296. Add(' TPoint = record');
  23297. Add(' x,y: integer;');
  23298. Add(' end;');
  23299. Add('var p: pointer;');
  23300. Add('begin');
  23301. Add(' p:=typeinfo(tpoint);');
  23302. Add('end;');
  23303. Add('begin');
  23304. SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
  23305. ConvertProgram;
  23306. end;
  23307. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  23308. begin
  23309. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23310. StartProgram(false);
  23311. Add([
  23312. '{$modeswitch externalclass}',
  23313. 'type',
  23314. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23315. ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
  23316. ' TFlag = (up,down);',
  23317. ' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;',
  23318. ' TFlags = set of TFlag;',
  23319. ' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;',
  23320. 'var',
  23321. ' ti: TTypeInfo;',
  23322. ' tiInt: TTypeInfoInteger;',
  23323. ' tiEnum: TTypeInfoEnum;',
  23324. ' tiSet: TTypeInfoSet;',
  23325. 'begin',
  23326. ' ti:=typeinfo(string);',
  23327. ' ti:=typeinfo(boolean);',
  23328. ' ti:=typeinfo(char);',
  23329. ' ti:=typeinfo(double);',
  23330. ' tiInt:=typeinfo(shortint);',
  23331. ' tiInt:=typeinfo(byte);',
  23332. ' tiInt:=typeinfo(smallint);',
  23333. ' tiInt:=typeinfo(word);',
  23334. ' tiInt:=typeinfo(longint);',
  23335. ' tiInt:=typeinfo(longword);',
  23336. ' ti:=typeinfo(jsvalue);',
  23337. ' tiEnum:=typeinfo(tflag);',
  23338. ' tiSet:=typeinfo(tflags);']);
  23339. ConvertProgram;
  23340. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
  23341. LinesToStr([ // statements
  23342. 'this.TFlag = {',
  23343. ' "0": "up",',
  23344. ' up: 0,',
  23345. ' "1": "down",',
  23346. ' down: 1',
  23347. '};',
  23348. '$mod.$rtti.$Enum("TFlag", {',
  23349. ' minvalue: 0,',
  23350. ' maxvalue: 1,',
  23351. ' ordtype: 1,',
  23352. ' enumtype: this.TFlag',
  23353. '});',
  23354. '$mod.$rtti.$Set("TFlags", {',
  23355. ' comptype: $mod.$rtti["TFlag"]',
  23356. '});',
  23357. 'this.ti = null;',
  23358. 'this.tiInt = null;',
  23359. 'this.tiEnum = null;',
  23360. 'this.tiSet = null;',
  23361. '']),
  23362. LinesToStr([ // $mod.$main
  23363. '$mod.ti = rtl.string;',
  23364. '$mod.ti = rtl.boolean;',
  23365. '$mod.ti = rtl.char;',
  23366. '$mod.ti = rtl.double;',
  23367. '$mod.tiInt = rtl.shortint;',
  23368. '$mod.tiInt = rtl.byte;',
  23369. '$mod.tiInt = rtl.smallint;',
  23370. '$mod.tiInt = rtl.word;',
  23371. '$mod.tiInt = rtl.longint;',
  23372. '$mod.tiInt = rtl.longword;',
  23373. '$mod.ti = rtl.jsvalue;',
  23374. '$mod.tiEnum = $mod.$rtti["TFlag"];',
  23375. '$mod.tiSet = $mod.$rtti["TFlags"];',
  23376. '']));
  23377. end;
  23378. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  23379. begin
  23380. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23381. StartProgram(false);
  23382. Add('{$modeswitch externalclass}');
  23383. Add('type');
  23384. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  23385. Add(' TStaticArr = array[boolean] of string;');
  23386. Add(' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
  23387. Add(' TDynArr = array of string;');
  23388. Add(' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
  23389. Add(' TProc = procedure;');
  23390. Add(' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
  23391. Add(' TMethod = procedure of object;');
  23392. Add(' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
  23393. Add('var');
  23394. Add(' StaticArray: TStaticArr;');
  23395. Add(' tiStaticArray: TTypeInfoStaticArray;');
  23396. Add(' DynArray: TDynArr;');
  23397. Add(' tiDynArray: TTypeInfoDynArray;');
  23398. Add(' ProcVar: TProc;');
  23399. Add(' tiProcVar: TTypeInfoProcVar;');
  23400. Add(' MethodVar: TMethod;');
  23401. Add(' tiMethodVar: TTypeInfoMethodVar;');
  23402. Add('begin');
  23403. Add(' tiStaticArray:=typeinfo(StaticArray);');
  23404. Add(' tiStaticArray:=typeinfo(TStaticArr);');
  23405. Add(' tiDynArray:=typeinfo(DynArray);');
  23406. Add(' tiDynArray:=typeinfo(TDynArr);');
  23407. Add(' tiProcVar:=typeinfo(ProcVar);');
  23408. Add(' tiProcVar:=typeinfo(TProc);');
  23409. Add(' tiMethodVar:=typeinfo(MethodVar);');
  23410. Add(' tiMethodVar:=typeinfo(TMethod);');
  23411. ConvertProgram;
  23412. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
  23413. LinesToStr([ // statements
  23414. ' $mod.$rtti.$StaticArray("TStaticArr", {',
  23415. ' dims: [2],',
  23416. ' eltype: rtl.string',
  23417. '});',
  23418. '$mod.$rtti.$DynArray("TDynArr", {',
  23419. ' eltype: rtl.string',
  23420. '});',
  23421. '$mod.$rtti.$ProcVar("TProc", {',
  23422. ' procsig: rtl.newTIProcSig(null)',
  23423. '});',
  23424. '$mod.$rtti.$MethodVar("TMethod", {',
  23425. ' procsig: rtl.newTIProcSig(null),',
  23426. ' methodkind: 0',
  23427. '});',
  23428. 'this.StaticArray = rtl.arraySetLength(null,"",2);',
  23429. 'this.tiStaticArray = null;',
  23430. 'this.DynArray = [];',
  23431. 'this.tiDynArray = null;',
  23432. 'this.ProcVar = null;',
  23433. 'this.tiProcVar = null;',
  23434. 'this.MethodVar = null;',
  23435. 'this.tiMethodVar = null;',
  23436. '']),
  23437. LinesToStr([ // $mod.$main
  23438. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  23439. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  23440. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  23441. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  23442. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  23443. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  23444. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  23445. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  23446. '']));
  23447. end;
  23448. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  23449. begin
  23450. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23451. StartProgram(false);
  23452. Add('{$modeswitch externalclass}');
  23453. Add('type');
  23454. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  23455. Add(' TRec = record end;');
  23456. Add(' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
  23457. // ToDo: ^PRec
  23458. Add(' TObject = class end;');
  23459. Add(' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
  23460. Add(' TClass = class of tobject;');
  23461. Add(' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
  23462. Add(' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
  23463. Add('var');
  23464. Add(' Rec: trec;');
  23465. Add(' tiRecord: ttypeinforecord;');
  23466. Add(' Obj: tobject;');
  23467. Add(' tiClass: ttypeinfoclass;');
  23468. Add(' aClass: tclass;');
  23469. Add(' tiClassRef: ttypeinfoclassref;');
  23470. // ToDo: ^PRec
  23471. Add(' tiPointer: ttypeinfopointer;');
  23472. Add('begin');
  23473. Add(' tirecord:=typeinfo(trec);');
  23474. Add(' tirecord:=typeinfo(trec);');
  23475. Add(' ticlass:=typeinfo(obj);');
  23476. Add(' ticlass:=typeinfo(tobject);');
  23477. Add(' ticlass:=typeinfo(aclass);');
  23478. Add(' ticlassref:=typeinfo(tclass);');
  23479. ConvertProgram;
  23480. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
  23481. LinesToStr([ // statements
  23482. 'rtl.recNewT($mod, "TRec", function () {',
  23483. ' this.$eq = function (b) {',
  23484. ' return true;',
  23485. ' };',
  23486. ' this.$assign = function (s) {',
  23487. ' return this;',
  23488. ' };',
  23489. ' $mod.$rtti.$Record("TRec", {});',
  23490. '});',
  23491. 'rtl.createClass($mod, "TObject", null, function () {',
  23492. ' this.$init = function () {',
  23493. ' };',
  23494. ' this.$final = function () {',
  23495. ' };',
  23496. '});',
  23497. '$mod.$rtti.$ClassRef("TClass", {',
  23498. ' instancetype: $mod.$rtti["TObject"]',
  23499. '});',
  23500. 'this.Rec = $mod.TRec.$new();',
  23501. 'this.tiRecord = null;',
  23502. 'this.Obj = null;',
  23503. 'this.tiClass = null;',
  23504. 'this.aClass = null;',
  23505. 'this.tiClassRef = null;',
  23506. 'this.tiPointer = null;',
  23507. '']),
  23508. LinesToStr([ // $mod.$main
  23509. '$mod.tiRecord = $mod.$rtti["TRec"];',
  23510. '$mod.tiRecord = $mod.$rtti["TRec"];',
  23511. '$mod.tiClass = $mod.Obj.$rtti;',
  23512. '$mod.tiClass = $mod.$rtti["TObject"];',
  23513. '$mod.tiClass = $mod.aClass.$rtti;',
  23514. '$mod.tiClassRef = $mod.$rtti["TClass"];',
  23515. '']));
  23516. end;
  23517. procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
  23518. begin
  23519. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23520. StartProgram(false);
  23521. Add([
  23522. '{$modeswitch externalclass}',
  23523. 'type',
  23524. ' TClass = class of tobject;',
  23525. ' TObject = class',
  23526. ' function MyClass: TClass;',
  23527. ' class function ClassType: TClass;',
  23528. ' end;',
  23529. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23530. ' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
  23531. 'function TObject.MyClass: TClass;',
  23532. 'var t: TTypeInfoClass;',
  23533. 'begin',
  23534. ' t:=TypeInfo(Self);',
  23535. ' t:=TypeInfo(Result);',
  23536. ' t:=TypeInfo(TObject);',
  23537. 'end;',
  23538. 'class function TObject.ClassType: TClass;',
  23539. 'var t: TTypeInfoClass;',
  23540. 'begin',
  23541. ' t:=TypeInfo(Self);',
  23542. ' t:=TypeInfo(Result);',
  23543. 'end;',
  23544. 'var',
  23545. ' Obj: TObject;',
  23546. ' t: TTypeInfoClass;',
  23547. 'begin',
  23548. ' t:=TypeInfo(TObject.ClassType);',
  23549. ' t:=TypeInfo(Obj.ClassType);',
  23550. ' t:=TypeInfo(Obj.MyClass);',
  23551. '']);
  23552. ConvertProgram;
  23553. CheckSource('TestRTTI_TypeInfo_FunctionClassType',
  23554. LinesToStr([ // statements
  23555. '$mod.$rtti.$Class("TObject");',
  23556. '$mod.$rtti.$ClassRef("TClass", {',
  23557. ' instancetype: $mod.$rtti["TObject"]',
  23558. '});',
  23559. 'rtl.createClass($mod, "TObject", null, function () {',
  23560. ' this.$init = function () {',
  23561. ' };',
  23562. ' this.$final = function () {',
  23563. ' };',
  23564. ' this.MyClass = function () {',
  23565. ' var Result = null;',
  23566. ' var t = null;',
  23567. ' t = this.$rtti;',
  23568. ' t = Result.$rtti;',
  23569. ' t = $mod.$rtti["TObject"];',
  23570. ' return Result;',
  23571. ' };',
  23572. ' this.ClassType = function () {',
  23573. ' var Result = null;',
  23574. ' var t = null;',
  23575. ' t = this.$rtti;',
  23576. ' t = Result.$rtti;',
  23577. ' return Result;',
  23578. ' };',
  23579. '});',
  23580. 'this.Obj = null;',
  23581. 'this.t = null;',
  23582. '']),
  23583. LinesToStr([ // $mod.$main
  23584. '$mod.t = $mod.TObject.ClassType().$rtti;',
  23585. '$mod.t = $mod.Obj.$class.ClassType().$rtti;',
  23586. '$mod.t = $mod.Obj.MyClass().$rtti;',
  23587. '']));
  23588. end;
  23589. procedure TTestModule.TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
  23590. begin
  23591. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23592. AddModuleWithIntfImplSrc('typinfo.pas',
  23593. LinesToStr([
  23594. '{$modeswitch externalclass}',
  23595. 'type',
  23596. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23597. ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
  23598. '']),
  23599. '');
  23600. AddModuleWithIntfImplSrc('unit2.pas',
  23601. LinesToStr([
  23602. 'uses typinfo;',
  23603. 'type PTypeInfo = TTypeInfo;', // delphi compatibility code
  23604. 'procedure DoPtr(p: PTypeInfo);',
  23605. 'procedure DoInfo(t: TTypeInfo);',
  23606. 'procedure DoInt(t: TTypeInfoInteger);',
  23607. '']),
  23608. LinesToStr([
  23609. 'procedure DoPtr(p: PTypeInfo);',
  23610. 'begin end;',
  23611. 'procedure DoInfo(t: TTypeInfo);',
  23612. 'begin end;',
  23613. 'procedure DoInt(t: TTypeInfoInteger);',
  23614. 'begin end;',
  23615. '']));
  23616. StartUnit(true);
  23617. Add([
  23618. 'interface',
  23619. 'uses unit2;', // does not use unit typinfo
  23620. 'implementation',
  23621. 'var',
  23622. ' i: byte;',
  23623. ' p: pointer;',
  23624. ' t: PTypeInfo;',
  23625. 'initialization',
  23626. ' p:=typeinfo(i);',
  23627. ' t:=typeinfo(i);',
  23628. ' if p=t then ;',
  23629. ' if p=typeinfo(i) then ;',
  23630. ' if typeinfo(i)=p then ;',
  23631. ' if t=typeinfo(i) then ;',
  23632. ' if typeinfo(i)=t then ;',
  23633. ' DoPtr(p);',
  23634. ' DoPtr(t);',
  23635. ' DoPtr(typeinfo(i));',
  23636. ' DoInfo(p);',
  23637. ' DoInfo(t);',
  23638. ' DoInfo(typeinfo(i));',
  23639. ' DoInt(typeinfo(i));',
  23640. '']);
  23641. ConvertUnit;
  23642. CheckSource('TestRTTI_TypeInfo_MixedUnits_PointerAndClass',
  23643. LinesToStr([ // statements
  23644. 'var $impl = $mod.$impl;',
  23645. '']),
  23646. LinesToStr([ // this.$init
  23647. '$impl.p = rtl.byte;',
  23648. '$impl.t = rtl.byte;',
  23649. 'if ($impl.p === $impl.t) ;',
  23650. 'if ($impl.p === rtl.byte) ;',
  23651. 'if (rtl.byte === $impl.p) ;',
  23652. 'if ($impl.t === rtl.byte) ;',
  23653. 'if (rtl.byte === $impl.t) ;',
  23654. 'pas.unit2.DoPtr($impl.p);',
  23655. 'pas.unit2.DoPtr($impl.t);',
  23656. 'pas.unit2.DoPtr(rtl.byte);',
  23657. 'pas.unit2.DoInfo($impl.p);',
  23658. 'pas.unit2.DoInfo($impl.t);',
  23659. 'pas.unit2.DoInfo(rtl.byte);',
  23660. 'pas.unit2.DoInt(rtl.byte);',
  23661. '']),
  23662. LinesToStr([ // implementation
  23663. '$impl.i = 0;',
  23664. '$impl.p = null;',
  23665. '$impl.t = null;',
  23666. '']) );
  23667. end;
  23668. procedure TTestModule.TestRTTI_Interface_Corba;
  23669. begin
  23670. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23671. StartProgram(false);
  23672. Add([
  23673. '{$interfaces corba}',
  23674. '{$modeswitch externalclass}',
  23675. 'type',
  23676. ' IUnknown = interface',
  23677. ' end;',
  23678. ' IBird = interface',
  23679. ' function GetItem: longint;',
  23680. ' procedure SetItem(Value: longint);',
  23681. ' property Item: longint read GetItem write SetItem;',
  23682. ' end;',
  23683. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23684. ' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
  23685. 'procedure DoIt(t: TTypeInfoInterface); begin end;',
  23686. 'var',
  23687. ' i: IBird;',
  23688. ' t: TTypeInfoInterface;',
  23689. 'begin',
  23690. ' t:=TypeInfo(IBird);',
  23691. ' t:=TypeInfo(i);',
  23692. ' DoIt(t);',
  23693. ' DoIt(TypeInfo(IBird));',
  23694. '']);
  23695. ConvertProgram;
  23696. CheckSource('TestRTTI_Interface_Corba',
  23697. LinesToStr([ // statements
  23698. 'rtl.createInterface(',
  23699. ' $mod,',
  23700. ' "IUnknown",',
  23701. ' "{B92D5841-758A-322B-B800-000000000000}",',
  23702. ' [],',
  23703. ' null,',
  23704. ' function () {',
  23705. ' }',
  23706. ');',
  23707. 'rtl.createInterface(',
  23708. ' $mod,',
  23709. ' "IBird",',
  23710. ' "{D32D5841-6264-3AE3-A2C9-B91CE922C9B9}",',
  23711. ' ["GetItem", "SetItem"],',
  23712. ' null,',
  23713. ' function () {',
  23714. ' var $r = this.$rtti;',
  23715. ' $r.addMethod("GetItem", 1, null, rtl.longint);',
  23716. ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
  23717. ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
  23718. ' }',
  23719. ');',
  23720. 'this.DoIt = function (t) {',
  23721. '}; ',
  23722. 'this.i = null;',
  23723. 'this.t = null;',
  23724. '']),
  23725. LinesToStr([ // $mod.$main
  23726. '$mod.t = $mod.$rtti["IBird"];',
  23727. '$mod.t = $mod.i.$rtti;',
  23728. '$mod.DoIt($mod.t);',
  23729. '$mod.DoIt($mod.$rtti["IBird"]);',
  23730. '']));
  23731. end;
  23732. procedure TTestModule.TestRTTI_Interface_COM;
  23733. begin
  23734. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23735. StartProgram(false);
  23736. Add([
  23737. '{$interfaces com}',
  23738. '{$modeswitch externalclass}',
  23739. 'type',
  23740. ' TGuid = record end;',
  23741. ' integer = longint;',
  23742. ' IUnknown = interface',
  23743. ' function QueryInterface(const iid: TGuid; out obj): Integer;',
  23744. ' function _AddRef: Integer;',
  23745. ' function _Release: Integer;',
  23746. ' end;',
  23747. ' IBird = interface',
  23748. ' function GetItem: longint;',
  23749. ' procedure SetItem(Value: longint);',
  23750. ' property Item: longint read GetItem write SetItem;',
  23751. ' end;',
  23752. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23753. ' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
  23754. 'var',
  23755. ' i: IBird;',
  23756. ' t: TTypeInfoInterface;',
  23757. 'begin',
  23758. ' t:=TypeInfo(IBird);',
  23759. ' t:=TypeInfo(i);',
  23760. '']);
  23761. ConvertProgram;
  23762. CheckSource('TestRTTI_Interface_COM',
  23763. LinesToStr([ // statements
  23764. 'rtl.recNewT($mod, "TGuid", function () {',
  23765. ' this.$eq = function (b) {',
  23766. ' return true;',
  23767. ' };',
  23768. ' this.$assign = function (s) {',
  23769. ' return this;',
  23770. ' };',
  23771. ' $mod.$rtti.$Record("TGuid", {});',
  23772. '});',
  23773. 'rtl.createInterface(',
  23774. ' $mod,',
  23775. ' "IUnknown",',
  23776. ' "{D7ADB00D-1A9B-3EDC-B123-730E661DDFA9}",',
  23777. ' ["QueryInterface", "_AddRef", "_Release"],',
  23778. ' null,',
  23779. ' function () {',
  23780. ' this.$kind = "com";',
  23781. ' var $r = this.$rtti;',
  23782. ' $r.addMethod("QueryInterface", 1, [["iid", $mod.$rtti["TGuid"], 2], ["obj", null, 4]], rtl.longint);',
  23783. ' $r.addMethod("_AddRef", 1, null, rtl.longint);',
  23784. ' $r.addMethod("_Release", 1, null, rtl.longint);',
  23785. ' }',
  23786. ');',
  23787. 'rtl.createInterface(',
  23788. ' $mod,',
  23789. ' "IBird",',
  23790. ' "{9CC77572-0E45-3594-9A88-9E8D865C9E0A}",',
  23791. ' ["GetItem", "SetItem"],',
  23792. ' $mod.IUnknown,',
  23793. ' function () {',
  23794. ' var $r = this.$rtti;',
  23795. ' $r.addMethod("GetItem", 1, null, rtl.longint);',
  23796. ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
  23797. ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
  23798. ' }',
  23799. ');',
  23800. 'this.i = null;',
  23801. 'this.t = null;',
  23802. '']),
  23803. LinesToStr([ // $mod.$main
  23804. '$mod.t = $mod.$rtti["IBird"];',
  23805. '$mod.t = $mod.i.$rtti;',
  23806. '']));
  23807. end;
  23808. procedure TTestModule.TestResourcestringProgram;
  23809. begin
  23810. StartProgram(false);
  23811. Add([
  23812. 'const Bar = ''bar'';',
  23813. 'resourcestring',
  23814. ' Red = ''red'';',
  23815. ' Foobar = ''fOo''+bar;',
  23816. 'var s: string;',
  23817. ' c: char;',
  23818. 'begin',
  23819. ' s:=red;',
  23820. ' s:=test1.red;',
  23821. ' c:=red[1];',
  23822. ' c:=test1.red[2];',
  23823. ' if red=foobar then ;',
  23824. ' if red[3]=red[4] then ;']);
  23825. ConvertProgram;
  23826. CheckSource('TestResourcestringProgram',
  23827. LinesToStr([ // statements
  23828. 'this.Bar = "bar";',
  23829. 'this.s = "";',
  23830. 'this.c = "";',
  23831. '$mod.$resourcestrings = {',
  23832. ' Red: {',
  23833. ' org: "red"',
  23834. ' },',
  23835. ' Foobar: {',
  23836. ' org: "fOobar"',
  23837. ' }',
  23838. '};',
  23839. '']),
  23840. LinesToStr([ // $mod.$main
  23841. '$mod.s = rtl.getResStr(pas.program, "Red");',
  23842. '$mod.s = rtl.getResStr(pas.program, "Red");',
  23843. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(0);',
  23844. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(1);',
  23845. 'if (rtl.getResStr(pas.program, "Red") === rtl.getResStr(pas.program, "Foobar")) ;',
  23846. 'if (rtl.getResStr(pas.program, "Red").charAt(2) === rtl.getResStr(pas.program, "Red").charAt(3)) ;',
  23847. '']));
  23848. end;
  23849. procedure TTestModule.TestResourcestringUnit;
  23850. begin
  23851. StartUnit(false);
  23852. Add([
  23853. 'interface',
  23854. 'const Red = ''rEd'';',
  23855. 'resourcestring',
  23856. ' Blue = ''blue'';',
  23857. ' NotRed = ''not''+Red;',
  23858. 'var s: string;',
  23859. 'implementation',
  23860. 'resourcestring',
  23861. ' ImplGreen = ''green'';',
  23862. 'initialization',
  23863. ' s:=blue+ImplGreen;',
  23864. ' s:=test1.blue+test1.implgreen;',
  23865. ' s:=blue[1]+implgreen[2];']);
  23866. ConvertUnit;
  23867. CheckSource('TestResourcestringUnit',
  23868. LinesToStr([ // statements
  23869. 'this.Red = "rEd";',
  23870. 'this.s = "";',
  23871. '$mod.$resourcestrings = {',
  23872. ' Blue: {',
  23873. ' org: "blue"',
  23874. ' },',
  23875. ' NotRed: {',
  23876. ' org: "notrEd"',
  23877. ' },',
  23878. ' ImplGreen: {',
  23879. ' org: "green"',
  23880. ' }',
  23881. '};',
  23882. '']),
  23883. LinesToStr([ // $mod.$main
  23884. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  23885. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  23886. '$mod.s = rtl.getResStr(pas.Test1, "Blue").charAt(0) + rtl.getResStr(pas.Test1, "ImplGreen").charAt(1);',
  23887. '']));
  23888. end;
  23889. procedure TTestModule.TestResourcestringImplementation;
  23890. begin
  23891. StartUnit(false);
  23892. Add([
  23893. 'interface',
  23894. 'implementation',
  23895. 'resourcestring',
  23896. ' ImplRed = ''red'';']);
  23897. ConvertUnit;
  23898. CheckSource('TestResourcestringImplementation',
  23899. LinesToStr([ // intf statements
  23900. 'var $impl = $mod.$impl;']),
  23901. LinesToStr([ // $mod.$init
  23902. '']),
  23903. LinesToStr([ // impl statements
  23904. '$mod.$resourcestrings = {',
  23905. ' ImplRed: {',
  23906. ' org: "red"',
  23907. ' }',
  23908. '};',
  23909. '']));
  23910. end;
  23911. procedure TTestModule.TestAtributes_Ignore;
  23912. begin
  23913. StartProgram(false);
  23914. Add([
  23915. '{$modeswitch ignoreattributes}',
  23916. 'type',
  23917. ' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
  23918. ' TObject = class',
  23919. ' [custom5()] FS: string;',
  23920. ' [customProp] property S: string read FS;',
  23921. ' end;',
  23922. 'var',
  23923. ' [custom6]',
  23924. ' o: TObject;',
  23925. 'begin',
  23926. '']);
  23927. ConvertProgram;
  23928. CheckSource('TestAtributes_Ignore',
  23929. LinesToStr([ // statements
  23930. 'rtl.createClass($mod, "TObject", null, function () {',
  23931. ' this.$init = function () {',
  23932. ' this.FS = "";',
  23933. ' };',
  23934. ' this.$final = function () {',
  23935. ' };',
  23936. '});',
  23937. 'this.o = null;',
  23938. '']),
  23939. LinesToStr([ // $mod.$main
  23940. '']));
  23941. end;
  23942. procedure TTestModule.TestAssert;
  23943. begin
  23944. StartProgram(false);
  23945. Add([
  23946. 'procedure DoIt;',
  23947. 'var',
  23948. ' b: boolean;',
  23949. ' s: string;',
  23950. 'begin',
  23951. ' {$Assertions on}',
  23952. ' Assert(b);',
  23953. 'end;',
  23954. 'begin',
  23955. ' DoIt;',
  23956. '']);
  23957. ConvertProgram;
  23958. CheckSource('TestAssert',
  23959. LinesToStr([ // statements
  23960. 'this.DoIt = function () {',
  23961. ' var b = false;',
  23962. ' var s = "";',
  23963. ' if (!b) throw "assert failed";',
  23964. '};',
  23965. '']),
  23966. LinesToStr([ // $mod.$main
  23967. '$mod.DoIt();',
  23968. '']));
  23969. end;
  23970. procedure TTestModule.TestAssert_SysUtils;
  23971. begin
  23972. AddModuleWithIntfImplSrc('SysUtils.pas',
  23973. LinesToStr([
  23974. 'type',
  23975. ' TObject = class',
  23976. ' constructor Create;',
  23977. ' end;',
  23978. ' EAssertionFailed = class',
  23979. ' constructor Create(s: string);',
  23980. ' end;',
  23981. '']),
  23982. LinesToStr([
  23983. 'constructor TObject.Create;',
  23984. 'begin end;',
  23985. 'constructor EAssertionFailed.Create(s: string);',
  23986. 'begin end;',
  23987. '']) );
  23988. StartProgram(true);
  23989. Add([
  23990. 'uses sysutils;',
  23991. 'procedure DoIt;',
  23992. 'var',
  23993. ' b: boolean;',
  23994. ' s: string;',
  23995. 'begin',
  23996. ' {$Assertions on}',
  23997. ' Assert(b);',
  23998. ' Assert(b,''msg'');',
  23999. 'end;',
  24000. 'begin',
  24001. ' DoIt;',
  24002. '']);
  24003. ConvertProgram;
  24004. CheckSource('TestAssert_SysUtils',
  24005. LinesToStr([ // statements
  24006. 'this.DoIt = function () {',
  24007. ' var b = false;',
  24008. ' var s = "";',
  24009. ' if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
  24010. ' if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
  24011. '};',
  24012. '']),
  24013. LinesToStr([ // $mod.$main
  24014. '$mod.DoIt();',
  24015. '']));
  24016. end;
  24017. procedure TTestModule.TestObjectChecks;
  24018. begin
  24019. Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsObjectChecks];
  24020. StartProgram(false);
  24021. Add([
  24022. 'type',
  24023. ' TObject = class',
  24024. ' procedure DoIt;',
  24025. ' end;',
  24026. ' TClass = class of tobject;',
  24027. ' TBird = class',
  24028. ' end;',
  24029. ' TBirdClass = class of TBird;',
  24030. 'var',
  24031. ' o : TObject;',
  24032. ' c: TClass;',
  24033. ' b: TBird;',
  24034. ' bc: TBirdClass;',
  24035. 'procedure TObject.DoIt;',
  24036. 'begin',
  24037. ' b:=TBird(o);',
  24038. 'end;',
  24039. 'begin',
  24040. ' o.DoIt;',
  24041. ' b:=TBird(o);',
  24042. ' bc:=TBirdClass(c);',
  24043. '']);
  24044. ConvertProgram;
  24045. CheckSource('TestCheckMethodCall',
  24046. LinesToStr([ // statements
  24047. 'rtl.createClass($mod, "TObject", null, function () {',
  24048. ' this.$init = function () {',
  24049. ' };',
  24050. ' this.$final = function () {',
  24051. ' };',
  24052. ' this.DoIt = function () {',
  24053. ' rtl.checkMethodCall(this,$mod.TObject);',
  24054. ' $mod.b = rtl.asExt($mod.o, $mod.TBird, 1);',
  24055. ' };',
  24056. '});',
  24057. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  24058. '});',
  24059. 'this.o = null;',
  24060. 'this.c = null;',
  24061. 'this.b = null;',
  24062. 'this.bc = null;',
  24063. '']),
  24064. LinesToStr([ // $mod.$main
  24065. '$mod.o.DoIt();',
  24066. '$mod.b = rtl.asExt($mod.o,$mod.TBird, 1);',
  24067. '$mod.bc = rtl.asExt($mod.c, $mod.TBird, 2);',
  24068. '']));
  24069. end;
  24070. procedure TTestModule.TestRangeChecks_AssignInt;
  24071. begin
  24072. Scanner.Options:=Scanner.Options+[po_CAssignments];
  24073. StartProgram(false);
  24074. Add([
  24075. '{$R+}',
  24076. 'var',
  24077. ' b: byte = 2;',
  24078. ' w: word = 3;',
  24079. 'procedure DoIt(p: byte);',
  24080. 'begin',
  24081. ' b:=w;',
  24082. ' b+=w;',
  24083. ' b:=1;',
  24084. 'end;',
  24085. '{$R-}',
  24086. 'procedure DoSome;',
  24087. 'begin',
  24088. ' DoIt(w);',
  24089. ' b:=w;',
  24090. ' b:=2;',
  24091. 'end;',
  24092. 'begin',
  24093. '{$R+}',
  24094. '']);
  24095. ConvertProgram;
  24096. CheckSource('TestRangeChecks_AssignInt',
  24097. LinesToStr([ // statements
  24098. 'this.b = 2;',
  24099. 'this.w = 3;',
  24100. 'this.DoIt = function (p) {',
  24101. ' rtl.rc(p, 0, 255);',
  24102. ' $mod.b = rtl.rc($mod.w,0,255);',
  24103. ' rtl.rc($mod.b += $mod.w, 0, 255);',
  24104. ' $mod.b = 1;',
  24105. '};',
  24106. 'this.DoSome = function () {',
  24107. ' $mod.DoIt($mod.w);',
  24108. ' $mod.b = $mod.w;',
  24109. ' $mod.b = 2;',
  24110. '};',
  24111. '']),
  24112. LinesToStr([ // $mod.$main
  24113. '']));
  24114. end;
  24115. procedure TTestModule.TestRangeChecks_AssignIntRange;
  24116. begin
  24117. Scanner.Options:=Scanner.Options+[po_CAssignments];
  24118. StartProgram(false);
  24119. Add([
  24120. '{$R+}',
  24121. 'type Ten = 1..10;',
  24122. 'var',
  24123. ' b: Ten = 2;',
  24124. ' w: Ten = 3;',
  24125. 'procedure DoIt(p: Ten);',
  24126. 'begin',
  24127. ' b:=w;',
  24128. ' b+=w;',
  24129. ' b:=1;',
  24130. 'end;',
  24131. '{$R-}',
  24132. 'procedure DoSome;',
  24133. 'begin',
  24134. ' DoIt(w);',
  24135. ' b:=w;',
  24136. ' b:=2;',
  24137. 'end;',
  24138. 'begin',
  24139. '{$R+}',
  24140. '']);
  24141. ConvertProgram;
  24142. CheckSource('TestRangeChecks_AssignIntRange',
  24143. LinesToStr([ // statements
  24144. 'this.b = 2;',
  24145. 'this.w = 3;',
  24146. 'this.DoIt = function (p) {',
  24147. ' rtl.rc(p, 1, 10);',
  24148. ' $mod.b = rtl.rc($mod.w, 1, 10);',
  24149. ' rtl.rc($mod.b += $mod.w, 1, 10);',
  24150. ' $mod.b = 1;',
  24151. '};',
  24152. 'this.DoSome = function () {',
  24153. ' $mod.DoIt($mod.w);',
  24154. ' $mod.b = $mod.w;',
  24155. ' $mod.b = 2;',
  24156. '};',
  24157. '']),
  24158. LinesToStr([ // $mod.$main
  24159. '']));
  24160. end;
  24161. procedure TTestModule.TestRangeChecks_AssignEnum;
  24162. begin
  24163. StartProgram(false);
  24164. Add([
  24165. '{$R+}',
  24166. 'type TEnum = (red,green);',
  24167. 'var',
  24168. ' e: TEnum = red;',
  24169. 'procedure DoIt(p: TEnum);',
  24170. 'begin',
  24171. ' e:=p;',
  24172. ' p:=TEnum(0);',
  24173. ' p:=succ(e);',
  24174. 'end;',
  24175. '{$R-}',
  24176. 'procedure DoSome;',
  24177. 'begin',
  24178. ' DoIt(e);',
  24179. ' e:=TEnum(1);',
  24180. ' e:=pred(e);',
  24181. 'end;',
  24182. 'begin',
  24183. '{$R+}',
  24184. '']);
  24185. ConvertProgram;
  24186. CheckSource('TestRangeChecks_AssignEnum',
  24187. LinesToStr([ // statements
  24188. 'this.TEnum = {',
  24189. ' "0": "red",',
  24190. ' red: 0,',
  24191. ' "1": "green",',
  24192. ' green: 1',
  24193. '};',
  24194. 'this.e = $mod.TEnum.red;',
  24195. 'this.DoIt = function (p) {',
  24196. ' rtl.rc(p, 0, 1);',
  24197. ' $mod.e = rtl.rc(p, 0, 1);',
  24198. ' p = 0;',
  24199. ' p = rtl.rc($mod.e + 1, 0, 1);',
  24200. '};',
  24201. 'this.DoSome = function () {',
  24202. ' $mod.DoIt($mod.e);',
  24203. ' $mod.e = 1;',
  24204. ' $mod.e = $mod.e - 1;',
  24205. '};',
  24206. '']),
  24207. LinesToStr([ // $mod.$main
  24208. '']));
  24209. end;
  24210. procedure TTestModule.TestRangeChecks_AssignEnumRange;
  24211. begin
  24212. StartProgram(false);
  24213. Add([
  24214. '{$R+}',
  24215. 'type',
  24216. ' TEnum = (red,green);',
  24217. ' TEnumRg = red..green;',
  24218. 'var',
  24219. ' e: TEnumRg = red;',
  24220. 'procedure DoIt(p: TEnumRg);',
  24221. 'begin',
  24222. ' e:=p;',
  24223. ' p:=TEnumRg(0);',
  24224. ' p:=succ(e);',
  24225. 'end;',
  24226. '{$R-}',
  24227. 'procedure DoSome;',
  24228. 'begin',
  24229. ' DoIt(e);',
  24230. ' e:=TEnum(1);',
  24231. ' e:=pred(e);',
  24232. 'end;',
  24233. 'begin',
  24234. '{$R+}',
  24235. '']);
  24236. ConvertProgram;
  24237. CheckSource('TestRangeChecks_AssignEnumRange',
  24238. LinesToStr([ // statements
  24239. 'this.TEnum = {',
  24240. ' "0": "red",',
  24241. ' red: 0,',
  24242. ' "1": "green",',
  24243. ' green: 1',
  24244. '};',
  24245. 'this.e = $mod.TEnum.red;',
  24246. 'this.DoIt = function (p) {',
  24247. ' rtl.rc(p, 0, 1);',
  24248. ' $mod.e = rtl.rc(p, 0, 1);',
  24249. ' p = 0;',
  24250. ' p = rtl.rc($mod.e + 1, 0, 1);',
  24251. '};',
  24252. 'this.DoSome = function () {',
  24253. ' $mod.DoIt($mod.e);',
  24254. ' $mod.e = 1;',
  24255. ' $mod.e = $mod.e - 1;',
  24256. '};',
  24257. '']),
  24258. LinesToStr([ // $mod.$main
  24259. '']));
  24260. end;
  24261. procedure TTestModule.TestRangeChecks_AssignChar;
  24262. begin
  24263. StartProgram(false);
  24264. Add([
  24265. '{$R+}',
  24266. 'type',
  24267. ' TLetter = char;',
  24268. 'var',
  24269. ' b: TLetter = ''2'';',
  24270. ' w: TLetter = ''3'';',
  24271. 'procedure DoIt(p: TLetter);',
  24272. 'begin',
  24273. ' b:=w;',
  24274. ' b:=''1'';',
  24275. 'end;',
  24276. '{$R-}',
  24277. 'procedure DoSome;',
  24278. 'begin',
  24279. ' DoIt(w);',
  24280. ' b:=w;',
  24281. ' b:=''2'';',
  24282. 'end;',
  24283. 'begin',
  24284. '{$R+}',
  24285. '']);
  24286. ConvertProgram;
  24287. CheckSource('TestRangeChecks_AssignChar',
  24288. LinesToStr([ // statements
  24289. 'this.b = "2";',
  24290. 'this.w = "3";',
  24291. 'this.DoIt = function (p) {',
  24292. ' rtl.rcc(p, 0, 65535);',
  24293. ' $mod.b = rtl.rcc($mod.w, 0, 65535);',
  24294. ' $mod.b = "1";',
  24295. '};',
  24296. 'this.DoSome = function () {',
  24297. ' $mod.DoIt($mod.w);',
  24298. ' $mod.b = $mod.w;',
  24299. ' $mod.b = "2";',
  24300. '};',
  24301. '']),
  24302. LinesToStr([ // $mod.$main
  24303. '']));
  24304. end;
  24305. procedure TTestModule.TestRangeChecks_AssignCharRange;
  24306. begin
  24307. StartProgram(false);
  24308. Add([
  24309. '{$R+}',
  24310. 'type TDigit = ''0''..''9'';',
  24311. 'var',
  24312. ' b: TDigit = ''2'';',
  24313. ' w: TDigit = ''3'';',
  24314. 'procedure DoIt(p: TDigit);',
  24315. 'begin',
  24316. ' b:=w;',
  24317. ' b:=''1'';',
  24318. 'end;',
  24319. '{$R-}',
  24320. 'procedure DoSome;',
  24321. 'begin',
  24322. ' DoIt(w);',
  24323. ' b:=w;',
  24324. ' b:=''2'';',
  24325. 'end;',
  24326. 'begin',
  24327. '{$R+}',
  24328. '']);
  24329. ConvertProgram;
  24330. CheckSource('TestRangeChecks_AssignCharRange',
  24331. LinesToStr([ // statements
  24332. 'this.b = "2";',
  24333. 'this.w = "3";',
  24334. 'this.DoIt = function (p) {',
  24335. ' rtl.rcc(p, 48, 57);',
  24336. ' $mod.b = rtl.rcc($mod.w, 48, 57);',
  24337. ' $mod.b = "1";',
  24338. '};',
  24339. 'this.DoSome = function () {',
  24340. ' $mod.DoIt($mod.w);',
  24341. ' $mod.b = $mod.w;',
  24342. ' $mod.b = "2";',
  24343. '};',
  24344. '']),
  24345. LinesToStr([ // $mod.$main
  24346. '']));
  24347. end;
  24348. procedure TTestModule.TestRangeChecks_ArrayIndex;
  24349. begin
  24350. StartProgram(false);
  24351. Add([
  24352. '{$R+}',
  24353. 'type',
  24354. ' Ten = 1..10;',
  24355. ' TArr = array of Ten;',
  24356. ' TArrArr = array of TArr;',
  24357. ' TArrByte = array[byte] of Ten;',
  24358. ' TArrChar = array[''0''..''9''] of Ten;',
  24359. ' TArrByteChar = array[byte,''0''..''9''] of Ten;',
  24360. ' TObject = class',
  24361. ' A: TArr;',
  24362. ' end;',
  24363. 'procedure DoIt;',
  24364. 'var',
  24365. ' Arr: TArr;',
  24366. ' ArrArr: TArrArr;',
  24367. ' ArrByte: TArrByte;',
  24368. ' ArrChar: TArrChar;',
  24369. ' ArrByteChar: TArrByteChar;',
  24370. ' i: Ten;',
  24371. ' c: char;',
  24372. ' o: tobject;',
  24373. 'begin',
  24374. ' i:=Arr[1];',
  24375. ' i:=ArrByteChar[1,''2''];',
  24376. ' Arr[1]:=Arr[1];',
  24377. ' Arr[i]:=Arr[i];',
  24378. ' ArrByte[3]:=ArrByte[3];',
  24379. ' ArrByte[i]:=ArrByte[i];',
  24380. ' ArrChar[''5'']:=ArrChar[''5''];',
  24381. ' ArrChar[c]:=ArrChar[c];',
  24382. ' ArrByteChar[7,''7'']:=ArrByteChar[7,''7''];',
  24383. ' ArrByteChar[i,c]:=ArrByteChar[i,c];',
  24384. ' o.a[i]:=o.a[i];',
  24385. 'end;',
  24386. 'begin',
  24387. '']);
  24388. ConvertProgram;
  24389. CheckSource('TestRangeChecks_ArrayIndex',
  24390. LinesToStr([ // statements
  24391. 'rtl.createClass($mod, "TObject", null, function () {',
  24392. ' this.$init = function () {',
  24393. ' this.A = [];',
  24394. ' };',
  24395. ' this.$final = function () {',
  24396. ' this.A = undefined;',
  24397. ' };',
  24398. '});',
  24399. 'this.DoIt = function () {',
  24400. ' var Arr = [];',
  24401. ' var ArrArr = [];',
  24402. ' var ArrByte = rtl.arraySetLength(null, 0, 256);',
  24403. ' var ArrChar = rtl.arraySetLength(null, 0, 10);',
  24404. ' var ArrByteChar = rtl.arraySetLength(null, 0, 256, 10);',
  24405. ' var i = 0;',
  24406. ' var c = "";',
  24407. ' var o = null;',
  24408. ' i = rtl.rc(Arr[1], 1, 10);',
  24409. ' i = rtl.rc(ArrByteChar[1][2], 1, 10);',
  24410. ' Arr[1] = rtl.rc(Arr[1], 1, 10);',
  24411. ' rtl.rcArrW(Arr, i, rtl.rcArrR(Arr, i));',
  24412. ' ArrByte[3] = rtl.rc(ArrByte[3], 1, 10);',
  24413. ' rtl.rcArrW(ArrByte, i, rtl.rcArrR(ArrByte, i));',
  24414. ' ArrChar[5] = rtl.rc(ArrChar[5], 1, 10);',
  24415. ' rtl.rcArrW(ArrChar, c.charCodeAt() - 48, rtl.rcArrR(ArrChar, c.charCodeAt() - 48));',
  24416. ' ArrByteChar[7][7] = rtl.rc(ArrByteChar[7][7], 1, 10);',
  24417. ' rtl.rcArrW(ArrByteChar, i, c.charCodeAt() - 48, rtl.rcArrR(ArrByteChar, i, c.charCodeAt() - 48));',
  24418. ' rtl.rcArrW(o.A, i, rtl.rcArrR(o.A, i));',
  24419. '};',
  24420. '']),
  24421. LinesToStr([ // $mod.$main
  24422. '']));
  24423. end;
  24424. procedure TTestModule.TestRangeChecks_ArrayOfRecIndex;
  24425. begin
  24426. StartProgram(false);
  24427. Add([
  24428. '{$R+}',
  24429. 'type',
  24430. ' Ten = 1..10;',
  24431. ' TRec = record x: Ten end;',
  24432. ' TArr = array of TRec;',
  24433. ' TArrArr = array of TArr;',
  24434. ' TObject = class',
  24435. ' A: TArr;',
  24436. ' end;',
  24437. 'procedure DoIt;',
  24438. 'var',
  24439. ' Arr: TArr;',
  24440. ' ArrArr: TArrArr;',
  24441. ' i: Ten;',
  24442. ' o: tobject;',
  24443. 'begin',
  24444. ' Arr[1]:=Arr[1];',
  24445. ' Arr[i]:=Arr[i+1];',
  24446. ' o.a[i]:=o.a[i+2];',
  24447. 'end;',
  24448. 'begin',
  24449. '']);
  24450. ConvertProgram;
  24451. CheckSource('TestRangeChecks_ArrayOfRecIndex',
  24452. LinesToStr([ // statements
  24453. 'rtl.recNewT($mod, "TRec", function () {',
  24454. ' this.x = 0;',
  24455. ' this.$eq = function (b) {',
  24456. ' return this.x === b.x;',
  24457. ' };',
  24458. ' this.$assign = function (s) {',
  24459. ' this.x = s.x;',
  24460. ' return this;',
  24461. ' };',
  24462. '});',
  24463. 'rtl.createClass($mod, "TObject", null, function () {',
  24464. ' this.$init = function () {',
  24465. ' this.A = [];',
  24466. ' };',
  24467. ' this.$final = function () {',
  24468. ' this.A = undefined;',
  24469. ' };',
  24470. '});',
  24471. 'this.DoIt = function () {',
  24472. ' var Arr = [];',
  24473. ' var ArrArr = [];',
  24474. ' var i = 0;',
  24475. ' var o = null;',
  24476. ' Arr[1].$assign(Arr[1]);',
  24477. ' rtl.rcArrR(Arr, i).$assign(rtl.rcArrR(Arr, i + 1));',
  24478. ' rtl.rcArrR(o.A, i).$assign(rtl.rcArrR(o.A, i + 2));',
  24479. '};',
  24480. '']),
  24481. LinesToStr([ // $mod.$main
  24482. '']));
  24483. end;
  24484. procedure TTestModule.TestRangeChecks_StringIndex;
  24485. begin
  24486. StartProgram(false);
  24487. Add([
  24488. 'type',
  24489. ' TObject = class',
  24490. ' S: string;',
  24491. ' end;',
  24492. '{$R+}',
  24493. 'procedure DoIt(var h: string);',
  24494. 'var',
  24495. ' s: string;',
  24496. ' i: longint;',
  24497. ' c: char;',
  24498. ' o: tobject;',
  24499. 'begin',
  24500. ' c:=s[1];',
  24501. ' s[i]:=s[i];',
  24502. ' h[i]:=h[i];',
  24503. ' c:=o.s[i];',
  24504. ' o.s[i]:=c;',
  24505. 'end;',
  24506. 'begin',
  24507. '']);
  24508. ConvertProgram;
  24509. CheckSource('TestRangeChecks_StringIndex',
  24510. LinesToStr([ // statements
  24511. 'rtl.createClass($mod, "TObject", null, function () {',
  24512. ' this.$init = function () {',
  24513. ' this.S = "";',
  24514. ' };',
  24515. ' this.$final = function () {',
  24516. ' };',
  24517. '});',
  24518. 'this.DoIt = function (h) {',
  24519. ' var s = "";',
  24520. ' var i = 0;',
  24521. ' var c = "";',
  24522. ' var o = null;',
  24523. ' c = rtl.rcc(rtl.rcCharAt(s, 0), 0, 65535);',
  24524. ' s = rtl.rcSetCharAt(s, i - 1, rtl.rcCharAt(s, i - 1));',
  24525. ' h.set(rtl.rcSetCharAt(h.get(), i - 1, rtl.rcCharAt(h.get(), i - 1)));',
  24526. ' c = rtl.rcc(rtl.rcCharAt(o.S, i - 1), 0, 65535);',
  24527. ' o.S = rtl.rcSetCharAt(o.S, i - 1, c);',
  24528. '};',
  24529. '']),
  24530. LinesToStr([ // $mod.$main
  24531. '']));
  24532. end;
  24533. procedure TTestModule.TestRangeChecks_TypecastInt;
  24534. begin
  24535. StartProgram(false);
  24536. Add([
  24537. '{$R+}',
  24538. 'var',
  24539. ' i: nativeint;',
  24540. ' b: byte;',
  24541. ' sh: shortint;',
  24542. ' w: word;',
  24543. ' sm: smallint;',
  24544. ' lw: longword;',
  24545. ' li: longint;',
  24546. 'begin',
  24547. ' b:=12+byte(i);',
  24548. ' sh:=12+shortint(i);',
  24549. ' w:=12+word(i);',
  24550. ' sm:=12+smallint(i);',
  24551. ' lw:=12+longword(i);',
  24552. ' li:=12+longint(i);',
  24553. '']);
  24554. ConvertProgram;
  24555. CheckSource('TestRangeChecks_TypecastInt',
  24556. LinesToStr([
  24557. 'this.i = 0;',
  24558. 'this.b = 0;',
  24559. 'this.sh = 0;',
  24560. 'this.w = 0;',
  24561. 'this.sm = 0;',
  24562. 'this.lw = 0;',
  24563. 'this.li = 0;',
  24564. '']),
  24565. LinesToStr([
  24566. '$mod.b = rtl.rc(12 + rtl.rc($mod.i, 0, 255), 0, 255);',
  24567. '$mod.sh = rtl.rc(12 + rtl.rc($mod.i, -128, 127), -128, 127);',
  24568. '$mod.w = rtl.rc(12 + rtl.rc($mod.i, 0, 65535), 0, 65535);',
  24569. '$mod.sm = rtl.rc(12 + rtl.rc($mod.i, -32768, 32767), -32768, 32767);',
  24570. '$mod.lw = rtl.rc(12 + rtl.rc($mod.i, 0, 4294967295), 0, 4294967295);',
  24571. '$mod.li = rtl.rc(12 + rtl.rc($mod.i, -2147483648, 2147483647), -2147483648, 2147483647);',
  24572. '']));
  24573. end;
  24574. Initialization
  24575. RegisterTests([TTestModule]);
  24576. end.