tcmodules.pas 679 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382153831538415385153861538715388153891539015391153921539315394153951539615397153981539915400154011540215403154041540515406154071540815409154101541115412154131541415415154161541715418154191542015421154221542315424154251542615427154281542915430154311543215433154341543515436154371543815439154401544115442154431544415445154461544715448154491545015451154521545315454154551545615457154581545915460154611546215463154641546515466154671546815469154701547115472154731547415475154761547715478154791548015481154821548315484154851548615487154881548915490154911549215493154941549515496154971549815499155001550115502155031550415505155061550715508155091551015511155121551315514155151551615517155181551915520155211552215523155241552515526155271552815529155301553115532155331553415535155361553715538155391554015541155421554315544155451554615547155481554915550155511555215553155541555515556155571555815559155601556115562155631556415565155661556715568155691557015571155721557315574155751557615577155781557915580155811558215583155841558515586155871558815589155901559115592155931559415595155961559715598155991560015601156021560315604156051560615607156081560915610156111561215613156141561515616156171561815619156201562115622156231562415625156261562715628156291563015631156321563315634156351563615637156381563915640156411564215643156441564515646156471564815649156501565115652156531565415655156561565715658156591566015661156621566315664156651566615667156681566915670156711567215673156741567515676156771567815679156801568115682156831568415685156861568715688156891569015691156921569315694156951569615697156981569915700157011570215703157041570515706157071570815709157101571115712157131571415715157161571715718157191572015721157221572315724157251572615727157281572915730157311573215733157341573515736157371573815739157401574115742157431574415745157461574715748157491575015751157521575315754157551575615757157581575915760157611576215763157641576515766157671576815769157701577115772157731577415775157761577715778157791578015781157821578315784157851578615787157881578915790157911579215793157941579515796157971579815799158001580115802158031580415805158061580715808158091581015811158121581315814158151581615817158181581915820158211582215823158241582515826158271582815829158301583115832158331583415835158361583715838158391584015841158421584315844158451584615847158481584915850158511585215853158541585515856158571585815859158601586115862158631586415865158661586715868158691587015871158721587315874158751587615877158781587915880158811588215883158841588515886158871588815889158901589115892158931589415895158961589715898158991590015901159021590315904159051590615907159081590915910159111591215913159141591515916159171591815919159201592115922159231592415925159261592715928159291593015931159321593315934159351593615937159381593915940159411594215943159441594515946159471594815949159501595115952159531595415955159561595715958159591596015961159621596315964159651596615967159681596915970159711597215973159741597515976159771597815979159801598115982159831598415985159861598715988159891599015991159921599315994159951599615997159981599916000160011600216003160041600516006160071600816009160101601116012160131601416015160161601716018160191602016021160221602316024160251602616027160281602916030160311603216033160341603516036160371603816039160401604116042160431604416045160461604716048160491605016051160521605316054160551605616057160581605916060160611606216063160641606516066160671606816069160701607116072160731607416075160761607716078160791608016081160821608316084160851608616087160881608916090160911609216093160941609516096160971609816099161001610116102161031610416105161061610716108161091611016111161121611316114161151611616117161181611916120161211612216123161241612516126161271612816129161301613116132161331613416135161361613716138161391614016141161421614316144161451614616147161481614916150161511615216153161541615516156161571615816159161601616116162161631616416165161661616716168161691617016171161721617316174161751617616177161781617916180161811618216183161841618516186161871618816189161901619116192161931619416195161961619716198161991620016201162021620316204162051620616207162081620916210162111621216213162141621516216162171621816219162201622116222162231622416225162261622716228162291623016231162321623316234162351623616237162381623916240162411624216243162441624516246162471624816249162501625116252162531625416255162561625716258162591626016261162621626316264162651626616267162681626916270162711627216273162741627516276162771627816279162801628116282162831628416285162861628716288162891629016291162921629316294162951629616297162981629916300163011630216303163041630516306163071630816309163101631116312163131631416315163161631716318163191632016321163221632316324163251632616327163281632916330163311633216333163341633516336163371633816339163401634116342163431634416345163461634716348163491635016351163521635316354163551635616357163581635916360163611636216363163641636516366163671636816369163701637116372163731637416375163761637716378163791638016381163821638316384163851638616387163881638916390163911639216393163941639516396163971639816399164001640116402164031640416405164061640716408164091641016411164121641316414164151641616417164181641916420164211642216423164241642516426164271642816429164301643116432164331643416435164361643716438164391644016441164421644316444164451644616447164481644916450164511645216453164541645516456164571645816459164601646116462164631646416465164661646716468164691647016471164721647316474164751647616477164781647916480164811648216483164841648516486164871648816489164901649116492164931649416495164961649716498164991650016501165021650316504165051650616507165081650916510165111651216513165141651516516165171651816519165201652116522165231652416525165261652716528165291653016531165321653316534165351653616537165381653916540165411654216543165441654516546165471654816549165501655116552165531655416555165561655716558165591656016561165621656316564165651656616567165681656916570165711657216573165741657516576165771657816579165801658116582165831658416585165861658716588165891659016591165921659316594165951659616597165981659916600166011660216603166041660516606166071660816609166101661116612166131661416615166161661716618166191662016621166221662316624166251662616627166281662916630166311663216633166341663516636166371663816639166401664116642166431664416645166461664716648166491665016651166521665316654166551665616657166581665916660166611666216663166641666516666166671666816669166701667116672166731667416675166761667716678166791668016681166821668316684166851668616687166881668916690166911669216693166941669516696166971669816699167001670116702167031670416705167061670716708167091671016711167121671316714167151671616717167181671916720167211672216723167241672516726167271672816729167301673116732167331673416735167361673716738167391674016741167421674316744167451674616747167481674916750167511675216753167541675516756167571675816759167601676116762167631676416765167661676716768167691677016771167721677316774167751677616777167781677916780167811678216783167841678516786167871678816789167901679116792167931679416795167961679716798167991680016801168021680316804168051680616807168081680916810168111681216813168141681516816168171681816819168201682116822168231682416825168261682716828168291683016831168321683316834168351683616837168381683916840168411684216843168441684516846168471684816849168501685116852168531685416855168561685716858168591686016861168621686316864168651686616867168681686916870168711687216873168741687516876168771687816879168801688116882168831688416885168861688716888168891689016891168921689316894168951689616897168981689916900169011690216903169041690516906169071690816909169101691116912169131691416915169161691716918169191692016921169221692316924169251692616927169281692916930169311693216933169341693516936169371693816939169401694116942169431694416945169461694716948169491695016951169521695316954169551695616957169581695916960169611696216963169641696516966169671696816969169701697116972169731697416975169761697716978169791698016981169821698316984169851698616987169881698916990169911699216993169941699516996169971699816999170001700117002170031700417005170061700717008170091701017011170121701317014170151701617017170181701917020170211702217023170241702517026170271702817029170301703117032170331703417035170361703717038170391704017041170421704317044170451704617047170481704917050170511705217053170541705517056170571705817059170601706117062170631706417065170661706717068170691707017071170721707317074170751707617077170781707917080170811708217083170841708517086170871708817089170901709117092170931709417095170961709717098170991710017101171021710317104171051710617107171081710917110171111711217113171141711517116171171711817119171201712117122171231712417125171261712717128171291713017131171321713317134171351713617137171381713917140171411714217143171441714517146171471714817149171501715117152171531715417155171561715717158171591716017161171621716317164171651716617167171681716917170171711717217173171741717517176171771717817179171801718117182171831718417185171861718717188171891719017191171921719317194171951719617197171981719917200172011720217203172041720517206172071720817209172101721117212172131721417215172161721717218172191722017221172221722317224172251722617227172281722917230172311723217233172341723517236172371723817239172401724117242172431724417245172461724717248172491725017251172521725317254172551725617257172581725917260172611726217263172641726517266172671726817269172701727117272172731727417275172761727717278172791728017281172821728317284172851728617287172881728917290172911729217293172941729517296172971729817299173001730117302173031730417305173061730717308173091731017311173121731317314173151731617317173181731917320173211732217323173241732517326173271732817329173301733117332173331733417335173361733717338173391734017341173421734317344173451734617347173481734917350173511735217353173541735517356173571735817359173601736117362173631736417365173661736717368173691737017371173721737317374173751737617377173781737917380173811738217383173841738517386173871738817389173901739117392173931739417395173961739717398173991740017401174021740317404174051740617407174081740917410174111741217413174141741517416174171741817419174201742117422174231742417425174261742717428174291743017431174321743317434174351743617437174381743917440174411744217443174441744517446174471744817449174501745117452174531745417455174561745717458174591746017461174621746317464174651746617467174681746917470174711747217473174741747517476174771747817479174801748117482174831748417485174861748717488174891749017491174921749317494174951749617497174981749917500175011750217503175041750517506175071750817509175101751117512175131751417515175161751717518175191752017521175221752317524175251752617527175281752917530175311753217533175341753517536175371753817539175401754117542175431754417545175461754717548175491755017551175521755317554175551755617557175581755917560175611756217563175641756517566175671756817569175701757117572175731757417575175761757717578175791758017581175821758317584175851758617587175881758917590175911759217593175941759517596175971759817599176001760117602176031760417605176061760717608176091761017611176121761317614176151761617617176181761917620176211762217623176241762517626176271762817629176301763117632176331763417635176361763717638176391764017641176421764317644176451764617647176481764917650176511765217653176541765517656176571765817659176601766117662176631766417665176661766717668176691767017671176721767317674176751767617677176781767917680176811768217683176841768517686176871768817689176901769117692176931769417695176961769717698176991770017701177021770317704177051770617707177081770917710177111771217713177141771517716177171771817719177201772117722177231772417725177261772717728177291773017731177321773317734177351773617737177381773917740177411774217743177441774517746177471774817749177501775117752177531775417755177561775717758177591776017761177621776317764177651776617767177681776917770177711777217773177741777517776177771777817779177801778117782177831778417785177861778717788177891779017791177921779317794177951779617797177981779917800178011780217803178041780517806178071780817809178101781117812178131781417815178161781717818178191782017821178221782317824178251782617827178281782917830178311783217833178341783517836178371783817839178401784117842178431784417845178461784717848178491785017851178521785317854178551785617857178581785917860178611786217863178641786517866178671786817869178701787117872178731787417875178761787717878178791788017881178821788317884178851788617887178881788917890178911789217893178941789517896178971789817899179001790117902179031790417905179061790717908179091791017911179121791317914179151791617917179181791917920179211792217923179241792517926179271792817929179301793117932179331793417935179361793717938179391794017941179421794317944179451794617947179481794917950179511795217953179541795517956179571795817959179601796117962179631796417965179661796717968179691797017971179721797317974179751797617977179781797917980179811798217983179841798517986179871798817989179901799117992179931799417995179961799717998179991800018001180021800318004180051800618007180081800918010180111801218013180141801518016180171801818019180201802118022180231802418025180261802718028180291803018031180321803318034180351803618037180381803918040180411804218043180441804518046180471804818049180501805118052180531805418055180561805718058180591806018061180621806318064180651806618067180681806918070180711807218073180741807518076180771807818079180801808118082180831808418085180861808718088180891809018091180921809318094180951809618097180981809918100181011810218103181041810518106181071810818109181101811118112181131811418115181161811718118181191812018121181221812318124181251812618127181281812918130181311813218133181341813518136181371813818139181401814118142181431814418145181461814718148181491815018151181521815318154181551815618157181581815918160181611816218163181641816518166181671816818169181701817118172181731817418175181761817718178181791818018181181821818318184181851818618187181881818918190181911819218193181941819518196181971819818199182001820118202182031820418205182061820718208182091821018211182121821318214182151821618217182181821918220182211822218223182241822518226182271822818229182301823118232182331823418235182361823718238182391824018241182421824318244182451824618247182481824918250182511825218253182541825518256182571825818259182601826118262182631826418265182661826718268182691827018271182721827318274182751827618277182781827918280182811828218283182841828518286182871828818289182901829118292182931829418295182961829718298182991830018301183021830318304183051830618307183081830918310183111831218313183141831518316183171831818319183201832118322183231832418325183261832718328183291833018331183321833318334183351833618337183381833918340183411834218343183441834518346183471834818349183501835118352183531835418355183561835718358183591836018361183621836318364183651836618367183681836918370183711837218373183741837518376183771837818379183801838118382183831838418385183861838718388183891839018391183921839318394183951839618397183981839918400184011840218403184041840518406184071840818409184101841118412184131841418415184161841718418184191842018421184221842318424184251842618427184281842918430184311843218433184341843518436184371843818439184401844118442184431844418445184461844718448184491845018451184521845318454184551845618457184581845918460184611846218463184641846518466184671846818469184701847118472184731847418475184761847718478184791848018481184821848318484184851848618487184881848918490184911849218493184941849518496184971849818499185001850118502185031850418505185061850718508185091851018511185121851318514185151851618517185181851918520185211852218523185241852518526185271852818529185301853118532185331853418535185361853718538185391854018541185421854318544185451854618547185481854918550185511855218553185541855518556185571855818559185601856118562185631856418565185661856718568185691857018571185721857318574185751857618577185781857918580185811858218583185841858518586185871858818589185901859118592185931859418595185961859718598185991860018601186021860318604186051860618607186081860918610186111861218613186141861518616186171861818619186201862118622186231862418625186261862718628186291863018631186321863318634186351863618637186381863918640186411864218643186441864518646186471864818649186501865118652186531865418655186561865718658186591866018661186621866318664186651866618667186681866918670186711867218673186741867518676186771867818679186801868118682186831868418685186861868718688186891869018691186921869318694186951869618697186981869918700187011870218703187041870518706187071870818709187101871118712187131871418715187161871718718187191872018721187221872318724187251872618727187281872918730187311873218733187341873518736187371873818739187401874118742187431874418745187461874718748187491875018751187521875318754187551875618757187581875918760187611876218763187641876518766187671876818769187701877118772187731877418775187761877718778187791878018781187821878318784187851878618787187881878918790187911879218793187941879518796187971879818799188001880118802188031880418805188061880718808188091881018811188121881318814188151881618817188181881918820188211882218823188241882518826188271882818829188301883118832188331883418835188361883718838188391884018841188421884318844188451884618847188481884918850188511885218853188541885518856188571885818859188601886118862188631886418865188661886718868188691887018871188721887318874188751887618877188781887918880188811888218883188841888518886188871888818889188901889118892188931889418895188961889718898188991890018901189021890318904189051890618907189081890918910189111891218913189141891518916189171891818919189201892118922189231892418925189261892718928189291893018931189321893318934189351893618937189381893918940189411894218943189441894518946189471894818949189501895118952189531895418955189561895718958189591896018961189621896318964189651896618967189681896918970189711897218973189741897518976189771897818979189801898118982189831898418985189861898718988189891899018991189921899318994189951899618997189981899919000190011900219003190041900519006190071900819009190101901119012190131901419015190161901719018190191902019021190221902319024190251902619027190281902919030190311903219033190341903519036190371903819039190401904119042190431904419045190461904719048190491905019051190521905319054190551905619057190581905919060190611906219063190641906519066190671906819069190701907119072190731907419075190761907719078190791908019081190821908319084190851908619087190881908919090190911909219093190941909519096190971909819099191001910119102191031910419105191061910719108191091911019111191121911319114191151911619117191181911919120191211912219123191241912519126191271912819129191301913119132191331913419135191361913719138191391914019141191421914319144191451914619147191481914919150191511915219153191541915519156191571915819159191601916119162191631916419165191661916719168191691917019171191721917319174191751917619177191781917919180191811918219183191841918519186191871918819189191901919119192191931919419195191961919719198191991920019201192021920319204192051920619207192081920919210192111921219213192141921519216192171921819219192201922119222192231922419225192261922719228192291923019231192321923319234192351923619237192381923919240192411924219243192441924519246192471924819249192501925119252192531925419255192561925719258192591926019261192621926319264192651926619267192681926919270192711927219273192741927519276192771927819279192801928119282192831928419285192861928719288192891929019291192921929319294192951929619297192981929919300193011930219303193041930519306193071930819309193101931119312193131931419315193161931719318193191932019321193221932319324193251932619327193281932919330193311933219333193341933519336193371933819339193401934119342193431934419345193461934719348193491935019351193521935319354193551935619357193581935919360193611936219363193641936519366193671936819369193701937119372193731937419375193761937719378193791938019381193821938319384193851938619387193881938919390193911939219393193941939519396193971939819399194001940119402194031940419405194061940719408194091941019411194121941319414194151941619417194181941919420194211942219423194241942519426194271942819429194301943119432194331943419435194361943719438194391944019441194421944319444194451944619447194481944919450194511945219453194541945519456194571945819459194601946119462194631946419465194661946719468194691947019471194721947319474194751947619477194781947919480194811948219483194841948519486194871948819489194901949119492194931949419495194961949719498194991950019501195021950319504195051950619507195081950919510195111951219513195141951519516195171951819519195201952119522195231952419525195261952719528195291953019531195321953319534195351953619537195381953919540195411954219543195441954519546195471954819549195501955119552195531955419555195561955719558195591956019561195621956319564195651956619567195681956919570195711957219573195741957519576195771957819579195801958119582195831958419585195861958719588195891959019591195921959319594195951959619597195981959919600196011960219603196041960519606196071960819609196101961119612196131961419615196161961719618196191962019621196221962319624196251962619627196281962919630196311963219633196341963519636196371963819639196401964119642196431964419645196461964719648196491965019651196521965319654196551965619657196581965919660196611966219663196641966519666196671966819669196701967119672196731967419675196761967719678196791968019681196821968319684196851968619687196881968919690196911969219693196941969519696196971969819699197001970119702197031970419705197061970719708197091971019711197121971319714197151971619717197181971919720197211972219723197241972519726197271972819729197301973119732197331973419735197361973719738197391974019741197421974319744197451974619747197481974919750197511975219753197541975519756197571975819759197601976119762197631976419765197661976719768197691977019771197721977319774197751977619777197781977919780197811978219783197841978519786197871978819789197901979119792197931979419795197961979719798197991980019801198021980319804198051980619807198081980919810198111981219813198141981519816198171981819819198201982119822198231982419825198261982719828198291983019831198321983319834198351983619837198381983919840198411984219843198441984519846198471984819849198501985119852198531985419855198561985719858198591986019861198621986319864198651986619867198681986919870198711987219873198741987519876198771987819879198801988119882198831988419885198861988719888198891989019891198921989319894198951989619897198981989919900199011990219903199041990519906199071990819909199101991119912199131991419915199161991719918199191992019921199221992319924199251992619927199281992919930199311993219933199341993519936199371993819939199401994119942199431994419945199461994719948199491995019951199521995319954199551995619957199581995919960199611996219963199641996519966199671996819969199701997119972199731997419975199761997719978199791998019981199821998319984199851998619987199881998919990199911999219993199941999519996199971999819999200002000120002200032000420005200062000720008200092001020011200122001320014200152001620017200182001920020200212002220023200242002520026200272002820029200302003120032200332003420035200362003720038200392004020041200422004320044200452004620047200482004920050200512005220053200542005520056200572005820059200602006120062200632006420065200662006720068200692007020071200722007320074200752007620077200782007920080200812008220083200842008520086200872008820089200902009120092200932009420095200962009720098200992010020101201022010320104201052010620107201082010920110201112011220113201142011520116201172011820119201202012120122201232012420125201262012720128201292013020131201322013320134201352013620137201382013920140201412014220143201442014520146201472014820149201502015120152201532015420155201562015720158201592016020161201622016320164201652016620167201682016920170201712017220173201742017520176201772017820179201802018120182201832018420185201862018720188201892019020191201922019320194201952019620197201982019920200202012020220203202042020520206202072020820209202102021120212202132021420215202162021720218202192022020221202222022320224202252022620227202282022920230202312023220233202342023520236202372023820239202402024120242202432024420245202462024720248202492025020251202522025320254202552025620257202582025920260202612026220263202642026520266202672026820269202702027120272202732027420275202762027720278202792028020281202822028320284202852028620287202882028920290202912029220293202942029520296202972029820299203002030120302203032030420305203062030720308203092031020311203122031320314203152031620317203182031920320203212032220323203242032520326203272032820329203302033120332203332033420335203362033720338203392034020341203422034320344203452034620347203482034920350203512035220353203542035520356203572035820359203602036120362203632036420365203662036720368203692037020371203722037320374203752037620377203782037920380203812038220383203842038520386203872038820389203902039120392203932039420395203962039720398203992040020401204022040320404204052040620407204082040920410204112041220413204142041520416204172041820419204202042120422204232042420425204262042720428204292043020431204322043320434204352043620437204382043920440204412044220443204442044520446204472044820449204502045120452204532045420455204562045720458204592046020461204622046320464204652046620467204682046920470204712047220473204742047520476204772047820479204802048120482204832048420485204862048720488204892049020491204922049320494204952049620497204982049920500205012050220503205042050520506205072050820509205102051120512205132051420515205162051720518205192052020521205222052320524205252052620527205282052920530205312053220533205342053520536205372053820539205402054120542205432054420545205462054720548205492055020551205522055320554205552055620557205582055920560205612056220563205642056520566205672056820569205702057120572205732057420575205762057720578205792058020581205822058320584205852058620587205882058920590205912059220593205942059520596205972059820599206002060120602206032060420605206062060720608206092061020611206122061320614206152061620617206182061920620206212062220623206242062520626206272062820629206302063120632206332063420635206362063720638206392064020641206422064320644206452064620647206482064920650206512065220653206542065520656206572065820659206602066120662206632066420665206662066720668206692067020671206722067320674206752067620677206782067920680206812068220683206842068520686206872068820689206902069120692206932069420695206962069720698206992070020701207022070320704207052070620707207082070920710207112071220713207142071520716207172071820719207202072120722207232072420725207262072720728207292073020731207322073320734207352073620737207382073920740207412074220743207442074520746207472074820749207502075120752207532075420755207562075720758207592076020761207622076320764207652076620767207682076920770207712077220773207742077520776207772077820779207802078120782207832078420785207862078720788207892079020791207922079320794207952079620797207982079920800208012080220803208042080520806208072080820809208102081120812208132081420815208162081720818208192082020821208222082320824208252082620827208282082920830208312083220833208342083520836208372083820839208402084120842208432084420845208462084720848208492085020851208522085320854208552085620857208582085920860208612086220863208642086520866208672086820869208702087120872208732087420875208762087720878208792088020881208822088320884208852088620887208882088920890208912089220893208942089520896208972089820899209002090120902209032090420905209062090720908209092091020911209122091320914209152091620917209182091920920209212092220923209242092520926209272092820929209302093120932209332093420935209362093720938209392094020941209422094320944209452094620947209482094920950209512095220953209542095520956209572095820959209602096120962209632096420965209662096720968209692097020971209722097320974209752097620977209782097920980209812098220983209842098520986209872098820989209902099120992209932099420995209962099720998209992100021001210022100321004210052100621007210082100921010210112101221013210142101521016210172101821019210202102121022210232102421025210262102721028210292103021031210322103321034210352103621037210382103921040210412104221043210442104521046210472104821049210502105121052210532105421055210562105721058210592106021061210622106321064210652106621067210682106921070210712107221073210742107521076210772107821079210802108121082210832108421085210862108721088210892109021091210922109321094210952109621097210982109921100211012110221103211042110521106211072110821109211102111121112211132111421115211162111721118211192112021121211222112321124211252112621127211282112921130211312113221133211342113521136211372113821139211402114121142211432114421145211462114721148211492115021151211522115321154211552115621157211582115921160211612116221163211642116521166211672116821169211702117121172211732117421175211762117721178211792118021181211822118321184211852118621187211882118921190211912119221193211942119521196211972119821199212002120121202212032120421205212062120721208212092121021211212122121321214212152121621217212182121921220212212122221223212242122521226212272122821229212302123121232212332123421235212362123721238212392124021241212422124321244212452124621247212482124921250212512125221253212542125521256212572125821259212602126121262212632126421265212662126721268212692127021271212722127321274212752127621277212782127921280212812128221283212842128521286212872128821289212902129121292212932129421295212962129721298212992130021301213022130321304213052130621307213082130921310213112131221313213142131521316213172131821319213202132121322213232132421325213262132721328213292133021331213322133321334213352133621337213382133921340213412134221343213442134521346213472134821349213502135121352213532135421355213562135721358213592136021361213622136321364213652136621367213682136921370213712137221373213742137521376213772137821379213802138121382213832138421385213862138721388213892139021391213922139321394213952139621397213982139921400214012140221403214042140521406214072140821409214102141121412214132141421415214162141721418214192142021421214222142321424214252142621427214282142921430214312143221433214342143521436214372143821439214402144121442214432144421445214462144721448214492145021451214522145321454214552145621457214582145921460214612146221463214642146521466214672146821469214702147121472214732147421475214762147721478214792148021481214822148321484214852148621487214882148921490214912149221493214942149521496214972149821499215002150121502215032150421505215062150721508215092151021511215122151321514215152151621517215182151921520215212152221523215242152521526215272152821529215302153121532215332153421535215362153721538215392154021541215422154321544215452154621547215482154921550215512155221553215542155521556215572155821559215602156121562215632156421565215662156721568215692157021571215722157321574215752157621577215782157921580215812158221583215842158521586215872158821589215902159121592215932159421595215962159721598215992160021601216022160321604216052160621607216082160921610216112161221613216142161521616216172161821619216202162121622216232162421625216262162721628216292163021631216322163321634216352163621637216382163921640216412164221643216442164521646216472164821649216502165121652216532165421655216562165721658216592166021661216622166321664216652166621667216682166921670216712167221673216742167521676216772167821679216802168121682216832168421685216862168721688216892169021691216922169321694216952169621697216982169921700217012170221703217042170521706217072170821709217102171121712217132171421715217162171721718217192172021721217222172321724217252172621727217282172921730217312173221733217342173521736217372173821739217402174121742217432174421745217462174721748217492175021751217522175321754217552175621757217582175921760217612176221763217642176521766217672176821769217702177121772217732177421775217762177721778217792178021781217822178321784217852178621787217882178921790217912179221793217942179521796217972179821799218002180121802218032180421805218062180721808218092181021811218122181321814218152181621817218182181921820218212182221823218242182521826218272182821829218302183121832218332183421835218362183721838218392184021841218422184321844218452184621847218482184921850218512185221853218542185521856218572185821859218602186121862218632186421865218662186721868218692187021871218722187321874218752187621877218782187921880218812188221883218842188521886218872188821889218902189121892218932189421895218962189721898218992190021901219022190321904219052190621907219082190921910219112191221913219142191521916219172191821919219202192121922219232192421925219262192721928219292193021931219322193321934219352193621937219382193921940219412194221943219442194521946219472194821949219502195121952219532195421955219562195721958219592196021961219622196321964219652196621967219682196921970219712197221973219742197521976219772197821979219802198121982219832198421985219862198721988219892199021991219922199321994219952199621997219982199922000220012200222003220042200522006220072200822009220102201122012220132201422015220162201722018220192202022021220222202322024220252202622027220282202922030220312203222033220342203522036220372203822039220402204122042220432204422045220462204722048220492205022051220522205322054220552205622057220582205922060220612206222063220642206522066220672206822069220702207122072220732207422075220762207722078220792208022081220822208322084220852208622087220882208922090220912209222093220942209522096220972209822099221002210122102221032210422105221062210722108221092211022111221122211322114221152211622117221182211922120221212212222123221242212522126221272212822129221302213122132221332213422135221362213722138221392214022141221422214322144221452214622147221482214922150221512215222153221542215522156221572215822159221602216122162221632216422165221662216722168221692217022171221722217322174221752217622177221782217922180221812218222183221842218522186221872218822189221902219122192221932219422195221962219722198221992220022201222022220322204222052220622207222082220922210222112221222213222142221522216222172221822219222202222122222222232222422225222262222722228222292223022231222322223322234222352223622237222382223922240222412224222243222442224522246222472224822249222502225122252222532225422255222562225722258222592226022261222622226322264222652226622267222682226922270222712227222273222742227522276222772227822279222802228122282222832228422285222862228722288222892229022291222922229322294222952229622297222982229922300223012230222303223042230522306223072230822309223102231122312223132231422315223162231722318223192232022321223222232322324223252232622327223282232922330223312233222333223342233522336223372233822339223402234122342223432234422345223462234722348223492235022351223522235322354223552235622357223582235922360223612236222363223642236522366223672236822369223702237122372223732237422375223762237722378223792238022381223822238322384223852238622387223882238922390223912239222393223942239522396223972239822399224002240122402224032240422405224062240722408224092241022411224122241322414224152241622417224182241922420224212242222423224242242522426224272242822429224302243122432224332243422435224362243722438224392244022441224422244322444224452244622447224482244922450224512245222453224542245522456224572245822459224602246122462224632246422465224662246722468224692247022471224722247322474224752247622477224782247922480224812248222483224842248522486224872248822489224902249122492224932249422495224962249722498224992250022501225022250322504225052250622507225082250922510225112251222513225142251522516225172251822519225202252122522225232252422525225262252722528225292253022531225322253322534225352253622537225382253922540225412254222543225442254522546225472254822549225502255122552225532255422555225562255722558225592256022561225622256322564225652256622567225682256922570225712257222573225742257522576225772257822579225802258122582225832258422585225862258722588225892259022591225922259322594225952259622597225982259922600226012260222603226042260522606226072260822609226102261122612226132261422615226162261722618226192262022621226222262322624226252262622627226282262922630226312263222633226342263522636226372263822639226402264122642226432264422645226462264722648226492265022651226522265322654226552265622657226582265922660226612266222663226642266522666226672266822669226702267122672226732267422675226762267722678226792268022681226822268322684226852268622687226882268922690226912269222693226942269522696226972269822699227002270122702227032270422705227062270722708227092271022711227122271322714227152271622717227182271922720227212272222723227242272522726227272272822729227302273122732227332273422735227362273722738227392274022741227422274322744227452274622747227482274922750227512275222753227542275522756227572275822759227602276122762227632276422765227662276722768227692277022771227722277322774227752277622777227782277922780227812278222783227842278522786227872278822789227902279122792227932279422795227962279722798227992280022801228022280322804228052280622807228082280922810228112281222813228142281522816228172281822819228202282122822228232282422825228262282722828228292283022831228322283322834228352283622837228382283922840228412284222843228442284522846228472284822849228502285122852228532285422855228562285722858228592286022861228622286322864228652286622867228682286922870228712287222873228742287522876228772287822879228802288122882228832288422885228862288722888228892289022891228922289322894228952289622897228982289922900229012290222903229042290522906229072290822909229102291122912229132291422915229162291722918229192292022921229222292322924229252292622927229282292922930229312293222933229342293522936229372293822939229402294122942229432294422945229462294722948229492295022951229522295322954229552295622957229582295922960229612296222963229642296522966229672296822969229702297122972229732297422975229762297722978229792298022981229822298322984229852298622987229882298922990229912299222993229942299522996229972299822999230002300123002230032300423005230062300723008230092301023011230122301323014230152301623017230182301923020230212302223023230242302523026230272302823029230302303123032230332303423035230362303723038230392304023041230422304323044230452304623047230482304923050230512305223053230542305523056230572305823059230602306123062230632306423065230662306723068230692307023071230722307323074230752307623077230782307923080230812308223083230842308523086230872308823089230902309123092230932309423095230962309723098230992310023101231022310323104231052310623107231082310923110231112311223113231142311523116231172311823119231202312123122231232312423125231262312723128231292313023131231322313323134231352313623137231382313923140231412314223143231442314523146231472314823149231502315123152231532315423155231562315723158231592316023161231622316323164231652316623167231682316923170231712317223173231742317523176231772317823179231802318123182231832318423185231862318723188231892319023191231922319323194231952319623197231982319923200232012320223203232042320523206232072320823209232102321123212232132321423215232162321723218232192322023221232222322323224232252322623227232282322923230232312323223233232342323523236232372323823239232402324123242232432324423245232462324723248232492325023251232522325323254232552325623257232582325923260232612326223263232642326523266232672326823269232702327123272232732327423275232762327723278232792328023281232822328323284232852328623287232882328923290232912329223293232942329523296232972329823299233002330123302233032330423305233062330723308233092331023311233122331323314233152331623317233182331923320233212332223323233242332523326233272332823329233302333123332233332333423335233362333723338233392334023341233422334323344233452334623347233482334923350233512335223353233542335523356233572335823359233602336123362233632336423365233662336723368233692337023371233722337323374233752337623377233782337923380233812338223383233842338523386233872338823389233902339123392233932339423395233962339723398233992340023401234022340323404234052340623407234082340923410234112341223413234142341523416234172341823419234202342123422234232342423425234262342723428234292343023431234322343323434234352343623437234382343923440234412344223443234442344523446234472344823449234502345123452234532345423455234562345723458234592346023461234622346323464234652346623467234682346923470234712347223473234742347523476234772347823479234802348123482234832348423485234862348723488234892349023491234922349323494234952349623497234982349923500235012350223503235042350523506235072350823509235102351123512235132351423515235162351723518235192352023521235222352323524235252352623527235282352923530235312353223533235342353523536235372353823539235402354123542235432354423545235462354723548235492355023551235522355323554235552355623557235582355923560235612356223563235642356523566235672356823569235702357123572235732357423575235762357723578235792358023581235822358323584235852358623587235882358923590235912359223593235942359523596235972359823599236002360123602236032360423605236062360723608236092361023611236122361323614236152361623617236182361923620236212362223623236242362523626236272362823629236302363123632236332363423635236362363723638236392364023641236422364323644236452364623647236482364923650236512365223653236542365523656236572365823659236602366123662236632366423665236662366723668236692367023671236722367323674236752367623677236782367923680236812368223683236842368523686236872368823689236902369123692236932369423695236962369723698236992370023701237022370323704237052370623707237082370923710237112371223713237142371523716237172371823719237202372123722237232372423725237262372723728237292373023731237322373323734237352373623737237382373923740237412374223743237442374523746237472374823749237502375123752237532375423755237562375723758237592376023761237622376323764237652376623767237682376923770237712377223773237742377523776237772377823779237802378123782237832378423785237862378723788237892379023791237922379323794237952379623797237982379923800238012380223803238042380523806238072380823809238102381123812238132381423815238162381723818238192382023821238222382323824238252382623827238282382923830238312383223833238342383523836238372383823839238402384123842238432384423845238462384723848238492385023851238522385323854238552385623857238582385923860238612386223863238642386523866238672386823869238702387123872238732387423875238762387723878238792388023881238822388323884238852388623887238882388923890238912389223893238942389523896238972389823899239002390123902239032390423905239062390723908239092391023911239122391323914239152391623917239182391923920239212392223923239242392523926239272392823929239302393123932239332393423935239362393723938239392394023941239422394323944239452394623947239482394923950239512395223953239542395523956239572395823959239602396123962239632396423965239662396723968239692397023971239722397323974239752397623977239782397923980239812398223983239842398523986239872398823989239902399123992239932399423995239962399723998239992400024001240022400324004240052400624007240082400924010240112401224013240142401524016240172401824019240202402124022240232402424025240262402724028240292403024031240322403324034240352403624037240382403924040240412404224043240442404524046240472404824049240502405124052240532405424055240562405724058240592406024061240622406324064240652406624067240682406924070240712407224073240742407524076240772407824079240802408124082240832408424085240862408724088240892409024091240922409324094240952409624097240982409924100241012410224103241042410524106241072410824109241102411124112241132411424115241162411724118241192412024121241222412324124241252412624127241282412924130241312413224133241342413524136241372413824139241402414124142241432414424145241462414724148241492415024151241522415324154241552415624157241582415924160241612416224163241642416524166241672416824169241702417124172241732417424175241762417724178241792418024181241822418324184241852418624187241882418924190241912419224193241942419524196241972419824199242002420124202242032420424205242062420724208242092421024211242122421324214242152421624217242182421924220242212422224223242242422524226242272422824229242302423124232242332423424235242362423724238242392424024241242422424324244242452424624247242482424924250242512425224253242542425524256242572425824259242602426124262242632426424265242662426724268242692427024271242722427324274242752427624277242782427924280242812428224283242842428524286242872428824289242902429124292242932429424295242962429724298242992430024301243022430324304243052430624307243082430924310243112431224313243142431524316243172431824319243202432124322243232432424325243262432724328243292433024331243322433324334243352433624337243382433924340243412434224343243442434524346243472434824349243502435124352243532435424355243562435724358243592436024361243622436324364243652436624367243682436924370243712437224373243742437524376243772437824379243802438124382243832438424385243862438724388243892439024391243922439324394243952439624397243982439924400244012440224403244042440524406244072440824409244102441124412244132441424415244162441724418244192442024421244222442324424244252442624427244282442924430244312443224433244342443524436244372443824439244402444124442244432444424445244462444724448244492445024451244522445324454244552445624457244582445924460244612446224463244642446524466244672446824469244702447124472244732447424475244762447724478244792448024481244822448324484244852448624487244882448924490244912449224493244942449524496244972449824499245002450124502245032450424505245062450724508245092451024511245122451324514245152451624517245182451924520245212452224523245242452524526245272452824529245302453124532245332453424535245362453724538245392454024541245422454324544245452454624547245482454924550245512455224553245542455524556245572455824559245602456124562245632456424565245662456724568245692457024571245722457324574245752457624577245782457924580245812458224583245842458524586245872458824589245902459124592245932459424595245962459724598245992460024601246022460324604246052460624607246082460924610246112461224613246142461524616246172461824619246202462124622246232462424625246262462724628246292463024631246322463324634246352463624637246382463924640246412464224643246442464524646246472464824649246502465124652246532465424655246562465724658246592466024661246622466324664246652466624667246682466924670246712467224673246742467524676246772467824679246802468124682246832468424685246862468724688246892469024691246922469324694246952469624697246982469924700247012470224703247042470524706247072470824709247102471124712247132471424715247162471724718247192472024721247222472324724247252472624727247282472924730247312473224733247342473524736247372473824739247402474124742247432474424745247462474724748247492475024751247522475324754247552475624757247582475924760247612476224763247642476524766247672476824769247702477124772247732477424775247762477724778247792478024781247822478324784247852478624787247882478924790247912479224793247942479524796247972479824799248002480124802248032480424805248062480724808248092481024811248122481324814248152481624817248182481924820248212482224823248242482524826248272482824829248302483124832248332483424835248362483724838248392484024841248422484324844248452484624847248482484924850248512485224853248542485524856248572485824859248602486124862248632486424865248662486724868248692487024871248722487324874248752487624877248782487924880248812488224883248842488524886248872488824889248902489124892248932489424895248962489724898248992490024901249022490324904249052490624907249082490924910249112491224913249142491524916249172491824919249202492124922249232492424925249262492724928249292493024931249322493324934249352493624937249382493924940249412494224943249442494524946249472494824949249502495124952249532495424955249562495724958249592496024961249622496324964249652496624967249682496924970249712497224973249742497524976249772497824979249802498124982249832498424985249862498724988249892499024991249922499324994249952499624997249982499925000250012500225003250042500525006250072500825009250102501125012250132501425015250162501725018250192502025021250222502325024250252502625027250282502925030250312503225033250342503525036250372503825039250402504125042250432504425045250462504725048250492505025051250522505325054250552505625057250582505925060250612506225063250642506525066250672506825069250702507125072250732507425075250762507725078250792508025081250822508325084250852508625087250882508925090250912509225093250942509525096250972509825099251002510125102251032510425105251062510725108251092511025111251122511325114251152511625117251182511925120251212512225123251242512525126251272512825129251302513125132251332513425135251362513725138251392514025141251422514325144251452514625147251482514925150251512515225153251542515525156251572515825159251602516125162251632516425165251662516725168251692517025171251722517325174251752517625177251782517925180251812518225183251842518525186251872518825189251902519125192251932519425195251962519725198251992520025201252022520325204252052520625207252082520925210252112521225213252142521525216252172521825219252202522125222252232522425225252262522725228252292523025231252322523325234252352523625237252382523925240252412524225243252442524525246252472524825249252502525125252252532525425255252562525725258252592526025261252622526325264252652526625267252682526925270252712527225273252742527525276252772527825279252802528125282252832528425285252862528725288252892529025291252922529325294252952529625297252982529925300253012530225303253042530525306253072530825309253102531125312253132531425315253162531725318253192532025321253222532325324253252532625327253282532925330253312533225333253342533525336253372533825339253402534125342253432534425345253462534725348253492535025351253522535325354253552535625357253582535925360253612536225363253642536525366253672536825369253702537125372253732537425375253762537725378253792538025381253822538325384253852538625387253882538925390253912539225393253942539525396253972539825399254002540125402254032540425405254062540725408254092541025411254122541325414254152541625417254182541925420254212542225423254242542525426254272542825429254302543125432254332543425435254362543725438254392544025441254422544325444254452544625447254482544925450254512545225453254542545525456254572545825459254602546125462254632546425465254662546725468254692547025471254722547325474254752547625477254782547925480254812548225483254842548525486254872548825489254902549125492254932549425495254962549725498254992550025501255022550325504255052550625507255082550925510255112551225513255142551525516255172551825519255202552125522255232552425525255262552725528255292553025531255322553325534255352553625537255382553925540255412554225543255442554525546255472554825549255502555125552255532555425555255562555725558255592556025561255622556325564255652556625567255682556925570255712557225573255742557525576255772557825579255802558125582255832558425585255862558725588255892559025591255922559325594255952559625597255982559925600256012560225603256042560525606
  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_Property;
  603. Procedure TestClassHelper_Property_Array;
  604. //Procedure TestClassHelper_Property_Array_Default;
  605. // todo: TestClassHelper_ClassProperty static/nonstatic
  606. // todo: TestClassHelper_ClassProperty_Array
  607. // todo: TestClassHelper_Overload
  608. // todo: TestClassHelper_ForIn
  609. // todo: TestRecordHelper_ClassVar
  610. // todo: TestRecordHelper_Method
  611. // todo: TestRecordHelper_ClassMethod
  612. // todo: TestRecordHelper_NestedMethod
  613. // todo: TestRecorHelper_Constructor;
  614. // todo: TestRecordHelper_Args
  615. // todo: TestRecordHelper_Property
  616. // todo: TestRecordHelper_Property_Array
  617. // todo: TestRecordHelper_ClassProperty
  618. // todo: TestRecordHelper_ClassProperty_Array
  619. // todo: TestTypeHelper_ClassVar
  620. // todo: TestTypeHelper_Method
  621. // todo: TestTypeHelper_ClassMethod
  622. // todo: TestTypeHelper_Constructor;
  623. // todo: TestTypeHelper_Property
  624. // todo: TestTypeHelper_Property_Array
  625. // todo: TestTypeHelper_ClassProperty
  626. // todo: TestTypeHelper_ClassProperty_Array
  627. // proc types
  628. Procedure TestProcType;
  629. Procedure TestProcType_Arg;
  630. Procedure TestProcType_FunctionFPC;
  631. Procedure TestProcType_FunctionDelphi;
  632. Procedure TestProcType_ProcedureDelphi;
  633. Procedure TestProcType_AsParam;
  634. Procedure TestProcType_MethodFPC;
  635. Procedure TestProcType_MethodDelphi;
  636. Procedure TestProcType_PropertyFPC;
  637. Procedure TestProcType_PropertyDelphi;
  638. Procedure TestProcType_WithClassInstDoPropertyFPC;
  639. Procedure TestProcType_Nested;
  640. Procedure TestProcType_NestedOfObject;
  641. Procedure TestProcType_ReferenceToProc;
  642. Procedure TestProcType_ReferenceToMethod;
  643. Procedure TestProcType_Typecast;
  644. Procedure TestProcType_PassProcToUntyped;
  645. Procedure TestProcType_PassProcToArray;
  646. // pointer
  647. Procedure TestPointer;
  648. Procedure TestPointer_Proc;
  649. Procedure TestPointer_AssignRecordFail;
  650. Procedure TestPointer_AssignStaticArrayFail;
  651. Procedure TestPointer_TypeCastJSValueToPointer;
  652. Procedure TestPointer_NonRecordFail;
  653. Procedure TestPointer_AnonymousArgTypeFail;
  654. Procedure TestPointer_AnonymousVarTypeFail;
  655. Procedure TestPointer_AnonymousResultTypeFail;
  656. Procedure TestPointer_AddrOperatorFail;
  657. Procedure TestPointer_ArrayParamsFail;
  658. Procedure TestPointer_PointerAddFail;
  659. Procedure TestPointer_IncPointerFail;
  660. Procedure TestPointer_Record;
  661. Procedure TestPointer_RecordArg;
  662. // jsvalue
  663. Procedure TestJSValue_AssignToJSValue;
  664. Procedure TestJSValue_TypeCastToBaseType;
  665. Procedure TestJSValue_Equal;
  666. Procedure TestJSValue_If;
  667. Procedure TestJSValue_Not;
  668. Procedure TestJSValue_Enum;
  669. Procedure TestJSValue_ClassInstance;
  670. Procedure TestJSValue_ClassOf;
  671. Procedure TestJSValue_ArrayOfJSValue;
  672. Procedure TestJSValue_ArrayLit;
  673. Procedure TestJSValue_Params;
  674. Procedure TestJSValue_UntypedParam;
  675. Procedure TestJSValue_FuncResultType;
  676. Procedure TestJSValue_ProcType_Assign;
  677. Procedure TestJSValue_ProcType_Equal;
  678. Procedure TestJSValue_ProcType_Param;
  679. Procedure TestJSValue_AssignToPointerFail;
  680. Procedure TestJSValue_OverloadDouble;
  681. Procedure TestJSValue_OverloadNativeInt;
  682. Procedure TestJSValue_OverloadWord;
  683. Procedure TestJSValue_OverloadString;
  684. Procedure TestJSValue_OverloadChar;
  685. Procedure TestJSValue_OverloadPointer;
  686. Procedure TestJSValue_ForIn;
  687. // RTTI
  688. Procedure TestRTTI_IntRange;
  689. Procedure TestRTTI_Double;
  690. Procedure TestRTTI_ProcType;
  691. Procedure TestRTTI_ProcType_ArgFromOtherUnit;
  692. Procedure TestRTTI_EnumAndSetType;
  693. Procedure TestRTTI_EnumRange;
  694. Procedure TestRTTI_AnonymousEnumType;
  695. Procedure TestRTTI_StaticArray;
  696. Procedure TestRTTI_DynArray;
  697. Procedure TestRTTI_ArrayNestedAnonymous;
  698. Procedure TestRTTI_PublishedMethodOverloadFail;
  699. Procedure TestRTTI_PublishedMethodExternalFail;
  700. Procedure TestRTTI_PublishedClassPropertyFail;
  701. Procedure TestRTTI_PublishedClassFieldFail;
  702. Procedure TestRTTI_PublishedFieldExternalFail;
  703. Procedure TestRTTI_Class_Field;
  704. Procedure TestRTTI_Class_Method;
  705. Procedure TestRTTI_Class_MethodArgFlags;
  706. Procedure TestRTTI_Class_Property;
  707. Procedure TestRTTI_Class_PropertyParams;
  708. Procedure TestRTTI_Class_OtherUnit_TypeAlias;
  709. Procedure TestRTTI_Class_OmitRTTI;
  710. Procedure TestRTTI_IndexModifier;
  711. Procedure TestRTTI_StoredModifier;
  712. Procedure TestRTTI_DefaultValue;
  713. Procedure TestRTTI_DefaultValueSet;
  714. Procedure TestRTTI_DefaultValueRangeType;
  715. Procedure TestRTTI_DefaultValueInherit;
  716. Procedure TestRTTI_OverrideMethod;
  717. Procedure TestRTTI_OverloadProperty;
  718. // ToDo: array argument
  719. Procedure TestRTTI_ClassForward;
  720. Procedure TestRTTI_ClassOf;
  721. Procedure TestRTTI_Record;
  722. Procedure TestRTTI_RecordAnonymousArray;
  723. Procedure TestRTTI_LocalTypes;
  724. Procedure TestRTTI_TypeInfo_BaseTypes;
  725. Procedure TestRTTI_TypeInfo_Type_BaseTypes;
  726. Procedure TestRTTI_TypeInfo_LocalFail;
  727. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  728. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  729. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  730. Procedure TestRTTI_TypeInfo_FunctionClassType;
  731. Procedure TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
  732. Procedure TestRTTI_Interface_Corba;
  733. Procedure TestRTTI_Interface_COM;
  734. // Resourcestring
  735. Procedure TestResourcestringProgram;
  736. Procedure TestResourcestringUnit;
  737. Procedure TestResourcestringImplementation;
  738. // Attributes
  739. Procedure TestAtributes_Ignore;
  740. // Assertions, checks
  741. procedure TestAssert;
  742. procedure TestAssert_SysUtils;
  743. procedure TestObjectChecks;
  744. procedure TestRangeChecks_AssignInt;
  745. procedure TestRangeChecks_AssignIntRange;
  746. procedure TestRangeChecks_AssignEnum;
  747. procedure TestRangeChecks_AssignEnumRange;
  748. procedure TestRangeChecks_AssignChar;
  749. procedure TestRangeChecks_AssignCharRange;
  750. procedure TestRangeChecks_ArrayIndex;
  751. procedure TestRangeChecks_ArrayOfRecIndex;
  752. procedure TestRangeChecks_StringIndex;
  753. procedure TestRangeChecks_TypecastInt;
  754. end;
  755. function LinesToStr(Args: array of const): string;
  756. function ExtractFileUnitName(aFilename: string): string;
  757. function JSToStr(El: TJSElement): string;
  758. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  759. implementation
  760. function LinesToStr(Args: array of const): string;
  761. var
  762. s: String;
  763. i: Integer;
  764. begin
  765. s:='';
  766. for i:=Low(Args) to High(Args) do
  767. case Args[i].VType of
  768. vtChar: s += Args[i].VChar+LineEnding;
  769. vtString: s += Args[i].VString^+LineEnding;
  770. vtPChar: s += Args[i].VPChar+LineEnding;
  771. vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
  772. vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
  773. vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
  774. vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
  775. vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
  776. end;
  777. Result:=s;
  778. end;
  779. function ExtractFileUnitName(aFilename: string): string;
  780. var
  781. p: Integer;
  782. begin
  783. Result:=ExtractFileName(aFilename);
  784. if Result='' then exit;
  785. for p:=length(Result) downto 1 do
  786. case Result[p] of
  787. '/','\': exit;
  788. '.':
  789. begin
  790. Delete(Result,p,length(Result));
  791. exit;
  792. end;
  793. end;
  794. end;
  795. function JSToStr(El: TJSElement): string;
  796. var
  797. aWriter: TBufferWriter;
  798. aJSWriter: TJSWriter;
  799. begin
  800. aJSWriter:=nil;
  801. aWriter:=TBufferWriter.Create(1000);
  802. try
  803. aJSWriter:=TJSWriter.Create(aWriter);
  804. aJSWriter.IndentSize:=2;
  805. aJSWriter.WriteJS(El);
  806. Result:=aWriter.AsString;
  807. finally
  808. aJSWriter.Free;
  809. aWriter.Free;
  810. end;
  811. end;
  812. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  813. // search diff, ignore changes in spaces
  814. const
  815. SpaceChars = [#9,#10,#13,' '];
  816. var
  817. ExpectedP, ActualP: PChar;
  818. function FindLineEnd(p: PChar): PChar;
  819. begin
  820. Result:=p;
  821. while not (Result^ in [#0,#10,#13]) do inc(Result);
  822. end;
  823. function FindLineStart(p, MinP: PChar): PChar;
  824. begin
  825. while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
  826. Result:=p;
  827. end;
  828. procedure SkipLineEnd(var p: PChar);
  829. begin
  830. if p^ in [#10,#13] then
  831. begin
  832. if (p[1] in [#10,#13]) and (p^<>p[1]) then
  833. inc(p,2)
  834. else
  835. inc(p);
  836. end;
  837. end;
  838. procedure DiffFound;
  839. var
  840. ActLineStartP, ActLineEndP, p, StartPos: PChar;
  841. ExpLine, ActLine: String;
  842. i, LineNo, DiffLineNo: Integer;
  843. begin
  844. writeln('Diff found "',Msg,'". Lines:');
  845. // write correct lines
  846. p:=PChar(Expected);
  847. LineNo:=0;
  848. DiffLineNo:=0;
  849. repeat
  850. StartPos:=p;
  851. while not (p^ in [#0,#10,#13]) do inc(p);
  852. ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
  853. SkipLineEnd(p);
  854. inc(LineNo);
  855. if (p<=ExpectedP) and (p^<>#0) then
  856. begin
  857. writeln('= ',ExpLine);
  858. end else begin
  859. // diff line
  860. if DiffLineNo=0 then DiffLineNo:=LineNo;
  861. // write actual line
  862. ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
  863. ActLineEndP:=FindLineEnd(ActualP);
  864. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  865. writeln('- ',ActLine);
  866. // write expected line
  867. writeln('+ ',ExpLine);
  868. // write empty line with pointer ^
  869. for i:=1 to 2+ExpectedP-StartPos do write(' ');
  870. writeln('^');
  871. Msg:='expected "'+ExpLine+'", but got "'+ActLine+'".';
  872. CheckSrcDiff:=false;
  873. // write up to three following actual lines to get some context
  874. for i:=1 to 3 do begin
  875. ActLineStartP:=ActLineEndP;
  876. SkipLineEnd(ActLineStartP);
  877. if ActLineStartP^=#0 then break;
  878. ActLineEndP:=FindLineEnd(ActLineStartP);
  879. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  880. writeln('~ ',ActLine);
  881. end;
  882. exit;
  883. end;
  884. until p^=#0;
  885. writeln('DiffFound Actual:-----------------------');
  886. writeln(Actual);
  887. writeln('DiffFound Expected:---------------------');
  888. writeln(Expected);
  889. writeln('DiffFound ------------------------------');
  890. Msg:='diff found, but lines are the same, internal error';
  891. CheckSrcDiff:=false;
  892. end;
  893. var
  894. IsSpaceNeeded: Boolean;
  895. LastChar, Quote: Char;
  896. begin
  897. Result:=true;
  898. Msg:='';
  899. if Expected='' then Expected:=' ';
  900. if Actual='' then Actual:=' ';
  901. ExpectedP:=PChar(Expected);
  902. ActualP:=PChar(Actual);
  903. repeat
  904. //writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
  905. case ExpectedP^ of
  906. #0:
  907. begin
  908. // check that rest of Actual has only spaces
  909. while ActualP^ in SpaceChars do inc(ActualP);
  910. if ActualP^<>#0 then
  911. begin
  912. DiffFound;
  913. exit;
  914. end;
  915. exit(true);
  916. end;
  917. ' ',#9,#10,#13:
  918. begin
  919. // skip space in Expected
  920. IsSpaceNeeded:=false;
  921. if ExpectedP>PChar(Expected) then
  922. LastChar:=ExpectedP[-1]
  923. else
  924. LastChar:=#0;
  925. while ExpectedP^ in SpaceChars do inc(ExpectedP);
  926. if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
  927. and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
  928. IsSpaceNeeded:=true;
  929. if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
  930. begin
  931. DiffFound;
  932. exit;
  933. end;
  934. while ActualP^ in SpaceChars do inc(ActualP);
  935. end;
  936. '''','"':
  937. begin
  938. while ActualP^ in SpaceChars do inc(ActualP);
  939. if ExpectedP^<>ActualP^ then
  940. begin
  941. DiffFound;
  942. exit;
  943. end;
  944. Quote:=ExpectedP^;
  945. repeat
  946. inc(ExpectedP);
  947. inc(ActualP);
  948. if ExpectedP^<>ActualP^ then
  949. begin
  950. DiffFound;
  951. exit;
  952. end;
  953. if (ExpectedP^ in [#0,#10,#13]) then
  954. break
  955. else if (ExpectedP^=Quote) then
  956. begin
  957. inc(ExpectedP);
  958. inc(ActualP);
  959. break;
  960. end;
  961. until false;
  962. end;
  963. else
  964. while ActualP^ in SpaceChars do inc(ActualP);
  965. if ExpectedP^<>ActualP^ then
  966. begin
  967. DiffFound;
  968. exit;
  969. end;
  970. inc(ExpectedP);
  971. inc(ActualP);
  972. end;
  973. until false;
  974. end;
  975. { TTestEnginePasResolver }
  976. destructor TTestEnginePasResolver.Destroy;
  977. begin
  978. FreeAndNil(FStreamResolver);
  979. FreeAndNil(FParser);
  980. FreeAndNil(FScanner);
  981. FreeAndNil(FStreamResolver);
  982. if Module<>nil then
  983. begin
  984. Module.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
  985. FModule:=nil;
  986. end;
  987. inherited Destroy;
  988. end;
  989. function TTestEnginePasResolver.FindUnit(const AName, InFilename: String;
  990. NameExpr, InFileExpr: TPasExpr): TPasModule;
  991. begin
  992. Result:=nil;
  993. if InFilename<>'' then
  994. RaiseNotYetImplemented(20180224101926,InFileExpr,'Use testcase tcunitsearch instead');
  995. if Assigned(OnFindUnit) then
  996. Result:=OnFindUnit(AName);
  997. if NameExpr=nil then ;
  998. end;
  999. procedure TTestEnginePasResolver.UsedInterfacesFinished(Section: TPasSection);
  1000. begin
  1001. // do not parse recursively
  1002. // parse via the queue
  1003. if Section=nil then ;
  1004. end;
  1005. { TCustomTestModule }
  1006. function TCustomTestModule.GetMsgCount: integer;
  1007. begin
  1008. Result:=FHintMsgs.Count;
  1009. end;
  1010. function TCustomTestModule.GetMsgs(Index: integer): TTestHintMessage;
  1011. begin
  1012. Result:=TTestHintMessage(FHintMsgs[Index]);
  1013. end;
  1014. function TCustomTestModule.GetResolverCount: integer;
  1015. begin
  1016. Result:=FModules.Count;
  1017. end;
  1018. function TCustomTestModule.GetResolvers(Index: integer
  1019. ): TTestEnginePasResolver;
  1020. begin
  1021. Result:=TTestEnginePasResolver(FModules[Index]);
  1022. end;
  1023. function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
  1024. ): TPasModule;
  1025. var
  1026. DefNamespace: String;
  1027. begin
  1028. //writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
  1029. if (Pos('.',aUnitName)<1) then
  1030. begin
  1031. DefNamespace:=GetDefaultNamespace;
  1032. if DefNamespace<>'' then
  1033. begin
  1034. Result:=LoadUnit(DefNamespace+'.'+aUnitName);
  1035. if Result<>nil then exit;
  1036. end;
  1037. end;
  1038. Result:=LoadUnit(aUnitName);
  1039. if Result<>nil then exit;
  1040. {$IFDEF VerbosePas2JS}
  1041. writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
  1042. {$ENDIF}
  1043. Fail('can''t find unit "'+aUnitName+'"');
  1044. end;
  1045. procedure TCustomTestModule.OnParserLog(Sender: TObject; const Msg: String);
  1046. var
  1047. aParser: TPasParser;
  1048. Item: TTestHintMessage;
  1049. begin
  1050. aParser:=Sender as TPasParser;
  1051. Item:=TTestHintMessage.Create;
  1052. Item.Id:=aParser.LastMsgNumber;
  1053. Item.MsgType:=aParser.LastMsgType;
  1054. Item.MsgNumber:=aParser.LastMsgNumber;
  1055. Item.Msg:=Msg;
  1056. Item.SourcePos:=aParser.Scanner.CurSourcePos;
  1057. {$IFDEF VerbosePas2JS}
  1058. writeln('TCustomTestModule.OnParserLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
  1059. {$ENDIF}
  1060. FHintMsgs.Add(Item);
  1061. end;
  1062. procedure TCustomTestModule.OnPasResolverLog(Sender: TObject; const Msg: String
  1063. );
  1064. var
  1065. aResolver: TTestEnginePasResolver;
  1066. Item: TTestHintMessage;
  1067. begin
  1068. aResolver:=Sender as TTestEnginePasResolver;
  1069. Item:=TTestHintMessage.Create;
  1070. Item.Id:=aResolver.LastMsgId;
  1071. Item.MsgType:=aResolver.LastMsgType;
  1072. Item.MsgNumber:=aResolver.LastMsgNumber;
  1073. Item.Msg:=Msg;
  1074. Item.SourcePos:=aResolver.LastSourcePos;
  1075. {$IFDEF VerbosePas2JS}
  1076. writeln('TCustomTestModule.OnPasResolverLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
  1077. {$ENDIF}
  1078. FHintMsgs.Add(Item);
  1079. end;
  1080. procedure TCustomTestModule.OnScannerLog(Sender: TObject; const Msg: String);
  1081. var
  1082. Item: TTestHintMessage;
  1083. aScanner: TPas2jsPasScanner;
  1084. begin
  1085. aScanner:=Sender as TPas2jsPasScanner;
  1086. Item:=TTestHintMessage.Create;
  1087. Item.Id:=aScanner.LastMsgNumber;
  1088. Item.MsgType:=aScanner.LastMsgType;
  1089. Item.MsgNumber:=aScanner.LastMsgNumber;
  1090. Item.Msg:=Msg;
  1091. Item.SourcePos:=aScanner.CurSourcePos;
  1092. {$IFDEF VerbosePas2JS}
  1093. writeln('TCustomTestModule.OnScannerLog ',GetObjName(Sender),' ',Item.MsgType,' (',Item.MsgNumber,') {',Msg,'}');
  1094. {$ENDIF}
  1095. FHintMsgs.Add(Item);
  1096. end;
  1097. function TCustomTestModule.LoadUnit(const aUnitName: String): TPasModule;
  1098. var
  1099. i: Integer;
  1100. CurEngine: TTestEnginePasResolver;
  1101. CurUnitName: String;
  1102. begin
  1103. //writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
  1104. Result:=nil;
  1105. if (Module.ClassType=TPasModule)
  1106. and (CompareText(Module.Name,aUnitName)=0) then
  1107. exit(Module);
  1108. for i:=0 to ResolverCount-1 do
  1109. begin
  1110. CurEngine:=Resolvers[i];
  1111. CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
  1112. //writeln('TTestModule.FindUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
  1113. if CompareText(aUnitName,CurUnitName)=0 then
  1114. begin
  1115. Result:=CurEngine.Module;
  1116. if Result<>nil then exit;
  1117. //writeln('TTestModule.FindUnit PARSING unit "',CurEngine.Filename,'"');
  1118. FileResolver.FindSourceFile(aUnitName);
  1119. CurEngine.StreamResolver:=TStreamResolver.Create;
  1120. CurEngine.StreamResolver.OwnsStreams:=True;
  1121. //writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
  1122. CurEngine.StreamResolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
  1123. CurEngine.Scanner:=TPas2jsPasScanner.Create(CurEngine.StreamResolver);
  1124. InitScanner(CurEngine.Scanner);
  1125. CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.StreamResolver,CurEngine);
  1126. CurEngine.Parser.Options:=po_tcmodules;
  1127. if CompareText(CurUnitName,'System')=0 then
  1128. CurEngine.Parser.ImplicitUses.Clear;
  1129. CurEngine.Scanner.OpenFile(CurEngine.Filename);
  1130. try
  1131. CurEngine.Parser.NextToken;
  1132. CurEngine.Parser.ParseUnit(CurEngine.FModule);
  1133. except
  1134. on E: Exception do
  1135. HandleException(E);
  1136. end;
  1137. //writeln('TTestModule.FindUnit END ',CurUnitName);
  1138. Result:=CurEngine.Module;
  1139. exit;
  1140. end;
  1141. end;
  1142. end;
  1143. procedure TCustomTestModule.SetUp;
  1144. begin
  1145. {$IFDEF EnablePasTreeGlobalRefCount}
  1146. FElementRefCountAtSetup:=TPasElement.GlobalRefCount;
  1147. {$ENDIF}
  1148. if FModules<>nil then
  1149. begin
  1150. writeln('TCustomTestModule.SetUp FModules<>nil');
  1151. Halt;
  1152. end;
  1153. inherited SetUp;
  1154. FSkipTests:=false;
  1155. FSource:=TStringList.Create;
  1156. FModules:=TObjectList.Create(true);
  1157. FFilename:='test1.pp';
  1158. FFileResolver:=TStreamResolver.Create;
  1159. FFileResolver.OwnsStreams:=True;
  1160. FScanner:=TPas2jsPasScanner.Create(FFileResolver);
  1161. InitScanner(FScanner);
  1162. FEngine:=AddModule(Filename);
  1163. FEngine.Scanner:=FScanner;
  1164. FScanner.Resolver:=FEngine;
  1165. FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
  1166. FParser.OnLog:=@OnParserLog;
  1167. FEngine.Parser:=FParser;
  1168. Parser.Options:=po_tcmodules;
  1169. FModule:=Nil;
  1170. FConverter:=CreateConverter;
  1171. FExpectedErrorClass:=nil;
  1172. end;
  1173. function TCustomTestModule.CreateConverter: TPasToJSConverter;
  1174. begin
  1175. Result:=TPasToJSConverter.Create;
  1176. Result.Options:=co_tcmodules;
  1177. Result.Globals:=TPasToJSConverterGlobals.Create(Result);
  1178. end;
  1179. procedure TCustomTestModule.InitScanner(aScanner: TPas2jsPasScanner);
  1180. begin
  1181. aScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
  1182. aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
  1183. aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
  1184. aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
  1185. aScanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
  1186. aScanner.CurrentBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
  1187. aScanner.OnLog:=@OnScannerLog;
  1188. aScanner.CompilerVersion:='Comp.Ver.tcmodules';
  1189. end;
  1190. procedure TCustomTestModule.TearDown;
  1191. {$IFDEF CheckPasTreeRefCount}
  1192. var
  1193. El: TPasElement;
  1194. {$ENDIF}
  1195. var
  1196. i: Integer;
  1197. CurModule: TPasModule;
  1198. begin
  1199. FHintMsgs.Clear;
  1200. FHintMsgsGood.Clear;
  1201. FSkipTests:=false;
  1202. FJSRegModuleCall:=nil;
  1203. FJSModuleCallArgs:=nil;
  1204. FJSImplentationUses:=nil;
  1205. FJSInterfaceUses:=nil;
  1206. FJSModuleSrc:=nil;
  1207. FJSInitBody:=nil;
  1208. FreeAndNil(FJSSource);
  1209. FreeAndNil(FJSModule);
  1210. FreeAndNil(FConverter);
  1211. Engine.Clear;
  1212. FreeAndNil(FSource);
  1213. FreeAndNil(FFileResolver);
  1214. if FModules<>nil then
  1215. begin
  1216. for i:=0 to FModules.Count-1 do
  1217. begin
  1218. CurModule:=TTestEnginePasResolver(FModules[i]).Module;
  1219. if CurModule=nil then continue;
  1220. //writeln('TCustomTestModule.TearDown ReleaseUsedUnits ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
  1221. CurModule.ReleaseUsedUnits;
  1222. end;
  1223. if FModule<>nil then
  1224. FModule.ReleaseUsedUnits;
  1225. for i:=0 to FModules.Count-1 do
  1226. begin
  1227. CurModule:=TTestEnginePasResolver(FModules[i]).Module;
  1228. if CurModule=nil then continue;
  1229. //writeln('TCustomTestModule.TearDown UsesReleased ',CurModule.Name,' ',CurModule.RefCount,' ',CurModule.RefIds.Text);
  1230. end;
  1231. FreeAndNil(FModules);
  1232. ReleaseAndNil(TPasElement(FModule){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
  1233. FEngine:=nil;
  1234. end;
  1235. inherited TearDown;
  1236. {$IFDEF EnablePasTreeGlobalRefCount}
  1237. if FElementRefCountAtSetup<>TPasElement.GlobalRefCount then
  1238. begin
  1239. writeln('TCustomTestModule.TearDown GlobalRefCount Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
  1240. {$IFDEF CheckPasTreeRefCount}
  1241. El:=TPasElement.FirstRefEl;
  1242. while El<>nil do
  1243. begin
  1244. writeln(' ',GetObjName(El),' RefIds.Count=',El.RefIds.Count,':');
  1245. for i:=0 to El.RefIds.Count-1 do
  1246. writeln(' ',El.RefIds[i]);
  1247. El:=El.NextRefEl;
  1248. end;
  1249. {$ENDIF}
  1250. Halt;
  1251. Fail('TCustomTestModule.TearDown Was='+IntToStr(FElementRefCountAtSetup)+' Now='+IntToStr(TPasElement.GlobalRefCount));
  1252. end;
  1253. {$ENDIF}
  1254. end;
  1255. procedure TCustomTestModule.Add(Line: string);
  1256. begin
  1257. Source.Add(Line);
  1258. end;
  1259. procedure TCustomTestModule.Add(const Lines: array of string);
  1260. var
  1261. i: Integer;
  1262. begin
  1263. for i:=low(Lines) to high(Lines) do
  1264. Add(Lines[i]);
  1265. end;
  1266. procedure TCustomTestModule.StartParsing;
  1267. var
  1268. Src: String;
  1269. begin
  1270. Src:=Source.Text;
  1271. FEngine.Source:=Src;
  1272. FileResolver.AddStream(FileName,TStringStream.Create(Src));
  1273. Scanner.OpenFile(FileName);
  1274. Writeln('// Test : ',Self.TestName);
  1275. Writeln(Src);
  1276. end;
  1277. procedure TCustomTestModule.ParseModuleQueue;
  1278. var
  1279. i: Integer;
  1280. CurResolver: TTestEnginePasResolver;
  1281. Found: Boolean;
  1282. Section: TPasSection;
  1283. begin
  1284. // parse til exception or all modules finished
  1285. while not SkipTests do
  1286. begin
  1287. Found:=false;
  1288. for i:=0 to ResolverCount-1 do
  1289. begin
  1290. CurResolver:=Resolvers[i];
  1291. if CurResolver.CurrentParser=nil then continue;
  1292. if not CurResolver.CurrentParser.CanParseContinue(Section) then
  1293. continue;
  1294. CurResolver.Parser.ParseContinue;
  1295. Found:=true;
  1296. break;
  1297. end;
  1298. if not Found then break;
  1299. end;
  1300. for i:=0 to ResolverCount-1 do
  1301. begin
  1302. CurResolver:=Resolvers[i];
  1303. if CurResolver.Parser=nil then
  1304. begin
  1305. if CurResolver.CurrentParser<>nil then
  1306. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' '+GetObjName(CurResolver.Parser)+'=Parser<>CurrentParser='+GetObjName(CurResolver.CurrentParser));
  1307. continue;
  1308. end;
  1309. if CurResolver.Parser.CurModule<>nil then
  1310. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' NOT FINISHED CurModule='+GetObjName(CurResolver.Parser.CurModule));
  1311. end;
  1312. end;
  1313. procedure TCustomTestModule.ParseModule;
  1314. begin
  1315. if SkipTests then exit;
  1316. FFirstPasStatement:=nil;
  1317. try
  1318. StartParsing;
  1319. Parser.ParseMain(FModule);
  1320. ParseModuleQueue;
  1321. except
  1322. on E: Exception do
  1323. HandleException(E);
  1324. end;
  1325. if SkipTests then exit;
  1326. AssertNotNull('Module resulted in Module',Module);
  1327. AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
  1328. TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
  1329. end;
  1330. procedure TCustomTestModule.ParseProgram;
  1331. begin
  1332. if SkipTests then exit;
  1333. ParseModule;
  1334. if SkipTests then exit;
  1335. AssertEquals('Has program',TPasProgram,Module.ClassType);
  1336. FPasProgram:=TPasProgram(Module);
  1337. AssertNotNull('Has program section',PasProgram.ProgramSection);
  1338. AssertNotNull('Has initialization section',PasProgram.InitializationSection);
  1339. if (PasProgram.InitializationSection.Elements.Count>0) then
  1340. if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
  1341. FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
  1342. end;
  1343. procedure TCustomTestModule.ParseUnit;
  1344. begin
  1345. if SkipTests then exit;
  1346. ParseModule;
  1347. if SkipTests then exit;
  1348. AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
  1349. AssertNotNull('Has interface section',Module.InterfaceSection);
  1350. AssertNotNull('Has implementation section',Module.ImplementationSection);
  1351. if (Module.InitializationSection<>nil)
  1352. and (Module.InitializationSection.Elements.Count>0)
  1353. and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
  1354. FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
  1355. end;
  1356. function TCustomTestModule.FindModuleWithFilename(aFilename: string
  1357. ): TTestEnginePasResolver;
  1358. var
  1359. i: Integer;
  1360. begin
  1361. for i:=0 to ResolverCount-1 do
  1362. if CompareText(Resolvers[i].Filename,aFilename)=0 then
  1363. exit(Resolvers[i]);
  1364. Result:=nil;
  1365. end;
  1366. function TCustomTestModule.AddModule(aFilename: string
  1367. ): TTestEnginePasResolver;
  1368. begin
  1369. //writeln('TTestModuleConverter.AddModule ',aFilename);
  1370. if FindModuleWithFilename(aFilename)<>nil then
  1371. Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
  1372. Result:=TTestEnginePasResolver.Create;
  1373. Result.Filename:=aFilename;
  1374. Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
  1375. Result.OnFindUnit:=@OnPasResolverFindUnit;
  1376. Result.OnLog:=@OnPasResolverLog;
  1377. FModules.Add(Result);
  1378. end;
  1379. function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
  1380. ): TTestEnginePasResolver;
  1381. begin
  1382. Result:=AddModule(aFilename);
  1383. Result.Source:=Src;
  1384. end;
  1385. function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  1386. ImplementationSrc: string): TTestEnginePasResolver;
  1387. var
  1388. Src: String;
  1389. begin
  1390. Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
  1391. Src+=LineEnding;
  1392. Src+='interface'+LineEnding;
  1393. Src+=LineEnding;
  1394. Src+=InterfaceSrc;
  1395. Src+='implementation'+LineEnding;
  1396. Src+=LineEnding;
  1397. Src+=ImplementationSrc;
  1398. Src+='end.'+LineEnding;
  1399. Result:=AddModuleWithSrc(aFilename,Src);
  1400. end;
  1401. procedure TCustomTestModule.AddSystemUnit;
  1402. begin
  1403. AddModuleWithIntfImplSrc('system.pp',
  1404. // interface
  1405. LinesToStr([
  1406. 'type',
  1407. ' integer=longint;',
  1408. 'var',
  1409. ' ExitCode: Longint;',
  1410. ''
  1411. // implementation
  1412. ]),LinesToStr([
  1413. ''
  1414. ]));
  1415. end;
  1416. procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean);
  1417. begin
  1418. if NeedSystemUnit then
  1419. AddSystemUnit
  1420. else
  1421. Parser.ImplicitUses.Clear;
  1422. Add('program '+ExtractFileUnitName(Filename)+';');
  1423. Add('');
  1424. end;
  1425. procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean);
  1426. begin
  1427. if NeedSystemUnit then
  1428. AddSystemUnit
  1429. else
  1430. Parser.ImplicitUses.Clear;
  1431. Add('unit Test1;');
  1432. Add('');
  1433. end;
  1434. procedure TCustomTestModule.ConvertModule;
  1435. procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
  1436. out UsesLit: TJSArrayLiteral);
  1437. var
  1438. i: Integer;
  1439. Item: TJSElement;
  1440. Lit: TJSLiteral;
  1441. begin
  1442. UsesLit:=nil;
  1443. AssertNotNull(UsesName+' uses section',Arg.Expr);
  1444. if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
  1445. exit; // null is ok
  1446. AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
  1447. FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
  1448. for i:=0 to FJSInterfaceUses.Elements.Count-1 do
  1449. begin
  1450. Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
  1451. AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
  1452. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
  1453. Lit:=TJSLiteral(Item);
  1454. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
  1455. ord(jsbase.jstString),ord(Lit.Value.ValueType));
  1456. end;
  1457. end;
  1458. procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
  1459. out Src: TJSSourceElements);
  1460. var
  1461. FunDecl: TJSFunctionDeclarationStatement;
  1462. FunDef: TJSFuncDef;
  1463. FunBody: TJSFunctionBody;
  1464. begin
  1465. Src:=nil;
  1466. AssertNotNull(ParamName,Arg.Expr);
  1467. AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
  1468. FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
  1469. AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
  1470. AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
  1471. FunDef:=FunDecl.AFunction as TJSFuncDef;
  1472. AssertEquals(ParamName+' name empty','',String(FunDef.Name));
  1473. AssertNotNull(ParamName+' body',FunDef.Body);
  1474. AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
  1475. FunBody:=FunDef.Body as TJSFunctionBody;
  1476. AssertNotNull(ParamName+' body.A',FunBody.A);
  1477. AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
  1478. Src:=FunBody.A as TJSSourceElements;
  1479. end;
  1480. var
  1481. ModuleNameExpr: TJSLiteral;
  1482. InitFunction: TJSFunctionDeclarationStatement;
  1483. InitAssign: TJSSimpleAssignStatement;
  1484. InitName: String;
  1485. LastNode: TJSElement;
  1486. Arg: TJSArrayLiteralElement;
  1487. begin
  1488. if SkipTests then exit;
  1489. try
  1490. FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
  1491. except
  1492. on E: Exception do
  1493. HandleException(E);
  1494. end;
  1495. if SkipTests then exit;
  1496. if ExpectedErrorClass<>nil then
  1497. Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
  1498. FJSSource:=TStringList.Create;
  1499. FJSSource.Text:=ConvertJSModuleToString(JSModule);
  1500. {$IFDEF VerbosePas2JS}
  1501. writeln('TTestModule.ConvertModule JS:');
  1502. write(FJSSource.Text);
  1503. {$ENDIF}
  1504. // rtl.module(...
  1505. AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
  1506. AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
  1507. AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
  1508. FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
  1509. AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
  1510. AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
  1511. AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
  1512. FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
  1513. // parameter 'unitname'
  1514. if JSModuleCallArgs.Elements.Count<1 then
  1515. Fail('rtl.module first param unit missing');
  1516. Arg:=JSModuleCallArgs.Elements.Elements[0];
  1517. AssertNotNull('module name param',Arg.Expr);
  1518. ModuleNameExpr:=Arg.Expr as TJSLiteral;
  1519. AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
  1520. if Module is TPasProgram then
  1521. AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
  1522. else
  1523. AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
  1524. // main uses section
  1525. if JSModuleCallArgs.Elements.Count<2 then
  1526. Fail('rtl.module second param main uses missing');
  1527. Arg:=JSModuleCallArgs.Elements.Elements[1];
  1528. CheckUsesList('interface',Arg,FJSInterfaceUses);
  1529. // program/library/interface function()
  1530. if JSModuleCallArgs.Elements.Count<3 then
  1531. Fail('rtl.module third param intf-function missing');
  1532. Arg:=JSModuleCallArgs.Elements.Elements[2];
  1533. CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
  1534. // search for $mod.$init or $mod.$main - the last statement
  1535. if Module is TPasProgram then
  1536. begin
  1537. InitName:='$main';
  1538. AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
  1539. end
  1540. else
  1541. InitName:='$init';
  1542. FJSInitBody:=nil;
  1543. if JSModuleSrc.Statements.Count>0 then
  1544. begin
  1545. LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
  1546. if LastNode is TJSSimpleAssignStatement then
  1547. begin
  1548. InitAssign:=LastNode as TJSSimpleAssignStatement;
  1549. if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
  1550. begin
  1551. InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
  1552. FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
  1553. end
  1554. else if Module is TPasProgram then
  1555. CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
  1556. end;
  1557. end;
  1558. // optional: implementation uses section
  1559. if JSModuleCallArgs.Elements.Count<4 then
  1560. exit;
  1561. Arg:=JSModuleCallArgs.Elements.Elements[3];
  1562. CheckUsesList('implementation',Arg,FJSImplentationUses);
  1563. // optional: implementation function()
  1564. if JSModuleCallArgs.Elements.Count<5 then
  1565. exit;
  1566. Arg:=JSModuleCallArgs.Elements.Elements[4];
  1567. CheckFunctionParam('module impl-function',Arg,FJSImplementationSrc);
  1568. end;
  1569. procedure TCustomTestModule.ConvertProgram;
  1570. begin
  1571. Add('end.');
  1572. ParseProgram;
  1573. ConvertModule;
  1574. end;
  1575. procedure TCustomTestModule.ConvertUnit;
  1576. begin
  1577. Add('end.');
  1578. ParseUnit;
  1579. ConvertModule;
  1580. end;
  1581. function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
  1582. begin
  1583. Result:=tcmodules.JSToStr(El);
  1584. end;
  1585. procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
  1586. DottedName: string);
  1587. begin
  1588. if DottedName='' then
  1589. begin
  1590. AssertNull(Msg,El);
  1591. end
  1592. else
  1593. begin
  1594. AssertNotNull(Msg,El);
  1595. AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
  1596. end;
  1597. end;
  1598. function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
  1599. begin
  1600. if El=nil then
  1601. Result:=''
  1602. else if El is TJSPrimaryExpressionIdent then
  1603. Result:=String(TJSPrimaryExpressionIdent(El).Name)
  1604. else if El is TJSDotMemberExpression then
  1605. Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
  1606. else
  1607. AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
  1608. end;
  1609. procedure TCustomTestModule.CheckSource(Msg, Statements: String;
  1610. InitStatements: string; ImplStatements: string);
  1611. var
  1612. ActualSrc, ExpectedSrc, InitName: String;
  1613. begin
  1614. ActualSrc:=JSToStr(JSModuleSrc);
  1615. ExpectedSrc:=
  1616. 'var $mod = this;'+LineEnding
  1617. +Statements;
  1618. if coUseStrict in Converter.Options then
  1619. ExpectedSrc:='"use strict";'+LineEnding+ExpectedSrc;
  1620. if Module is TPasProgram then
  1621. InitName:='$main'
  1622. else
  1623. InitName:='$init';
  1624. if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
  1625. ExpectedSrc:=ExpectedSrc+LineEnding
  1626. +'$mod.'+InitName+' = function () {'+LineEnding
  1627. +InitStatements
  1628. +'};'+LineEnding;
  1629. //writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
  1630. //writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
  1631. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1632. if (JSImplementationSrc<>nil) then
  1633. begin
  1634. ActualSrc:=JSToStr(JSImplementationSrc);
  1635. ExpectedSrc:=
  1636. 'var $mod = this;'+LineEnding
  1637. +'var $impl = $mod.$impl;'+LineEnding
  1638. +ImplStatements;
  1639. end
  1640. else
  1641. begin
  1642. ActualSrc:='';
  1643. ExpectedSrc:=ImplStatements;
  1644. end;
  1645. //writeln('TTestModule.CheckSource InitStatements="',InitStatements,'"');
  1646. //writeln('TCustomTestModule.CheckSource Expected: ',ExpectedSrc);
  1647. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1648. end;
  1649. procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
  1650. // search diff, ignore changes in spaces
  1651. var
  1652. s: string;
  1653. begin
  1654. if CheckSrcDiff(Expected,Actual,s) then exit;
  1655. Fail(Msg+': '+s);
  1656. end;
  1657. procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
  1658. var
  1659. aResolver: TTestEnginePasResolver;
  1660. aConverter: TPasToJSConverter;
  1661. aJSModule: TJSSourceElements;
  1662. ActualSrc: String;
  1663. begin
  1664. aResolver:=GetResolver(Filename);
  1665. AssertNotNull('missing resolver of unit '+Filename,aResolver);
  1666. {$IFDEF VerbosePas2JS}
  1667. writeln('CheckUnit '+Filename+' converting ...');
  1668. {$ENDIF}
  1669. aConverter:=CreateConverter;
  1670. aJSModule:=nil;
  1671. try
  1672. try
  1673. aJSModule:=aConverter.ConvertPasElement(aResolver.Module,aResolver) as TJSSourceElements;
  1674. except
  1675. on E: Exception do
  1676. HandleException(E);
  1677. end;
  1678. ActualSrc:=ConvertJSModuleToString(aJSModule);
  1679. {$IFDEF VerbosePas2JS}
  1680. writeln('TTestModule.CheckUnit ',Filename,' Pas:');
  1681. write(aResolver.Source);
  1682. writeln('TTestModule.CheckUnit ',Filename,' JS:');
  1683. write(ActualSrc);
  1684. {$ENDIF}
  1685. CheckDiff('Converted unit: "'+ChangeFileExt(Filename,'.js')+'"',ExpectedSrc,ActualSrc);
  1686. finally
  1687. aJSModule.Free;
  1688. aConverter.Free;
  1689. end;
  1690. end;
  1691. procedure TCustomTestModule.CheckHint(MsgType: TMessageType;
  1692. MsgNumber: integer; Msg: string; Marker: PSrcMarker);
  1693. var
  1694. i: Integer;
  1695. Item: TTestHintMessage;
  1696. Expected,Actual: string;
  1697. begin
  1698. //writeln('TCustomTestModule.CheckHint MsgCount=',MsgCount);
  1699. for i:=0 to MsgCount-1 do
  1700. begin
  1701. Item:=Msgs[i];
  1702. if (Item.MsgNumber<>MsgNumber) or (Item.Msg<>Msg) then continue;
  1703. if (Marker<>nil) then
  1704. begin
  1705. if Item.SourcePos.Row<>cardinal(Marker^.Row) then continue;
  1706. if (Item.SourcePos.Column<cardinal(Marker^.StartCol))
  1707. or (Item.SourcePos.Column>cardinal(Marker^.EndCol)) then continue;
  1708. end;
  1709. // found
  1710. FHintMsgsGood.Add(Item);
  1711. str(Item.MsgType,Actual);
  1712. str(MsgType,Expected);
  1713. AssertEquals('MsgType',Expected,Actual);
  1714. exit;
  1715. end;
  1716. // needed message missing -> show emitted messages
  1717. WriteSources('',0,0);
  1718. for i:=0 to MsgCount-1 do
  1719. begin
  1720. Item:=Msgs[i];
  1721. write('TCustomTestModule.CheckHint ',i,'/',MsgCount,' ',Item.MsgType,
  1722. ' ('+IntToStr(Item.MsgNumber),')');
  1723. if Marker<>nil then
  1724. write(' '+ExtractFileName(Item.SourcePos.FileName),'(',Item.SourcePos.Row,',',Item.SourcePos.Column,')');
  1725. writeln(' {',Item.Msg,'}');
  1726. end;
  1727. str(MsgType,Expected);
  1728. Actual:='Missing '+Expected+' ('+IntToStr(MsgNumber)+')';
  1729. if Marker<>nil then
  1730. Actual:=Actual+' '+ExtractFileName(Marker^.Filename)+'('+IntToStr(Marker^.Row)+','+IntToStr(Marker^.StartCol)+'..'+IntToStr(Marker^.EndCol)+')';
  1731. Actual:=Actual+' '+Msg;
  1732. Fail(Actual);
  1733. end;
  1734. procedure TCustomTestModule.CheckResolverUnexpectedHints(WithSourcePos: boolean
  1735. );
  1736. var
  1737. i: Integer;
  1738. s, Txt: String;
  1739. Msg: TTestHintMessage;
  1740. begin
  1741. for i:=0 to MsgCount-1 do
  1742. begin
  1743. Msg:=Msgs[i];
  1744. if FHintMsgsGood.IndexOf(Msg)>=0 then continue;
  1745. s:='';
  1746. str(Msg.MsgType,s);
  1747. Txt:='Unexpected resolver message found ['+IntToStr(Msg.Id)+'] '
  1748. +s+': ('+IntToStr(Msg.MsgNumber)+')';
  1749. if WithSourcePos then
  1750. Txt:=Txt+' '+ExtractFileName(Msg.SourcePos.FileName)+'('+IntToStr(Msg.SourcePos.Row)+','+IntToStr(Msg.SourcePos.Column)+')';
  1751. Txt:=Txt+' {'+Msg.Msg+'}';
  1752. Fail(Txt);
  1753. end;
  1754. end;
  1755. procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
  1756. MsgNumber: integer);
  1757. begin
  1758. ExpectedErrorClass:=EScannerError;
  1759. ExpectedErrorMsg:=Msg;
  1760. ExpectedErrorNumber:=MsgNumber;
  1761. end;
  1762. procedure TCustomTestModule.SetExpectedParserError(Msg: string;
  1763. MsgNumber: integer);
  1764. begin
  1765. ExpectedErrorClass:=EParserError;
  1766. ExpectedErrorMsg:=Msg;
  1767. ExpectedErrorNumber:=MsgNumber;
  1768. end;
  1769. procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
  1770. MsgNumber: integer);
  1771. begin
  1772. ExpectedErrorClass:=EPasResolve;
  1773. ExpectedErrorMsg:=Msg;
  1774. ExpectedErrorNumber:=MsgNumber;
  1775. end;
  1776. procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
  1777. MsgNumber: integer);
  1778. begin
  1779. ExpectedErrorClass:=EPas2JS;
  1780. ExpectedErrorMsg:=Msg;
  1781. ExpectedErrorNumber:=MsgNumber;
  1782. end;
  1783. function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
  1784. var
  1785. MsgNumber: Integer;
  1786. Msg: String;
  1787. begin
  1788. Result:=false;
  1789. if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
  1790. Msg:=E.Message;
  1791. if E is EPas2JS then
  1792. MsgNumber:=EPas2JS(E).MsgNumber
  1793. else if E is EPasResolve then
  1794. MsgNumber:=EPasResolve(E).MsgNumber
  1795. else if E is EParserError then
  1796. MsgNumber:=Parser.LastMsgNumber
  1797. else if E is EScannerError then
  1798. begin
  1799. MsgNumber:=Scanner.LastMsgNumber;
  1800. Msg:=Scanner.LastMsg;
  1801. end
  1802. else
  1803. MsgNumber:=0;
  1804. Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
  1805. if Result then
  1806. SkipTests:=true;
  1807. end;
  1808. procedure TCustomTestModule.HandleScannerError(E: EScannerError);
  1809. begin
  1810. if IsErrorExpected(E) then exit;
  1811. WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
  1812. writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
  1813. +' '+Scanner.CurFilename
  1814. +'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
  1815. FailException(E);
  1816. end;
  1817. procedure TCustomTestModule.HandleParserError(E: EParserError);
  1818. begin
  1819. if IsErrorExpected(E) then exit;
  1820. WriteSources(E.Filename,E.Row,E.Column);
  1821. writeln('ERROR: TCustomTestModule.HandleParserError '+E.ClassName+':'+E.Message
  1822. +' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')'
  1823. +' MainModuleScannerLine="'+Scanner.CurLine+'"'
  1824. );
  1825. FailException(E);
  1826. end;
  1827. procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
  1828. var
  1829. P: TPasSourcePos;
  1830. begin
  1831. if IsErrorExpected(E) then exit;
  1832. P:=E.SourcePos;
  1833. WriteSources(P.FileName,P.Row,P.Column);
  1834. writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
  1835. +' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
  1836. FailException(E);
  1837. end;
  1838. procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
  1839. var
  1840. Row, Col: integer;
  1841. begin
  1842. if IsErrorExpected(E) then exit;
  1843. Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
  1844. WriteSources(E.PasElement.SourceFilename,Row,Col);
  1845. writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
  1846. +' '+E.PasElement.SourceFilename
  1847. +'('+IntToStr(Row)+','+IntToStr(Col)+')');
  1848. FailException(E);
  1849. end;
  1850. procedure TCustomTestModule.HandleException(E: Exception);
  1851. begin
  1852. if E is EScannerError then
  1853. HandleScannerError(EScannerError(E))
  1854. else if E is EParserError then
  1855. HandleParserError(EParserError(E))
  1856. else if E is EPasResolve then
  1857. HandlePasResolveError(EPasResolve(E))
  1858. else if E is EPas2JS then
  1859. HandlePas2JSError(EPas2JS(E))
  1860. else
  1861. begin
  1862. if IsErrorExpected(E) then exit;
  1863. if not (E is EAssertionFailedError) then
  1864. begin
  1865. WriteSources('',0,0);
  1866. writeln('ERROR: TCustomTestModule.HandleException '+E.ClassName+':'+E.Message);
  1867. end;
  1868. FailException(E);
  1869. end;
  1870. end;
  1871. procedure TCustomTestModule.FailException(E: Exception);
  1872. var
  1873. MsgNumber: Integer;
  1874. begin
  1875. if ExpectedErrorClass<>nil then
  1876. begin
  1877. if FExpectedErrorClass=E.ClassType then
  1878. begin
  1879. if E is EPas2JS then
  1880. MsgNumber:=EPas2JS(E).MsgNumber
  1881. else if E is EPasResolve then
  1882. MsgNumber:=EPasResolve(E).MsgNumber
  1883. else if E is EParserError then
  1884. MsgNumber:=Parser.LastMsgNumber
  1885. else if E is EScannerError then
  1886. MsgNumber:=Scanner.LastMsgNumber
  1887. else
  1888. MsgNumber:=0;
  1889. AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
  1890. AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
  1891. ExpectedErrorNumber,MsgNumber);
  1892. end else begin
  1893. AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
  1894. end;
  1895. end;
  1896. Fail(E.Message);
  1897. end;
  1898. procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
  1899. aCol: integer);
  1900. var
  1901. IsSrc: Boolean;
  1902. i, j: Integer;
  1903. SrcLines: TStringList;
  1904. Line: string;
  1905. aModule: TTestEnginePasResolver;
  1906. begin
  1907. writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
  1908. for i:=0 to ResolverCount-1 do
  1909. begin
  1910. aModule:=Resolvers[i];
  1911. SrcLines:=TStringList.Create;
  1912. try
  1913. SrcLines.Text:=aModule.Source;
  1914. IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
  1915. writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
  1916. for j:=1 to SrcLines.Count do
  1917. begin
  1918. Line:=SrcLines[j-1];
  1919. if IsSrc and (j=aRow) then
  1920. begin
  1921. write('*');
  1922. Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
  1923. end;
  1924. writeln(Format('%:4d: ',[j]),Line);
  1925. end;
  1926. finally
  1927. SrcLines.Free;
  1928. end;
  1929. end;
  1930. end;
  1931. function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
  1932. var
  1933. i: Integer;
  1934. begin
  1935. for i:=0 to ResolverCount-1 do
  1936. if Filename=Resolvers[i].Filename then exit(i);
  1937. Result:=-1;
  1938. end;
  1939. function TCustomTestModule.GetResolver(const Filename: string
  1940. ): TTestEnginePasResolver;
  1941. var
  1942. i: Integer;
  1943. begin
  1944. i:=IndexOfResolver(Filename);
  1945. if i<0 then exit(nil);
  1946. Result:=Resolvers[i];
  1947. end;
  1948. function TCustomTestModule.GetDefaultNamespace: string;
  1949. var
  1950. C: TClass;
  1951. begin
  1952. Result:='';
  1953. if FModule=nil then exit;
  1954. C:=FModule.ClassType;
  1955. if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
  1956. Result:=Engine.DefaultNameSpace;
  1957. end;
  1958. constructor TCustomTestModule.Create;
  1959. begin
  1960. inherited Create;
  1961. FHintMsgs:=TObjectList.Create(true);
  1962. FHintMsgsGood:=TFPList.Create;
  1963. end;
  1964. destructor TCustomTestModule.Destroy;
  1965. begin
  1966. FreeAndNil(FHintMsgs);
  1967. FreeAndNil(FHintMsgsGood);
  1968. inherited Destroy;
  1969. end;
  1970. { TTestModule }
  1971. procedure TTestModule.TestReservedWords;
  1972. var
  1973. i: integer;
  1974. begin
  1975. for i:=low(JSReservedWords) to High(JSReservedWords)-1 do
  1976. if CompareStr(JSReservedWords[i],JSReservedWords[i+1])>=0 then
  1977. Fail('20170203135442 '+JSReservedWords[i]+' >= '+JSReservedWords[i+1]);
  1978. for i:=low(JSReservedGlobalWords) to High(JSReservedGlobalWords)-1 do
  1979. if CompareStr(JSReservedGlobalWords[i],JSReservedGlobalWords[i+1])>=0 then
  1980. Fail('20170203135443 '+JSReservedGlobalWords[i]+' >= '+JSReservedGlobalWords[i+1]);
  1981. end;
  1982. procedure TTestModule.TestEmptyProgram;
  1983. begin
  1984. StartProgram(false);
  1985. Add('begin');
  1986. ConvertProgram;
  1987. CheckSource('TestEmptyProgram','','');
  1988. end;
  1989. procedure TTestModule.TestEmptyProgramUseStrict;
  1990. begin
  1991. Converter.Options:=Converter.Options+[coUseStrict];
  1992. StartProgram(false);
  1993. Add('begin');
  1994. ConvertProgram;
  1995. CheckSource('TestEmptyProgramUseStrict','','');
  1996. end;
  1997. procedure TTestModule.TestEmptyUnit;
  1998. begin
  1999. StartUnit(false);
  2000. Add('interface');
  2001. Add('implementation');
  2002. ConvertUnit;
  2003. CheckSource('TestEmptyUnit',
  2004. LinesToStr([
  2005. ]),
  2006. '');
  2007. end;
  2008. procedure TTestModule.TestEmptyUnitUseStrict;
  2009. begin
  2010. Converter.Options:=Converter.Options+[coUseStrict];
  2011. StartUnit(false);
  2012. Add('interface');
  2013. Add('implementation');
  2014. ConvertUnit;
  2015. CheckSource('TestEmptyUnitUseStrict',
  2016. LinesToStr([
  2017. ''
  2018. ]),
  2019. '');
  2020. end;
  2021. procedure TTestModule.TestDottedUnitNames;
  2022. begin
  2023. AddModuleWithIntfImplSrc('NS1.Unit2.pas',
  2024. LinesToStr([
  2025. 'var iV: longint;'
  2026. ]),
  2027. '');
  2028. FFilename:='ns1.test1.pp';
  2029. StartProgram(true);
  2030. Add('uses unIt2;');
  2031. Add('implementation');
  2032. Add('var');
  2033. Add(' i: longint;');
  2034. Add('begin');
  2035. Add(' i:=iv;');
  2036. Add(' i:=uNit2.iv;');
  2037. Add(' i:=Ns1.TEst1.i;');
  2038. ConvertProgram;
  2039. CheckSource('TestDottedUnitNames',
  2040. LinesToStr([
  2041. 'this.i = 0;',
  2042. '']),
  2043. LinesToStr([ // this.$init
  2044. '$mod.i = pas["NS1.Unit2"].iV;',
  2045. '$mod.i = pas["NS1.Unit2"].iV;',
  2046. '$mod.i = $mod.i;',
  2047. '']) );
  2048. end;
  2049. procedure TTestModule.TestDottedUnitNameImpl;
  2050. begin
  2051. AddModuleWithIntfImplSrc('TEST.UnitA.pas',
  2052. LinesToStr([
  2053. 'type',
  2054. ' TObject = class end;',
  2055. ' TTestA = class',
  2056. ' end;'
  2057. ]),
  2058. LinesToStr(['uses TEST.UnitB;'])
  2059. );
  2060. AddModuleWithIntfImplSrc('TEST.UnitB.pas',
  2061. LinesToStr([
  2062. 'uses TEST.UnitA;',
  2063. 'type TTestB = class(TTestA);'
  2064. ]),
  2065. ''
  2066. );
  2067. StartProgram(true);
  2068. Add('uses TEST.UnitA;');
  2069. Add('begin');
  2070. ConvertProgram;
  2071. CheckSource('TestDottedUnitNameImpl',
  2072. LinesToStr([
  2073. '']),
  2074. LinesToStr([ // this.$init
  2075. '']) );
  2076. CheckUnit('TEST.UnitA.pas',
  2077. LinesToStr([
  2078. 'rtl.module("TEST.UnitA", ["system"], function () {',
  2079. ' var $mod = this;',
  2080. ' rtl.createClass($mod, "TObject", null, function () {',
  2081. ' this.$init = function () {',
  2082. ' };',
  2083. ' this.$final = function () {',
  2084. ' };',
  2085. ' });',
  2086. ' rtl.createClass($mod, "TTestA", $mod.TObject, function () {',
  2087. ' });',
  2088. '}, ["TEST.UnitB"]);'
  2089. ]));
  2090. CheckUnit('TEST.UnitB.pas',
  2091. LinesToStr([
  2092. 'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
  2093. ' var $mod = this;',
  2094. ' rtl.createClass($mod, "TTestB", pas["TEST.UnitA"].TTestA, function () {',
  2095. ' });',
  2096. '});'
  2097. ]));
  2098. end;
  2099. procedure TTestModule.TestDottedUnitExpr;
  2100. begin
  2101. AddModuleWithIntfImplSrc('NS2.SubNs2.Unit2.pas',
  2102. LinesToStr([
  2103. 'procedure DoIt;'
  2104. ]),
  2105. 'procedure DoIt; begin end;');
  2106. FFilename:='Ns1.SubNs1.Test1.pp';
  2107. StartProgram(true);
  2108. Add('uses Ns2.sUbnS2.unIt2;');
  2109. Add('implementation');
  2110. Add('var');
  2111. Add(' i: longint;');
  2112. Add('begin');
  2113. Add(' ns2.subns2.unit2.doit;');
  2114. Add(' i:=Ns1.SubNS1.TEst1.i;');
  2115. ConvertProgram;
  2116. CheckSource('TestDottedUnitExpr',
  2117. LinesToStr([
  2118. 'this.i = 0;',
  2119. '']),
  2120. LinesToStr([ // this.$init
  2121. 'pas["NS2.SubNs2.Unit2"].DoIt();',
  2122. '$mod.i = $mod.i;',
  2123. '']) );
  2124. end;
  2125. procedure TTestModule.Test_ModeFPCFail;
  2126. begin
  2127. StartProgram(false);
  2128. Add('{$mode FPC}');
  2129. Add('begin');
  2130. SetExpectedScannerError('Invalid mode: "FPC"',nErrInvalidMode);
  2131. ConvertProgram;
  2132. end;
  2133. procedure TTestModule.Test_ModeSwitchCBlocksFail;
  2134. begin
  2135. StartProgram(false);
  2136. Add('{$modeswitch cblocks-}');
  2137. Add('begin');
  2138. SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
  2139. ConvertProgram;
  2140. end;
  2141. procedure TTestModule.TestUnit_UseSystem;
  2142. begin
  2143. StartUnit(true);
  2144. Add([
  2145. 'interface',
  2146. 'var i: integer;',
  2147. 'implementation']);
  2148. ConvertUnit;
  2149. CheckSource('TestUnit_UseSystem',
  2150. LinesToStr([
  2151. 'this.i = 0;',
  2152. '']),
  2153. LinesToStr([
  2154. '']) );
  2155. end;
  2156. procedure TTestModule.TestUnit_Intf1Impl2Intf1;
  2157. begin
  2158. AddModuleWithIntfImplSrc('unit1.pp',
  2159. LinesToStr([
  2160. 'type number = longint;']),
  2161. LinesToStr([
  2162. 'uses test1;',
  2163. 'procedure DoIt;',
  2164. 'begin',
  2165. ' i:=3;',
  2166. 'end;']));
  2167. StartUnit(true);
  2168. Add([
  2169. 'interface',
  2170. 'uses unit1;',
  2171. 'var i: number;',
  2172. 'implementation']);
  2173. ConvertUnit;
  2174. CheckSource('TestUnit_Intf1Impl2Intf1',
  2175. LinesToStr([
  2176. 'this.i = 0;',
  2177. '']),
  2178. LinesToStr([
  2179. '']) );
  2180. end;
  2181. procedure TTestModule.TestIncludeVersion;
  2182. begin
  2183. StartProgram(false);
  2184. Add([
  2185. 'var',
  2186. ' s: string;',
  2187. ' i: word;',
  2188. 'begin',
  2189. ' s:={$I %line%};',
  2190. ' i:={$I %linenum%};',
  2191. ' s:={$I %currentroutine%};',
  2192. ' s:={$I %pas2jsversion%};',
  2193. ' s:={$I %pas2jstarget%};',
  2194. ' s:={$I %pas2jstargetos%};',
  2195. ' s:={$I %pas2jstargetcpu%};',
  2196. ' s:={$I %file%};',
  2197. '']);
  2198. ConvertProgram;
  2199. CheckSource('TestIncludeVersion',
  2200. LinesToStr([
  2201. 'this.s="";',
  2202. 'this.i = 0;']),
  2203. LinesToStr([
  2204. '$mod.s = "7";',
  2205. '$mod.i = 8;',
  2206. '$mod.s = "<anonymous>";',
  2207. '$mod.s = "Comp.Ver.tcmodules";',
  2208. '$mod.s = "Browser";',
  2209. '$mod.s = "Browser";',
  2210. '$mod.s = "ECMAScript5";',
  2211. '$mod.s = "test1.pp";',
  2212. '']));
  2213. end;
  2214. procedure TTestModule.TestVarInt;
  2215. begin
  2216. StartProgram(false);
  2217. Add('var MyI: longint;');
  2218. Add('begin');
  2219. ConvertProgram;
  2220. CheckSource('TestVarInt','this.MyI=0;','');
  2221. end;
  2222. procedure TTestModule.TestVarBaseTypes;
  2223. begin
  2224. StartProgram(false);
  2225. Add('var');
  2226. Add(' i: longint;');
  2227. Add(' s: string;');
  2228. Add(' c: char;');
  2229. Add(' b: boolean;');
  2230. Add(' d: double;');
  2231. Add(' i2: longint = 3;');
  2232. Add(' s2: string = ''foo'';');
  2233. Add(' c2: char = ''4'';');
  2234. Add(' b2: boolean = true;');
  2235. Add(' d2: double = 5.6;');
  2236. Add(' i3: longint = $707;');
  2237. Add(' i4: nativeint = 4503599627370495;');
  2238. Add(' i5: nativeint = -4503599627370495-1;');
  2239. Add(' i6: nativeint = $fffffffffffff;');
  2240. Add(' i7: nativeint = -$fffffffffffff-1;');
  2241. Add(' i8: byte = 00;');
  2242. Add(' u8: nativeuint = $fffffffffffff;');
  2243. Add(' u9: nativeuint = $0000000000000;');
  2244. Add(' u10: nativeuint = $00ff00;');
  2245. Add('begin');
  2246. ConvertProgram;
  2247. CheckSource('TestVarBaseTypes',
  2248. LinesToStr([
  2249. 'this.i = 0;',
  2250. 'this.s = "";',
  2251. 'this.c = "";',
  2252. 'this.b = false;',
  2253. 'this.d = 0.0;',
  2254. 'this.i2 = 3;',
  2255. 'this.s2 = "foo";',
  2256. 'this.c2 = "4";',
  2257. 'this.b2 = true;',
  2258. 'this.d2 = 5.6;',
  2259. 'this.i3 = 0x707;',
  2260. 'this.i4 = 4503599627370495;',
  2261. 'this.i5 = -4503599627370495-1;',
  2262. 'this.i6 = 0xfffffffffffff;',
  2263. 'this.i7 =-0xfffffffffffff-1;',
  2264. 'this.i8 = 0;',
  2265. 'this.u8 = 0xfffffffffffff;',
  2266. 'this.u9 = 0x0;',
  2267. 'this.u10 = 0xff00;'
  2268. ]),
  2269. '');
  2270. end;
  2271. procedure TTestModule.TestBaseTypeSingleFail;
  2272. begin
  2273. StartProgram(false);
  2274. Add('var s: single;');
  2275. SetExpectedPasResolverError('identifier not found "single"',PasResolveEval.nIdentifierNotFound);
  2276. ConvertProgram;
  2277. end;
  2278. procedure TTestModule.TestBaseTypeExtendedFail;
  2279. begin
  2280. StartProgram(false);
  2281. Add('var e: extended;');
  2282. SetExpectedPasResolverError('identifier not found "extended"',PasResolveEval.nIdentifierNotFound);
  2283. ConvertProgram;
  2284. end;
  2285. procedure TTestModule.TestConstBaseTypes;
  2286. begin
  2287. StartProgram(false);
  2288. Add('const');
  2289. Add(' i: longint = 3;');
  2290. Add(' s: string = ''foo'';');
  2291. Add(' c: char = ''4'';');
  2292. Add(' b: boolean = true;');
  2293. Add(' d: double = 5.6;');
  2294. Add(' e = low(word);');
  2295. Add(' f = high(word);');
  2296. Add('begin');
  2297. ConvertProgram;
  2298. CheckSource('TestVarBaseTypes',
  2299. LinesToStr([
  2300. 'this.i=3;',
  2301. 'this.s="foo";',
  2302. 'this.c="4";',
  2303. 'this.b=true;',
  2304. 'this.d=5.6;',
  2305. 'this.e = 0;',
  2306. 'this.f = 65535;'
  2307. ]),
  2308. '');
  2309. end;
  2310. procedure TTestModule.TestAliasTypeRef;
  2311. begin
  2312. StartProgram(false);
  2313. Add('type');
  2314. Add(' a=longint;');
  2315. Add(' b=a;');
  2316. Add('var');
  2317. Add(' c: A;');
  2318. Add(' d: B;');
  2319. Add('begin');
  2320. ConvertProgram;
  2321. CheckSource('TestAliasTypeRef',
  2322. LinesToStr([ // statements
  2323. 'this.c = 0;',
  2324. 'this.d = 0;'
  2325. ]),
  2326. LinesToStr([ // this.$main
  2327. ''
  2328. ]));
  2329. end;
  2330. procedure TTestModule.TestTypeCast_BaseTypes;
  2331. begin
  2332. StartProgram(false);
  2333. Add([
  2334. 'var',
  2335. ' i: longint;',
  2336. ' b: boolean;',
  2337. ' d: double;',
  2338. ' s: string;',
  2339. ' c: char;',
  2340. 'begin',
  2341. ' i:=longint(i);',
  2342. ' i:=longint(b);',
  2343. ' b:=boolean(b);',
  2344. ' b:=boolean(i);',
  2345. ' d:=double(d);',
  2346. ' d:=double(i);',
  2347. ' s:=string(s);',
  2348. ' s:=string(c);',
  2349. ' c:=char(c);',
  2350. ' c:=char(i);',
  2351. ' c:=char(65);',
  2352. ' c:=char(#10);',
  2353. ' c:=char(#$E000);',
  2354. '']);
  2355. ConvertProgram;
  2356. CheckSource('TestAliasTypeRef',
  2357. LinesToStr([ // statements
  2358. 'this.i = 0;',
  2359. 'this.b = false;',
  2360. 'this.d = 0.0;',
  2361. 'this.s = "";',
  2362. 'this.c = "";',
  2363. '']),
  2364. LinesToStr([ // this.$main
  2365. '$mod.i = $mod.i;',
  2366. '$mod.i = ($mod.b ? 1 : 0);',
  2367. '$mod.b = $mod.b;',
  2368. '$mod.b = $mod.i != 0;',
  2369. '$mod.d = $mod.d;',
  2370. '$mod.d = $mod.i;',
  2371. '$mod.s = $mod.s;',
  2372. '$mod.s = $mod.c;',
  2373. '$mod.c = $mod.c;',
  2374. '$mod.c = String.fromCharCode($mod.i);',
  2375. '$mod.c = "A";',
  2376. '$mod.c = "\n";',
  2377. '$mod.c = "";',
  2378. '']));
  2379. end;
  2380. procedure TTestModule.TestTypeCast_AliasBaseTypes;
  2381. begin
  2382. StartProgram(false);
  2383. Add('type');
  2384. Add(' integer = longint;');
  2385. Add(' TYesNo = boolean;');
  2386. Add(' TFloat = double;');
  2387. Add(' TCaption = string;');
  2388. Add(' TChar = char;');
  2389. Add('var');
  2390. Add(' i: integer;');
  2391. Add(' b: TYesNo;');
  2392. Add(' d: TFloat;');
  2393. Add(' s: TCaption;');
  2394. Add(' c: TChar;');
  2395. Add('begin');
  2396. Add(' i:=integer(i);');
  2397. Add(' i:=integer(b);');
  2398. Add(' b:=TYesNo(b);');
  2399. Add(' b:=TYesNo(i);');
  2400. Add(' d:=TFloat(d);');
  2401. Add(' d:=TFloat(i);');
  2402. Add(' s:=TCaption(s);');
  2403. Add(' s:=TCaption(c);');
  2404. Add(' c:=TChar(c);');
  2405. ConvertProgram;
  2406. CheckSource('TestAliasTypeRef',
  2407. LinesToStr([ // statements
  2408. 'this.i = 0;',
  2409. 'this.b = false;',
  2410. 'this.d = 0.0;',
  2411. 'this.s = "";',
  2412. 'this.c = "";',
  2413. '']),
  2414. LinesToStr([ // this.$main
  2415. '$mod.i = $mod.i;',
  2416. '$mod.i = ($mod.b ? 1 : 0);',
  2417. '$mod.b = $mod.b;',
  2418. '$mod.b = $mod.i != 0;',
  2419. '$mod.d = $mod.d;',
  2420. '$mod.d = $mod.i;',
  2421. '$mod.s = $mod.s;',
  2422. '$mod.s = $mod.c;',
  2423. '$mod.c = $mod.c;',
  2424. '']));
  2425. end;
  2426. procedure TTestModule.TestEmptyProc;
  2427. begin
  2428. StartProgram(false);
  2429. Add('procedure Test;');
  2430. Add('begin');
  2431. Add('end;');
  2432. Add('begin');
  2433. ConvertProgram;
  2434. CheckSource('TestEmptyProc',
  2435. LinesToStr([ // statements
  2436. 'this.Test = function () {',
  2437. '};'
  2438. ]),
  2439. LinesToStr([ // this.$main
  2440. ''
  2441. ]));
  2442. end;
  2443. procedure TTestModule.TestProcOneParam;
  2444. begin
  2445. StartProgram(false);
  2446. Add('procedure ProcA(i: longint);');
  2447. Add('begin');
  2448. Add('end;');
  2449. Add('begin');
  2450. Add(' PROCA(3);');
  2451. ConvertProgram;
  2452. CheckSource('TestProcOneParam',
  2453. LinesToStr([ // statements
  2454. 'this.ProcA = function (i) {',
  2455. '};'
  2456. ]),
  2457. LinesToStr([ // this.$main
  2458. '$mod.ProcA(3);'
  2459. ]));
  2460. end;
  2461. procedure TTestModule.TestFunctionWithoutParams;
  2462. begin
  2463. StartProgram(false);
  2464. Add('function FuncA: longint;');
  2465. Add('begin');
  2466. Add('end;');
  2467. Add('var i: longint;');
  2468. Add('begin');
  2469. Add(' I:=FUNCA();');
  2470. Add(' I:=FUNCA;');
  2471. Add(' FUNCA();');
  2472. Add(' FUNCA;');
  2473. ConvertProgram;
  2474. CheckSource('TestProcWithoutParams',
  2475. LinesToStr([ // statements
  2476. 'this.FuncA = function () {',
  2477. ' var Result = 0;',
  2478. ' return Result;',
  2479. '};',
  2480. 'this.i=0;'
  2481. ]),
  2482. LinesToStr([ // this.$main
  2483. '$mod.i=$mod.FuncA();',
  2484. '$mod.i=$mod.FuncA();',
  2485. '$mod.FuncA();',
  2486. '$mod.FuncA();'
  2487. ]));
  2488. end;
  2489. procedure TTestModule.TestProcedureWithoutParams;
  2490. begin
  2491. StartProgram(false);
  2492. Add('procedure ProcA;');
  2493. Add('begin');
  2494. Add('end;');
  2495. Add('begin');
  2496. Add(' PROCA();');
  2497. Add(' PROCA;');
  2498. ConvertProgram;
  2499. CheckSource('TestProcWithoutParams',
  2500. LinesToStr([ // statements
  2501. 'this.ProcA = function () {',
  2502. '};'
  2503. ]),
  2504. LinesToStr([ // this.$main
  2505. '$mod.ProcA();',
  2506. '$mod.ProcA();'
  2507. ]));
  2508. end;
  2509. procedure TTestModule.TestIncDec;
  2510. begin
  2511. StartProgram(false);
  2512. Add([
  2513. 'procedure DoIt(var i: longint);',
  2514. 'begin',
  2515. ' inc(i);',
  2516. ' inc(i,2);',
  2517. 'end;',
  2518. 'var',
  2519. ' Bar: longint;',
  2520. 'begin',
  2521. ' inc(bar);',
  2522. ' inc(bar,2);',
  2523. ' dec(bar);',
  2524. ' dec(bar,3);',
  2525. '']);
  2526. ConvertProgram;
  2527. CheckSource('TestIncDec',
  2528. LinesToStr([ // statements
  2529. 'this.DoIt = function (i) {',
  2530. ' i.set(i.get()+1);',
  2531. ' i.set(i.get()+2);',
  2532. '};',
  2533. 'this.Bar = 0;'
  2534. ]),
  2535. LinesToStr([ // this.$main
  2536. '$mod.Bar+=1;',
  2537. '$mod.Bar+=2;',
  2538. '$mod.Bar-=1;',
  2539. '$mod.Bar-=3;'
  2540. ]));
  2541. end;
  2542. procedure TTestModule.TestLoHiFpcMode;
  2543. begin
  2544. StartProgram(false);
  2545. Add([
  2546. '{$mode objfpc}',
  2547. 'const',
  2548. ' LoByte1 = Lo(Word($1234));',
  2549. ' HiByte1 = Hi(Word($1234));',
  2550. ' LoByte2 = Lo(SmallInt($1234));',
  2551. ' HiByte2 = Hi(SmallInt($1234));',
  2552. ' LoWord1 = Lo($1234CDEF);',
  2553. ' HiWord1 = Hi($1234CDEF);',
  2554. ' LoWord2 = Lo(-$1234CDEF);',
  2555. ' HiWord2 = Hi(-$1234CDEF);',
  2556. ' lo4:byte=lo(byte($34));',
  2557. ' hi4:byte=hi(byte($34));',
  2558. ' lo5:byte=lo(shortint(-$34));',
  2559. ' hi5:byte=hi(shortint(-$34));',
  2560. ' lo6:longword=lo($123456789ABCD);',
  2561. ' hi6:longword=hi($123456789ABCD);',
  2562. ' lo7:longword=lo(-$123456789ABCD);',
  2563. ' hi7:longword=hi(-$123456789ABCD);',
  2564. 'var',
  2565. ' b: Byte;',
  2566. ' ss: shortint;',
  2567. ' w: Word;',
  2568. ' si: SmallInt;',
  2569. ' lw: LongWord;',
  2570. ' li: LongInt;',
  2571. ' b2: Byte;',
  2572. ' ni: nativeint;',
  2573. 'begin',
  2574. ' w := $1234;',
  2575. ' ss := -$12;',
  2576. ' b := lo(ss);',
  2577. ' b := HI(ss);',
  2578. ' b := lo(w);',
  2579. ' b := HI(w);',
  2580. ' b2 := lo(b);',
  2581. ' b2 := hi(b);',
  2582. ' lw := $1234CDEF;',
  2583. ' w := lo(lw);',
  2584. ' w := hi(lw);',
  2585. ' ni := $123456789ABCD;',
  2586. ' lw := lo(ni);',
  2587. ' lw := hi(ni);',
  2588. '']);
  2589. ConvertProgram;
  2590. CheckSource('TestLoHiFpcMode',
  2591. LinesToStr([ // statements
  2592. 'this.LoByte1 = 0x1234 & 0xFF;',
  2593. 'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
  2594. 'this.LoByte2 = 0x1234 & 0xFF;',
  2595. 'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
  2596. 'this.LoWord1 = 0x1234CDEF & 0xFFFF;',
  2597. 'this.HiWord1 = (0x1234CDEF >> 16) & 0xFFFF;',
  2598. 'this.LoWord2 = -0x1234CDEF & 0xFFFF;',
  2599. 'this.HiWord2 = (-0x1234CDEF >> 16) & 0xFFFF;',
  2600. 'this.lo4 = 0x34 & 0xF;',
  2601. 'this.hi4 = (0x34 >> 4) & 0xF;',
  2602. 'this.lo5 = (((-0x34 & 255) << 24) >> 24) & 0xFF;',
  2603. 'this.hi5 = ((((-0x34 & 255) << 24) >> 24) >> 8) & 0xFF;',
  2604. 'this.lo6 = 0x123456789ABCD >>> 0;',
  2605. 'this.hi6 = 74565 >>> 0;',
  2606. 'this.lo7 = -0x123456789ABCD >>> 0;',
  2607. 'this.hi7 = Math.floor(-0x123456789ABCD / 4294967296) >>> 0;',
  2608. 'this.b = 0;',
  2609. 'this.ss = 0;',
  2610. 'this.w = 0;',
  2611. 'this.si = 0;',
  2612. 'this.lw = 0;',
  2613. 'this.li = 0;',
  2614. 'this.b2 = 0;',
  2615. 'this.ni = 0;',
  2616. '']),
  2617. LinesToStr([ // this.$main
  2618. '$mod.w = 0x1234;',
  2619. '$mod.ss = -0x12;',
  2620. '$mod.b = $mod.ss & 0xFF;',
  2621. '$mod.b = ($mod.ss >> 8) & 0xFF;',
  2622. '$mod.b = $mod.w & 0xFF;',
  2623. '$mod.b = ($mod.w >> 8) & 0xFF;',
  2624. '$mod.b2 = $mod.b & 0xF;',
  2625. '$mod.b2 = ($mod.b >> 4) & 0xF;',
  2626. '$mod.lw = 0x1234CDEF;',
  2627. '$mod.w = $mod.lw & 0xFFFF;',
  2628. '$mod.w = ($mod.lw >> 16) & 0xFFFF;',
  2629. '$mod.ni = 0x123456789ABCD;',
  2630. '$mod.lw = $mod.ni >>> 0;',
  2631. '$mod.lw = Math.floor($mod.ni / 4294967296) >>> 0;',
  2632. '']));
  2633. end;
  2634. procedure TTestModule.TestLoHiDelphiMode;
  2635. begin
  2636. StartProgram(false);
  2637. Add([
  2638. '{$mode delphi}',
  2639. 'const',
  2640. ' LoByte1 = Lo(Word($1234));',
  2641. ' HiByte1 = Hi(Word($1234));',
  2642. ' LoByte2 = Lo(SmallInt($1234));',
  2643. ' HiByte2 = Hi(SmallInt($1234));',
  2644. ' LoByte3 = Lo($1234CDEF);',
  2645. ' HiByte3 = Hi($1234CDEF);',
  2646. ' LoByte4 = Lo(-$1234CDEF);',
  2647. ' HiByte4 = Hi(-$1234CDEF);',
  2648. 'var',
  2649. ' b: Byte;',
  2650. ' w: Word;',
  2651. ' si: SmallInt;',
  2652. ' lw: LongWord;',
  2653. ' li: LongInt;',
  2654. 'begin',
  2655. ' w := $1234;',
  2656. ' b := lo(w);',
  2657. ' b := HI(w);',
  2658. ' lw := $1234CDEF;',
  2659. ' b := lo(lw);',
  2660. ' b := hi(lw);',
  2661. '']);
  2662. ConvertProgram;
  2663. CheckSource('TestLoHiDelphiMode',
  2664. LinesToStr([ // statements
  2665. 'this.LoByte1 = 0x1234 & 0xFF;',
  2666. 'this.HiByte1 = (0x1234 >> 8) & 0xFF;',
  2667. 'this.LoByte2 = 0x1234 & 0xFF;',
  2668. 'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
  2669. 'this.LoByte3 = 0x1234CDEF & 0xFF;',
  2670. 'this.HiByte3 = (0x1234CDEF >> 8) & 0xFF;',
  2671. 'this.LoByte4 = -0x1234CDEF & 0xFF;',
  2672. 'this.HiByte4 = (-0x1234CDEF >> 8) & 0xFF;',
  2673. 'this.b = 0;',
  2674. 'this.w = 0;',
  2675. 'this.si = 0;',
  2676. 'this.lw = 0;',
  2677. 'this.li = 0;'
  2678. ]),
  2679. LinesToStr([ // this.$main
  2680. '$mod.w = 0x1234;',
  2681. '$mod.b = $mod.w & 0xFF;',
  2682. '$mod.b = ($mod.w >> 8) & 0xFF;',
  2683. '$mod.lw = 0x1234CDEF;',
  2684. '$mod.b = $mod.lw & 0xFF;',
  2685. '$mod.b = ($mod.lw >> 8) & 0xFF;'
  2686. ]));
  2687. end;
  2688. procedure TTestModule.TestAssignments;
  2689. begin
  2690. StartProgram(false);
  2691. Parser.Options:=Parser.Options+[po_cassignments];
  2692. Add('var');
  2693. Add(' Bar:longint;');
  2694. Add('begin');
  2695. Add(' bar:=3;');
  2696. Add(' bar+=4;');
  2697. Add(' bar-=5;');
  2698. Add(' bar*=6;');
  2699. ConvertProgram;
  2700. CheckSource('TestAssignments',
  2701. LinesToStr([ // statements
  2702. 'this.Bar = 0;'
  2703. ]),
  2704. LinesToStr([ // this.$main
  2705. '$mod.Bar=3;',
  2706. '$mod.Bar+=4;',
  2707. '$mod.Bar-=5;',
  2708. '$mod.Bar*=6;'
  2709. ]));
  2710. end;
  2711. procedure TTestModule.TestArithmeticOperators1;
  2712. begin
  2713. StartProgram(false);
  2714. Add('var');
  2715. Add(' vA,vB,vC:longint;');
  2716. Add('begin');
  2717. Add(' va:=1;');
  2718. Add(' vb:=va+va;');
  2719. Add(' vb:=va div vb;');
  2720. Add(' vb:=va mod vb;');
  2721. Add(' vb:=va+va*vb+va div vb;');
  2722. Add(' vc:=-va;');
  2723. Add(' va:=va-vb;');
  2724. Add(' vb:=va;');
  2725. Add(' if va<vb then vc:=va else vc:=vb;');
  2726. ConvertProgram;
  2727. CheckSource('TestArithmeticOperators1',
  2728. LinesToStr([ // statements
  2729. 'this.vA = 0;',
  2730. 'this.vB = 0;',
  2731. 'this.vC = 0;'
  2732. ]),
  2733. LinesToStr([ // this.$main
  2734. '$mod.vA = 1;',
  2735. '$mod.vB = $mod.vA + $mod.vA;',
  2736. '$mod.vB = Math.floor($mod.vA / $mod.vB);',
  2737. '$mod.vB = $mod.vA % $mod.vB;',
  2738. '$mod.vB = $mod.vA + ($mod.vA * $mod.vB) + Math.floor($mod.vA / $mod.vB);',
  2739. '$mod.vC = -$mod.vA;',
  2740. '$mod.vA = $mod.vA - $mod.vB;',
  2741. '$mod.vB = $mod.vA;',
  2742. 'if ($mod.vA < $mod.vB){ $mod.vC = $mod.vA } else $mod.vC = $mod.vB;'
  2743. ]));
  2744. end;
  2745. procedure TTestModule.TestLogicalOperators;
  2746. begin
  2747. StartProgram(false);
  2748. Add('var');
  2749. Add(' vA,vB,vC:boolean;');
  2750. Add('begin');
  2751. Add(' va:=vb and vc;');
  2752. Add(' va:=vb or vc;');
  2753. Add(' va:=vb xor vc;');
  2754. Add(' va:=true and vc;');
  2755. Add(' va:=(vb and vc) or (va and vb);');
  2756. Add(' va:=not vb;');
  2757. ConvertProgram;
  2758. CheckSource('TestLogicalOperators',
  2759. LinesToStr([ // statements
  2760. 'this.vA = false;',
  2761. 'this.vB = false;',
  2762. 'this.vC = false;'
  2763. ]),
  2764. LinesToStr([ // this.$main
  2765. '$mod.vA = $mod.vB && $mod.vC;',
  2766. '$mod.vA = $mod.vB || $mod.vC;',
  2767. '$mod.vA = $mod.vB ^ $mod.vC;',
  2768. '$mod.vA = true && $mod.vC;',
  2769. '$mod.vA = ($mod.vB && $mod.vC) || ($mod.vA && $mod.vB);',
  2770. '$mod.vA = !$mod.vB;'
  2771. ]));
  2772. end;
  2773. procedure TTestModule.TestBitwiseOperators;
  2774. begin
  2775. StartProgram(false);
  2776. Add('var');
  2777. Add(' vA,vB,vC:longint;');
  2778. Add('begin');
  2779. Add(' va:=vb and vc;');
  2780. Add(' va:=vb or vc;');
  2781. Add(' va:=vb xor vc;');
  2782. Add(' va:=vb shl vc;');
  2783. Add(' va:=vb shr vc;');
  2784. Add(' va:=3 and vc;');
  2785. Add(' va:=(vb and vc) or (va and vb);');
  2786. Add(' va:=not vb;');
  2787. ConvertProgram;
  2788. CheckSource('TestBitwiseOperators',
  2789. LinesToStr([ // statements
  2790. 'this.vA = 0;',
  2791. 'this.vB = 0;',
  2792. 'this.vC = 0;'
  2793. ]),
  2794. LinesToStr([ // this.$main
  2795. '$mod.vA = $mod.vB & $mod.vC;',
  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 = 3 & $mod.vC;',
  2801. '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
  2802. '$mod.vA = ~$mod.vB;'
  2803. ]));
  2804. end;
  2805. procedure TTestModule.TestPrgProcVar;
  2806. begin
  2807. StartProgram(false);
  2808. Add('procedure Proc1;');
  2809. Add('type');
  2810. Add(' t1=longint;');
  2811. Add('var');
  2812. Add(' vA:t1;');
  2813. Add('begin');
  2814. Add('end;');
  2815. Add('begin');
  2816. ConvertProgram;
  2817. CheckSource('TestPrgProcVar',
  2818. LinesToStr([ // statements
  2819. 'this.Proc1 = function () {',
  2820. ' var vA=0;',
  2821. '};'
  2822. ]),
  2823. LinesToStr([ // this.$main
  2824. ''
  2825. ]));
  2826. end;
  2827. procedure TTestModule.TestUnitProcVar;
  2828. begin
  2829. StartUnit(false);
  2830. Add('interface');
  2831. Add('');
  2832. Add('type tA=string; // unit scope');
  2833. Add('procedure Proc1;');
  2834. Add('');
  2835. Add('implementation');
  2836. Add('');
  2837. Add('procedure Proc1;');
  2838. Add('type tA=longint; // local proc scope');
  2839. Add('var v1:tA; // using local tA');
  2840. Add('begin');
  2841. Add('end;');
  2842. Add('var v2:tA; // using interface tA');
  2843. ConvertUnit;
  2844. CheckSource('TestUnitProcVar',
  2845. LinesToStr([ // statements
  2846. 'var $impl = $mod.$impl;',
  2847. 'this.Proc1 = function () {',
  2848. ' var v1 = 0;',
  2849. '};',
  2850. '']),
  2851. // this.$init
  2852. '',
  2853. // implementation
  2854. LinesToStr([
  2855. '$impl.v2 = "";',
  2856. '']));
  2857. end;
  2858. procedure TTestModule.TestImplProc;
  2859. begin
  2860. StartUnit(false);
  2861. Add('interface');
  2862. Add('');
  2863. Add('procedure Proc1;');
  2864. Add('');
  2865. Add('implementation');
  2866. Add('');
  2867. Add('procedure Proc1; begin end;');
  2868. Add('procedure Proc2; begin end;');
  2869. Add('initialization');
  2870. Add(' Proc1;');
  2871. Add(' Proc2;');
  2872. ConvertUnit;
  2873. CheckSource('TestImplProc',
  2874. LinesToStr([ // statements
  2875. 'var $impl = $mod.$impl;',
  2876. 'this.Proc1 = function () {',
  2877. '};',
  2878. '']),
  2879. LinesToStr([ // this.$init
  2880. '$mod.Proc1();',
  2881. '$impl.Proc2();',
  2882. '']),
  2883. LinesToStr([ // implementation
  2884. '$impl.Proc2 = function () {',
  2885. '};',
  2886. ''])
  2887. );
  2888. end;
  2889. procedure TTestModule.TestFunctionResult;
  2890. begin
  2891. StartProgram(false);
  2892. Add('function Func1: longint;');
  2893. Add('begin');
  2894. Add(' Result:=3;');
  2895. Add(' Func1:=4;');
  2896. Add('end;');
  2897. Add('begin');
  2898. ConvertProgram;
  2899. CheckSource('TestFunctionResult',
  2900. LinesToStr([ // statements
  2901. 'this.Func1 = function () {',
  2902. ' var Result = 0;',
  2903. ' Result = 3;',
  2904. ' Result = 4;',
  2905. ' return Result;',
  2906. '};'
  2907. ]),
  2908. '');
  2909. end;
  2910. procedure TTestModule.TestNestedProc;
  2911. begin
  2912. StartProgram(false);
  2913. Add([
  2914. 'var vInUnit: longint;',
  2915. 'function DoIt(pA,pD: longint): longint;',
  2916. 'var',
  2917. ' vB: longint;',
  2918. ' vC: longint;',
  2919. ' function Nesty(pA: longint): longint; ',
  2920. ' var vB: longint;',
  2921. ' begin',
  2922. ' Result:=pa+vb+vc+pd+vInUnit;',
  2923. ' nesty:=3;',
  2924. ' doit:=4;',
  2925. ' exit;',
  2926. ' end;',
  2927. 'begin',
  2928. ' Result:=pa+vb+vc;',
  2929. ' doit:=6;',
  2930. ' exit;',
  2931. 'end;',
  2932. 'begin']);
  2933. ConvertProgram;
  2934. CheckSource('TestNestedProc',
  2935. LinesToStr([ // statements
  2936. 'this.vInUnit = 0;',
  2937. 'this.DoIt = function (pA, pD) {',
  2938. ' var Result = 0;',
  2939. ' var vB = 0;',
  2940. ' var vC = 0;',
  2941. ' function Nesty(pA) {',
  2942. ' var Result$1 = 0;',
  2943. ' var vB = 0;',
  2944. ' Result$1 = pA + vB + vC + pD + $mod.vInUnit;',
  2945. ' Result$1 = 3;',
  2946. ' Result = 4;',
  2947. ' return Result$1;',
  2948. ' return Result$1;',
  2949. ' };',
  2950. ' Result = pA + vB + vC;',
  2951. ' Result = 6;',
  2952. ' return Result;',
  2953. ' return Result;',
  2954. '};'
  2955. ]),
  2956. '');
  2957. end;
  2958. procedure TTestModule.TestNestedProc_ResultString;
  2959. begin
  2960. StartProgram(false);
  2961. Add([
  2962. 'function DoIt: string;',
  2963. ' function Nesty: string; ',
  2964. ' begin',
  2965. ' nesty:=#65#66;',
  2966. ' nesty[1]:=#67;',
  2967. ' doit:=#68;',
  2968. ' doit[2]:=#69;',
  2969. ' end;',
  2970. 'begin',
  2971. ' doit:=#70;',
  2972. ' doit[3]:=#71;',
  2973. 'end;',
  2974. 'begin']);
  2975. ConvertProgram;
  2976. CheckSource('TestNestedProc_ResultString',
  2977. LinesToStr([ // statements
  2978. 'this.DoIt = function () {',
  2979. ' var Result = "";',
  2980. ' function Nesty() {',
  2981. ' var Result$1 = "";',
  2982. ' Result$1 = "AB";',
  2983. ' Result$1 = rtl.setCharAt(Result$1, 0, "C");',
  2984. ' Result = "D";',
  2985. ' Result = rtl.setCharAt(Result, 1, "E");',
  2986. ' return Result$1;',
  2987. ' };',
  2988. ' Result = "F";',
  2989. ' Result = rtl.setCharAt(Result, 2, "G");',
  2990. ' return Result;',
  2991. '};'
  2992. ]),
  2993. '');
  2994. end;
  2995. procedure TTestModule.TestForwardProc;
  2996. begin
  2997. StartProgram(false);
  2998. Add('procedure FuncA(Bar: longint); forward;');
  2999. Add('procedure FuncB(Bar: longint);');
  3000. Add('begin');
  3001. Add(' funca(bar);');
  3002. Add('end;');
  3003. Add('procedure funca(bar: longint);');
  3004. Add('begin');
  3005. Add(' if bar=3 then ;');
  3006. Add('end;');
  3007. Add('begin');
  3008. Add(' funca(4);');
  3009. Add(' funcb(5);');
  3010. ConvertProgram;
  3011. CheckSource('TestForwardProc',
  3012. LinesToStr([ // statements'
  3013. 'this.FuncB = function (Bar) {',
  3014. ' $mod.FuncA(Bar);',
  3015. '};',
  3016. 'this.FuncA = function (Bar) {',
  3017. ' if (Bar === 3);',
  3018. '};'
  3019. ]),
  3020. LinesToStr([
  3021. '$mod.FuncA(4);',
  3022. '$mod.FuncB(5);'
  3023. ])
  3024. );
  3025. end;
  3026. procedure TTestModule.TestNestedForwardProc;
  3027. begin
  3028. StartProgram(false);
  3029. Add('procedure FuncA;');
  3030. Add(' procedure FuncB(i: longint); forward;');
  3031. Add(' procedure FuncC(i: longint);');
  3032. Add(' begin');
  3033. Add(' funcb(i);');
  3034. Add(' end;');
  3035. Add(' procedure FuncB(i: longint);');
  3036. Add(' begin');
  3037. Add(' if i=3 then ;');
  3038. Add(' end;');
  3039. Add('begin');
  3040. Add(' funcc(4)');
  3041. Add('end;');
  3042. Add('begin');
  3043. Add(' funca;');
  3044. ConvertProgram;
  3045. CheckSource('TestNestedForwardProc',
  3046. LinesToStr([ // statements'
  3047. 'this.FuncA = function () {',
  3048. ' function FuncC(i) {',
  3049. ' FuncB(i);',
  3050. ' };',
  3051. ' function FuncB(i) {',
  3052. ' if (i === 3);',
  3053. ' };',
  3054. ' FuncC(4);',
  3055. '};'
  3056. ]),
  3057. LinesToStr([
  3058. '$mod.FuncA();'
  3059. ])
  3060. );
  3061. end;
  3062. procedure TTestModule.TestAssignFunctionResult;
  3063. begin
  3064. StartProgram(false);
  3065. Add('function Func1: longint;');
  3066. Add('begin');
  3067. Add('end;');
  3068. Add('var i: longint;');
  3069. Add('begin');
  3070. Add(' i:=func1();');
  3071. Add(' i:=func1()+func1();');
  3072. ConvertProgram;
  3073. CheckSource('TestAssignFunctionResult',
  3074. LinesToStr([ // statements
  3075. 'this.Func1 = function () {',
  3076. ' var Result = 0;',
  3077. ' return Result;',
  3078. '};',
  3079. 'this.i = 0;'
  3080. ]),
  3081. LinesToStr([
  3082. '$mod.i = $mod.Func1();',
  3083. '$mod.i = $mod.Func1() + $mod.Func1();'
  3084. ]));
  3085. end;
  3086. procedure TTestModule.TestFunctionResultInCondition;
  3087. begin
  3088. StartProgram(false);
  3089. Add('function Func1: longint;');
  3090. Add('begin');
  3091. Add('end;');
  3092. Add('function Func2: boolean;');
  3093. Add('begin');
  3094. Add('end;');
  3095. Add('var i: longint;');
  3096. Add('begin');
  3097. Add(' if func2 then ;');
  3098. Add(' if i=func1() then ;');
  3099. Add(' if i=func1 then ;');
  3100. ConvertProgram;
  3101. CheckSource('TestFunctionResultInCondition',
  3102. LinesToStr([ // statements
  3103. 'this.Func1 = function () {',
  3104. ' var Result = 0;',
  3105. ' return Result;',
  3106. '};',
  3107. 'this.Func2 = function () {',
  3108. ' var Result = false;',
  3109. ' return Result;',
  3110. '};',
  3111. 'this.i = 0;'
  3112. ]),
  3113. LinesToStr([
  3114. 'if ($mod.Func2());',
  3115. 'if ($mod.i === $mod.Func1());',
  3116. 'if ($mod.i === $mod.Func1());'
  3117. ]));
  3118. end;
  3119. procedure TTestModule.TestFunctionResultInForLoop;
  3120. begin
  3121. StartProgram(false);
  3122. Add([
  3123. 'function Func1(a: array of longint): longint;',
  3124. 'begin',
  3125. ' for Result:=High(a) downto Low(a) do if a[Result]=0 then exit;',
  3126. ' for Result in a do if a[Result]=0 then exit;',
  3127. 'end;',
  3128. 'begin',
  3129. ' Func1([1,2,3])']);
  3130. ConvertProgram;
  3131. CheckSource('TestFunctionResultInForLoop',
  3132. LinesToStr([ // statements
  3133. 'this.Func1 = function (a) {',
  3134. ' var Result = 0;',
  3135. ' for (var $l1 = rtl.length(a) - 1; $l1 >= 0; $l1--) {',
  3136. ' Result = $l1;',
  3137. ' if (a[Result] === 0) return Result;',
  3138. ' };',
  3139. ' for (var $in2 = a, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) {',
  3140. ' Result = $in2[$l3];',
  3141. ' if (a[Result] === 0) return Result;',
  3142. ' };',
  3143. ' return Result;',
  3144. '};',
  3145. '']),
  3146. LinesToStr([
  3147. '$mod.Func1([1, 2, 3]);'
  3148. ]));
  3149. end;
  3150. procedure TTestModule.TestFunctionResultInTypeCast;
  3151. begin
  3152. StartProgram(false);
  3153. Add([
  3154. 'function GetInt: longint;',
  3155. 'begin',
  3156. 'end;',
  3157. 'begin',
  3158. ' if Byte(GetInt)=0 then ;',
  3159. '']);
  3160. ConvertProgram;
  3161. CheckSource('TestFunctionResultInTypeCast',
  3162. LinesToStr([ // statements
  3163. 'this.GetInt = function () {',
  3164. ' var Result = 0;',
  3165. ' return Result;',
  3166. '};',
  3167. '']),
  3168. LinesToStr([
  3169. 'if (($mod.GetInt() & 255) === 0) ;'
  3170. ]));
  3171. end;
  3172. procedure TTestModule.TestExit;
  3173. begin
  3174. StartProgram(false);
  3175. Add('procedure ProcA;');
  3176. Add('begin');
  3177. Add(' exit;');
  3178. Add('end;');
  3179. Add('function FuncB: longint;');
  3180. Add('begin');
  3181. Add(' exit;');
  3182. Add(' exit(3);');
  3183. Add('end;');
  3184. Add('function FuncC: string;');
  3185. Add('begin');
  3186. Add(' exit;');
  3187. Add(' exit(''a'');');
  3188. Add(' exit(''abc'');');
  3189. Add('end;');
  3190. Add('begin');
  3191. Add(' exit;');
  3192. Add(' exit(1);');
  3193. ConvertProgram;
  3194. CheckSource('TestExit',
  3195. LinesToStr([ // statements
  3196. 'this.ProcA = function () {',
  3197. ' return;',
  3198. '};',
  3199. 'this.FuncB = function () {',
  3200. ' var Result = 0;',
  3201. ' return Result;',
  3202. ' return 3;',
  3203. ' return Result;',
  3204. '};',
  3205. 'this.FuncC = function () {',
  3206. ' var Result = "";',
  3207. ' return Result;',
  3208. ' return "a";',
  3209. ' return "abc";',
  3210. ' return Result;',
  3211. '};'
  3212. ]),
  3213. LinesToStr([
  3214. 'return;',
  3215. 'return 1;',
  3216. '']));
  3217. end;
  3218. procedure TTestModule.TestBreak;
  3219. begin
  3220. StartProgram(false);
  3221. Add([
  3222. 'var',
  3223. ' i: longint;',
  3224. 'begin',
  3225. ' repeat',
  3226. ' break;',
  3227. ' until true;',
  3228. ' while true do',
  3229. ' break;',
  3230. ' for i:=1 to 2 do',
  3231. ' break;']);
  3232. ConvertProgram;
  3233. CheckSource('TestBreak',
  3234. LinesToStr([ // statements
  3235. 'this.i = 0;'
  3236. ]),
  3237. LinesToStr([
  3238. 'do {',
  3239. ' break;',
  3240. '} while (!true);',
  3241. 'while (true) break;',
  3242. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) break;',
  3243. '']));
  3244. end;
  3245. procedure TTestModule.TestBreakAsVar;
  3246. begin
  3247. StartProgram(false);
  3248. Add([
  3249. 'procedure DoIt(break: boolean);',
  3250. 'begin',
  3251. ' if break then ;',
  3252. 'end;',
  3253. 'var',
  3254. ' break: boolean;',
  3255. 'begin',
  3256. ' if break then ;']);
  3257. ConvertProgram;
  3258. CheckSource('TestBreakAsVar',
  3259. LinesToStr([ // statements
  3260. 'this.DoIt = function (Break) {',
  3261. ' if (Break) ;',
  3262. '};',
  3263. 'this.Break = false;',
  3264. '']),
  3265. LinesToStr([
  3266. 'if($mod.Break) ;',
  3267. '']));
  3268. end;
  3269. procedure TTestModule.TestContinue;
  3270. begin
  3271. StartProgram(false);
  3272. Add('var i: longint;');
  3273. Add('begin');
  3274. Add(' repeat');
  3275. Add(' continue;');
  3276. Add(' until true;');
  3277. Add(' while true do');
  3278. Add(' continue;');
  3279. Add(' for i:=1 to 2 do');
  3280. Add(' continue;');
  3281. ConvertProgram;
  3282. CheckSource('TestContinue',
  3283. LinesToStr([ // statements
  3284. 'this.i = 0;'
  3285. ]),
  3286. LinesToStr([
  3287. 'do {',
  3288. ' continue;',
  3289. '} while (!true);',
  3290. 'while (true) continue;',
  3291. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) continue;',
  3292. '']));
  3293. end;
  3294. procedure TTestModule.TestProc_External;
  3295. begin
  3296. StartProgram(false);
  3297. Add('procedure Foo; external name ''console.log'';');
  3298. Add('function Bar: longint; external name ''get.item'';');
  3299. Add('function Bla(s: string): longint; external name ''apply.something'';');
  3300. Add('var');
  3301. Add(' i: longint;');
  3302. Add('begin');
  3303. Add(' Foo;');
  3304. Add(' i:=Bar;');
  3305. Add(' i:=Bla(''abc'');');
  3306. ConvertProgram;
  3307. CheckSource('TestProc_External',
  3308. LinesToStr([ // statements
  3309. 'this.i = 0;'
  3310. ]),
  3311. LinesToStr([
  3312. 'console.log();',
  3313. '$mod.i = get.item();',
  3314. '$mod.i = apply.something("abc");'
  3315. ]));
  3316. end;
  3317. procedure TTestModule.TestProc_ExternalOtherUnit;
  3318. begin
  3319. AddModuleWithIntfImplSrc('unit2.pas',
  3320. LinesToStr([
  3321. 'procedure Now; external name ''Date.now'';',
  3322. 'procedure DoIt;'
  3323. ]),
  3324. 'procedure doit; begin end;');
  3325. StartUnit(true);
  3326. Add('interface');
  3327. Add('uses unit2;');
  3328. Add('implementation');
  3329. Add('begin');
  3330. Add(' now;');
  3331. Add(' now();');
  3332. Add(' uNit2.now;');
  3333. Add(' uNit2.now();');
  3334. Add(' doit;');
  3335. Add(' uNit2.doit;');
  3336. ConvertUnit;
  3337. CheckSource('TestProc_ExternalOtherUnit',
  3338. LinesToStr([
  3339. '']),
  3340. LinesToStr([
  3341. 'Date.now();',
  3342. 'Date.now();',
  3343. 'Date.now();',
  3344. 'Date.now();',
  3345. 'pas.unit2.DoIt();',
  3346. 'pas.unit2.DoIt();',
  3347. '']));
  3348. end;
  3349. procedure TTestModule.TestProc_Asm;
  3350. begin
  3351. StartProgram(false);
  3352. Add([
  3353. 'function DoIt: longint;',
  3354. 'begin;',
  3355. ' asm',
  3356. ' { a:{ b:{}, c:[]}, d:''1'' };',
  3357. ' end;',
  3358. ' asm console.log(); end;',
  3359. ' asm',
  3360. ' s = "'' ";',
  3361. ' s = ''" '';',
  3362. ' s = s + "world" + "''";',
  3363. ' // end',
  3364. ' s = ''end'';',
  3365. ' s = "end";',
  3366. ' end;',
  3367. 'end;',
  3368. 'begin']);
  3369. ConvertProgram;
  3370. CheckSource('TestProc_Asm',
  3371. LinesToStr([ // statements
  3372. 'this.DoIt = function () {',
  3373. ' var Result = 0;',
  3374. ' { a:{ b:{}, c:[]}, d:''1'' };',
  3375. ' console.log();',
  3376. ' s = "'' ";',
  3377. ' s = ''" '';',
  3378. ' s = s + "world" + "''";',
  3379. ' // end',
  3380. ' s = ''end'';',
  3381. ' s = "end";',
  3382. ' return Result;',
  3383. '};'
  3384. ]),
  3385. LinesToStr([
  3386. ''
  3387. ]));
  3388. end;
  3389. procedure TTestModule.TestProc_Assembler;
  3390. begin
  3391. StartProgram(false);
  3392. Add('function DoIt: longint; assembler;');
  3393. Add('asm');
  3394. Add('{ a:{ b:{}, c:[]}, d:''1'' };');
  3395. Add('end;');
  3396. Add('begin');
  3397. ConvertProgram;
  3398. CheckSource('TestProc_Assembler',
  3399. LinesToStr([ // statements
  3400. 'this.DoIt = function () {',
  3401. ' { a:{ b:{}, c:[]}, d:''1'' };',
  3402. '};'
  3403. ]),
  3404. LinesToStr([
  3405. ''
  3406. ]));
  3407. end;
  3408. procedure TTestModule.TestProc_VarParam;
  3409. begin
  3410. StartProgram(false);
  3411. Add('type integer = longint;');
  3412. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  3413. Add('var vJ: integer;');
  3414. Add('begin');
  3415. Add(' vg:=vg+1;');
  3416. Add(' vj:=vh+2;');
  3417. Add(' vi:=vi+3;');
  3418. Add(' doit(vg,vg,vg);');
  3419. Add(' doit(vh,vh,vj);');
  3420. Add(' doit(vi,vi,vi);');
  3421. Add(' doit(vj,vj,vj);');
  3422. Add('end;');
  3423. Add('var i: integer;');
  3424. Add('begin');
  3425. Add(' doit(i,i,i);');
  3426. ConvertProgram;
  3427. CheckSource('TestProc_VarParam',
  3428. LinesToStr([ // statements
  3429. 'this.DoIt = function (vG,vH,vI) {',
  3430. ' var vJ = 0;',
  3431. ' vG = vG + 1;',
  3432. ' vJ = vH + 2;',
  3433. ' vI.set(vI.get()+3);',
  3434. ' $mod.DoIt(vG, vG, {',
  3435. ' get: function () {',
  3436. ' return vG;',
  3437. ' },',
  3438. ' set: function (v) {',
  3439. ' vG = v;',
  3440. ' }',
  3441. ' });',
  3442. ' $mod.DoIt(vH, vH, {',
  3443. ' get: function () {',
  3444. ' return vJ;',
  3445. ' },',
  3446. ' set: function (v) {',
  3447. ' vJ = v;',
  3448. ' }',
  3449. ' });',
  3450. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  3451. ' $mod.DoIt(vJ, vJ, {',
  3452. ' get: function () {',
  3453. ' return vJ;',
  3454. ' },',
  3455. ' set: function (v) {',
  3456. ' vJ = v;',
  3457. ' }',
  3458. ' });',
  3459. '};',
  3460. 'this.i = 0;'
  3461. ]),
  3462. LinesToStr([
  3463. '$mod.DoIt($mod.i,$mod.i,{',
  3464. ' p: $mod,',
  3465. ' get: function () {',
  3466. ' return this.p.i;',
  3467. ' },',
  3468. ' set: function (v) {',
  3469. ' this.p.i = v;',
  3470. ' }',
  3471. '});'
  3472. ]));
  3473. end;
  3474. procedure TTestModule.TestProc_VarParamString;
  3475. begin
  3476. StartProgram(false);
  3477. Add(['type TCaption = string;',
  3478. 'procedure DoIt(vA: TCaption; var vB: TCaption; out vC: TCaption);',
  3479. 'var c: char;',
  3480. 'begin',
  3481. ' va[1]:=c;',
  3482. ' vb[2]:=c;',
  3483. ' vc[3]:=c;',
  3484. 'end;',
  3485. 'begin']);
  3486. ConvertProgram;
  3487. CheckSource('TestProc_VarParamString',
  3488. LinesToStr([ // statements
  3489. 'this.DoIt = function (vA,vB,vC) {',
  3490. ' var c = "";',
  3491. ' vA = rtl.setCharAt(vA, 0, c);',
  3492. ' vB.set(rtl.setCharAt(vB.get(), 1, c));',
  3493. ' vC.set(rtl.setCharAt(vC.get(), 2, c));',
  3494. '};',
  3495. '']),
  3496. LinesToStr([
  3497. ]));
  3498. end;
  3499. procedure TTestModule.TestProc_VarParamV;
  3500. begin
  3501. StartProgram(false);
  3502. Add([
  3503. 'procedure Inc2(var i: longint);',
  3504. 'begin',
  3505. ' i:=i+2;',
  3506. 'end;',
  3507. 'procedure DoIt(v: longint);',
  3508. 'var p: array of longint;',
  3509. 'begin',
  3510. ' Inc2(v);',
  3511. ' Inc2(p[v]);',
  3512. 'end;',
  3513. 'begin']);
  3514. ConvertProgram;
  3515. CheckSource('TestProc_VarParamV',
  3516. LinesToStr([ // statements
  3517. 'this.Inc2 = function (i) {',
  3518. ' i.set(i.get()+2);',
  3519. '};',
  3520. 'this.DoIt = function (v) {',
  3521. ' var p = [];',
  3522. ' $mod.Inc2({get: function () {',
  3523. ' return v;',
  3524. ' }, set: function (w) {',
  3525. ' v = w;',
  3526. ' }});',
  3527. ' $mod.Inc2({',
  3528. ' a: v,',
  3529. ' p: p,',
  3530. ' get: function () {',
  3531. ' return this.p[this.a];',
  3532. ' },',
  3533. ' set: function (v) {',
  3534. ' this.p[this.a] = v;',
  3535. ' }',
  3536. ' });',
  3537. '};',
  3538. '']),
  3539. LinesToStr([
  3540. '']));
  3541. end;
  3542. procedure TTestModule.TestProc_Overload;
  3543. begin
  3544. StartProgram(false);
  3545. Add('procedure DoIt(vI: longint); begin end;');
  3546. Add('procedure DoIt(vI, vJ: longint); begin end;');
  3547. Add('procedure DoIt(vD: double); begin end;');
  3548. Add('begin');
  3549. Add(' DoIt(1);');
  3550. Add(' DoIt(2,3);');
  3551. Add(' DoIt(4.5);');
  3552. ConvertProgram;
  3553. CheckSource('TestProcedureOverload',
  3554. LinesToStr([ // statements
  3555. 'this.DoIt = function (vI) {',
  3556. '};',
  3557. 'this.DoIt$1 = function (vI, vJ) {',
  3558. '};',
  3559. 'this.DoIt$2 = function (vD) {',
  3560. '};',
  3561. '']),
  3562. LinesToStr([
  3563. '$mod.DoIt(1);',
  3564. '$mod.DoIt$1(2, 3);',
  3565. '$mod.DoIt$2(4.5);',
  3566. '']));
  3567. end;
  3568. procedure TTestModule.TestProc_OverloadForward;
  3569. begin
  3570. StartProgram(false);
  3571. Add('procedure DoIt(vI: longint); forward;');
  3572. Add('procedure DoIt(vI, vJ: longint); begin end;');
  3573. Add('procedure doit(vi: longint); begin end;');
  3574. Add('begin');
  3575. Add(' doit(1);');
  3576. Add(' doit(2,3);');
  3577. ConvertProgram;
  3578. CheckSource('TestProcedureOverloadForward',
  3579. LinesToStr([ // statements
  3580. 'this.DoIt$1 = function (vI, vJ) {',
  3581. '};',
  3582. 'this.DoIt = function (vI) {',
  3583. '};',
  3584. '']),
  3585. LinesToStr([
  3586. '$mod.DoIt(1);',
  3587. '$mod.DoIt$1(2, 3);',
  3588. '']));
  3589. end;
  3590. procedure TTestModule.TestProc_OverloadIntfImpl;
  3591. begin
  3592. StartUnit(false);
  3593. Add('interface');
  3594. Add('procedure DoIt(vI: longint);');
  3595. Add('procedure DoIt(vI, vJ: longint);');
  3596. Add('implementation');
  3597. Add('procedure DoIt(vI, vJ, vK, vL, vM: longint); forward;');
  3598. Add('procedure DoIt(vI, vJ, vK: longint); begin end;');
  3599. Add('procedure DoIt(vi: longint); begin end;');
  3600. Add('procedure DoIt(vI, vJ, vK, vL: longint); begin end;');
  3601. Add('procedure DoIt(vi, vj: longint); begin end;');
  3602. Add('procedure DoIt(vi, vj, vk, vl, vm: longint); begin end;');
  3603. Add('begin');
  3604. Add(' doit(1);');
  3605. Add(' doit(2,3);');
  3606. Add(' doit(4,5,6);');
  3607. Add(' doit(7,8,9,10);');
  3608. Add(' doit(11,12,13,14,15);');
  3609. ConvertUnit;
  3610. CheckSource('TestProcedureOverloadUnit',
  3611. LinesToStr([ // statements
  3612. 'var $impl = $mod.$impl;',
  3613. 'this.DoIt = function (vI) {',
  3614. '};',
  3615. 'this.DoIt$1 = function (vI, vJ) {',
  3616. '};',
  3617. '']),
  3618. LinesToStr([ // this.$init
  3619. '$mod.DoIt(1);',
  3620. '$mod.DoIt$1(2, 3);',
  3621. '$impl.DoIt$3(4,5,6);',
  3622. '$impl.DoIt$4(7,8,9,10);',
  3623. '$impl.DoIt$2(11,12,13,14,15);',
  3624. '']),
  3625. LinesToStr([ // implementation
  3626. '$impl.DoIt$3 = function (vI, vJ, vK) {',
  3627. '};',
  3628. '$impl.DoIt$4 = function (vI, vJ, vK, vL) {',
  3629. '};',
  3630. '$impl.DoIt$2 = function (vI, vJ, vK, vL, vM) {',
  3631. '};',
  3632. '']));
  3633. end;
  3634. procedure TTestModule.TestProc_OverloadNested;
  3635. begin
  3636. StartProgram(false);
  3637. Add([
  3638. 'procedure DoIt(vA: longint); overload; forward;',
  3639. 'procedure DoIt(vB, vC: longint); overload;',
  3640. 'begin // 2 param overload',
  3641. ' doit(1);',
  3642. ' doit(1,2);',
  3643. 'end;',
  3644. 'procedure doit(vA: longint);',
  3645. ' procedure DoIt(vA, vB, vC: longint); overload; forward;',
  3646. ' procedure DoIt(vA, vB, vC, vD: longint); overload;',
  3647. ' begin // 4 param overload',
  3648. ' doit(1);',
  3649. ' doit(1,2);',
  3650. ' doit(1,2,3);',
  3651. ' doit(1,2,3,4);',
  3652. ' end;',
  3653. ' procedure doit(vA, vB, vC: longint);',
  3654. ' procedure DoIt(vA, vB, vC, vD, vE: longint); overload; forward;',
  3655. ' procedure DoIt(vA, vB, vC, vD, vE, vF: longint); overload;',
  3656. ' begin // 6 param overload',
  3657. ' doit(1);',
  3658. ' doit(1,2);',
  3659. ' doit(1,2,3);',
  3660. ' doit(1,2,3,4);',
  3661. ' doit(1,2,3,4,5);',
  3662. ' doit(1,2,3,4,5,6);',
  3663. ' end;',
  3664. ' procedure doit(vA, vB, vC, vD, vE: longint);',
  3665. ' begin // 5 param overload',
  3666. ' doit(1);',
  3667. ' doit(1,2);',
  3668. ' doit(1,2,3);',
  3669. ' doit(1,2,3,4);',
  3670. ' doit(1,2,3,4,5);',
  3671. ' doit(1,2,3,4,5,6);',
  3672. ' end;',
  3673. ' begin // 3 param overload',
  3674. ' doit(1);',
  3675. ' doit(1,2);',
  3676. ' doit(1,2,3);',
  3677. ' doit(1,2,3,4);',
  3678. ' doit(1,2,3,4,5);',
  3679. ' doit(1,2,3,4,5,6);',
  3680. ' end;',
  3681. 'begin // 1 param overload',
  3682. ' doit(1);',
  3683. ' doit(1,2);',
  3684. ' doit(1,2,3);',
  3685. ' doit(1,2,3,4);',
  3686. 'end;',
  3687. 'begin // main',
  3688. ' doit(1);',
  3689. ' doit(1,2);']);
  3690. ConvertProgram;
  3691. CheckSource('TestProcedureOverloadNested',
  3692. LinesToStr([ // statements
  3693. 'this.DoIt$1 = function (vB, vC) {',
  3694. ' $mod.DoIt(1);',
  3695. ' $mod.DoIt$1(1, 2);',
  3696. '};',
  3697. 'this.DoIt = function (vA) {',
  3698. ' function DoIt$3(vA, vB, vC, vD) {',
  3699. ' $mod.DoIt(1);',
  3700. ' $mod.DoIt$1(1, 2);',
  3701. ' DoIt$2(1, 2, 3);',
  3702. ' DoIt$3(1, 2, 3, 4);',
  3703. ' };',
  3704. ' function DoIt$2(vA, vB, vC) {',
  3705. ' function DoIt$5(vA, vB, vC, vD, vE, vF) {',
  3706. ' $mod.DoIt(1);',
  3707. ' $mod.DoIt$1(1, 2);',
  3708. ' DoIt$2(1, 2, 3);',
  3709. ' DoIt$3(1, 2, 3, 4);',
  3710. ' DoIt$4(1, 2, 3, 4, 5);',
  3711. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3712. ' };',
  3713. ' function DoIt$4(vA, vB, vC, vD, vE) {',
  3714. ' $mod.DoIt(1);',
  3715. ' $mod.DoIt$1(1, 2);',
  3716. ' DoIt$2(1, 2, 3);',
  3717. ' DoIt$3(1, 2, 3, 4);',
  3718. ' DoIt$4(1, 2, 3, 4, 5);',
  3719. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3720. ' };',
  3721. ' $mod.DoIt(1);',
  3722. ' $mod.DoIt$1(1, 2);',
  3723. ' DoIt$2(1, 2, 3);',
  3724. ' DoIt$3(1, 2, 3, 4);',
  3725. ' DoIt$4(1, 2, 3, 4, 5);',
  3726. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3727. ' };',
  3728. ' $mod.DoIt(1);',
  3729. ' $mod.DoIt$1(1, 2);',
  3730. ' DoIt$2(1, 2, 3);',
  3731. ' DoIt$3(1, 2, 3, 4);',
  3732. '};',
  3733. '']),
  3734. LinesToStr([
  3735. '$mod.DoIt(1);',
  3736. '$mod.DoIt$1(1, 2);',
  3737. '']));
  3738. end;
  3739. procedure TTestModule.TestProc_OverloadUnitCycle;
  3740. begin
  3741. AddModuleWithIntfImplSrc('Unit2.pas',
  3742. LinesToStr([
  3743. 'type',
  3744. ' TObject = class',
  3745. ' procedure DoIt(b: boolean); virtual; abstract;',
  3746. ' procedure DoIt(i: longint); virtual; abstract;',
  3747. ' end;',
  3748. '']),
  3749. 'uses test1;');
  3750. StartUnit(true);
  3751. Add([
  3752. 'interface',
  3753. 'uses unit2;',
  3754. 'type',
  3755. ' TEagle = class(TObject)',
  3756. ' procedure DoIt(b: boolean); override;',
  3757. ' procedure DoIt(i: longint); override;',
  3758. ' end;',
  3759. 'implementation',
  3760. 'procedure TEagle.DoIt(b: boolean); begin end;',
  3761. 'procedure TEagle.DoIt(i: longint); begin end;',
  3762. '']);
  3763. ConvertUnit;
  3764. CheckSource('TestProc_OverloadUnitCycle',
  3765. LinesToStr([ // statements
  3766. 'rtl.createClass($mod, "TEagle", pas.Unit2.TObject, function () {',
  3767. ' this.DoIt = function (b) {',
  3768. ' };',
  3769. ' this.DoIt$1 = function (i) {',
  3770. ' };',
  3771. '});',
  3772. '']),
  3773. '',
  3774. LinesToStr([
  3775. '']));
  3776. end;
  3777. procedure TTestModule.TestProc_Varargs;
  3778. begin
  3779. StartProgram(false);
  3780. Add([
  3781. 'procedure ProcA(i:longint); varargs; external name ''ProcA'';',
  3782. 'procedure ProcB; varargs; external name ''ProcB'';',
  3783. 'procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';',
  3784. 'function GetIt: longint; begin end;',
  3785. 'begin',
  3786. ' ProcA(1);',
  3787. ' ProcA(1,2);',
  3788. ' ProcA(1,2.0);',
  3789. ' ProcA(1,2,3);',
  3790. ' ProcA(1,''2'');',
  3791. ' ProcA(2,'''');',
  3792. ' ProcA(3,false);',
  3793. ' ProcB;',
  3794. ' ProcB();',
  3795. ' ProcB(4);',
  3796. ' ProcB(''foo'');',
  3797. ' ProcC;',
  3798. ' ProcC();',
  3799. ' ProcC(4);',
  3800. ' ProcC(5,''foo'');',
  3801. ' ProcB(GetIt);',
  3802. ' ProcB(GetIt());',
  3803. ' ProcB(GetIt,GetIt());']);
  3804. ConvertProgram;
  3805. CheckSource('TestProc_Varargs',
  3806. LinesToStr([ // statements
  3807. 'this.GetIt = function () {',
  3808. ' var Result = 0;',
  3809. ' return Result;',
  3810. '};',
  3811. '']),
  3812. LinesToStr([
  3813. 'ProcA(1);',
  3814. 'ProcA(1, 2);',
  3815. 'ProcA(1, 2.0);',
  3816. 'ProcA(1, 2, 3);',
  3817. 'ProcA(1, "2");',
  3818. 'ProcA(2, "");',
  3819. 'ProcA(3, false);',
  3820. 'ProcB();',
  3821. 'ProcB();',
  3822. 'ProcB(4);',
  3823. 'ProcB("foo");',
  3824. 'ProcC(17);',
  3825. 'ProcC(17);',
  3826. 'ProcC(4);',
  3827. 'ProcC(5, "foo");',
  3828. 'ProcB($mod.GetIt());',
  3829. 'ProcB($mod.GetIt());',
  3830. 'ProcB($mod.GetIt(), $mod.GetIt());',
  3831. '']));
  3832. end;
  3833. procedure TTestModule.TestProc_ConstOrder;
  3834. begin
  3835. StartProgram(false);
  3836. Add([
  3837. 'const A = 3;',
  3838. 'const B = A+1;',
  3839. 'procedure DoIt;',
  3840. 'const C = A+1;',
  3841. 'const D = B+1;',
  3842. 'const E = D+C+B+A;',
  3843. 'begin',
  3844. 'end;',
  3845. 'begin'
  3846. ]);
  3847. ConvertProgram;
  3848. CheckSource('TestProc_ConstOrder',
  3849. LinesToStr([ // statements
  3850. 'this.A = 3;',
  3851. 'this.B = 3 + 1;',
  3852. 'var C = 3 + 1;',
  3853. 'var D = 4 + 1;',
  3854. 'var E = 5 + 4 + 4 + 3;',
  3855. 'this.DoIt = function () {',
  3856. '};',
  3857. '']),
  3858. LinesToStr([
  3859. ''
  3860. ]));
  3861. end;
  3862. procedure TTestModule.TestProc_DuplicateConst;
  3863. begin
  3864. StartProgram(false);
  3865. Add([
  3866. 'const A = 1;',
  3867. 'procedure DoIt;',
  3868. 'const A = 2;',
  3869. ' procedure SubIt;',
  3870. ' const A = 21;',
  3871. ' begin',
  3872. ' end;',
  3873. 'begin',
  3874. 'end;',
  3875. 'procedure DoSome;',
  3876. 'const A = 3;',
  3877. 'begin',
  3878. 'end;',
  3879. 'begin'
  3880. ]);
  3881. ConvertProgram;
  3882. CheckSource('TestProc_DuplicateConst',
  3883. LinesToStr([ // statements
  3884. 'this.A = 1;',
  3885. 'var A$1 = 2;',
  3886. 'var A$2 = 21;',
  3887. 'this.DoIt = function () {',
  3888. ' function SubIt() {',
  3889. ' };',
  3890. '};',
  3891. 'var A$3 = 3;',
  3892. 'this.DoSome = function () {',
  3893. '};',
  3894. '']),
  3895. LinesToStr([
  3896. ''
  3897. ]));
  3898. end;
  3899. procedure TTestModule.TestProc_LocalVarAbsolute;
  3900. begin
  3901. StartProgram(false);
  3902. Add([
  3903. 'type',
  3904. ' TObject = class',
  3905. ' Index: longint;',
  3906. ' procedure DoAbs(Item: pointer);',
  3907. ' end;',
  3908. 'procedure TObject.DoAbs(Item: pointer);',
  3909. 'var',
  3910. ' o: TObject absolute Item;',
  3911. 'begin',
  3912. ' if o.Index<o.Index then o.Index:=o.Index;',
  3913. 'end;',
  3914. 'procedure DoIt(i: longint; p: pointer);',
  3915. 'var',
  3916. ' d: double absolute i;',
  3917. ' s: string absolute d;',
  3918. ' oi: TObject absolute i;',
  3919. ' op: TObject absolute p;',
  3920. 'begin',
  3921. ' if d=d then d:=d;',
  3922. ' if s=s then s:=s;',
  3923. ' if oi.Index<oi.Index then oi.Index:=oi.Index;',
  3924. ' if op.Index=op.Index then op.Index:=op.Index;',
  3925. 'end;',
  3926. 'begin']);
  3927. ConvertProgram;
  3928. CheckSource('TestProc_LocalVarAbsolute',
  3929. LinesToStr([ // statements
  3930. 'rtl.createClass($mod, "TObject", null, function () {',
  3931. ' this.$init = function () {',
  3932. ' this.Index = 0;',
  3933. ' };',
  3934. ' this.$final = function () {',
  3935. ' };',
  3936. ' this.DoAbs = function (Item) {',
  3937. ' if (Item.Index < Item.Index) Item.Index = Item.Index;',
  3938. ' };',
  3939. '});',
  3940. 'this.DoIt = function (i, p) {',
  3941. ' if (i === i) i = i;',
  3942. ' if (i === i) i = i;',
  3943. ' if (i.Index < i.Index) i.Index = i.Index;',
  3944. ' if (p.Index === p.Index) p.Index = p.Index;',
  3945. '};'
  3946. ]),
  3947. LinesToStr([
  3948. ]));
  3949. end;
  3950. procedure TTestModule.TestProc_ReservedWords;
  3951. begin
  3952. StartProgram(false);
  3953. Add([
  3954. 'procedure Date(ArrayBuffer: longint);',
  3955. 'const',
  3956. ' NaN: longint = 3;',
  3957. 'var',
  3958. ' &Boolean: longint;',
  3959. ' procedure Error(ArrayBuffer: longint);',
  3960. ' begin',
  3961. ' end;',
  3962. 'begin',
  3963. ' Nan:=&bOolean;',
  3964. 'end;',
  3965. 'begin',
  3966. ' Date(1);']);
  3967. ConvertProgram;
  3968. CheckSource('TestProc_ReservedWords',
  3969. LinesToStr([ // statements
  3970. 'var naN = 3;',
  3971. 'this.Date = function (arrayBuffer) {',
  3972. ' var boolean = 0;',
  3973. ' function error(arrayBuffer) {',
  3974. ' };',
  3975. ' naN = boolean;',
  3976. '};',
  3977. '']),
  3978. LinesToStr([
  3979. ' $mod.Date(1);'
  3980. ]));
  3981. end;
  3982. procedure TTestModule.TestAnonymousProc_Assign_ObjFPC;
  3983. begin
  3984. StartProgram(false);
  3985. Add([
  3986. '{$mode objfpc}',
  3987. 'type',
  3988. ' TFunc = reference to function(x: word): word;',
  3989. 'var Func: TFunc;',
  3990. 'procedure DoIt(a: word);',
  3991. 'begin',
  3992. ' Func:=function(b:word): word',
  3993. ' begin',
  3994. ' Result:=a+b;',
  3995. ' exit(b);',
  3996. ' exit(Result);',
  3997. ' end;',// test semicolon
  3998. ' a:=3;',
  3999. 'end;',
  4000. 'begin',
  4001. ' Func:=function(c:word):word begin',
  4002. ' Result:=3+c;',
  4003. ' exit(c);',
  4004. ' exit(Result);',
  4005. ' end;']);
  4006. ConvertProgram;
  4007. CheckSource('TestAnonymousProc_Assign_ObjFPC',
  4008. LinesToStr([ // statements
  4009. 'this.Func = null;',
  4010. 'this.DoIt = function (a) {',
  4011. ' $mod.Func = function (b) {',
  4012. ' var Result = 0;',
  4013. ' Result = a + b;',
  4014. ' return b;',
  4015. ' return Result;',
  4016. ' return Result;',
  4017. ' };',
  4018. ' a = 3;',
  4019. '};',
  4020. '']),
  4021. LinesToStr([
  4022. '$mod.Func = function (c) {',
  4023. ' var Result = 0;',
  4024. ' Result = 3 + c;',
  4025. ' return c;',
  4026. ' return Result;',
  4027. ' return Result;',
  4028. '};',
  4029. '']));
  4030. end;
  4031. procedure TTestModule.TestAnonymousProc_Assign_Delphi;
  4032. begin
  4033. StartProgram(false);
  4034. Add([
  4035. '{$mode delphi}',
  4036. 'type',
  4037. ' TProc = reference to procedure(x: word);',
  4038. 'procedure DoIt(a: word);',
  4039. 'var Proc: TProc;',
  4040. 'begin',
  4041. ' Proc:=procedure(b:word) begin end;',
  4042. 'end;',
  4043. 'var Proc: TProc;',
  4044. 'begin',
  4045. ' Proc:=procedure(c:word) begin end;',
  4046. '']);
  4047. ConvertProgram;
  4048. CheckSource('TestAnonymousProc_Assign_Delphi',
  4049. LinesToStr([ // statements
  4050. 'this.DoIt = function (a) {',
  4051. ' var Proc = null;',
  4052. ' Proc = function (b) {',
  4053. ' };',
  4054. '};',
  4055. 'this.Proc = null;',
  4056. '']),
  4057. LinesToStr([
  4058. '$mod.Proc = function (c) {',
  4059. '};',
  4060. '']));
  4061. end;
  4062. procedure TTestModule.TestAnonymousProc_Arg;
  4063. begin
  4064. StartProgram(false);
  4065. Add([
  4066. 'type',
  4067. ' TProc = reference to procedure;',
  4068. ' TFunc = reference to function(x: word): word;',
  4069. 'procedure DoMore(f,g: TProc);',
  4070. 'begin',
  4071. 'end;',
  4072. 'procedure DoOdd(v: jsvalue);',
  4073. 'begin',
  4074. 'end;',
  4075. 'procedure DoIt(f: TFunc);',
  4076. 'begin',
  4077. ' DoIt(function(b:word): word',
  4078. ' begin',
  4079. ' Result:=1+b;',
  4080. ' end);',
  4081. ' DoMore(procedure begin end, procedure begin end);',
  4082. ' DoOdd(procedure begin end);',
  4083. 'end;',
  4084. 'begin',
  4085. ' DoMore(procedure begin end,',
  4086. ' procedure assembler asm',
  4087. ' console.log("c");',
  4088. ' end);',
  4089. '']);
  4090. ConvertProgram;
  4091. CheckSource('TestAnonymousProc_Arg',
  4092. LinesToStr([ // statements
  4093. 'this.DoMore = function (f, g) {',
  4094. '};',
  4095. 'this.DoOdd = function (v) {',
  4096. '};',
  4097. 'this.DoIt = function (f) {',
  4098. ' $mod.DoIt(function (b) {',
  4099. ' var Result = 0;',
  4100. ' Result = 1 + b;',
  4101. ' return Result;',
  4102. ' });',
  4103. ' $mod.DoMore(function () {',
  4104. ' }, function () {',
  4105. ' });',
  4106. ' $mod.DoOdd(function () {',
  4107. ' });',
  4108. '};',
  4109. '']),
  4110. LinesToStr([
  4111. '$mod.DoMore(function () {',
  4112. '}, function () {',
  4113. ' console.log("c");',
  4114. '});',
  4115. '']));
  4116. end;
  4117. procedure TTestModule.TestAnonymousProc_Typecast;
  4118. begin
  4119. StartProgram(false);
  4120. Add([
  4121. 'type',
  4122. ' TProc = reference to procedure(w: word);',
  4123. ' TArr = array of word;',
  4124. ' TFuncArr = reference to function: TArr;',
  4125. 'procedure DoIt(p: TProc);',
  4126. 'var',
  4127. ' w: word;',
  4128. ' a: TArr;',
  4129. 'begin',
  4130. ' p:=TProc(procedure(b: smallint) begin end);',
  4131. ' a:=TFuncArr(function: TArr begin end)();',
  4132. ' w:=TFuncArr(function: TArr begin end)()[3];',
  4133. 'end;',
  4134. 'begin']);
  4135. ConvertProgram;
  4136. CheckSource('TestAnonymousProc_Typecast',
  4137. LinesToStr([ // statements
  4138. 'this.DoIt = function (p) {',
  4139. ' var w = 0;',
  4140. ' var a = [];',
  4141. ' p = function (b) {',
  4142. ' };',
  4143. ' a = function () {',
  4144. ' var Result = [];',
  4145. ' return Result;',
  4146. ' }();',
  4147. ' w = function () {',
  4148. ' var Result = [];',
  4149. ' return Result;',
  4150. ' }()[3];',
  4151. '};',
  4152. '']),
  4153. LinesToStr([
  4154. '']));
  4155. end;
  4156. procedure TTestModule.TestAnonymousProc_With;
  4157. begin
  4158. StartProgram(false);
  4159. Add([
  4160. 'type',
  4161. ' TProc = reference to procedure(w: word);',
  4162. ' TObject = class',
  4163. ' b: boolean;',
  4164. ' end;',
  4165. 'var',
  4166. ' p: TProc;',
  4167. ' bird: TObject;',
  4168. 'begin',
  4169. ' with bird do',
  4170. ' p:=procedure(w: word)',
  4171. ' begin',
  4172. ' b:=w>2;',
  4173. ' end;',
  4174. '']);
  4175. ConvertProgram;
  4176. CheckSource('TestAnonymousProc_With',
  4177. LinesToStr([ // statements
  4178. 'rtl.createClass($mod, "TObject", null, function () {',
  4179. ' this.$init = function () {',
  4180. ' this.b = false;',
  4181. ' };',
  4182. ' this.$final = function () {',
  4183. ' };',
  4184. '});',
  4185. 'this.p = null;',
  4186. 'this.bird = null;',
  4187. '']),
  4188. LinesToStr([
  4189. 'var $with1 = $mod.bird;',
  4190. '$mod.p = function (w) {',
  4191. ' $with1.b = w > 2;',
  4192. '};',
  4193. '']));
  4194. end;
  4195. procedure TTestModule.TestAnonymousProc_ExceptOn;
  4196. begin
  4197. StartProgram(false);
  4198. Add([
  4199. 'type',
  4200. ' TProc = reference to procedure;',
  4201. ' TObject = class',
  4202. ' b: boolean;',
  4203. ' end;',
  4204. 'procedure DoIt;',
  4205. 'var',
  4206. ' p: TProc;',
  4207. 'begin',
  4208. ' try',
  4209. ' except',
  4210. ' on E: TObject do',
  4211. ' p:=procedure',
  4212. ' begin',
  4213. ' E.b:=true;',
  4214. ' end;',
  4215. ' end;',
  4216. 'end;',
  4217. 'begin']);
  4218. ConvertProgram;
  4219. CheckSource('TestAnonymousProc_ExceptOn',
  4220. LinesToStr([ // statements
  4221. 'rtl.createClass($mod, "TObject", null, function () {',
  4222. ' this.$init = function () {',
  4223. ' this.b = false;',
  4224. ' };',
  4225. ' this.$final = function () {',
  4226. ' };',
  4227. '});',
  4228. 'this.DoIt = function () {',
  4229. ' var p = null;',
  4230. ' try {} catch ($e) {',
  4231. ' if ($mod.TObject.isPrototypeOf($e)) {',
  4232. ' var E = $e;',
  4233. ' p = function () {',
  4234. ' E.b = true;',
  4235. ' };',
  4236. ' } else throw $e',
  4237. ' };',
  4238. '};',
  4239. '']),
  4240. LinesToStr([
  4241. '']));
  4242. end;
  4243. procedure TTestModule.TestAnonymousProc_Nested;
  4244. begin
  4245. StartProgram(false);
  4246. Add([
  4247. 'type',
  4248. ' TProc = reference to procedure;',
  4249. ' TObject = class',
  4250. ' i: byte;',
  4251. ' procedure DoIt;',
  4252. ' end;',
  4253. 'procedure TObject.DoIt;',
  4254. 'var',
  4255. ' p: TProc;',
  4256. ' procedure Sub;',
  4257. ' begin',
  4258. ' p:=procedure',
  4259. ' begin',
  4260. ' i:=3;',
  4261. ' Self.i:=4;',
  4262. ' p:=procedure',
  4263. ' procedure SubSub;',
  4264. ' begin',
  4265. ' i:=13;',
  4266. ' Self.i:=14;',
  4267. ' end;',
  4268. ' begin',
  4269. ' i:=13;',
  4270. ' Self.i:=14;',
  4271. ' end;',
  4272. ' end;',
  4273. ' end;',
  4274. 'begin',
  4275. 'end;',
  4276. 'begin']);
  4277. ConvertProgram;
  4278. CheckSource('TestAnonymousProc_Nested',
  4279. LinesToStr([ // statements
  4280. 'rtl.createClass($mod, "TObject", null, function () {',
  4281. ' this.$init = function () {',
  4282. ' this.i = 0;',
  4283. ' };',
  4284. ' this.$final = function () {',
  4285. ' };',
  4286. ' this.DoIt = function () {',
  4287. ' var $Self = this;',
  4288. ' var p = null;',
  4289. ' function Sub() {',
  4290. ' p = function () {',
  4291. ' $Self.i = 3;',
  4292. ' $Self.i = 4;',
  4293. ' p = function () {',
  4294. ' function SubSub() {',
  4295. ' $Self.i = 13;',
  4296. ' $Self.i = 14;',
  4297. ' };',
  4298. ' $Self.i = 13;',
  4299. ' $Self.i = 14;',
  4300. ' };',
  4301. ' };',
  4302. ' };',
  4303. ' };',
  4304. '});',
  4305. '']),
  4306. LinesToStr([
  4307. '']));
  4308. end;
  4309. procedure TTestModule.TestAnonymousProc_NestedAssignResult;
  4310. begin
  4311. StartProgram(false);
  4312. Add([
  4313. 'type',
  4314. ' TProc = reference to procedure;',
  4315. 'function DoIt: TProc;',
  4316. ' function Sub: TProc;',
  4317. ' begin',
  4318. ' Result:=procedure',
  4319. ' begin',
  4320. ' Sub:=procedure',
  4321. ' procedure SubSub;',
  4322. ' begin',
  4323. ' Result:=nil;',
  4324. ' Sub:=nil;',
  4325. ' DoIt:=nil;',
  4326. ' end;',
  4327. ' begin',
  4328. ' Result:=nil;',
  4329. ' Sub:=nil;',
  4330. ' DoIt:=nil;',
  4331. ' end;',
  4332. ' end;',
  4333. ' end;',
  4334. 'begin',
  4335. 'end;',
  4336. 'begin']);
  4337. ConvertProgram;
  4338. CheckSource('TestAnonymousProc_NestedAssignResult',
  4339. LinesToStr([ // statements
  4340. 'this.DoIt = function () {',
  4341. ' var Result = null;',
  4342. ' function Sub() {',
  4343. ' var Result$1 = null;',
  4344. ' Result$1 = function () {',
  4345. ' Result$1 = function () {',
  4346. ' function SubSub() {',
  4347. ' Result$1 = null;',
  4348. ' Result$1 = null;',
  4349. ' Result = null;',
  4350. ' };',
  4351. ' Result$1 = null;',
  4352. ' Result$1 = null;',
  4353. ' Result = null;',
  4354. ' };',
  4355. ' };',
  4356. ' return Result$1;',
  4357. ' };',
  4358. ' return Result;',
  4359. '};',
  4360. '']),
  4361. LinesToStr([
  4362. '']));
  4363. end;
  4364. procedure TTestModule.TestEnum_Name;
  4365. begin
  4366. StartProgram(false);
  4367. Add('type TMyEnum = (Red, Green, Blue);');
  4368. Add('var e: TMyEnum;');
  4369. Add('var f: TMyEnum = Blue;');
  4370. Add('begin');
  4371. Add(' e:=green;');
  4372. Add(' e:=default(TMyEnum);');
  4373. ConvertProgram;
  4374. CheckSource('TestEnumName',
  4375. LinesToStr([ // statements
  4376. 'this.TMyEnum = {',
  4377. ' "0":"Red",',
  4378. ' Red:0,',
  4379. ' "1":"Green",',
  4380. ' Green:1,',
  4381. ' "2":"Blue",',
  4382. ' Blue:2',
  4383. ' };',
  4384. 'this.e = 0;',
  4385. 'this.f = $mod.TMyEnum.Blue;'
  4386. ]),
  4387. LinesToStr([
  4388. '$mod.e=$mod.TMyEnum.Green;',
  4389. '$mod.e=$mod.TMyEnum.Red;'
  4390. ]));
  4391. end;
  4392. procedure TTestModule.TestEnum_Number;
  4393. begin
  4394. Converter.Options:=Converter.Options+[coEnumNumbers];
  4395. StartProgram(false);
  4396. Add('type TMyEnum = (Red, Green);');
  4397. Add('var');
  4398. Add(' e: TMyEnum;');
  4399. Add(' f: TMyEnum = Green;');
  4400. Add(' i: longint;');
  4401. Add('begin');
  4402. Add(' e:=green;');
  4403. Add(' i:=longint(e);');
  4404. ConvertProgram;
  4405. CheckSource('TestEnumNumber',
  4406. LinesToStr([ // statements
  4407. 'this.TMyEnum = {',
  4408. ' "0":"Red",',
  4409. ' Red:0,',
  4410. ' "1":"Green",',
  4411. ' Green:1',
  4412. ' };',
  4413. 'this.e = 0;',
  4414. 'this.f = 1;',
  4415. 'this.i = 0;'
  4416. ]),
  4417. LinesToStr([
  4418. '$mod.e=1;',
  4419. '$mod.i=$mod.e;'
  4420. ]));
  4421. end;
  4422. procedure TTestModule.TestEnum_ConstFail;
  4423. begin
  4424. StartProgram(false);
  4425. Add([
  4426. 'type TMyEnum = (Red = 100, Green = 101);',
  4427. 'var',
  4428. ' e: TMyEnum;',
  4429. ' f: TMyEnum = Green;',
  4430. 'begin',
  4431. ' e:=green;']);
  4432. SetExpectedPasResolverError('not yet implemented: Red:TPasEnumValue [20180126202434] enum const',3002);
  4433. ConvertProgram;
  4434. end;
  4435. procedure TTestModule.TestEnum_Functions;
  4436. begin
  4437. StartProgram(false);
  4438. Add([
  4439. 'type TMyEnum = (Red, Green);',
  4440. 'procedure DoIt(var e: TMyEnum; var i: word);',
  4441. 'var',
  4442. ' v: longint;',
  4443. ' s: string;',
  4444. 'begin',
  4445. ' val(s,e,v);',
  4446. ' val(s,e,i);',
  4447. 'end;',
  4448. 'var',
  4449. ' e: TMyEnum;',
  4450. ' i: longint;',
  4451. ' s: string;',
  4452. ' b: boolean;',
  4453. 'begin',
  4454. ' i:=ord(red);',
  4455. ' i:=ord(green);',
  4456. ' i:=ord(e);',
  4457. ' i:=ord(b);',
  4458. ' e:=low(tmyenum);',
  4459. ' e:=low(e);',
  4460. ' b:=low(boolean);',
  4461. ' e:=high(tmyenum);',
  4462. ' e:=high(e);',
  4463. ' b:=high(boolean);',
  4464. ' e:=pred(green);',
  4465. ' e:=pred(e);',
  4466. ' b:=pred(b);',
  4467. ' e:=succ(red);',
  4468. ' e:=succ(e);',
  4469. ' b:=succ(b);',
  4470. ' e:=tmyenum(1);',
  4471. ' e:=tmyenum(i);',
  4472. ' s:=str(e);',
  4473. ' str(e,s);',
  4474. ' str(red,s);',
  4475. ' s:=str(e:3);',
  4476. ' writestr(s,e:3,red);',
  4477. ' val(s,e,i);',
  4478. ' e:=TMyEnum(i);',
  4479. ' i:=longint(e);']);
  4480. ConvertProgram;
  4481. CheckSource('TestEnum_Functions',
  4482. LinesToStr([ // statements
  4483. 'this.TMyEnum = {',
  4484. ' "0":"Red",',
  4485. ' Red:0,',
  4486. ' "1":"Green",',
  4487. ' Green:1',
  4488. ' };',
  4489. 'this.DoIt = function (e, i) {',
  4490. ' var v = 0;',
  4491. ' var s = "";',
  4492. ' e.set(rtl.valEnum(s, $mod.TMyEnum, function (w) {',
  4493. ' v = w;',
  4494. ' }));',
  4495. ' e.set(rtl.valEnum(s, $mod.TMyEnum, i.set));',
  4496. '};',
  4497. 'this.e = 0;',
  4498. 'this.i = 0;',
  4499. 'this.s = "";',
  4500. 'this.b = false;',
  4501. '']),
  4502. LinesToStr([
  4503. '$mod.i=$mod.TMyEnum.Red;',
  4504. '$mod.i=$mod.TMyEnum.Green;',
  4505. '$mod.i=$mod.e;',
  4506. '$mod.i=$mod.b+0;',
  4507. '$mod.e=$mod.TMyEnum.Red;',
  4508. '$mod.e=$mod.TMyEnum.Red;',
  4509. '$mod.b=false;',
  4510. '$mod.e=$mod.TMyEnum.Green;',
  4511. '$mod.e=$mod.TMyEnum.Green;',
  4512. '$mod.b=true;',
  4513. '$mod.e=$mod.TMyEnum.Green-1;',
  4514. '$mod.e=$mod.e-1;',
  4515. '$mod.b=false;',
  4516. '$mod.e=$mod.TMyEnum.Red+1;',
  4517. '$mod.e=$mod.e+1;',
  4518. '$mod.b=true;',
  4519. '$mod.e=1;',
  4520. '$mod.e=$mod.i;',
  4521. '$mod.s = $mod.TMyEnum[$mod.e];',
  4522. '$mod.s = $mod.TMyEnum[$mod.e];',
  4523. '$mod.s = $mod.TMyEnum[$mod.TMyEnum.Red];',
  4524. '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
  4525. '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3)+$mod.TMyEnum[$mod.TMyEnum.Red];',
  4526. '$mod.e = rtl.valEnum($mod.s, $mod.TMyEnum, function (v) {',
  4527. ' $mod.i = v;',
  4528. '});',
  4529. '$mod.e=$mod.i;',
  4530. '$mod.i=$mod.e;',
  4531. '']));
  4532. end;
  4533. procedure TTestModule.TestEnum_AsParams;
  4534. begin
  4535. StartProgram(false);
  4536. Add('type TEnum = (Red,Blue);');
  4537. Add('procedure DoIt(vG: TEnum; const vH: TEnum; var vI: TEnum);');
  4538. Add('var vJ: TEnum;');
  4539. Add('begin');
  4540. Add(' vg:=vg;');
  4541. Add(' vj:=vh;');
  4542. Add(' vi:=vi;');
  4543. Add(' doit(vg,vg,vg);');
  4544. Add(' doit(vh,vh,vj);');
  4545. Add(' doit(vi,vi,vi);');
  4546. Add(' doit(vj,vj,vj);');
  4547. Add('end;');
  4548. Add('var i: TEnum;');
  4549. Add('begin');
  4550. Add(' doit(i,i,i);');
  4551. ConvertProgram;
  4552. CheckSource('TestEnum_AsParams',
  4553. LinesToStr([ // statements
  4554. 'this.TEnum = {',
  4555. ' "0": "Red",',
  4556. ' Red: 0,',
  4557. ' "1": "Blue",',
  4558. ' Blue: 1',
  4559. '};',
  4560. 'this.DoIt = function (vG,vH,vI) {',
  4561. ' var vJ = 0;',
  4562. ' vG = vG;',
  4563. ' vJ = vH;',
  4564. ' vI.set(vI.get());',
  4565. ' $mod.DoIt(vG, vG, {',
  4566. ' get: function () {',
  4567. ' return vG;',
  4568. ' },',
  4569. ' set: function (v) {',
  4570. ' vG = v;',
  4571. ' }',
  4572. ' });',
  4573. ' $mod.DoIt(vH, vH, {',
  4574. ' get: function () {',
  4575. ' return vJ;',
  4576. ' },',
  4577. ' set: function (v) {',
  4578. ' vJ = v;',
  4579. ' }',
  4580. ' });',
  4581. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  4582. ' $mod.DoIt(vJ, vJ, {',
  4583. ' get: function () {',
  4584. ' return vJ;',
  4585. ' },',
  4586. ' set: function (v) {',
  4587. ' vJ = v;',
  4588. ' }',
  4589. ' });',
  4590. '};',
  4591. 'this.i = 0;'
  4592. ]),
  4593. LinesToStr([
  4594. '$mod.DoIt($mod.i,$mod.i,{',
  4595. ' p: $mod,',
  4596. ' get: function () {',
  4597. ' return this.p.i;',
  4598. ' },',
  4599. ' set: function (v) {',
  4600. ' this.p.i = v;',
  4601. ' }',
  4602. '});'
  4603. ]));
  4604. end;
  4605. procedure TTestModule.TestEnumRange_Array;
  4606. begin
  4607. StartProgram(false);
  4608. Add([
  4609. 'type',
  4610. ' TEnum = (Red, Green, Blue);',
  4611. ' TEnumRg = green..blue;',
  4612. ' TArr = array[TEnumRg] of byte;',
  4613. ' TArr2 = array[green..blue] of byte;',
  4614. 'var',
  4615. ' a: TArr;',
  4616. ' b: TArr = (3,4);',
  4617. ' c: TArr2 = (5,6);',
  4618. 'begin',
  4619. ' a[green] := b[blue];',
  4620. ' c[green] := c[blue];',
  4621. '']);
  4622. ConvertProgram;
  4623. CheckSource('TestEnumRange_Array',
  4624. LinesToStr([ // statements
  4625. 'this.TEnum = {',
  4626. ' "0": "Red",',
  4627. ' Red: 0,',
  4628. ' "1": "Green",',
  4629. ' Green: 1,',
  4630. ' "2": "Blue",',
  4631. ' Blue: 2',
  4632. '};',
  4633. 'this.a = rtl.arraySetLength(null, 0, 2);',
  4634. 'this.b = [3, 4];',
  4635. 'this.c = [5, 6];',
  4636. '']),
  4637. LinesToStr([
  4638. ' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
  4639. ' $mod.c[$mod.TEnum.Green - 1] = $mod.c[$mod.TEnum.Blue - 1];',
  4640. '']));
  4641. end;
  4642. procedure TTestModule.TestEnum_ForIn;
  4643. begin
  4644. StartProgram(false);
  4645. Add([
  4646. 'type',
  4647. ' TEnum = (Red, Green, Blue);',
  4648. ' TEnumRg = green..blue;',
  4649. ' TArr = array[TEnum] of byte;',
  4650. ' TArrRg = array[TEnumRg] of byte;',
  4651. 'var',
  4652. ' e: TEnum;',
  4653. ' a1: TArr = (3,4,5);',
  4654. ' a2: TArrRg = (11,12);',
  4655. ' b: byte;',
  4656. 'begin',
  4657. ' for e in TEnum do ;',
  4658. ' for e in TEnumRg do ;',
  4659. ' for e in TArr do ;',
  4660. ' for e in TArrRg do ;',
  4661. ' for b in a1 do ;',
  4662. ' for b in a2 do ;',
  4663. '']);
  4664. ConvertProgram;
  4665. CheckSource('TestEnum_ForIn',
  4666. LinesToStr([ // statements
  4667. 'this.TEnum = {',
  4668. ' "0": "Red",',
  4669. ' Red: 0,',
  4670. ' "1": "Green",',
  4671. ' Green: 1,',
  4672. ' "2": "Blue",',
  4673. ' Blue: 2',
  4674. '};',
  4675. 'this.e = 0;',
  4676. 'this.a1 = [3, 4, 5];',
  4677. 'this.a2 = [11, 12];',
  4678. 'this.b = 0;',
  4679. '']),
  4680. LinesToStr([
  4681. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  4682. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  4683. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  4684. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  4685. ' for (var $in1 = $mod.a1, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.b = $in1[$l2];',
  4686. ' for (var $in4 = $mod.a2, $l5 = 0, $end6 = rtl.length($in4) - 1; $l5 <= $end6; $l5++) $mod.b = $in4[$l5];',
  4687. '']));
  4688. end;
  4689. procedure TTestModule.TestEnum_ScopedNumber;
  4690. begin
  4691. Converter.Options:=Converter.Options+[coEnumNumbers];
  4692. StartProgram(false);
  4693. Add([
  4694. 'type',
  4695. ' TEnum = (Red, Green);',
  4696. 'var',
  4697. ' e: TEnum;',
  4698. 'begin',
  4699. ' e:=TEnum.Green;',
  4700. '']);
  4701. ConvertProgram;
  4702. CheckSource('TestEnum_ScopedNumber',
  4703. LinesToStr([ // statements
  4704. 'this.TEnum = {',
  4705. ' "0": "Red",',
  4706. ' Red: 0,',
  4707. ' "1": "Green",',
  4708. ' Green: 1',
  4709. '};',
  4710. 'this.e = 0;',
  4711. '']),
  4712. LinesToStr([
  4713. '$mod.e = 1;']));
  4714. end;
  4715. procedure TTestModule.TestEnum_InFunction;
  4716. begin
  4717. StartProgram(false);
  4718. Add([
  4719. 'const TEnum = 3;',
  4720. 'procedure DoIt;',
  4721. 'type',
  4722. ' TEnum = (Red, Green, Blue);',
  4723. ' procedure Sub;',
  4724. ' type',
  4725. ' TEnumSub = (Left, Right);',
  4726. ' var',
  4727. ' es: TEnumSub;',
  4728. ' begin',
  4729. ' es:=Left;',
  4730. ' end;',
  4731. 'var',
  4732. ' e, e2: TEnum;',
  4733. 'begin',
  4734. ' if e in [red,blue] then e2:=e;',
  4735. 'end;',
  4736. 'begin']);
  4737. ConvertProgram;
  4738. CheckSource('TestEnum_InFunction',
  4739. LinesToStr([ // statements
  4740. 'this.TEnum = 3;',
  4741. 'var TEnum$1 = {',
  4742. ' "0":"Red",',
  4743. ' Red:0,',
  4744. ' "1":"Green",',
  4745. ' Green:1,',
  4746. ' "2":"Blue",',
  4747. ' Blue:2',
  4748. ' };',
  4749. 'var TEnumSub = {',
  4750. ' "0": "Left",',
  4751. ' Left: 0,',
  4752. ' "1": "Right",',
  4753. ' Right: 1',
  4754. '};',
  4755. 'this.DoIt = function () {',
  4756. ' function Sub() {',
  4757. ' var es = 0;',
  4758. ' es = TEnumSub.Left;',
  4759. ' };',
  4760. ' var e = 0;',
  4761. ' var e2 = 0;',
  4762. ' if (e in rtl.createSet(TEnum$1.Red, TEnum$1.Blue)) e2 = e;',
  4763. '};',
  4764. '']),
  4765. LinesToStr([
  4766. '']));
  4767. end;
  4768. procedure TTestModule.TestSet_Enum;
  4769. begin
  4770. StartProgram(false);
  4771. Add([
  4772. 'type',
  4773. ' TColor = (Red, Green, Blue);',
  4774. ' TColors = set of TColor;',
  4775. 'var',
  4776. ' c: TColor;',
  4777. ' s: TColors;',
  4778. ' t: TColors = [];',
  4779. ' u: TColors = [Red];',
  4780. 'begin',
  4781. ' s:=[];',
  4782. ' s:=[Green];',
  4783. ' s:=[Green,Blue];',
  4784. ' s:=[Red..Blue];',
  4785. ' s:=[Red,Green..Blue];',
  4786. ' s:=[Red,c];',
  4787. ' s:=t;',
  4788. ' s:=default(TColors);',
  4789. '']);
  4790. ConvertProgram;
  4791. CheckSource('TestSet',
  4792. LinesToStr([ // statements
  4793. 'this.TColor = {',
  4794. ' "0":"Red",',
  4795. ' Red:0,',
  4796. ' "1":"Green",',
  4797. ' Green:1,',
  4798. ' "2":"Blue",',
  4799. ' Blue:2',
  4800. ' };',
  4801. 'this.c = 0;',
  4802. 'this.s = {};',
  4803. 'this.t = {};',
  4804. 'this.u = rtl.createSet($mod.TColor.Red);'
  4805. ]),
  4806. LinesToStr([
  4807. '$mod.s={};',
  4808. '$mod.s=rtl.createSet($mod.TColor.Green);',
  4809. '$mod.s=rtl.createSet($mod.TColor.Green,$mod.TColor.Blue);',
  4810. '$mod.s=rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);',
  4811. '$mod.s=rtl.createSet($mod.TColor.Red,null,$mod.TColor.Green,$mod.TColor.Blue);',
  4812. '$mod.s=rtl.createSet($mod.TColor.Red,$mod.c);',
  4813. '$mod.s=rtl.refSet($mod.t);',
  4814. '$mod.s={};',
  4815. '']));
  4816. end;
  4817. procedure TTestModule.TestSet_Operators;
  4818. begin
  4819. StartProgram(false);
  4820. Add('type');
  4821. Add(' TColor = (Red, Green, Blue);');
  4822. Add(' TColors = set of tcolor;');
  4823. Add('var');
  4824. Add(' vC: TColor;');
  4825. Add(' vS: TColors;');
  4826. Add(' vT: TColors;');
  4827. Add(' vU: TColors;');
  4828. Add(' B: boolean;');
  4829. Add('begin');
  4830. Add(' include(vs,green);');
  4831. Add(' exclude(vs,vc);');
  4832. Add(' vs:=vt+vu;');
  4833. Add(' vs:=vt+[red];');
  4834. Add(' vs:=[red]+vt;');
  4835. Add(' vs:=[red]+[green];');
  4836. Add(' vs:=vt-vu;');
  4837. Add(' vs:=vt-[red];');
  4838. Add(' vs:=[red]-vt;');
  4839. Add(' vs:=[red]-[green];');
  4840. Add(' vs:=vt*vu;');
  4841. Add(' vs:=vt*[red];');
  4842. Add(' vs:=[red]*vt;');
  4843. Add(' vs:=[red]*[green];');
  4844. Add(' vs:=vt><vu;');
  4845. Add(' vs:=vt><[red];');
  4846. Add(' vs:=[red]><vt;');
  4847. Add(' vs:=[red]><[green];');
  4848. Add(' b:=vt=vu;');
  4849. Add(' b:=vt=[red];');
  4850. Add(' b:=[red]=vt;');
  4851. Add(' b:=[red]=[green];');
  4852. Add(' b:=vt<>vu;');
  4853. Add(' b:=vt<>[red];');
  4854. Add(' b:=[red]<>vt;');
  4855. Add(' b:=[red]<>[green];');
  4856. Add(' b:=vt<=vu;');
  4857. Add(' b:=vt<=[red];');
  4858. Add(' b:=[red]<=vt;');
  4859. Add(' b:=[red]<=[green];');
  4860. Add(' b:=vt>=vu;');
  4861. Add(' b:=vt>=[red];');
  4862. Add(' b:=[red]>=vt;');
  4863. Add(' b:=[red]>=[green];');
  4864. ConvertProgram;
  4865. CheckSource('TestSet_Operators',
  4866. LinesToStr([ // statements
  4867. 'this.TColor = {',
  4868. ' "0":"Red",',
  4869. ' Red:0,',
  4870. ' "1":"Green",',
  4871. ' Green:1,',
  4872. ' "2":"Blue",',
  4873. ' Blue:2',
  4874. ' };',
  4875. 'this.vC = 0;',
  4876. 'this.vS = {};',
  4877. 'this.vT = {};',
  4878. 'this.vU = {};',
  4879. 'this.B = false;'
  4880. ]),
  4881. LinesToStr([
  4882. '$mod.vS = rtl.includeSet($mod.vS,$mod.TColor.Green);',
  4883. '$mod.vS = rtl.excludeSet($mod.vS,$mod.vC);',
  4884. '$mod.vS = rtl.unionSet($mod.vT, $mod.vU);',
  4885. '$mod.vS = rtl.unionSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4886. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4887. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4888. '$mod.vS = rtl.diffSet($mod.vT, $mod.vU);',
  4889. '$mod.vS = rtl.diffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4890. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4891. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4892. '$mod.vS = rtl.intersectSet($mod.vT, $mod.vU);',
  4893. '$mod.vS = rtl.intersectSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4894. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4895. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4896. '$mod.vS = rtl.symDiffSet($mod.vT, $mod.vU);',
  4897. '$mod.vS = rtl.symDiffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4898. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4899. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4900. '$mod.B = rtl.eqSet($mod.vT, $mod.vU);',
  4901. '$mod.B = rtl.eqSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4902. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4903. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4904. '$mod.B = rtl.neSet($mod.vT, $mod.vU);',
  4905. '$mod.B = rtl.neSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4906. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4907. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4908. '$mod.B = rtl.leSet($mod.vT, $mod.vU);',
  4909. '$mod.B = rtl.leSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4910. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4911. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4912. '$mod.B = rtl.geSet($mod.vT, $mod.vU);',
  4913. '$mod.B = rtl.geSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  4914. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  4915. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  4916. '']));
  4917. end;
  4918. procedure TTestModule.TestSet_Operator_In;
  4919. begin
  4920. StartProgram(false);
  4921. Add('type');
  4922. Add(' TColor = (Red, Green, Blue);');
  4923. Add(' TColors = set of tcolor;');
  4924. Add('var');
  4925. Add(' vC: tcolor;');
  4926. Add(' vT: tcolors;');
  4927. Add(' B: boolean;');
  4928. Add('begin');
  4929. Add(' b:=red in vt;');
  4930. Add(' b:=vc in vt;');
  4931. Add(' b:=green in [red..blue];');
  4932. Add(' b:=vc in [red..blue];');
  4933. Add(' ');
  4934. Add(' if red in vt then ;');
  4935. Add(' while vC in vt do ;');
  4936. Add(' repeat');
  4937. Add(' until vC in vt;');
  4938. ConvertProgram;
  4939. CheckSource('TestSet_Operator_In',
  4940. LinesToStr([ // statements
  4941. 'this.TColor = {',
  4942. ' "0":"Red",',
  4943. ' Red:0,',
  4944. ' "1":"Green",',
  4945. ' Green:1,',
  4946. ' "2":"Blue",',
  4947. ' Blue:2',
  4948. ' };',
  4949. 'this.vC = 0;',
  4950. 'this.vT = {};',
  4951. 'this.B = false;'
  4952. ]),
  4953. LinesToStr([
  4954. '$mod.B = $mod.TColor.Red in $mod.vT;',
  4955. '$mod.B = $mod.vC in $mod.vT;',
  4956. '$mod.B = $mod.TColor.Green in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  4957. '$mod.B = $mod.vC in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  4958. 'if ($mod.TColor.Red in $mod.vT) ;',
  4959. 'while ($mod.vC in $mod.vT) {',
  4960. '};',
  4961. 'do {',
  4962. '} while (!($mod.vC in $mod.vT));',
  4963. '']));
  4964. end;
  4965. procedure TTestModule.TestSet_Functions;
  4966. begin
  4967. StartProgram(false);
  4968. Add('type');
  4969. Add(' TMyEnum = (Red, Green);');
  4970. Add(' TMyEnums = set of TMyEnum;');
  4971. Add('var');
  4972. Add(' e: TMyEnum;');
  4973. Add(' s: TMyEnums;');
  4974. Add('begin');
  4975. Add(' e:=Low(TMyEnums);');
  4976. Add(' e:=Low(s);');
  4977. Add(' e:=High(TMyEnums);');
  4978. Add(' e:=High(s);');
  4979. ConvertProgram;
  4980. CheckSource('TestSetFunctions',
  4981. LinesToStr([ // statements
  4982. 'this.TMyEnum = {',
  4983. ' "0":"Red",',
  4984. ' Red:0,',
  4985. ' "1":"Green",',
  4986. ' Green:1',
  4987. ' };',
  4988. 'this.e = 0;',
  4989. 'this.s = {};'
  4990. ]),
  4991. LinesToStr([
  4992. '$mod.e=$mod.TMyEnum.Red;',
  4993. '$mod.e=$mod.TMyEnum.Red;',
  4994. '$mod.e=$mod.TMyEnum.Green;',
  4995. '$mod.e=$mod.TMyEnum.Green;',
  4996. '']));
  4997. end;
  4998. procedure TTestModule.TestSet_PassAsArgClone;
  4999. begin
  5000. StartProgram(false);
  5001. Add('type');
  5002. Add(' TMyEnum = (Red, Green);');
  5003. Add(' TMyEnums = set of TMyEnum;');
  5004. Add('procedure DoDefault(s: tmyenums); begin end;');
  5005. Add('procedure DoConst(const s: tmyenums); begin end;');
  5006. Add('var');
  5007. Add(' aSet: tmyenums;');
  5008. Add('begin');
  5009. Add(' dodefault(aset);');
  5010. Add(' doconst(aset);');
  5011. ConvertProgram;
  5012. CheckSource('TestSetFunctions',
  5013. LinesToStr([ // statements
  5014. 'this.TMyEnum = {',
  5015. ' "0":"Red",',
  5016. ' Red:0,',
  5017. ' "1":"Green",',
  5018. ' Green:1',
  5019. ' };',
  5020. 'this.DoDefault = function (s) {',
  5021. '};',
  5022. 'this.DoConst = function (s) {',
  5023. '};',
  5024. 'this.aSet = {};'
  5025. ]),
  5026. LinesToStr([
  5027. '$mod.DoDefault(rtl.refSet($mod.aSet));',
  5028. '$mod.DoConst($mod.aSet);',
  5029. '']));
  5030. end;
  5031. procedure TTestModule.TestSet_AsParams;
  5032. begin
  5033. StartProgram(false);
  5034. Add([
  5035. 'type TEnum = (Red,Blue);',
  5036. 'type TEnums = set of TEnum;',
  5037. 'function DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums): TEnums;',
  5038. 'var vJ: TEnums;',
  5039. 'begin',
  5040. ' Include(vg,red);',
  5041. ' Include(result,blue);',
  5042. ' vg:=vg;',
  5043. ' vj:=vh;',
  5044. ' vi:=vi;',
  5045. ' doit(vg,vg,vg);',
  5046. ' doit(vh,vh,vj);',
  5047. ' doit(vi,vi,vi);',
  5048. ' doit(vj,vj,vj);',
  5049. 'end;',
  5050. 'var i: TEnums;',
  5051. 'begin',
  5052. ' doit(i,i,i);']);
  5053. ConvertProgram;
  5054. CheckSource('TestSet_AsParams',
  5055. LinesToStr([ // statements
  5056. 'this.TEnum = {',
  5057. ' "0": "Red",',
  5058. ' Red: 0,',
  5059. ' "1": "Blue",',
  5060. ' Blue: 1',
  5061. '};',
  5062. 'this.DoIt = function (vG,vH,vI) {',
  5063. ' var Result = {};',
  5064. ' var vJ = {};',
  5065. ' vG = rtl.includeSet(vG, $mod.TEnum.Red);',
  5066. ' Result = rtl.includeSet(Result, $mod.TEnum.Blue);',
  5067. ' vG = rtl.refSet(vG);',
  5068. ' vJ = rtl.refSet(vH);',
  5069. ' vI.set(rtl.refSet(vI.get()));',
  5070. ' $mod.DoIt(rtl.refSet(vG), vG, {',
  5071. ' get: function () {',
  5072. ' return vG;',
  5073. ' },',
  5074. ' set: function (v) {',
  5075. ' vG = v;',
  5076. ' }',
  5077. ' });',
  5078. ' $mod.DoIt(rtl.refSet(vH), vH, {',
  5079. ' get: function () {',
  5080. ' return vJ;',
  5081. ' },',
  5082. ' set: function (v) {',
  5083. ' vJ = v;',
  5084. ' }',
  5085. ' });',
  5086. ' $mod.DoIt(rtl.refSet(vI.get()), vI.get(), vI);',
  5087. ' $mod.DoIt(rtl.refSet(vJ), vJ, {',
  5088. ' get: function () {',
  5089. ' return vJ;',
  5090. ' },',
  5091. ' set: function (v) {',
  5092. ' vJ = v;',
  5093. ' }',
  5094. ' });',
  5095. ' return Result;',
  5096. '};',
  5097. 'this.i = {};'
  5098. ]),
  5099. LinesToStr([
  5100. '$mod.DoIt(rtl.refSet($mod.i),$mod.i,{',
  5101. ' p: $mod,',
  5102. ' get: function () {',
  5103. ' return this.p.i;',
  5104. ' },',
  5105. ' set: function (v) {',
  5106. ' this.p.i = v;',
  5107. ' }',
  5108. '});'
  5109. ]));
  5110. end;
  5111. procedure TTestModule.TestSet_Property;
  5112. begin
  5113. StartProgram(false);
  5114. Add('type');
  5115. Add(' TEnum = (Red,Blue);');
  5116. Add(' TEnums = set of TEnum;');
  5117. Add(' TObject = class');
  5118. Add(' function GetColors: TEnums; external name ''GetColors'';');
  5119. Add(' procedure SetColors(const Value: TEnums); external name ''SetColors'';');
  5120. Add(' property Colors: TEnums read GetColors write SetColors;');
  5121. Add(' end;');
  5122. Add('procedure DoIt(i: TEnums; const j: TEnums; var k: TEnums; out l: TEnums);');
  5123. Add('begin end;');
  5124. Add('var Obj: TObject;');
  5125. Add('begin');
  5126. Add(' Include(Obj.Colors,Red);');
  5127. Add(' Exclude(Obj.Colors,Red);');
  5128. //Add(' DoIt(Obj.Colors,Obj.Colors,Obj.Colors,Obj.Colors);');
  5129. ConvertProgram;
  5130. CheckSource('TestSet_Property',
  5131. LinesToStr([ // statements
  5132. 'this.TEnum = {',
  5133. ' "0": "Red",',
  5134. ' Red: 0,',
  5135. ' "1": "Blue",',
  5136. ' Blue: 1',
  5137. '};',
  5138. 'rtl.createClass($mod, "TObject", null, function () {',
  5139. ' this.$init = function () {',
  5140. ' };',
  5141. ' this.$final = function () {',
  5142. ' };',
  5143. '});',
  5144. 'this.DoIt = function (i, j, k, l) {',
  5145. '};',
  5146. 'this.Obj = null;',
  5147. '']),
  5148. LinesToStr([
  5149. '$mod.Obj.SetColors(rtl.includeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  5150. '$mod.Obj.SetColors(rtl.excludeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  5151. '']));
  5152. end;
  5153. procedure TTestModule.TestSet_EnumConst;
  5154. begin
  5155. StartProgram(false);
  5156. Add([
  5157. 'type',
  5158. ' TEnum = (Red,Blue);',
  5159. ' TEnums = set of TEnum;',
  5160. 'const',
  5161. ' Orange = red;',
  5162. 'var',
  5163. ' Enum: tenum;',
  5164. ' Enums: tenums;',
  5165. 'begin',
  5166. ' Include(enums,orange);',
  5167. ' Exclude(enums,orange);',
  5168. ' if orange in enums then;',
  5169. ' if orange in [orange,red] then;']);
  5170. ConvertProgram;
  5171. CheckSource('TestSet_EnumConst',
  5172. LinesToStr([ // statements
  5173. 'this.TEnum = {',
  5174. ' "0": "Red",',
  5175. ' Red: 0,',
  5176. ' "1": "Blue",',
  5177. ' Blue: 1',
  5178. '};',
  5179. 'this.Orange = $mod.TEnum.Red;',
  5180. 'this.Enum = 0;',
  5181. 'this.Enums = {};',
  5182. '']),
  5183. LinesToStr([
  5184. '$mod.Enums = rtl.includeSet($mod.Enums, $mod.TEnum.Red);',
  5185. '$mod.Enums = rtl.excludeSet($mod.Enums, $mod.TEnum.Red);',
  5186. 'if ($mod.TEnum.Red in $mod.Enums) ;',
  5187. 'if ($mod.TEnum.Red in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Red)) ;',
  5188. '']));
  5189. end;
  5190. procedure TTestModule.TestSet_IntConst;
  5191. begin
  5192. StartProgram(false);
  5193. Add([
  5194. 'type',
  5195. ' TEnums = set of Byte;',
  5196. 'const',
  5197. ' Orange = 0;',
  5198. 'var',
  5199. ' Enum: byte;',
  5200. ' Enums: tenums;',
  5201. 'begin',
  5202. ' Enums:=[];',
  5203. ' Enums:=[0];',
  5204. ' Enums:=[1..2];',
  5205. //' Include(enums,orange);',
  5206. //' Exclude(enums,orange);',
  5207. ' if orange in enums then;',
  5208. ' if orange in [orange,1] then;']);
  5209. ConvertProgram;
  5210. CheckSource('TestSet_IntConst',
  5211. LinesToStr([ // statements
  5212. 'this.Orange = 0;',
  5213. 'this.Enum = 0;',
  5214. 'this.Enums = {};',
  5215. '']),
  5216. LinesToStr([
  5217. '$mod.Enums = {};',
  5218. '$mod.Enums = rtl.createSet(0);',
  5219. '$mod.Enums = rtl.createSet(null, 1, 2);',
  5220. 'if (0 in $mod.Enums) ;',
  5221. 'if (0 in rtl.createSet(0, 1)) ;',
  5222. '']));
  5223. end;
  5224. procedure TTestModule.TestSet_AnonymousEnumType;
  5225. begin
  5226. StartProgram(false);
  5227. Add('type');
  5228. Add(' TFlags = set of (red, green);');
  5229. Add('const');
  5230. Add(' favorite = red;');
  5231. Add('var');
  5232. Add(' f: TFlags;');
  5233. Add(' i: longint;');
  5234. Add('begin');
  5235. Add(' Include(f,red);');
  5236. Add(' Include(f,favorite);');
  5237. Add(' i:=ord(red);');
  5238. Add(' i:=ord(favorite);');
  5239. Add(' i:=ord(low(TFlags));');
  5240. Add(' i:=ord(low(f));');
  5241. Add(' i:=ord(low(favorite));');
  5242. Add(' i:=ord(high(TFlags));');
  5243. Add(' i:=ord(high(f));');
  5244. Add(' i:=ord(high(favorite));');
  5245. Add(' f:=[green,favorite];');
  5246. ConvertProgram;
  5247. CheckSource('TestSet_AnonymousEnumType',
  5248. LinesToStr([ // statements
  5249. 'this.TFlags$a = {',
  5250. ' "0": "red",',
  5251. ' red: 0,',
  5252. ' "1": "green",',
  5253. ' green: 1',
  5254. '};',
  5255. 'this.favorite = $mod.TFlags$a.red;',
  5256. 'this.f = {};',
  5257. 'this.i = 0;',
  5258. '']),
  5259. LinesToStr([
  5260. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  5261. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  5262. '$mod.i = $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.green;',
  5268. '$mod.i = $mod.TFlags$a.green;',
  5269. '$mod.i = $mod.TFlags$a.green;',
  5270. '$mod.f = rtl.createSet($mod.TFlags$a.green, $mod.TFlags$a.red);',
  5271. '']));
  5272. end;
  5273. procedure TTestModule.TestSet_AnonymousEnumTypeChar;
  5274. begin
  5275. exit;
  5276. StartProgram(false);
  5277. Add([
  5278. 'type',
  5279. ' TAtoZ = ''A''..''Z'';',
  5280. ' TSetOfAZ = set of TAtoZ;',
  5281. 'var',
  5282. ' c: char;',
  5283. ' a: TAtoZ;',
  5284. ' s: TSetOfAZ = [''P'',''A''];',
  5285. ' i: longint;',
  5286. 'begin',
  5287. ' Include(s,''S'');',
  5288. ' Include(s,c);',
  5289. ' Include(s,a);',
  5290. ' c:=low(TAtoZ);',
  5291. ' i:=ord(low(TAtoZ));',
  5292. ' a:=high(TAtoZ);',
  5293. ' a:=high(TSetOfAtoZ);',
  5294. ' s:=[a,c,''M''];',
  5295. '']);
  5296. ConvertProgram;
  5297. CheckSource('TestSet_AnonymousEnumTypeChar',
  5298. LinesToStr([ // statements
  5299. '']),
  5300. LinesToStr([
  5301. '']));
  5302. end;
  5303. procedure TTestModule.TestSet_ConstEnum;
  5304. begin
  5305. StartProgram(false);
  5306. Add([
  5307. 'type',
  5308. ' TEnum = (red,blue,green);',
  5309. ' TEnums = set of TEnum;',
  5310. 'const',
  5311. ' teAny = [low(TEnum)..high(TEnum)];',
  5312. ' teRedBlue = [low(TEnum)..pred(high(TEnum))];',
  5313. 'var',
  5314. ' e: TEnum;',
  5315. ' s: TEnums;',
  5316. 'begin',
  5317. ' if blue in teAny then;',
  5318. ' if blue in teAny+[e] then;',
  5319. ' if blue in teAny+teRedBlue then;',
  5320. ' if e in [red,blue] then;',
  5321. ' s:=teAny;',
  5322. ' s:=teAny+[e];',
  5323. ' s:=[e]+teAny;',
  5324. ' s:=teAny+teRedBlue;',
  5325. ' s:=teAny+teRedBlue+[e];',
  5326. '']);
  5327. ConvertProgram;
  5328. CheckSource('TestSet_ConstEnum',
  5329. LinesToStr([ // statements
  5330. 'this.TEnum = {',
  5331. ' "0": "red",',
  5332. ' red: 0,',
  5333. ' "1": "blue",',
  5334. ' blue: 1,',
  5335. ' "2": "green",',
  5336. ' green: 2',
  5337. '};',
  5338. 'this.teAny = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green);',
  5339. 'this.teRedBlue = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green - 1);',
  5340. 'this.e = 0;',
  5341. 'this.s = {};',
  5342. '']),
  5343. LinesToStr([
  5344. 'if ($mod.TEnum.blue in $mod.teAny) ;',
  5345. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, rtl.createSet($mod.e))) ;',
  5346. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, $mod.teRedBlue)) ;',
  5347. 'if ($mod.e in rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)) ;',
  5348. '$mod.s = rtl.refSet($mod.teAny);',
  5349. '$mod.s = rtl.unionSet($mod.teAny, rtl.createSet($mod.e));',
  5350. '$mod.s = rtl.unionSet(rtl.createSet($mod.e), $mod.teAny);',
  5351. '$mod.s = rtl.unionSet($mod.teAny, $mod.teRedBlue);',
  5352. '$mod.s = rtl.unionSet(rtl.unionSet($mod.teAny, $mod.teRedBlue), rtl.createSet($mod.e));',
  5353. '']));
  5354. end;
  5355. procedure TTestModule.TestSet_ConstChar;
  5356. begin
  5357. StartProgram(false);
  5358. Add([
  5359. 'const',
  5360. ' LowChars = [''a''..''z''];',
  5361. ' Chars = LowChars+[''A''..''Z''];',
  5362. ' sc = [''А'', ''Я''];',
  5363. 'var',
  5364. ' c: char;',
  5365. ' s: string;',
  5366. 'begin',
  5367. ' if c in lowchars then ;',
  5368. ' if ''a'' in lowchars then ;',
  5369. ' if s[1] in lowchars then ;',
  5370. ' if c in chars then ;',
  5371. ' if c in [''a''..''z'',''_''] then ;',
  5372. ' if ''b'' in [''a''..''z'',''_''] then ;',
  5373. ' if ''Я'' in sc then ;',
  5374. '']);
  5375. ConvertProgram;
  5376. CheckSource('TestSet_ConstChar',
  5377. LinesToStr([ // statements
  5378. 'this.LowChars = rtl.createSet(null, 97, 122);',
  5379. 'this.Chars = rtl.unionSet($mod.LowChars, rtl.createSet(null, 65, 90));',
  5380. 'this.sc = rtl.createSet(1040, 1071);',
  5381. 'this.c = "";',
  5382. 'this.s = "";',
  5383. '']),
  5384. LinesToStr([
  5385. 'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
  5386. 'if (97 in $mod.LowChars) ;',
  5387. 'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
  5388. 'if ($mod.c.charCodeAt() in $mod.Chars) ;',
  5389. 'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
  5390. 'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
  5391. 'if (1071 in $mod.sc) ;',
  5392. '']));
  5393. end;
  5394. procedure TTestModule.TestSet_ConstInt;
  5395. begin
  5396. StartProgram(false);
  5397. Add([
  5398. 'const',
  5399. ' Months = [1..12];',
  5400. ' Mirror = [-12..-1]+Months;',
  5401. 'var',
  5402. ' i: smallint;',
  5403. 'begin',
  5404. ' if 3 in Months then;',
  5405. ' if i in Months+[i] then;',
  5406. ' if i in Months+Mirror then;',
  5407. ' if i in [4..6,8] then;',
  5408. '']);
  5409. ConvertProgram;
  5410. CheckSource('TestSet_ConstInt',
  5411. LinesToStr([ // statements
  5412. 'this.Months = rtl.createSet(null, 1, 12);',
  5413. 'this.Mirror = rtl.unionSet(rtl.createSet(null, -12, -1), $mod.Months);',
  5414. 'this.i = 0;',
  5415. '']),
  5416. LinesToStr([
  5417. 'if (3 in $mod.Months) ;',
  5418. 'if ($mod.i in rtl.unionSet($mod.Months, rtl.createSet($mod.i))) ;',
  5419. 'if ($mod.i in rtl.unionSet($mod.Months, $mod.Mirror)) ;',
  5420. 'if ($mod.i in rtl.createSet(null, 4, 6, 8)) ;',
  5421. '']));
  5422. end;
  5423. procedure TTestModule.TestSet_InFunction;
  5424. begin
  5425. StartProgram(false);
  5426. Add([
  5427. 'const',
  5428. ' TEnum = 3;',
  5429. ' TSetOfEnum = 4;',
  5430. ' TSetOfAno = 5;',
  5431. 'procedure DoIt;',
  5432. 'type',
  5433. ' TEnum = (red, blue);',
  5434. ' TSetOfEnum = set of TEnum;',
  5435. ' TSetOfAno = set of (up,down);',
  5436. 'var',
  5437. ' e: TEnum;',
  5438. ' se: TSetOfEnum;',
  5439. ' sa: TSetOfAno;',
  5440. 'begin',
  5441. ' se:=[e];',
  5442. ' sa:=[up];',
  5443. 'end;',
  5444. 'begin',
  5445. '']);
  5446. ConvertProgram;
  5447. CheckSource('TestSet_InFunction',
  5448. LinesToStr([ // statements
  5449. 'this.TEnum = 3;',
  5450. 'this.TSetOfEnum = 4;',
  5451. 'this.TSetOfAno = 5;',
  5452. 'var TEnum$1 = {',
  5453. ' "0": "red",',
  5454. ' red: 0,',
  5455. ' "1": "blue",',
  5456. ' blue: 1',
  5457. '};',
  5458. 'var TSetOfAno$a = {',
  5459. ' "0": "up",',
  5460. ' up: 0,',
  5461. ' "1": "down",',
  5462. ' down: 1',
  5463. '};',
  5464. 'this.DoIt = function () {',
  5465. ' var e = 0;',
  5466. ' var se = {};',
  5467. ' var sa = {};',
  5468. ' se = rtl.createSet(e);',
  5469. ' sa = rtl.createSet(TSetOfAno$a.up);',
  5470. '};',
  5471. '']),
  5472. LinesToStr([
  5473. '']));
  5474. end;
  5475. procedure TTestModule.TestSet_ForIn;
  5476. begin
  5477. StartProgram(false);
  5478. Add([
  5479. 'type',
  5480. ' TEnum = (Red, Green, Blue);',
  5481. ' TEnumRg = green..blue;',
  5482. ' TSetOfEnum = set of TEnum;',
  5483. ' TSetOfEnumRg = set of TEnumRg;',
  5484. 'var',
  5485. ' e, e2: TEnum;',
  5486. ' er: TEnum;',
  5487. ' s: TSetOfEnum;',
  5488. 'begin',
  5489. ' for e in TSetOfEnum do ;',
  5490. ' for e in TSetOfEnumRg do ;',
  5491. ' for e in [] do e2:=e;',
  5492. ' for e in [red..green] do e2:=e;',
  5493. ' for e in [green,blue] do e2:=e;',
  5494. ' for e in [red,blue] do e2:=e;',
  5495. ' for e in s do e2:=e;',
  5496. ' for er in TSetOfEnumRg do ;',
  5497. '']);
  5498. ConvertProgram;
  5499. CheckSource('TestSet_ForIn',
  5500. LinesToStr([ // statements
  5501. 'this.TEnum = {',
  5502. ' "0":"Red",',
  5503. ' Red:0,',
  5504. ' "1":"Green",',
  5505. ' Green:1,',
  5506. ' "2":"Blue",',
  5507. ' Blue:2',
  5508. ' };',
  5509. 'this.e = 0;',
  5510. 'this.e2 = 0;',
  5511. 'this.er = 0;',
  5512. 'this.s = {};',
  5513. '']),
  5514. LinesToStr([
  5515. 'for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  5516. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  5517. 'for ($mod.e = 0; $mod.e <= 1; $mod.e++) $mod.e2 = $mod.e;',
  5518. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) $mod.e2 = $mod.e;',
  5519. 'for ($mod.e in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Blue)) $mod.e2 = $mod.e;',
  5520. 'for (var $l1 in $mod.s){',
  5521. ' $mod.e = +$l1;',
  5522. ' $mod.e2 = $mod.e;',
  5523. '};',
  5524. 'for ($mod.er = 1; $mod.er <= 2; $mod.er++) ;',
  5525. '']));
  5526. end;
  5527. procedure TTestModule.TestNestBegin;
  5528. begin
  5529. StartProgram(false);
  5530. Add('begin');
  5531. Add(' begin');
  5532. Add(' begin');
  5533. Add(' end;');
  5534. Add(' begin');
  5535. Add(' if true then ;');
  5536. Add(' end;');
  5537. Add(' end;');
  5538. ConvertProgram;
  5539. CheckSource('TestNestBegin',
  5540. '',
  5541. 'if (true) ;');
  5542. end;
  5543. procedure TTestModule.TestUnitImplVars;
  5544. begin
  5545. StartUnit(false);
  5546. Add('interface');
  5547. Add('implementation');
  5548. Add('var');
  5549. Add(' V1:longint;');
  5550. Add(' V2:longint = 3;');
  5551. Add(' V3:string = ''abc'';');
  5552. ConvertUnit;
  5553. CheckSource('TestUnitImplVars',
  5554. LinesToStr([ // statements
  5555. 'var $impl = $mod.$impl;',
  5556. '']),
  5557. '', // this.$init
  5558. LinesToStr([ // implementation
  5559. '$impl.V1 = 0;',
  5560. '$impl.V2 = 3;',
  5561. '$impl.V3 = "abc";',
  5562. '']) );
  5563. end;
  5564. procedure TTestModule.TestUnitImplConsts;
  5565. begin
  5566. StartUnit(false);
  5567. Add('interface');
  5568. Add('implementation');
  5569. Add('const');
  5570. Add(' v1 = 3;');
  5571. Add(' v2:longint = 4;');
  5572. Add(' v3:string = ''abc'';');
  5573. ConvertUnit;
  5574. CheckSource('TestUnitImplConsts',
  5575. LinesToStr([ // statements
  5576. 'var $impl = $mod.$impl;',
  5577. '']),
  5578. '', // this.$init
  5579. LinesToStr([ // implementation
  5580. '$impl.v1 = 3;',
  5581. '$impl.v2 = 4;',
  5582. '$impl.v3 = "abc";',
  5583. '']) );
  5584. end;
  5585. procedure TTestModule.TestUnitImplRecord;
  5586. begin
  5587. StartUnit(false);
  5588. Add('interface');
  5589. Add('implementation');
  5590. Add('type');
  5591. Add(' TMyRecord = record');
  5592. Add(' i: longint;');
  5593. Add(' end;');
  5594. Add('var aRec: TMyRecord;');
  5595. Add('initialization');
  5596. Add(' arec.i:=3;');
  5597. ConvertUnit;
  5598. CheckSource('TestUnitImplRecord',
  5599. LinesToStr([ // statements
  5600. 'var $impl = $mod.$impl;',
  5601. '']),
  5602. // this.$init
  5603. '$impl.aRec.i = 3;',
  5604. LinesToStr([ // implementation
  5605. 'rtl.recNewT($impl, "TMyRecord", function () {',
  5606. ' this.i = 0;',
  5607. ' this.$eq = function (b) {',
  5608. ' return this.i === b.i;',
  5609. ' };',
  5610. ' this.$assign = function (s) {',
  5611. ' this.i = s.i;',
  5612. ' return this;',
  5613. ' };',
  5614. '});',
  5615. '$impl.aRec = $impl.TMyRecord.$new();',
  5616. '']) );
  5617. end;
  5618. procedure TTestModule.TestRenameJSNameConflict;
  5619. begin
  5620. StartProgram(false);
  5621. Add('var apply: longint;');
  5622. Add('var bind: longint;');
  5623. Add('var call: longint;');
  5624. Add('begin');
  5625. ConvertProgram;
  5626. CheckSource('TestRenameJSNameConflict',
  5627. LinesToStr([ // statements
  5628. 'this.Apply = 0;',
  5629. 'this.Bind = 0;',
  5630. 'this.Call = 0;'
  5631. ]),
  5632. LinesToStr([ // this.$main
  5633. ''
  5634. ]));
  5635. end;
  5636. procedure TTestModule.TestLocalConst;
  5637. begin
  5638. StartProgram(false);
  5639. Add('procedure DoIt;');
  5640. Add('const');
  5641. Add(' cA: longint = 1;');
  5642. Add(' cB = 2;');
  5643. Add(' procedure Sub;');
  5644. Add(' const');
  5645. Add(' csA = 3;');
  5646. Add(' cB: double = 4;');
  5647. Add(' begin');
  5648. Add(' cb:=cb+csa;');
  5649. Add(' ca:=ca+csa+5;');
  5650. Add(' end;');
  5651. Add('begin');
  5652. Add(' ca:=ca+cb+6;');
  5653. Add('end;');
  5654. Add('begin');
  5655. ConvertProgram;
  5656. CheckSource('TestLocalConst',
  5657. LinesToStr([
  5658. 'var cA = 1;',
  5659. 'var cB = 2;',
  5660. 'var csA = 3;',
  5661. 'var cB$1 = 4;',
  5662. 'this.DoIt = function () {',
  5663. ' function Sub() {',
  5664. ' cB$1 = cB$1 + 3;',
  5665. ' cA = cA + 3 + 5;',
  5666. ' };',
  5667. ' cA = cA + 2 + 6;',
  5668. '};'
  5669. ]),
  5670. LinesToStr([
  5671. ]));
  5672. end;
  5673. procedure TTestModule.TestVarExternal;
  5674. begin
  5675. StartProgram(false);
  5676. Add('var');
  5677. Add(' NaN: double; external name ''Global.NaN'';');
  5678. Add(' d: double;');
  5679. Add('begin');
  5680. Add(' d:=NaN;');
  5681. ConvertProgram;
  5682. CheckSource('TestVarExternal',
  5683. LinesToStr([
  5684. 'this.d = 0.0;'
  5685. ]),
  5686. LinesToStr([
  5687. '$mod.d = Global.NaN;'
  5688. ]));
  5689. end;
  5690. procedure TTestModule.TestVarExternalOtherUnit;
  5691. begin
  5692. AddModuleWithIntfImplSrc('unit2.pas',
  5693. LinesToStr([
  5694. 'var NaN: double; external name ''Global.NaN'';',
  5695. 'var iV: longint;'
  5696. ]),
  5697. '');
  5698. StartUnit(true);
  5699. Add('interface');
  5700. Add('uses unit2;');
  5701. Add('implementation');
  5702. Add('var');
  5703. Add(' d: double;');
  5704. Add(' i: longint; external name ''$i'';');
  5705. Add('begin');
  5706. Add(' d:=nan;');
  5707. Add(' d:=uNit2.nan;');
  5708. Add(' d:=test1.d;');
  5709. Add(' i:=iv;');
  5710. Add(' i:=uNit2.iv;');
  5711. Add(' i:=test1.i;');
  5712. ConvertUnit;
  5713. CheckSource('TestVarExternalOtherUnit',
  5714. LinesToStr([
  5715. 'var $impl = $mod.$impl;',
  5716. '']),
  5717. LinesToStr([ // this.$init
  5718. '$impl.d = Global.NaN;',
  5719. '$impl.d = Global.NaN;',
  5720. '$impl.d = $impl.d;',
  5721. '$i = pas.unit2.iV;',
  5722. '$i = pas.unit2.iV;',
  5723. '$i = $i;',
  5724. '']),
  5725. LinesToStr([ // implementation
  5726. '$impl.d = 0.0;',
  5727. '']) );
  5728. end;
  5729. procedure TTestModule.TestVarAbsoluteFail;
  5730. begin
  5731. StartProgram(false);
  5732. Add([
  5733. 'var',
  5734. ' a: longint;',
  5735. ' b: longword absolute a;',
  5736. 'begin']);
  5737. SetExpectedPasResolverError('Invalid variable modifier "absolute"',nInvalidVariableModifier);
  5738. ConvertProgram;
  5739. end;
  5740. procedure TTestModule.TestConstExternal;
  5741. begin
  5742. StartProgram(false);
  5743. Add([
  5744. 'const',
  5745. ' PI: double; external name ''Global.PI'';',
  5746. ' Tau = 2*pi;',
  5747. 'var d: double;',
  5748. 'begin',
  5749. ' d:=pi;',
  5750. ' d:=tau+pi;']);
  5751. ConvertProgram;
  5752. CheckSource('TestConstExternal',
  5753. LinesToStr([
  5754. 'this.Tau = 2*Global.PI;',
  5755. 'this.d = 0.0;'
  5756. ]),
  5757. LinesToStr([
  5758. '$mod.d = Global.PI;',
  5759. '$mod.d = $mod.Tau + Global.PI;'
  5760. ]));
  5761. end;
  5762. procedure TTestModule.TestDouble;
  5763. begin
  5764. StartProgram(false);
  5765. Add([
  5766. 'type',
  5767. ' TDateTime = double;',
  5768. 'const',
  5769. ' a = TDateTime(2.7);',
  5770. ' b = a + TDateTime(1.7);',
  5771. ' c = 0.9 + 0.1;',
  5772. ' f0_1 = 0.1;',
  5773. ' f0_3 = 0.3;',
  5774. ' fn0_1 = -0.1;',
  5775. ' fn0_3 = -0.3;',
  5776. ' fn0_003 = -0.003;',
  5777. ' fn0_123456789 = -0.123456789;',
  5778. ' fn300_0 = -300.0;',
  5779. ' fn123456_0 = -123456.0;',
  5780. ' fn1234567_8 = -1234567.8;',
  5781. ' fn12345678_9 = -12345678.9;',
  5782. ' f1_0En12 = 1E-12;',
  5783. ' fn1_0En12 = -1E-12;',
  5784. ' maxdouble = 1.7e+308;',
  5785. ' mindouble = -1.7e+308;',
  5786. ' MinSafeIntDouble = -$10000000000000;',
  5787. ' MinSafeIntDouble2 = -$fffffffffffff-1;',
  5788. ' MaxSafeIntDouble = $fffffffffffff;',
  5789. ' DZeroResolution = 1E-12;',
  5790. ' Minus1 = -1E-12;',
  5791. ' EPS = 1E-9;',
  5792. ' DELTA = 0.001;',
  5793. ' Big = 129.789E+100;',
  5794. ' Test0_15 = 0.15;',
  5795. ' Test999 = 2.9999999999999;',
  5796. ' Test111999 = 211199999999999000.0;',
  5797. ' TestMinus111999 = -211199999999999000.0;',
  5798. 'var',
  5799. ' d: double = b;',
  5800. 'begin',
  5801. ' d:=1.0;',
  5802. ' d:=1.0/3.0;',
  5803. ' d:=1/3;',
  5804. ' d:=5.0E-324;',
  5805. ' d:=1.7E308;',
  5806. ' d:=001.00E00;',
  5807. ' d:=002.00E001;',
  5808. ' d:=003.000E000;',
  5809. ' d:=-004.00E-00;',
  5810. ' d:=-005.00E-001;',
  5811. ' d:=10**3;',
  5812. ' d:=10 mod 3;',
  5813. ' d:=10 div 3;',
  5814. ' d:=c;',
  5815. ' d:=f0_1;',
  5816. ' d:=f0_3;',
  5817. ' d:=fn0_1;',
  5818. ' d:=fn0_3;',
  5819. ' d:=fn0_003;',
  5820. ' d:=fn0_123456789;',
  5821. ' d:=fn300_0;',
  5822. ' d:=fn123456_0;',
  5823. ' d:=fn1234567_8;',
  5824. ' d:=fn12345678_9;',
  5825. ' d:=f1_0En12;',
  5826. ' d:=fn1_0En12;',
  5827. ' d:=maxdouble;',
  5828. ' d:=mindouble;',
  5829. ' d:=MinSafeIntDouble;',
  5830. ' d:=double(MinSafeIntDouble);',
  5831. ' d:=MinSafeIntDouble2;',
  5832. ' d:=double(MinSafeIntDouble2);',
  5833. ' d:=MaxSafeIntDouble;',
  5834. ' d:=default(double);',
  5835. '']);
  5836. ConvertProgram;
  5837. CheckSource('TestDouble',
  5838. LinesToStr([
  5839. 'this.a = 2.7;',
  5840. 'this.b = 2.7 + 1.7;',
  5841. 'this.c = 0.9 + 0.1;',
  5842. 'this.f0_1 = 0.1;',
  5843. 'this.f0_3 = 0.3;',
  5844. 'this.fn0_1 = -0.1;',
  5845. 'this.fn0_3 = -0.3;',
  5846. 'this.fn0_003 = -0.003;',
  5847. 'this.fn0_123456789 = -0.123456789;',
  5848. 'this.fn300_0 = -300.0;',
  5849. 'this.fn123456_0 = -123456.0;',
  5850. 'this.fn1234567_8 = -1234567.8;',
  5851. 'this.fn12345678_9 = -12345678.9;',
  5852. 'this.f1_0En12 = 1E-12;',
  5853. 'this.fn1_0En12 = -1E-12;',
  5854. 'this.maxdouble = 1.7e+308;',
  5855. 'this.mindouble = -1.7e+308;',
  5856. 'this.MinSafeIntDouble = -0x10000000000000;',
  5857. 'this.MinSafeIntDouble2 = -0xfffffffffffff - 1;',
  5858. 'this.MaxSafeIntDouble = 0xfffffffffffff;',
  5859. 'this.DZeroResolution = 1E-12;',
  5860. 'this.Minus1 = -1E-12;',
  5861. 'this.EPS = 1E-9;',
  5862. 'this.DELTA = 0.001;',
  5863. 'this.Big = 129.789E+100;',
  5864. 'this.Test0_15 = 0.15;',
  5865. 'this.Test999 = 2.9999999999999;',
  5866. 'this.Test111999 = 211199999999999000.0;',
  5867. 'this.TestMinus111999 = -211199999999999000.0;',
  5868. 'this.d = 4.4;'
  5869. ]),
  5870. LinesToStr([
  5871. '$mod.d = 1.0;',
  5872. '$mod.d = 1.0 / 3.0;',
  5873. '$mod.d = 1 / 3;',
  5874. '$mod.d = 5.0E-324;',
  5875. '$mod.d = 1.7E308;',
  5876. '$mod.d = 1.00E0;',
  5877. '$mod.d = 2.00E1;',
  5878. '$mod.d = 3.000E0;',
  5879. '$mod.d = -4.00E-0;',
  5880. '$mod.d = -5.00E-1;',
  5881. '$mod.d = Math.pow(10, 3);',
  5882. '$mod.d = 10 % 3;',
  5883. '$mod.d = Math.floor(10 / 3);',
  5884. '$mod.d = 1;',
  5885. '$mod.d = 0.1;',
  5886. '$mod.d = 0.3;',
  5887. '$mod.d = -0.1;',
  5888. '$mod.d = -0.3;',
  5889. '$mod.d = -0.003;',
  5890. '$mod.d = -0.123456789;',
  5891. '$mod.d = -300;',
  5892. '$mod.d = -123456;',
  5893. '$mod.d = -1234567.8;',
  5894. '$mod.d = -1.23456789E7;',
  5895. '$mod.d = 1E-12;',
  5896. '$mod.d = -1E-12;',
  5897. '$mod.d = 1.7E308;',
  5898. '$mod.d = -1.7E308;',
  5899. '$mod.d = -4503599627370496;',
  5900. '$mod.d = -4503599627370496;',
  5901. '$mod.d = -4503599627370496;',
  5902. '$mod.d = -4503599627370496;',
  5903. '$mod.d = 4503599627370495;',
  5904. '$mod.d = 0.0;',
  5905. '']));
  5906. end;
  5907. procedure TTestModule.TestInteger;
  5908. begin
  5909. StartProgram(false);
  5910. Add([
  5911. 'const',
  5912. ' MinInt = low(NativeInt);',
  5913. ' MaxInt = high(NativeInt);',
  5914. 'type',
  5915. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  5916. 'const',
  5917. ' a = low(TMyInt)+High(TMyInt);',
  5918. 'var',
  5919. ' i: TMyInt;',
  5920. 'begin',
  5921. ' i:=-MinInt;',
  5922. ' i:=default(TMyInt);',
  5923. ' i:=low(i)+high(i);',
  5924. '']);
  5925. ConvertProgram;
  5926. CheckSource('TestIntegerRange',
  5927. LinesToStr([
  5928. 'this.MinInt = -4503599627370496;',
  5929. 'this.MaxInt = 4503599627370495;',
  5930. 'this.a = -4503599627370496 + 4503599627370495;',
  5931. 'this.i = 0;',
  5932. '']),
  5933. LinesToStr([
  5934. '$mod.i = - -4503599627370496;',
  5935. '$mod.i = -4503599627370496;',
  5936. '$mod.i = -4503599627370496 + 4503599627370495;',
  5937. '']));
  5938. end;
  5939. procedure TTestModule.TestIntegerRange;
  5940. begin
  5941. StartProgram(false);
  5942. Add([
  5943. 'const',
  5944. ' MinInt = -1;',
  5945. ' MaxInt = +1;',
  5946. 'type',
  5947. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  5948. ' TInt2 = 1..3;',
  5949. 'const',
  5950. ' a = low(TMyInt)+High(TMyInt);',
  5951. ' b = low(TInt2)+High(TInt2);',
  5952. ' s1 = [1];',
  5953. ' s2 = [1,2];',
  5954. ' s3 = [1..3];',
  5955. ' s4 = [low(shortint)..high(shortint)];',
  5956. ' s5 = [succ(low(shortint))..pred(high(shortint))];',
  5957. ' s6 = 1 in s2;',
  5958. 'var',
  5959. ' i: TMyInt;',
  5960. ' i2: TInt2;',
  5961. 'begin',
  5962. ' i:=i2;',
  5963. ' i:=default(TMyInt);',
  5964. ' if i=i2 then ;']);
  5965. ConvertProgram;
  5966. CheckSource('TestIntegerRange',
  5967. LinesToStr([
  5968. 'this.MinInt = -1;',
  5969. 'this.MaxInt = +1;',
  5970. 'this.a = -1 + 1;',
  5971. 'this.b = 1 + 3;',
  5972. 'this.s1 = rtl.createSet(1);',
  5973. 'this.s2 = rtl.createSet(1, 2);',
  5974. 'this.s3 = rtl.createSet(null, 1, 3);',
  5975. 'this.s4 = rtl.createSet(null, -128, 127);',
  5976. 'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
  5977. 'this.s6 = 1 in $mod.s2;',
  5978. 'this.i = 0;',
  5979. 'this.i2 = 0;',
  5980. '']),
  5981. LinesToStr([
  5982. '$mod.i = $mod.i2;',
  5983. '$mod.i = -1;',
  5984. 'if ($mod.i === $mod.i2) ;',
  5985. '']));
  5986. end;
  5987. procedure TTestModule.TestIntegerTypecasts;
  5988. begin
  5989. StartProgram(false);
  5990. Add([
  5991. 'var',
  5992. ' i: nativeint;',
  5993. ' b: byte;',
  5994. ' sh: shortint;',
  5995. ' w: word;',
  5996. ' sm: smallint;',
  5997. ' lw: longword;',
  5998. ' li: longint;',
  5999. 'begin',
  6000. ' b:=byte(i);',
  6001. ' sh:=shortint(i);',
  6002. ' w:=word(i);',
  6003. ' sm:=smallint(i);',
  6004. ' lw:=longword(i);',
  6005. ' li:=longint(i);',
  6006. '']);
  6007. ConvertProgram;
  6008. CheckSource('TestIntegerTypecasts',
  6009. LinesToStr([
  6010. 'this.i = 0;',
  6011. 'this.b = 0;',
  6012. 'this.sh = 0;',
  6013. 'this.w = 0;',
  6014. 'this.sm = 0;',
  6015. 'this.lw = 0;',
  6016. 'this.li = 0;',
  6017. '']),
  6018. LinesToStr([
  6019. '$mod.b = $mod.i & 255;',
  6020. '$mod.sh = (($mod.i & 255) << 24) >> 24;',
  6021. '$mod.w = $mod.i & 65535;',
  6022. '$mod.sm = (($mod.i & 65535) << 16) >> 16;',
  6023. '$mod.lw = $mod.i >>> 0;',
  6024. '$mod.li = $mod.i & 0xFFFFFFFF;',
  6025. '']));
  6026. end;
  6027. procedure TTestModule.TestBitwiseAndNativeIntWarn;
  6028. begin
  6029. StartProgram(false);
  6030. Add([
  6031. 'var',
  6032. ' i,j: nativeint;',
  6033. 'begin',
  6034. ' i:=i and j;',
  6035. '']);
  6036. ConvertProgram;
  6037. CheckSource('TestBitwiseAndNativeIntWarn',
  6038. LinesToStr([
  6039. 'this.i = 0;',
  6040. 'this.j = 0;',
  6041. '']),
  6042. LinesToStr([
  6043. '$mod.i = $mod.i & $mod.j;',
  6044. '']));
  6045. CheckHint(mtWarning,nBitWiseOperationsAre32Bit,sBitWiseOperationsAre32Bit);
  6046. end;
  6047. procedure TTestModule.TestCurrency;
  6048. begin
  6049. StartProgram(false);
  6050. Add([
  6051. 'type',
  6052. ' TCoin = currency;',
  6053. 'const',
  6054. ' a = TCoin(2.7);',
  6055. ' b = a + TCoin(1.7);',
  6056. ' MinSafeIntCurrency: TCoin = -92233720368.5477;',
  6057. ' MaxSafeIntCurrency: TCoin = 92233720368.5477;',
  6058. 'var',
  6059. ' c: TCoin = b;',
  6060. ' i: nativeint;',
  6061. ' d: double;',
  6062. ' j: jsvalue;',
  6063. 'function DoIt(c: currency): currency; begin end;',
  6064. 'function GetIt(d: double): double; begin end;',
  6065. 'procedure Write(v: jsvalue); begin end;',
  6066. 'begin',
  6067. ' c:=1.0;',
  6068. ' c:=0.1;',
  6069. ' c:=1.0/3.0;',
  6070. ' c:=1/3;',
  6071. ' c:=a;',
  6072. ' d:=c;',
  6073. ' c:=d;',
  6074. ' c:=currency(c);',
  6075. ' c:=currency(d);',
  6076. ' d:=double(c);',
  6077. ' c:=i;',
  6078. ' c:=currency(i);',
  6079. //' i:=c;', not allowed
  6080. ' i:=nativeint(c);',
  6081. ' c:=c+a;',
  6082. ' c:=-c-a;',
  6083. ' c:=d+c;',
  6084. ' c:=c+d;',
  6085. ' c:=d-c;',
  6086. ' c:=c-d;',
  6087. ' c:=c*a;',
  6088. ' c:=a*c;',
  6089. ' c:=d*c;',
  6090. ' c:=c*d;',
  6091. ' c:=c/a;',
  6092. ' c:=a/c;',
  6093. ' c:=d/c;',
  6094. ' c:=c/d;',
  6095. ' c:=c**a;',
  6096. ' c:=a**c;',
  6097. ' c:=d**c;',
  6098. ' c:=c**d;',
  6099. ' if c=c then ;',
  6100. ' if c=a then ;',
  6101. ' if a=c then ;',
  6102. ' if d=c then ;',
  6103. ' if c=d then ;',
  6104. ' c:=DoIt(c);',
  6105. ' c:=DoIt(i);',
  6106. ' c:=DoIt(d);',
  6107. ' c:=GetIt(c);',
  6108. ' j:=c;',
  6109. ' Write(c);',
  6110. ' c:=default(currency);',
  6111. ' j:=str(c);',
  6112. ' j:=str(c:0:3);',
  6113. '']);
  6114. ConvertProgram;
  6115. CheckSource('TestCurrency',
  6116. LinesToStr([
  6117. 'this.a = 27000;',
  6118. 'this.b = $mod.a + 17000;',
  6119. 'this.MinSafeIntCurrency = -92233720368.5477;',
  6120. 'this.MaxSafeIntCurrency = 92233720368.5477;',
  6121. 'this.c = $mod.b;',
  6122. 'this.i = 0;',
  6123. 'this.d = 0.0;',
  6124. 'this.j = undefined;',
  6125. 'this.DoIt = function (c) {',
  6126. ' var Result = 0;',
  6127. ' return Result;',
  6128. '};',
  6129. 'this.GetIt = function (d) {',
  6130. ' var Result = 0.0;',
  6131. ' return Result;',
  6132. '};',
  6133. 'this.Write = function (v) {',
  6134. '};',
  6135. '']),
  6136. LinesToStr([
  6137. '$mod.c = 10000;',
  6138. '$mod.c = 1000;',
  6139. '$mod.c = Math.floor((1.0 / 3.0) * 10000);',
  6140. '$mod.c = Math.floor((1 / 3) * 10000);',
  6141. '$mod.c = $mod.a;',
  6142. '$mod.d = $mod.c / 10000;',
  6143. '$mod.c = Math.floor($mod.d * 10000);',
  6144. '$mod.c = $mod.c;',
  6145. '$mod.c = $mod.d * 10000;',
  6146. '$mod.d = $mod.c / 10000;',
  6147. '$mod.c = $mod.i * 10000;',
  6148. '$mod.c = $mod.i * 10000;',
  6149. '$mod.i = Math.floor($mod.c / 10000);',
  6150. '$mod.c = $mod.c + $mod.a;',
  6151. '$mod.c = -$mod.c - $mod.a;',
  6152. '$mod.c = ($mod.d * 10000) + $mod.c;',
  6153. '$mod.c = $mod.c + ($mod.d * 10000);',
  6154. '$mod.c = ($mod.d * 10000) - $mod.c;',
  6155. '$mod.c = $mod.c - ($mod.d * 10000);',
  6156. '$mod.c = ($mod.c * $mod.a) / 10000;',
  6157. '$mod.c = ($mod.a * $mod.c) / 10000;',
  6158. '$mod.c = $mod.d * $mod.c;',
  6159. '$mod.c = $mod.c * $mod.d;',
  6160. '$mod.c = Math.floor(($mod.c / $mod.a) * 10000);',
  6161. '$mod.c = Math.floor(($mod.a / $mod.c) * 10000);',
  6162. '$mod.c = Math.floor($mod.d / $mod.c);',
  6163. '$mod.c = Math.floor($mod.c / $mod.d);',
  6164. '$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.a / 10000) * 10000);',
  6165. '$mod.c = Math.floor(Math.pow($mod.a / 10000, $mod.c / 10000) * 10000);',
  6166. '$mod.c = Math.floor(Math.pow($mod.d, $mod.c / 10000) * 10000);',
  6167. '$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.d) * 10000);',
  6168. 'if ($mod.c === $mod.c) ;',
  6169. 'if ($mod.c === $mod.a) ;',
  6170. 'if ($mod.a === $mod.c) ;',
  6171. 'if (($mod.d * 10000) === $mod.c) ;',
  6172. 'if ($mod.c === ($mod.d * 10000)) ;',
  6173. '$mod.c = $mod.DoIt($mod.c);',
  6174. '$mod.c = $mod.DoIt($mod.i * 10000);',
  6175. '$mod.c = $mod.DoIt($mod.d * 10000);',
  6176. '$mod.c = Math.floor($mod.GetIt($mod.c / 10000) * 10000);',
  6177. '$mod.j = $mod.c / 10000;',
  6178. '$mod.Write($mod.c / 10000);',
  6179. '$mod.c = 0;',
  6180. '$mod.j = rtl.floatToStr($mod.c / 10000);',
  6181. '$mod.j = rtl.floatToStr($mod.c / 10000, 0, 3);',
  6182. '']));
  6183. end;
  6184. procedure TTestModule.TestForBoolDo;
  6185. begin
  6186. StartProgram(false);
  6187. Add([
  6188. 'var b: boolean;',
  6189. 'begin',
  6190. ' for b:=false to true do ;',
  6191. ' for b:=b downto false do ;',
  6192. ' for b in boolean do ;',
  6193. '']);
  6194. ConvertProgram;
  6195. CheckSource('TestForBoolDo',
  6196. LinesToStr([ // statements
  6197. 'this.b = false;']),
  6198. LinesToStr([ // this.$main
  6199. 'for (var $l1 = 0; $l1 <= 1; $l1++) $mod.b = $l1 !== 0;',
  6200. 'for (var $l2 = +$mod.b; $l2 >= 0; $l2--) $mod.b = $l2 !== 0;',
  6201. 'for (var $l3 = 0; $l3 <= 1; $l3++) $mod.b = $l3 !== 0;',
  6202. '']));
  6203. end;
  6204. procedure TTestModule.TestForIntDo;
  6205. begin
  6206. StartProgram(false);
  6207. Add([
  6208. 'var i: longint;',
  6209. 'begin',
  6210. ' for i:=3 to 5 do ;',
  6211. ' for i:=i downto 2 do ;',
  6212. ' for i in byte do ;',
  6213. '']);
  6214. ConvertProgram;
  6215. CheckSource('TestForIntDo',
  6216. LinesToStr([ // statements
  6217. 'this.i = 0;']),
  6218. LinesToStr([ // this.$main
  6219. 'for ($mod.i = 3; $mod.i <= 5; $mod.i++) ;',
  6220. 'for (var $l1 = $mod.i; $l1 >= 2; $l1--) $mod.i = $l1;',
  6221. 'for (var $l2 = 0; $l2 <= 255; $l2++) $mod.i = $l2;',
  6222. '']));
  6223. end;
  6224. procedure TTestModule.TestForIntInDo;
  6225. begin
  6226. StartProgram(false);
  6227. Add([
  6228. 'type',
  6229. ' TSetOfInt = set of byte;',
  6230. ' TIntRg = 3..7;',
  6231. ' TSetOfIntRg = set of TIntRg;',
  6232. 'var',
  6233. ' i,i2: longint;',
  6234. ' a1: array of byte;',
  6235. ' a2: array[1..3] of byte;',
  6236. ' soi: TSetOfInt;',
  6237. ' soir: TSetOfIntRg;',
  6238. ' ir: TIntRg;',
  6239. 'begin',
  6240. ' for i in byte do ;',
  6241. ' for i in a1 do ;',
  6242. ' for i in a2 do ;',
  6243. ' for i in [11..13] do ;',
  6244. ' for i in TSetOfInt do ;',
  6245. ' for i in TIntRg do ;',
  6246. ' for i in soi do i2:=i;',
  6247. ' for i in TSetOfIntRg do ;',
  6248. ' for i in soir do ;',
  6249. ' for ir in TIntRg do ;',
  6250. ' for ir in TSetOfIntRg do ;',
  6251. ' for ir in soir do ;',
  6252. '']);
  6253. ConvertProgram;
  6254. CheckSource('TestForIntInDo',
  6255. LinesToStr([ // statements
  6256. 'this.i = 0;',
  6257. 'this.i2 = 0;',
  6258. 'this.a1 = [];',
  6259. 'this.a2 = rtl.arraySetLength(null, 0, 3);',
  6260. 'this.soi = {};',
  6261. 'this.soir = {};',
  6262. 'this.ir = 0;',
  6263. '']),
  6264. LinesToStr([ // this.$main
  6265. 'for (var $l1 = 0; $l1 <= 255; $l1++) $mod.i = $l1;',
  6266. 'for (var $in2 = $mod.a1, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) $mod.i = $in2[$l3];',
  6267. 'for (var $in5 = $mod.a2, $l6 = 0, $end7 = rtl.length($in5) - 1; $l6 <= $end7; $l6++) $mod.i = $in5[$l6];',
  6268. 'for (var $l8 = 11; $l8 <= 13; $l8++) $mod.i = $l8;',
  6269. 'for (var $l9 = 0; $l9 <= 255; $l9++) $mod.i = $l9;',
  6270. 'for (var $l10 = 3; $l10 <= 7; $l10++) $mod.i = $l10;',
  6271. 'for (var $l11 in $mod.soi) {',
  6272. ' $mod.i = +$l11;',
  6273. ' $mod.i2 = $mod.i;',
  6274. '};',
  6275. 'for (var $l12 = 3; $l12 <= 7; $l12++) $mod.i = $l12;',
  6276. 'for (var $l13 in $mod.soir) $mod.i = +$l13;',
  6277. 'for (var $l14 = 3; $l14 <= 7; $l14++) $mod.ir = $l14;',
  6278. 'for (var $l15 = 3; $l15 <= 7; $l15++) $mod.ir = $l15;',
  6279. 'for (var $l16 in $mod.soir) $mod.ir = +$l16;',
  6280. '']));
  6281. end;
  6282. procedure TTestModule.TestCharConst;
  6283. begin
  6284. StartProgram(false);
  6285. Add([
  6286. 'const',
  6287. ' a = #$00F3;',
  6288. ' c: char = ''1'';',
  6289. 'begin',
  6290. ' c:=#0;',
  6291. ' c:=#1;',
  6292. ' c:=#9;',
  6293. ' c:=#10;',
  6294. ' c:=#13;',
  6295. ' c:=#31;',
  6296. ' c:=#32;',
  6297. ' c:=#$A;',
  6298. ' c:=#$0A;',
  6299. ' c:=#$b;',
  6300. ' c:=#$0b;',
  6301. ' c:=^A;',
  6302. ' c:=''"'';',
  6303. ' c:=default(char);',
  6304. ' c:=#$00E4;', // ä
  6305. ' c:=''ä'';',
  6306. ' c:=#$E4;', // ä
  6307. ' c:=#$D800;', // invalid UTF-16
  6308. ' c:=#$DFFF;', // invalid UTF-16
  6309. ' c:=#$FFFF;', // last UCS-2
  6310. ' c:=high(c);', // last UCS-2
  6311. '']);
  6312. ConvertProgram;
  6313. CheckSource('TestCharConst',
  6314. LinesToStr([
  6315. 'this.a="ó";',
  6316. 'this.c="1";'
  6317. ]),
  6318. LinesToStr([
  6319. '$mod.c="\x00";',
  6320. '$mod.c="\x01";',
  6321. '$mod.c="\t";',
  6322. '$mod.c="\n";',
  6323. '$mod.c="\r";',
  6324. '$mod.c="\x1F";',
  6325. '$mod.c=" ";',
  6326. '$mod.c="\n";',
  6327. '$mod.c="\n";',
  6328. '$mod.c="\x0B";',
  6329. '$mod.c="\x0B";',
  6330. '$mod.c="\x01";',
  6331. '$mod.c=''"'';',
  6332. '$mod.c="\x00";',
  6333. '$mod.c = "ä";',
  6334. '$mod.c = "ä";',
  6335. '$mod.c = "ä";',
  6336. '$mod.c="\uD800";',
  6337. '$mod.c="\uDFFF";',
  6338. '$mod.c="\uFFFF";',
  6339. '$mod.c="\uFFFF";',
  6340. '']));
  6341. end;
  6342. procedure TTestModule.TestChar_Compare;
  6343. begin
  6344. StartProgram(false);
  6345. Add('var');
  6346. Add(' c: char;');
  6347. Add(' b: boolean;');
  6348. Add('begin');
  6349. Add(' b:=c=''1'';');
  6350. Add(' b:=''2''=c;');
  6351. Add(' b:=''3''=''4'';');
  6352. Add(' b:=c<>''5'';');
  6353. Add(' b:=''6''<>c;');
  6354. Add(' b:=c>''7'';');
  6355. Add(' b:=''8''>c;');
  6356. Add(' b:=c>=''9'';');
  6357. Add(' b:=''A''>=c;');
  6358. Add(' b:=c<''B'';');
  6359. Add(' b:=''C''<c;');
  6360. Add(' b:=c<=''D'';');
  6361. Add(' b:=''E''<=c;');
  6362. ConvertProgram;
  6363. CheckSource('TestChar_Compare',
  6364. LinesToStr([
  6365. 'this.c="";',
  6366. 'this.b = false;'
  6367. ]),
  6368. LinesToStr([
  6369. '$mod.b = $mod.c === "1";',
  6370. '$mod.b = "2" === $mod.c;',
  6371. '$mod.b = "3" === "4";',
  6372. '$mod.b = $mod.c !== "5";',
  6373. '$mod.b = "6" !== $mod.c;',
  6374. '$mod.b = $mod.c > "7";',
  6375. '$mod.b = "8" > $mod.c;',
  6376. '$mod.b = $mod.c >= "9";',
  6377. '$mod.b = "A" >= $mod.c;',
  6378. '$mod.b = $mod.c < "B";',
  6379. '$mod.b = "C" < $mod.c;',
  6380. '$mod.b = $mod.c <= "D";',
  6381. '$mod.b = "E" <= $mod.c;',
  6382. '']));
  6383. end;
  6384. procedure TTestModule.TestChar_BuiltInProcs;
  6385. begin
  6386. StartProgram(false);
  6387. Add([
  6388. 'var',
  6389. ' c: char;',
  6390. ' i: longint;',
  6391. ' s: string;',
  6392. 'begin',
  6393. ' i:=ord(c);',
  6394. ' i:=ord(s[i]);',
  6395. ' c:=chr(i);',
  6396. ' c:=pred(c);',
  6397. ' c:=succ(c);',
  6398. ' c:=low(c);',
  6399. ' c:=high(c);',
  6400. ' i:=byte(c);',
  6401. ' i:=word(c);',
  6402. ' i:=longint(c);',
  6403. '']);
  6404. ConvertProgram;
  6405. CheckSource('TestChar_BuiltInProcs',
  6406. LinesToStr([
  6407. 'this.c = "";',
  6408. 'this.i = 0;',
  6409. 'this.s = "";'
  6410. ]),
  6411. LinesToStr([
  6412. '$mod.i = $mod.c.charCodeAt();',
  6413. '$mod.i = $mod.s.charCodeAt($mod.i-1);',
  6414. '$mod.c = String.fromCharCode($mod.i);',
  6415. '$mod.c = String.fromCharCode($mod.c.charCodeAt() - 1);',
  6416. '$mod.c = String.fromCharCode($mod.c.charCodeAt() + 1);',
  6417. '$mod.c = "\x00";',
  6418. '$mod.c = "\uFFFF";',
  6419. '$mod.i = $mod.c.charCodeAt() & 255;',
  6420. '$mod.i = $mod.c.charCodeAt();',
  6421. '$mod.i = $mod.c.charCodeAt() & 0xFFFFFFFF;',
  6422. '']));
  6423. end;
  6424. procedure TTestModule.TestStringConst;
  6425. begin
  6426. StartProgram(false);
  6427. Add([
  6428. '{$H+}',
  6429. 'const',
  6430. ' a = #$00F3#$017C;', // first <256, then >=256
  6431. ' b = string(''a'');',
  6432. ' c = string(''ä'');',
  6433. ' d = UnicodeString(''b'');',
  6434. ' e = UnicodeString(''ö'');',
  6435. 'var',
  6436. ' s: string = ''abc'';',
  6437. 'begin',
  6438. ' s:='''';',
  6439. ' s:=#13#10;',
  6440. ' s:=#9''foo'';',
  6441. ' s:=#$A9;',
  6442. ' s:=''foo''#13''bar'';',
  6443. ' s:=''"'';',
  6444. ' s:=''"''''"'';',
  6445. ' s:=#$20AC;', // euro
  6446. ' s:=#$10437;', // outside BMP
  6447. ' s:=default(string);',
  6448. ' s:=concat(s);',
  6449. ' s:=concat(s,''a'',s)',
  6450. '']);
  6451. ConvertProgram;
  6452. CheckSource('TestStringConst',
  6453. LinesToStr([
  6454. 'this.a = "óż";',
  6455. 'this.b = "a";',
  6456. 'this.c = "ä";',
  6457. 'this.d = "b";',
  6458. 'this.e = "ö";',
  6459. 'this.s="abc";',
  6460. '']),
  6461. LinesToStr([
  6462. '$mod.s="";',
  6463. '$mod.s="\r\n";',
  6464. '$mod.s="\tfoo";',
  6465. '$mod.s="©";',
  6466. '$mod.s="foo\rbar";',
  6467. '$mod.s=''"'';',
  6468. '$mod.s=''"\''"'';',
  6469. '$mod.s="€";',
  6470. '$mod.s="'#$F0#$90#$90#$B7'";',
  6471. '$mod.s="";',
  6472. '$mod.s = $mod.s;',
  6473. '$mod.s = $mod.s.concat("a", $mod.s);',
  6474. '']));
  6475. end;
  6476. procedure TTestModule.TestStringConstSurrogate;
  6477. begin
  6478. StartProgram(false);
  6479. Add([
  6480. 'var',
  6481. ' s: string;',
  6482. 'begin',
  6483. ' s:=''😊'';', // 1F60A
  6484. '']);
  6485. ConvertProgram;
  6486. CheckSource('TestStringConstSurrogate',
  6487. LinesToStr([
  6488. 'this.s="";'
  6489. ]),
  6490. LinesToStr([
  6491. '$mod.s="😊";'
  6492. ]));
  6493. end;
  6494. procedure TTestModule.TestString_Length;
  6495. begin
  6496. StartProgram(false);
  6497. Add('const c = ''foo'';');
  6498. Add('var');
  6499. Add(' s: string;');
  6500. Add(' i: longint;');
  6501. Add('begin');
  6502. Add(' i:=length(s);');
  6503. Add(' i:=length(s+s);');
  6504. Add(' i:=length(''abc'');');
  6505. Add(' i:=length(c);');
  6506. ConvertProgram;
  6507. CheckSource('TestString_Length',
  6508. LinesToStr([
  6509. 'this.c = "foo";',
  6510. 'this.s = "";',
  6511. 'this.i = 0;',
  6512. '']),
  6513. LinesToStr([
  6514. '$mod.i = $mod.s.length;',
  6515. '$mod.i = ($mod.s+$mod.s).length;',
  6516. '$mod.i = "abc".length;',
  6517. '$mod.i = $mod.c.length;',
  6518. '']));
  6519. end;
  6520. procedure TTestModule.TestString_Compare;
  6521. begin
  6522. StartProgram(false);
  6523. Add('var');
  6524. Add(' s, t: string;');
  6525. Add(' b: boolean;');
  6526. Add('begin');
  6527. Add(' b:=s=t;');
  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. ConvertProgram;
  6534. CheckSource('TestString_Compare',
  6535. LinesToStr([ // statements
  6536. 'this.s = "";',
  6537. 'this.t = "";',
  6538. 'this.b =false;'
  6539. ]),
  6540. LinesToStr([ // this.$main
  6541. '$mod.b = $mod.s === $mod.t;',
  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. '']));
  6548. end;
  6549. procedure TTestModule.TestString_SetLength;
  6550. begin
  6551. StartProgram(false);
  6552. Add([
  6553. 'procedure DoIt(var s: string);',
  6554. 'begin',
  6555. ' SetLength(s,2);',
  6556. 'end;',
  6557. 'var s: string;',
  6558. 'begin',
  6559. ' SetLength(s,3);',
  6560. '']);
  6561. ConvertProgram;
  6562. CheckSource('TestString_SetLength',
  6563. LinesToStr([ // statements
  6564. 'this.DoIt = function (s) {',
  6565. ' s.set(rtl.strSetLength(s.get(), 2));',
  6566. '};',
  6567. 'this.s = "";',
  6568. '']),
  6569. LinesToStr([ // this.$main
  6570. '$mod.s = rtl.strSetLength($mod.s, 3);'
  6571. ]));
  6572. end;
  6573. procedure TTestModule.TestString_CharAt;
  6574. begin
  6575. StartProgram(false);
  6576. Add([
  6577. 'var',
  6578. ' s: string;',
  6579. ' c: char;',
  6580. ' b: boolean;',
  6581. 'begin',
  6582. ' b:= s[1] = c;',
  6583. ' b:= c = s[1];',
  6584. ' b:= c <> s[1];',
  6585. ' b:= c > s[1];',
  6586. ' b:= c >= s[1];',
  6587. ' b:= c < s[2];',
  6588. ' b:= c <= s[1];',
  6589. ' s[1] := c;',
  6590. ' s[2+3] := c;']);
  6591. ConvertProgram;
  6592. CheckSource('TestString_CharAt',
  6593. LinesToStr([ // statements
  6594. 'this.s = "";',
  6595. 'this.c = "";',
  6596. 'this.b = false;'
  6597. ]),
  6598. LinesToStr([ // this.$main
  6599. '$mod.b = $mod.s.charAt(0) === $mod.c;',
  6600. '$mod.b = $mod.c === $mod.s.charAt(0);',
  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(1);',
  6605. '$mod.b = $mod.c <= $mod.s.charAt(0);',
  6606. '$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
  6607. '$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
  6608. '']));
  6609. end;
  6610. procedure TTestModule.TestStringHMinusFail;
  6611. begin
  6612. StartProgram(false);
  6613. Add([
  6614. '{$H-}',
  6615. 'var s: string;',
  6616. 'begin']);
  6617. ConvertProgram;
  6618. CheckHint(mtWarning,nWarnIllegalCompilerDirectiveX,'Warning: test1.pp(3,6) : Illegal compiler directive "H-"');
  6619. end;
  6620. procedure TTestModule.TestStr;
  6621. begin
  6622. StartProgram(false);
  6623. Add('var');
  6624. Add(' b: boolean;');
  6625. Add(' i: longint;');
  6626. Add(' d: double;');
  6627. Add(' s: string;');
  6628. Add('begin');
  6629. Add(' str(b,s);');
  6630. Add(' str(i,s);');
  6631. Add(' str(d,s);');
  6632. Add(' str(i:3,s);');
  6633. Add(' str(d:3:2,s);');
  6634. Add(' Str(12.456:12:1,s);');
  6635. Add(' Str(12.456:12,s);');
  6636. Add(' s:=str(b);');
  6637. Add(' s:=str(i);');
  6638. Add(' s:=str(d);');
  6639. Add(' s:=str(i,i);');
  6640. Add(' s:=str(i:3);');
  6641. Add(' s:=str(d:3:2);');
  6642. Add(' s:=str(i:4,i);');
  6643. Add(' s:=str(i,i:5);');
  6644. Add(' s:=str(i:4,i:5);');
  6645. Add(' s:=str(s,s);');
  6646. Add(' s:=str(s,''foo'');');
  6647. ConvertProgram;
  6648. CheckSource('TestStr',
  6649. LinesToStr([ // statements
  6650. 'this.b = false;',
  6651. 'this.i = 0;',
  6652. 'this.d = 0.0;',
  6653. 'this.s = "";',
  6654. '']),
  6655. LinesToStr([ // this.$main
  6656. '$mod.s = ""+$mod.b;',
  6657. '$mod.s = ""+$mod.i;',
  6658. '$mod.s = rtl.floatToStr($mod.d);',
  6659. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  6660. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  6661. '$mod.s = rtl.floatToStr(12.456,12,1);',
  6662. '$mod.s = rtl.floatToStr(12.456,12);',
  6663. '$mod.s = ""+$mod.b;',
  6664. '$mod.s = ""+$mod.i;',
  6665. '$mod.s = rtl.floatToStr($mod.d);',
  6666. '$mod.s = ""+$mod.i+$mod.i;',
  6667. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  6668. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  6669. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
  6670. '$mod.s = "" + $mod.i + rtl.spaceLeft("" + $mod.i, 5);',
  6671. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
  6672. '$mod.s = $mod.s + $mod.s;',
  6673. '$mod.s = $mod.s + "foo";',
  6674. '']));
  6675. end;
  6676. procedure TTestModule.TestBaseType_AnsiStringFail;
  6677. begin
  6678. StartProgram(false);
  6679. Add('var s: AnsiString');
  6680. SetExpectedPasResolverError('identifier not found "AnsiString"',PasResolveEval.nIdentifierNotFound);
  6681. ConvertProgram;
  6682. end;
  6683. procedure TTestModule.TestBaseType_WideStringFail;
  6684. begin
  6685. StartProgram(false);
  6686. Add('var s: WideString');
  6687. SetExpectedPasResolverError('identifier not found "WideString"',PasResolveEval.nIdentifierNotFound);
  6688. ConvertProgram;
  6689. end;
  6690. procedure TTestModule.TestBaseType_ShortStringFail;
  6691. begin
  6692. StartProgram(false);
  6693. Add('var s: ShortString');
  6694. SetExpectedPasResolverError('identifier not found "ShortString"',PasResolveEval.nIdentifierNotFound);
  6695. ConvertProgram;
  6696. end;
  6697. procedure TTestModule.TestBaseType_RawByteStringFail;
  6698. begin
  6699. StartProgram(false);
  6700. Add('var s: RawByteString');
  6701. SetExpectedPasResolverError('identifier not found "RawByteString"',PasResolveEval.nIdentifierNotFound);
  6702. ConvertProgram;
  6703. end;
  6704. procedure TTestModule.TestTypeShortstring_Fail;
  6705. begin
  6706. StartProgram(false);
  6707. Add('type t = string[12];');
  6708. Add('var s: t;');
  6709. Add('begin');
  6710. SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
  6711. ConvertProgram;
  6712. end;
  6713. procedure TTestModule.TestCharSet_Custom;
  6714. begin
  6715. StartProgram(false);
  6716. Add([
  6717. 'type',
  6718. ' TCharRg = ''a''..''z'';',
  6719. ' TSetOfCharRg = set of TCharRg;',
  6720. ' TCharRg2 = ''m''..''p'';',
  6721. 'const',
  6722. ' crg: TCharRg = ''b'';',
  6723. 'var',
  6724. ' c: char;',
  6725. ' crg2: TCharRg2;',
  6726. ' s: TSetOfCharRg;',
  6727. 'begin',
  6728. ' c:=crg;',
  6729. ' crg:=c;',
  6730. ' crg2:=crg;',
  6731. ' if c=crg then ;',
  6732. ' if crg=c then ;',
  6733. ' if crg=crg2 then ;',
  6734. ' if c in s then ;',
  6735. ' if crg2 in s then ;',
  6736. ' c:=default(TCharRg);',
  6737. '']);
  6738. ConvertProgram;
  6739. CheckSource('TestCharSet_Custom',
  6740. LinesToStr([ // statements
  6741. 'this.crg = "b";',
  6742. 'this.c = "";',
  6743. 'this.crg2 = "m";',
  6744. 'this.s = {};',
  6745. '']),
  6746. LinesToStr([ // this.$main
  6747. '$mod.c = $mod.crg;',
  6748. '$mod.crg = $mod.c;',
  6749. '$mod.crg2 = $mod.crg;',
  6750. 'if ($mod.c === $mod.crg) ;',
  6751. 'if ($mod.crg === $mod.c) ;',
  6752. 'if ($mod.crg === $mod.crg2) ;',
  6753. 'if ($mod.c.charCodeAt() in $mod.s) ;',
  6754. 'if ($mod.crg2.charCodeAt() in $mod.s) ;',
  6755. '$mod.c = "a";',
  6756. '']));
  6757. end;
  6758. procedure TTestModule.TestForCharDo;
  6759. begin
  6760. StartProgram(false);
  6761. Add([
  6762. 'var c: char;',
  6763. 'begin',
  6764. ' for c:=''a'' to ''c'' do ;',
  6765. ' for c:=c downto ''a'' do ;',
  6766. ' for c:=''Б'' to ''Я'' do ;',
  6767. '']);
  6768. ConvertProgram;
  6769. CheckSource('TestForCharDo',
  6770. LinesToStr([ // statements
  6771. 'this.c = "";']),
  6772. LinesToStr([ // this.$main
  6773. 'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
  6774. 'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $l2--) $mod.c = String.fromCharCode($l2);',
  6775. 'for (var $l3 = 1041; $l3 <= 1071; $l3++) $mod.c = String.fromCharCode($l3);',
  6776. '']));
  6777. end;
  6778. procedure TTestModule.TestForCharInDo;
  6779. begin
  6780. StartProgram(false);
  6781. Add([
  6782. 'type',
  6783. ' TSetOfChar = set of char;',
  6784. ' TCharRg = ''a''..''z'';',
  6785. ' TSetOfCharRg = set of TCharRg;',
  6786. 'const Foo = ''foo'';',
  6787. 'var',
  6788. ' c,c2: char;',
  6789. ' s: string;',
  6790. ' a1: array of char;',
  6791. ' a2: array[1..3] of char;',
  6792. ' soc: TSetOfChar;',
  6793. ' socr: TSetOfCharRg;',
  6794. ' cr: TCharRg;',
  6795. 'begin',
  6796. ' for c in foo do ;',
  6797. ' for c in s do ;',
  6798. ' for c in char do ;',
  6799. ' for c in a1 do ;',
  6800. ' for c in a2 do ;',
  6801. ' for c in [''1''..''3''] do ;',
  6802. ' for c in TSetOfChar do ;',
  6803. ' for c in TCharRg do ;',
  6804. ' for c in soc do c2:=c;',
  6805. ' for c in TSetOfCharRg do ;',
  6806. ' for c in socr do ;',
  6807. ' for cr in TCharRg do ;',
  6808. ' for cr in TSetOfCharRg do ;',
  6809. ' for cr in socr do ;',
  6810. '']);
  6811. ConvertProgram;
  6812. CheckSource('TestForCharInDo',
  6813. LinesToStr([ // statements
  6814. 'this.Foo = "foo";',
  6815. 'this.c = "";',
  6816. 'this.c2 = "";',
  6817. 'this.s = "";',
  6818. 'this.a1 = [];',
  6819. 'this.a2 = rtl.arraySetLength(null, "", 3);',
  6820. 'this.soc = {};',
  6821. 'this.socr = {};',
  6822. 'this.cr = "a";',
  6823. '']),
  6824. LinesToStr([ // this.$main
  6825. 'for (var $in1 = $mod.Foo, $l2 = 0, $end3 = $in1.length - 1; $l2 <= $end3; $l2++) $mod.c = $in1.charAt($l2);',
  6826. 'for (var $in4 = $mod.s, $l5 = 0, $end6 = $in4.length - 1; $l5 <= $end6; $l5++) $mod.c = $in4.charAt($l5);',
  6827. 'for (var $l7 = 0; $l7 <= 65535; $l7++) $mod.c = String.fromCharCode($l7);',
  6828. 'for (var $in8 = $mod.a1, $l9 = 0, $end10 = rtl.length($in8) - 1; $l9 <= $end10; $l9++) $mod.c = $in8[$l9];',
  6829. 'for (var $in11 = $mod.a2, $l12 = 0, $end13 = rtl.length($in11) - 1; $l12 <= $end13; $l12++) $mod.c = $in11[$l12];',
  6830. 'for (var $l14 = 49; $l14 <= 51; $l14++) $mod.c = String.fromCharCode($l14);',
  6831. 'for (var $l15 = 0; $l15 <= 65535; $l15++) $mod.c = String.fromCharCode($l15);',
  6832. 'for (var $l16 = 97; $l16 <= 122; $l16++) $mod.c = String.fromCharCode($l16);',
  6833. 'for (var $l17 in $mod.soc) {',
  6834. ' $mod.c = String.fromCharCode($l17);',
  6835. ' $mod.c2 = $mod.c;',
  6836. '};',
  6837. 'for (var $l18 = 97; $l18 <= 122; $l18++) $mod.c = String.fromCharCode($l18);',
  6838. 'for (var $l19 in $mod.socr) $mod.c = String.fromCharCode($l19);',
  6839. 'for (var $l20 = 97; $l20 <= 122; $l20++) $mod.cr = String.fromCharCode($l20);',
  6840. 'for (var $l21 = 97; $l21 <= 122; $l21++) $mod.cr = String.fromCharCode($l21);',
  6841. 'for (var $l22 in $mod.socr) $mod.cr = String.fromCharCode($l22);',
  6842. '']));
  6843. end;
  6844. procedure TTestModule.TestProcTwoArgs;
  6845. begin
  6846. StartProgram(false);
  6847. Add('procedure Test(a,b: longint);');
  6848. Add('begin');
  6849. Add('end;');
  6850. Add('begin');
  6851. ConvertProgram;
  6852. CheckSource('TestProcTwoArgs',
  6853. LinesToStr([ // statements
  6854. 'this.Test = function (a,b) {',
  6855. '};'
  6856. ]),
  6857. LinesToStr([ // this.$main
  6858. ''
  6859. ]));
  6860. end;
  6861. procedure TTestModule.TestProc_DefaultValue;
  6862. begin
  6863. StartProgram(false);
  6864. Add('procedure p1(i: longint = 1);');
  6865. Add('begin');
  6866. Add('end;');
  6867. Add('procedure p2(i: longint = 1; c: char = ''a'');');
  6868. Add('begin');
  6869. Add('end;');
  6870. Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');');
  6871. Add('begin');
  6872. Add('end;');
  6873. Add('begin');
  6874. Add(' p1;');
  6875. Add(' p1();');
  6876. Add(' p1(11);');
  6877. Add(' p2;');
  6878. Add(' p2();');
  6879. Add(' p2(12);');
  6880. Add(' p2(13,''b'');');
  6881. Add(' p3();');
  6882. ConvertProgram;
  6883. CheckSource('TestProc_DefaultValue',
  6884. LinesToStr([ // statements
  6885. 'this.p1 = function (i) {',
  6886. '};',
  6887. 'this.p2 = function (i,c) {',
  6888. '};',
  6889. 'this.p3 = function (d,b,s) {',
  6890. '};'
  6891. ]),
  6892. LinesToStr([ // this.$main
  6893. ' $mod.p1(1);',
  6894. ' $mod.p1(1);',
  6895. ' $mod.p1(11);',
  6896. ' $mod.p2(1,"a");',
  6897. ' $mod.p2(1,"a");',
  6898. ' $mod.p2(12,"a");',
  6899. ' $mod.p2(13,"b");',
  6900. ' $mod.p3(1.0,false,"abc");'
  6901. ]));
  6902. end;
  6903. procedure TTestModule.TestFunctionInt;
  6904. begin
  6905. StartProgram(false);
  6906. Add('function MyTest(Bar: longint): longint;');
  6907. Add('begin');
  6908. Add(' Result:=2*bar');
  6909. Add('end;');
  6910. Add('begin');
  6911. ConvertProgram;
  6912. CheckSource('TestFunctionInt',
  6913. LinesToStr([ // statements
  6914. 'this.MyTest = function (Bar) {',
  6915. ' var Result = 0;',
  6916. ' Result = 2*Bar;',
  6917. ' return Result;',
  6918. '};'
  6919. ]),
  6920. LinesToStr([ // this.$main
  6921. ''
  6922. ]));
  6923. end;
  6924. procedure TTestModule.TestFunctionString;
  6925. begin
  6926. StartProgram(false);
  6927. Add('function Test(Bar: string): string;');
  6928. Add('begin');
  6929. Add(' Result:=bar+BAR');
  6930. Add('end;');
  6931. Add('begin');
  6932. ConvertProgram;
  6933. CheckSource('TestFunctionString',
  6934. LinesToStr([ // statements
  6935. 'this.Test = function (Bar) {',
  6936. ' var Result = "";',
  6937. ' Result = Bar+Bar;',
  6938. ' return Result;',
  6939. '};'
  6940. ]),
  6941. LinesToStr([ // this.$main
  6942. ''
  6943. ]));
  6944. end;
  6945. procedure TTestModule.TestIfThen;
  6946. begin
  6947. StartProgram(false);
  6948. Add([
  6949. 'var b: boolean;',
  6950. 'begin',
  6951. ' if b then ;',
  6952. ' if b then else ;']);
  6953. ConvertProgram;
  6954. CheckSource('TestIfThen',
  6955. LinesToStr([ // statements
  6956. 'this.b = false;',
  6957. '']),
  6958. LinesToStr([ // this.$main
  6959. 'if ($mod.b) ;',
  6960. 'if ($mod.b) ;',
  6961. '']));
  6962. end;
  6963. procedure TTestModule.TestForLoop;
  6964. begin
  6965. StartProgram(false);
  6966. Add('var');
  6967. Add(' vI, vJ, vN: longint;');
  6968. Add('begin');
  6969. Add(' VJ:=0;');
  6970. Add(' VN:=3;');
  6971. Add(' for VI:=1 to VN do');
  6972. Add(' begin');
  6973. Add(' VJ:=VJ+VI;');
  6974. Add(' end;');
  6975. ConvertProgram;
  6976. CheckSource('TestForLoop',
  6977. LinesToStr([ // statements
  6978. 'this.vI = 0;',
  6979. 'this.vJ = 0;',
  6980. 'this.vN = 0;'
  6981. ]),
  6982. LinesToStr([ // this.$main
  6983. ' $mod.vJ = 0;',
  6984. ' $mod.vN = 3;',
  6985. ' for (var $l1 = 1, $end2 = $mod.vN; $l1 <= $end2; $l1++) {',
  6986. ' $mod.vI = $l1;',
  6987. ' $mod.vJ = $mod.vJ + $mod.vI;',
  6988. ' };',
  6989. '']));
  6990. end;
  6991. procedure TTestModule.TestForLoopInsideFunction;
  6992. begin
  6993. StartProgram(false);
  6994. Add('function SumNumbers(Count: longint): longint;');
  6995. Add('var');
  6996. Add(' vI, vJ: longint;');
  6997. Add('begin');
  6998. Add(' vj:=0;');
  6999. Add(' for vi:=1 to count do');
  7000. Add(' begin');
  7001. Add(' vj:=vj+vi;');
  7002. Add(' end;');
  7003. Add('end;');
  7004. Add('begin');
  7005. Add(' sumnumbers(3);');
  7006. ConvertProgram;
  7007. CheckSource('TestForLoopInsideFunction',
  7008. LinesToStr([ // statements
  7009. 'this.SumNumbers = function (Count) {',
  7010. ' var Result = 0;',
  7011. ' var vI = 0;',
  7012. ' var vJ = 0;',
  7013. ' vJ = 0;',
  7014. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  7015. ' vI = $l1;',
  7016. ' vJ = vJ + vI;',
  7017. ' };',
  7018. ' return Result;',
  7019. '};'
  7020. ]),
  7021. LinesToStr([ // $mod.$main
  7022. ' $mod.SumNumbers(3);'
  7023. ]));
  7024. end;
  7025. procedure TTestModule.TestForLoop_ReadVarAfter;
  7026. begin
  7027. StartProgram(false);
  7028. Add('var');
  7029. Add(' vI: longint;');
  7030. Add('begin');
  7031. Add(' for vi:=1 to 2 do ;');
  7032. Add(' if vi=3 then ;');
  7033. ConvertProgram;
  7034. CheckSource('TestForLoop',
  7035. LinesToStr([ // statements
  7036. 'this.vI = 0;'
  7037. ]),
  7038. LinesToStr([ // this.$main
  7039. ' for ($mod.vI = 1; $mod.vI <= 2; $mod.vI++) ;',
  7040. ' if ($mod.vI===3) ;'
  7041. ]));
  7042. end;
  7043. procedure TTestModule.TestForLoop_Nested;
  7044. begin
  7045. StartProgram(false);
  7046. Add('function SumNumbers(Count: longint): longint;');
  7047. Add('var');
  7048. Add(' vI, vJ, vK: longint;');
  7049. Add('begin');
  7050. Add(' VK:=0;');
  7051. Add(' for VI:=1 to count do');
  7052. Add(' begin');
  7053. Add(' for vj:=1 to vi do');
  7054. Add(' begin');
  7055. Add(' vk:=VK+VI;');
  7056. Add(' end;');
  7057. Add(' end;');
  7058. Add('end;');
  7059. Add('begin');
  7060. Add(' sumnumbers(3);');
  7061. ConvertProgram;
  7062. CheckSource('TestForLoopInFunction',
  7063. LinesToStr([ // statements
  7064. 'this.SumNumbers = function (Count) {',
  7065. ' var Result = 0;',
  7066. ' var vI = 0;',
  7067. ' var vJ = 0;',
  7068. ' var vK = 0;',
  7069. ' vK = 0;',
  7070. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  7071. ' vI = $l1;',
  7072. ' for (var $l3 = 1, $end4 = vI; $l3 <= $end4; $l3++) {',
  7073. ' vJ = $l3;',
  7074. ' vK = vK + vI;',
  7075. ' };',
  7076. ' };',
  7077. ' return Result;',
  7078. '};'
  7079. ]),
  7080. LinesToStr([ // $mod.$main
  7081. ' $mod.SumNumbers(3);'
  7082. ]));
  7083. end;
  7084. procedure TTestModule.TestRepeatUntil;
  7085. begin
  7086. StartProgram(false);
  7087. Add('var');
  7088. Add(' vI, vJ, vN: longint;');
  7089. Add('begin');
  7090. Add(' vn:=3;');
  7091. Add(' vj:=0;');
  7092. Add(' VI:=0;');
  7093. Add(' repeat');
  7094. Add(' VI:=vi+1;');
  7095. Add(' vj:=VJ+vI;');
  7096. Add(' until vi>=vn');
  7097. ConvertProgram;
  7098. CheckSource('TestRepeatUntil',
  7099. LinesToStr([ // statements
  7100. 'this.vI = 0;',
  7101. 'this.vJ = 0;',
  7102. 'this.vN = 0;'
  7103. ]),
  7104. LinesToStr([ // $mod.$main
  7105. ' $mod.vN = 3;',
  7106. ' $mod.vJ = 0;',
  7107. ' $mod.vI = 0;',
  7108. ' do{',
  7109. ' $mod.vI = $mod.vI + 1;',
  7110. ' $mod.vJ = $mod.vJ + $mod.vI;',
  7111. ' }while(!($mod.vI>=$mod.vN));'
  7112. ]));
  7113. end;
  7114. procedure TTestModule.TestAsmBlock;
  7115. begin
  7116. StartProgram(false);
  7117. Add([
  7118. 'var',
  7119. ' vI: longint;',
  7120. 'begin',
  7121. ' vi:=1;',
  7122. ' asm',
  7123. ' if (vI===1) {',
  7124. ' vI=2;',
  7125. //' console.log(''end;'');', ToDo
  7126. ' }',
  7127. ' if (vI===2){ vI=3; }',
  7128. ' end;',
  7129. ' VI:=4;']);
  7130. ConvertProgram;
  7131. CheckSource('TestAsmBlock',
  7132. LinesToStr([ // statements
  7133. 'this.vI = 0;'
  7134. ]),
  7135. LinesToStr([ // $mod.$main
  7136. '$mod.vI = 1;',
  7137. 'if (vI===1) {',
  7138. ' vI=2;',
  7139. '}',
  7140. 'if (vI===2){ vI=3; }',
  7141. ';',
  7142. '$mod.vI = 4;'
  7143. ]));
  7144. end;
  7145. procedure TTestModule.TestAsmPas_Impl;
  7146. begin
  7147. StartUnit(false);
  7148. Add('interface');
  7149. Add('const cIntf: longint = 1;');
  7150. Add('var vIntf: longint;');
  7151. Add('implementation');
  7152. Add('const cImpl: longint = 2;');
  7153. Add('var vImpl: longint;');
  7154. Add('procedure DoIt;');
  7155. Add('const cLoc: longint = 3;');
  7156. Add('var vLoc: longint;');
  7157. Add('begin;');
  7158. Add(' asm');
  7159. //Add(' pas(vIntf)=pas(cIntf);');
  7160. //Add(' pas(vImpl)=pas(cImpl);');
  7161. //Add(' pas(vLoc)=pas(cLoc);');
  7162. Add(' end;');
  7163. Add('end;');
  7164. ConvertUnit;
  7165. CheckSource('TestAsmPas_Impl',
  7166. LinesToStr([
  7167. 'var $impl = $mod.$impl;',
  7168. 'this.cIntf = 1;',
  7169. 'this.vIntf = 0;',
  7170. '']),
  7171. '', // this.$init
  7172. LinesToStr([ // implementation
  7173. '$impl.cImpl = 2;',
  7174. '$impl.vImpl = 0;',
  7175. 'var cLoc = 3;',
  7176. '$impl.DoIt = function () {',
  7177. ' var vLoc = 0;',
  7178. '};',
  7179. '']) );
  7180. end;
  7181. procedure TTestModule.TestTryFinally;
  7182. begin
  7183. StartProgram(false);
  7184. Add('var i: longint;');
  7185. Add('begin');
  7186. Add(' try');
  7187. Add(' i:=0; i:=2 div i;');
  7188. Add(' finally');
  7189. Add(' i:=3');
  7190. Add(' end;');
  7191. ConvertProgram;
  7192. CheckSource('TestTryFinally',
  7193. LinesToStr([ // statements
  7194. 'this.i = 0;'
  7195. ]),
  7196. LinesToStr([ // $mod.$main
  7197. 'try {',
  7198. ' $mod.i = 0;',
  7199. ' $mod.i = Math.floor(2 / $mod.i);',
  7200. '} finally {',
  7201. ' $mod.i = 3;',
  7202. '};'
  7203. ]));
  7204. end;
  7205. procedure TTestModule.TestTryExcept;
  7206. begin
  7207. StartProgram(false);
  7208. Add('type');
  7209. Add(' TObject = class end;');
  7210. Add(' Exception = class Msg: string; end;');
  7211. Add(' EInvalidCast = class(Exception) end;');
  7212. Add('var vI: longint;');
  7213. Add('begin');
  7214. Add(' try');
  7215. Add(' vi:=1;');
  7216. Add(' except');
  7217. Add(' vi:=2');
  7218. Add(' end;');
  7219. Add(' try');
  7220. Add(' vi:=3;');
  7221. Add(' except');
  7222. Add(' raise;');
  7223. Add(' end;');
  7224. Add(' try');
  7225. Add(' VI:=4;');
  7226. Add(' except');
  7227. Add(' on einvalidcast do');
  7228. Add(' raise;');
  7229. Add(' on E: exception do');
  7230. Add(' if e.msg='''' then');
  7231. Add(' raise e;');
  7232. Add(' else');
  7233. Add(' vi:=5');
  7234. Add(' end;');
  7235. Add(' try');
  7236. Add(' VI:=6;');
  7237. Add(' except');
  7238. Add(' on einvalidcast do ;');
  7239. Add(' end;');
  7240. ConvertProgram;
  7241. CheckSource('TestTryExcept',
  7242. LinesToStr([ // statements
  7243. 'rtl.createClass($mod, "TObject", null, function () {',
  7244. ' this.$init = function () {',
  7245. ' };',
  7246. ' this.$final = function () {',
  7247. ' };',
  7248. '});',
  7249. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  7250. ' this.$init = function () {',
  7251. ' $mod.TObject.$init.call(this);',
  7252. ' this.Msg = "";',
  7253. ' };',
  7254. '});',
  7255. 'rtl.createClass($mod, "EInvalidCast", $mod.Exception, function () {',
  7256. '});',
  7257. 'this.vI = 0;'
  7258. ]),
  7259. LinesToStr([ // $mod.$main
  7260. 'try {',
  7261. ' $mod.vI = 1;',
  7262. '} catch ($e) {',
  7263. ' $mod.vI = 2;',
  7264. '};',
  7265. 'try {',
  7266. ' $mod.vI = 3;',
  7267. '} catch ($e) {',
  7268. ' throw $e;',
  7269. '};',
  7270. 'try {',
  7271. ' $mod.vI = 4;',
  7272. '} catch ($e) {',
  7273. ' if ($mod.EInvalidCast.isPrototypeOf($e)){',
  7274. ' throw $e',
  7275. ' } else if ($mod.Exception.isPrototypeOf($e)) {',
  7276. ' var E = $e;',
  7277. ' if (E.Msg === "") throw E;',
  7278. ' } else {',
  7279. ' $mod.vI = 5;',
  7280. ' }',
  7281. '};',
  7282. 'try {',
  7283. ' $mod.vI = 6;',
  7284. '} catch ($e) {',
  7285. ' if ($mod.EInvalidCast.isPrototypeOf($e)){' ,
  7286. ' } else throw $e',
  7287. '};',
  7288. '']));
  7289. end;
  7290. procedure TTestModule.TestTryExcept_ReservedWords;
  7291. begin
  7292. StartProgram(false);
  7293. Add([
  7294. 'type',
  7295. ' TObject = class end;',
  7296. ' Exception = class',
  7297. ' Symbol: string;',
  7298. ' end;',
  7299. 'var &try: longint;',
  7300. 'begin',
  7301. ' try',
  7302. ' &try:=4;',
  7303. ' except',
  7304. ' on Error: exception do',
  7305. ' if errOR.symBol='''' then',
  7306. ' raise ERRor;',
  7307. ' end;',
  7308. '']);
  7309. ConvertProgram;
  7310. CheckSource('TestTryExcept_ReservedWords',
  7311. LinesToStr([ // statements
  7312. 'rtl.createClass($mod, "TObject", null, function () {',
  7313. ' this.$init = function () {',
  7314. ' };',
  7315. ' this.$final = function () {',
  7316. ' };',
  7317. '});',
  7318. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  7319. ' this.$init = function () {',
  7320. ' $mod.TObject.$init.call(this);',
  7321. ' this.Symbol = "";',
  7322. ' };',
  7323. '});',
  7324. 'this.Try = 0;',
  7325. '']),
  7326. LinesToStr([ // $mod.$main
  7327. 'try {',
  7328. ' $mod.Try = 4;',
  7329. '} catch ($e) {',
  7330. ' if ($mod.Exception.isPrototypeOf($e)) {',
  7331. ' var error = $e;',
  7332. ' if (error.Symbol === "") throw error;',
  7333. ' } else throw $e',
  7334. '};',
  7335. '']));
  7336. end;
  7337. procedure TTestModule.TestIfThenRaiseElse;
  7338. begin
  7339. StartProgram(false);
  7340. Add([
  7341. 'type',
  7342. ' TObject = class',
  7343. ' constructor Create;',
  7344. ' end;',
  7345. 'constructor TObject.Create;',
  7346. 'begin',
  7347. 'end;',
  7348. 'var b: boolean;',
  7349. 'begin',
  7350. ' if b then',
  7351. ' raise TObject.Create',
  7352. ' else',
  7353. ' b:=false;',
  7354. '']);
  7355. ConvertProgram;
  7356. CheckSource('TestIfThenRaiseElse',
  7357. LinesToStr([ // statements
  7358. 'rtl.createClass($mod, "TObject", null, function () {',
  7359. ' this.$init = function () {',
  7360. ' };',
  7361. ' this.$final = function () {',
  7362. ' };',
  7363. ' this.Create = function () {',
  7364. ' return this;',
  7365. ' };',
  7366. '});',
  7367. 'this.b = false;',
  7368. '']),
  7369. LinesToStr([ // $mod.$main
  7370. 'if ($mod.b) {',
  7371. ' throw $mod.TObject.$create("Create")}',
  7372. ' else $mod.b = false;',
  7373. '']));
  7374. end;
  7375. procedure TTestModule.TestCaseOf;
  7376. begin
  7377. StartProgram(false);
  7378. Add([
  7379. 'const e: longint; external name ''$e'';',
  7380. 'var vI: longint;',
  7381. 'begin',
  7382. ' case vi of',
  7383. ' 1: ;',
  7384. ' 2: vi:=3;',
  7385. ' e: ;',
  7386. ' else',
  7387. ' VI:=4',
  7388. ' end;']);
  7389. ConvertProgram;
  7390. CheckSource('TestCaseOf',
  7391. LinesToStr([ // statements
  7392. 'this.vI = 0;'
  7393. ]),
  7394. LinesToStr([ // $mod.$main
  7395. 'var $tmp1 = $mod.vI;',
  7396. 'if ($tmp1 === 1) {}',
  7397. 'else if ($tmp1 === 2) {',
  7398. ' $mod.vI = 3}',
  7399. ' else if ($tmp1 === $e) {}',
  7400. 'else {',
  7401. ' $mod.vI = 4;',
  7402. '};'
  7403. ]));
  7404. end;
  7405. procedure TTestModule.TestCaseOf_UseSwitch;
  7406. begin
  7407. StartProgram(false);
  7408. Converter.UseSwitchStatement:=true;
  7409. Add('var Vi: longint;');
  7410. Add('begin');
  7411. Add(' case vi of');
  7412. Add(' 1: ;');
  7413. Add(' 2: VI:=3;');
  7414. Add(' else');
  7415. Add(' vi:=4');
  7416. Add(' end;');
  7417. ConvertProgram;
  7418. CheckSource('TestCaseOf_UseSwitch',
  7419. LinesToStr([ // statements
  7420. 'this.Vi = 0;'
  7421. ]),
  7422. LinesToStr([ // $mod.$main
  7423. 'switch ($mod.Vi) {',
  7424. 'case 1:',
  7425. ' break;',
  7426. 'case 2:',
  7427. ' $mod.Vi = 3;',
  7428. ' break;',
  7429. 'default:',
  7430. ' $mod.Vi = 4;',
  7431. '};'
  7432. ]));
  7433. end;
  7434. procedure TTestModule.TestCaseOfNoElse;
  7435. begin
  7436. StartProgram(false);
  7437. Add('var Vi: longint;');
  7438. Add('begin');
  7439. Add(' case vi of');
  7440. Add(' 1: begin vi:=2; VI:=3; end;');
  7441. Add(' end;');
  7442. ConvertProgram;
  7443. CheckSource('TestCaseOfNoElse',
  7444. LinesToStr([ // statements
  7445. 'this.Vi = 0;'
  7446. ]),
  7447. LinesToStr([ // $mod.$main
  7448. 'var $tmp1 = $mod.Vi;',
  7449. 'if ($tmp1 === 1) {',
  7450. ' $mod.Vi = 2;',
  7451. ' $mod.Vi = 3;',
  7452. '};'
  7453. ]));
  7454. end;
  7455. procedure TTestModule.TestCaseOfNoElse_UseSwitch;
  7456. begin
  7457. StartProgram(false);
  7458. Converter.UseSwitchStatement:=true;
  7459. Add('var vI: longint;');
  7460. Add('begin');
  7461. Add(' case vi of');
  7462. Add(' 1: begin VI:=2; vi:=3; end;');
  7463. Add(' end;');
  7464. ConvertProgram;
  7465. CheckSource('TestCaseOfNoElse_UseSwitch',
  7466. LinesToStr([ // statements
  7467. 'this.vI = 0;'
  7468. ]),
  7469. LinesToStr([ // $mod.$main
  7470. 'switch ($mod.vI) {',
  7471. 'case 1:',
  7472. ' $mod.vI = 2;',
  7473. ' $mod.vI = 3;',
  7474. ' break;',
  7475. '};'
  7476. ]));
  7477. end;
  7478. procedure TTestModule.TestCaseOfRange;
  7479. begin
  7480. StartProgram(false);
  7481. Add('var vI: longint;');
  7482. Add('begin');
  7483. Add(' case vi of');
  7484. Add(' 1..3: vi:=14;');
  7485. Add(' 4,5: vi:=16;');
  7486. Add(' 6..7,9..10: ;');
  7487. Add(' else ;');
  7488. Add(' end;');
  7489. ConvertProgram;
  7490. CheckSource('TestCaseOfRange',
  7491. LinesToStr([ // statements
  7492. 'this.vI = 0;'
  7493. ]),
  7494. LinesToStr([ // $mod.$main
  7495. 'var $tmp1 = $mod.vI;',
  7496. 'if (($tmp1 >= 1) && ($tmp1 <= 3)){',
  7497. ' $mod.vI = 14',
  7498. '} else if (($tmp1 === 4) || ($tmp1 === 5)){',
  7499. ' $mod.vI = 16',
  7500. '} else if ((($tmp1 >= 6) && ($tmp1 <= 7)) || (($tmp1 >= 9) && ($tmp1 <= 10))) ;'
  7501. ]));
  7502. end;
  7503. procedure TTestModule.TestCaseOfString;
  7504. begin
  7505. StartProgram(false);
  7506. Add([
  7507. 'var s,h: string;',
  7508. 'begin',
  7509. ' case s of',
  7510. ' ''foo'': s:=h;',
  7511. ' ''a''..''z'': h:=s;',
  7512. ' ''ў'', ''ё'': ;',
  7513. ' ''Б''..''Я'': ;',
  7514. ' end;',
  7515. '']);
  7516. ConvertProgram;
  7517. CheckSource('TestCaseOfString',
  7518. LinesToStr([ // statements
  7519. 'this.s = "";',
  7520. 'this.h = "";',
  7521. '']),
  7522. LinesToStr([ // $mod.$main
  7523. 'var $tmp1 = $mod.s;',
  7524. 'if ($tmp1 === "foo") {',
  7525. ' $mod.s = $mod.h}',
  7526. ' else if (($tmp1.length === 1) && ($tmp1 >= "a") && ($tmp1 <= "z")) {',
  7527. ' $mod.h = $mod.s}',
  7528. ' else if (($tmp1 === "ў") || ($tmp1 === "ё")) {}',
  7529. ' else if (($tmp1.length === 1) && ($tmp1 >= "Б") && ($tmp1 <= "Я")) ;',
  7530. '']));
  7531. end;
  7532. procedure TTestModule.TestCaseOfChar;
  7533. begin
  7534. StartProgram(false);
  7535. Add([
  7536. 'var s,h: char;',
  7537. 'begin',
  7538. ' case s of',
  7539. ' ''a''..''z'': h:=s;',
  7540. ' ''ä'': ;',
  7541. ' ''ў'', ''ё'': ;',
  7542. ' ''Б''..''Я'': ;',
  7543. ' end;',
  7544. '']);
  7545. ConvertProgram;
  7546. CheckSource('TestCaseOfString',
  7547. LinesToStr([ // statements
  7548. 'this.s = "";',
  7549. 'this.h = "";',
  7550. '']),
  7551. LinesToStr([ // $mod.$main
  7552. 'var $tmp1 = $mod.s;',
  7553. 'if (($tmp1 >= "a") && ($tmp1 <= "z")) {',
  7554. ' $mod.h = $mod.s}',
  7555. ' else if ($tmp1 === "ä") {}',
  7556. ' else if (($tmp1 === "ў") || ($tmp1 === "ё")) {}',
  7557. ' else if (($tmp1 >= "Б") && ($tmp1 <= "Я")) ;',
  7558. '']));
  7559. end;
  7560. procedure TTestModule.TestCaseOfExternalClassConst;
  7561. begin
  7562. StartProgram(false);
  7563. Add([
  7564. '{$modeswitch externalclass}',
  7565. 'type',
  7566. ' TBird = class external name ''Bird''',
  7567. ' const e: longint;',
  7568. ' end;',
  7569. 'var vI: longint;',
  7570. 'begin',
  7571. ' case vi of',
  7572. ' 1: vi:=3;',
  7573. ' TBird.e: ;',
  7574. ' end;']);
  7575. ConvertProgram;
  7576. CheckSource('TestCaseOfExternalClassConst',
  7577. LinesToStr([ // statements
  7578. 'this.vI = 0;'
  7579. ]),
  7580. LinesToStr([ // $mod.$main
  7581. 'var $tmp1 = $mod.vI;',
  7582. 'if ($tmp1 === 1) {',
  7583. ' $mod.vI = 3}',
  7584. ' else if ($tmp1 === Bird.e) ;'
  7585. ]));
  7586. end;
  7587. procedure TTestModule.TestDebugger;
  7588. begin
  7589. StartProgram(false);
  7590. Add([
  7591. 'procedure DoIt;',
  7592. 'begin',
  7593. ' deBugger;',
  7594. ' DeBugger();',
  7595. 'end;',
  7596. 'begin',
  7597. ' Debugger;']);
  7598. ConvertProgram;
  7599. CheckSource('TestDebugger',
  7600. LinesToStr([ // statements
  7601. 'this.DoIt = function () {',
  7602. ' debugger;',
  7603. ' debugger;',
  7604. '};',
  7605. '']),
  7606. LinesToStr([ // $mod.$main
  7607. 'debugger;',
  7608. '']));
  7609. end;
  7610. procedure TTestModule.TestArray_Dynamic;
  7611. begin
  7612. StartProgram(false);
  7613. Add(['type',
  7614. ' TArrayInt = array of longint;',
  7615. 'var',
  7616. ' Arr: TArrayInt;',
  7617. ' i: longint;',
  7618. ' b: boolean;',
  7619. 'begin',
  7620. ' SetLength(arr,3);',
  7621. ' arr[0]:=4;',
  7622. ' arr[1]:=length(arr)+arr[0];',
  7623. ' arr[i]:=5;',
  7624. ' arr[arr[i]]:=arr[6];',
  7625. ' i:=low(arr);',
  7626. ' i:=high(arr);',
  7627. ' b:=Assigned(arr);',
  7628. ' Arr:=default(TArrayInt);']);
  7629. ConvertProgram;
  7630. CheckSource('TestArray_Dynamic',
  7631. LinesToStr([ // statements
  7632. 'this.Arr = [];',
  7633. 'this.i = 0;',
  7634. 'this.b = false;'
  7635. ]),
  7636. LinesToStr([ // $mod.$main
  7637. '$mod.Arr = rtl.arraySetLength($mod.Arr,0,3);',
  7638. '$mod.Arr[0] = 4;',
  7639. '$mod.Arr[1] = rtl.length($mod.Arr) + $mod.Arr[0];',
  7640. '$mod.Arr[$mod.i] = 5;',
  7641. '$mod.Arr[$mod.Arr[$mod.i]] = $mod.Arr[6];',
  7642. '$mod.i = 0;',
  7643. '$mod.i = rtl.length($mod.Arr) - 1;',
  7644. '$mod.b = rtl.length($mod.Arr) > 0;',
  7645. '$mod.Arr = [];',
  7646. '']));
  7647. end;
  7648. procedure TTestModule.TestArray_Dynamic_Nil;
  7649. begin
  7650. StartProgram(false);
  7651. Add('type');
  7652. Add(' TArrayInt = array of longint;');
  7653. Add('var');
  7654. Add(' Arr: TArrayInt;');
  7655. Add('procedure DoIt(const i: TArrayInt; j: TArrayInt); begin end;');
  7656. Add('begin');
  7657. Add(' arr:=nil;');
  7658. Add(' if arr=nil then;');
  7659. Add(' if nil=arr then;');
  7660. Add(' if arr<>nil then;');
  7661. Add(' if nil<>arr then;');
  7662. Add(' DoIt(nil,nil);');
  7663. ConvertProgram;
  7664. CheckSource('TestArray_Dynamic',
  7665. LinesToStr([ // statements
  7666. 'this.Arr = [];',
  7667. 'this.DoIt = function(i,j){',
  7668. '};'
  7669. ]),
  7670. LinesToStr([ // $mod.$main
  7671. '$mod.Arr = [];',
  7672. 'if (rtl.length($mod.Arr) === 0) ;',
  7673. 'if (rtl.length($mod.Arr) === 0) ;',
  7674. 'if (rtl.length($mod.Arr) > 0) ;',
  7675. 'if (rtl.length($mod.Arr) > 0) ;',
  7676. '$mod.DoIt([],[]);',
  7677. '']));
  7678. end;
  7679. procedure TTestModule.TestArray_DynMultiDimensional;
  7680. begin
  7681. StartProgram(false);
  7682. Add('type');
  7683. Add(' TArrayInt = array of longint;');
  7684. Add(' TArrayArrayInt = array of TArrayInt;');
  7685. Add('var');
  7686. Add(' Arr: TArrayInt;');
  7687. Add(' Arr2: TArrayArrayInt;');
  7688. Add(' i: longint;');
  7689. Add('begin');
  7690. Add(' arr2:=nil;');
  7691. Add(' if arr2=nil then;');
  7692. Add(' if nil=arr2 then;');
  7693. Add(' i:=low(arr2);');
  7694. Add(' i:=low(arr2[1]);');
  7695. Add(' i:=high(arr2);');
  7696. Add(' i:=high(arr2[2]);');
  7697. Add(' arr2[3]:=arr;');
  7698. Add(' arr2[4][5]:=i;');
  7699. Add(' i:=arr2[6][7];');
  7700. Add(' arr2[8,9]:=i;');
  7701. Add(' i:=arr2[10,11];');
  7702. Add(' SetLength(arr2,14);');
  7703. Add(' SetLength(arr2[15],16);');
  7704. ConvertProgram;
  7705. CheckSource('TestArray_Dynamic',
  7706. LinesToStr([ // statements
  7707. 'this.Arr = [];',
  7708. 'this.Arr2 = [];',
  7709. 'this.i = 0;'
  7710. ]),
  7711. LinesToStr([ // $mod.$main
  7712. '$mod.Arr2 = [];',
  7713. 'if (rtl.length($mod.Arr2) === 0) ;',
  7714. 'if (rtl.length($mod.Arr2) === 0) ;',
  7715. '$mod.i = 0;',
  7716. '$mod.i = 0;',
  7717. '$mod.i = rtl.length($mod.Arr2) - 1;',
  7718. '$mod.i = rtl.length($mod.Arr2[2]) - 1;',
  7719. '$mod.Arr2[3] = $mod.Arr;',
  7720. '$mod.Arr2[4][5] = $mod.i;',
  7721. '$mod.i = $mod.Arr2[6][7];',
  7722. '$mod.Arr2[8][9] = $mod.i;',
  7723. '$mod.i = $mod.Arr2[10][11];',
  7724. '$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
  7725. '$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
  7726. '']));
  7727. end;
  7728. procedure TTestModule.TestArray_StaticInt;
  7729. begin
  7730. StartProgram(false);
  7731. Add('type');
  7732. Add(' TArrayInt = array[2..4] of longint;');
  7733. Add('var');
  7734. Add(' Arr: TArrayInt;');
  7735. Add(' Arr2: TArrayInt = (5,6,7);');
  7736. Add(' i: longint;');
  7737. Add(' b: boolean;');
  7738. Add('begin');
  7739. Add(' arr[2]:=4;');
  7740. Add(' arr[3]:=arr[2]+arr[3];');
  7741. Add(' arr[i]:=5;');
  7742. Add(' arr[arr[i]]:=arr[high(arr)];');
  7743. Add(' i:=low(arr);');
  7744. Add(' i:=high(arr);');
  7745. Add(' b:=arr[2]=arr[3];');
  7746. Add(' arr:=default(TArrayInt);');
  7747. ConvertProgram;
  7748. CheckSource('TestArray_StaticInt',
  7749. LinesToStr([ // statements
  7750. 'this.Arr = rtl.arraySetLength(null,0,3);',
  7751. 'this.Arr2 = [5, 6, 7];',
  7752. 'this.i = 0;',
  7753. 'this.b = false;'
  7754. ]),
  7755. LinesToStr([ // $mod.$main
  7756. '$mod.Arr[0] = 4;',
  7757. '$mod.Arr[1] = $mod.Arr[0] + $mod.Arr[1];',
  7758. '$mod.Arr[$mod.i-2] = 5;',
  7759. '$mod.Arr[$mod.Arr[$mod.i-2]-2] = $mod.Arr[2];',
  7760. '$mod.i = 2;',
  7761. '$mod.i = 4;',
  7762. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  7763. '$mod.Arr = rtl.arraySetLength(null,0,3).slice(0);',
  7764. '']));
  7765. end;
  7766. procedure TTestModule.TestArray_StaticBool;
  7767. begin
  7768. StartProgram(false);
  7769. Add('type');
  7770. Add(' TBools = array[boolean] of boolean;');
  7771. Add(' TBool2 = array[true..true] of boolean;');
  7772. Add('var');
  7773. Add(' Arr: TBools;');
  7774. Add(' Arr2: TBool2;');
  7775. Add(' Arr3: TBools = (true,false);');
  7776. Add(' b: boolean;');
  7777. Add('begin');
  7778. Add(' b:=low(arr);');
  7779. Add(' b:=high(arr);');
  7780. Add(' arr[true]:=false;');
  7781. Add(' arr[false]:=arr[b] or arr[true];');
  7782. Add(' arr[b]:=true;');
  7783. Add(' arr[arr[b]]:=arr[high(arr)];');
  7784. Add(' b:=arr[false]=arr[true];');
  7785. Add(' b:=low(arr2);');
  7786. Add(' b:=high(arr2);');
  7787. Add(' arr2[true]:=true;');
  7788. Add(' arr2[true]:=arr2[true] and arr2[b];');
  7789. Add(' arr2[b]:=false;');
  7790. ConvertProgram;
  7791. CheckSource('TestArray_StaticBool',
  7792. LinesToStr([ // statements
  7793. 'this.Arr = rtl.arraySetLength(null,false,2);',
  7794. 'this.Arr2 = rtl.arraySetLength(null,false,1);',
  7795. 'this.Arr3 = [true, false];',
  7796. 'this.b = false;'
  7797. ]),
  7798. LinesToStr([ // $mod.$main
  7799. '$mod.b = false;',
  7800. '$mod.b = true;',
  7801. '$mod.Arr[1] = false;',
  7802. '$mod.Arr[0] = $mod.Arr[+$mod.b] || $mod.Arr[1];',
  7803. '$mod.Arr[+$mod.b] = true;',
  7804. '$mod.Arr[+$mod.Arr[+$mod.b]] = $mod.Arr[1];',
  7805. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  7806. '$mod.b = true;',
  7807. '$mod.b = true;',
  7808. '$mod.Arr2[0] = true;',
  7809. '$mod.Arr2[0] = $mod.Arr2[0] && $mod.Arr2[1-$mod.b];',
  7810. '$mod.Arr2[1-$mod.b] = false;',
  7811. '']));
  7812. end;
  7813. procedure TTestModule.TestArray_StaticChar;
  7814. begin
  7815. StartProgram(false);
  7816. Add([
  7817. 'type',
  7818. ' TChars = array[char] of char;',
  7819. ' TChars2 = array[''a''..''z''] of char;',
  7820. 'var',
  7821. ' Arr: TChars;',
  7822. ' Arr2: TChars2;',
  7823. ' Arr3: array[2..4] of char = (''p'',''a'',''s'');',
  7824. ' Arr4: array[11..13] of char = ''pas'';',
  7825. ' Arr5: array[21..22] of char = ''äö'';',
  7826. ' Arr6: array[31..32] of char = ''ä''+''ö'';',
  7827. ' c: char;',
  7828. ' b: boolean;',
  7829. 'begin',
  7830. ' c:=low(arr);',
  7831. ' c:=high(arr);',
  7832. ' arr[''B'']:=''a'';',
  7833. ' arr[''D'']:=arr[c];',
  7834. ' arr[c]:=arr[''d''];',
  7835. ' arr[arr[c]]:=arr[high(arr)];',
  7836. ' b:=arr[low(arr)]=arr[''e''];',
  7837. ' c:=low(arr2);',
  7838. ' c:=high(arr2);',
  7839. ' arr2[''b'']:=''f'';',
  7840. ' arr2[''a'']:=arr2[c];',
  7841. ' arr2[c]:=arr2[''g''];']);
  7842. ConvertProgram;
  7843. CheckSource('TestArray_StaticChar',
  7844. LinesToStr([ // statements
  7845. 'this.Arr = rtl.arraySetLength(null, "", 65536);',
  7846. 'this.Arr2 = rtl.arraySetLength(null, "", 26);',
  7847. 'this.Arr3 = ["p", "a", "s"];',
  7848. 'this.Arr4 = ["p", "a", "s"];',
  7849. 'this.Arr5 = ["ä", "ö"];',
  7850. 'this.Arr6 = ["ä", "ö"];',
  7851. 'this.c = "";',
  7852. 'this.b = false;',
  7853. '']),
  7854. LinesToStr([ // $mod.$main
  7855. '$mod.c = "\x00";',
  7856. '$mod.c = "\uFFFF";',
  7857. '$mod.Arr[66] = "a";',
  7858. '$mod.Arr[68] = $mod.Arr[$mod.c.charCodeAt()];',
  7859. '$mod.Arr[$mod.c.charCodeAt()] = $mod.Arr[100];',
  7860. '$mod.Arr[$mod.Arr[$mod.c.charCodeAt()].charCodeAt()] = $mod.Arr[65535];',
  7861. '$mod.b = $mod.Arr[0] === $mod.Arr[101];',
  7862. '$mod.c = "a";',
  7863. '$mod.c = "z";',
  7864. '$mod.Arr2[1] = "f";',
  7865. '$mod.Arr2[0] = $mod.Arr2[$mod.c.charCodeAt() - 97];',
  7866. '$mod.Arr2[$mod.c.charCodeAt() - 97] = $mod.Arr2[6];',
  7867. '']));
  7868. end;
  7869. procedure TTestModule.TestArray_StaticMultiDim;
  7870. begin
  7871. StartProgram(false);
  7872. Add([
  7873. 'type',
  7874. ' TArrayInt = array[1..3] of longint;',
  7875. ' TArrayArrayInt = array[5..6] of TArrayInt;',
  7876. 'var',
  7877. ' Arr: TArrayInt;',
  7878. ' Arr2: TArrayArrayInt;',
  7879. ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
  7880. ' i: longint;',
  7881. 'begin',
  7882. ' i:=low(arr);',
  7883. ' i:=low(arr2);',
  7884. ' i:=low(arr2[5]);',
  7885. ' i:=high(arr);',
  7886. ' i:=high(arr2);',
  7887. ' i:=high(arr2[6]);',
  7888. ' arr2[5]:=arr;',
  7889. ' arr2[6][2]:=i;',
  7890. ' i:=arr2[6][3];',
  7891. ' arr2[6,3]:=i;',
  7892. ' i:=arr2[5,2];',
  7893. ' arr2:=arr2;',// clone multi dim static array
  7894. //' arr3:=arr3;',// clone anonymous multi dim static array
  7895. '']);
  7896. ConvertProgram;
  7897. CheckSource('TestArray_StaticMultiDim',
  7898. LinesToStr([ // statements
  7899. 'this.TArrayArrayInt$clone = function (a) {',
  7900. ' var r = [];',
  7901. ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
  7902. ' return r;',
  7903. '};',
  7904. 'this.Arr = rtl.arraySetLength(null, 0, 3);',
  7905. 'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
  7906. 'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
  7907. 'this.i = 0;'
  7908. ]),
  7909. LinesToStr([ // $mod.$main
  7910. '$mod.i = 1;',
  7911. '$mod.i = 5;',
  7912. '$mod.i = 1;',
  7913. '$mod.i = 3;',
  7914. '$mod.i = 6;',
  7915. '$mod.i = 3;',
  7916. '$mod.Arr2[0] = $mod.Arr.slice(0);',
  7917. '$mod.Arr2[1][1] = $mod.i;',
  7918. '$mod.i = $mod.Arr2[1][2];',
  7919. '$mod.Arr2[1][2] = $mod.i;',
  7920. '$mod.i = $mod.Arr2[0][1];',
  7921. '$mod.Arr2 = $mod.TArrayArrayInt$clone($mod.Arr2);',
  7922. '']));
  7923. end;
  7924. procedure TTestModule.TestArray_StaticInFunction;
  7925. begin
  7926. StartProgram(false);
  7927. Add([
  7928. 'const TArrayInt = 3;',
  7929. 'const TArrayArrayInt = 4;',
  7930. 'procedure DoIt;',
  7931. 'type',
  7932. ' TArrayInt = array[1..3] of longint;',
  7933. ' TArrayArrayInt = array[5..6] of TArrayInt;',
  7934. 'var',
  7935. ' Arr: TArrayInt;',
  7936. ' Arr2: TArrayArrayInt;',
  7937. ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
  7938. ' i: longint;',
  7939. 'begin',
  7940. ' arr2[5]:=arr;',
  7941. ' arr2:=arr2;',// clone multi dim static array
  7942. 'end;',
  7943. 'begin',
  7944. '']);
  7945. ConvertProgram;
  7946. CheckSource('TestArray_StaticInFunction',
  7947. LinesToStr([ // statements
  7948. 'this.TArrayInt = 3;',
  7949. 'this.TArrayArrayInt = 4;',
  7950. 'var TArrayArrayInt$1$clone = function (a) {',
  7951. ' var r = [];',
  7952. ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
  7953. ' return r;',
  7954. '};',
  7955. 'this.DoIt = function () {',
  7956. ' var Arr = rtl.arraySetLength(null, 0, 3);',
  7957. ' var Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
  7958. ' var Arr3 = [[11, 12, 13], [21, 22, 23]];',
  7959. ' var i = 0;',
  7960. ' Arr2[0] = Arr.slice(0);',
  7961. ' Arr2 = TArrayArrayInt$1$clone(Arr2);',
  7962. '};',
  7963. '']),
  7964. LinesToStr([ // $mod.$main
  7965. '']));
  7966. end;
  7967. procedure TTestModule.TestArrayOfRecord;
  7968. begin
  7969. StartProgram(false);
  7970. Add([
  7971. 'type',
  7972. ' TRec = record',
  7973. ' Int: longint;',
  7974. ' end;',
  7975. ' TArrayRec = array of TRec;',
  7976. 'procedure DoIt(vd: TRec; const vc: TRec; var vv: TRec);',
  7977. 'begin',
  7978. 'end;',
  7979. 'var',
  7980. ' Arr: TArrayRec;',
  7981. ' r: TRec;',
  7982. ' i: longint;',
  7983. 'begin',
  7984. ' SetLength(arr,3);',
  7985. ' arr[0].int:=4;',
  7986. ' arr[1].int:=length(arr)+arr[2].int;',
  7987. ' arr[arr[i].int].int:=arr[5].int;',
  7988. ' arr[7]:=r;',
  7989. ' r:=arr[8];',
  7990. ' i:=low(arr);',
  7991. ' i:=high(arr);',
  7992. ' DoIt(Arr[9],Arr[10],Arr[11]);']);
  7993. ConvertProgram;
  7994. CheckSource('TestArrayOfRecord',
  7995. LinesToStr([ // statements
  7996. 'rtl.recNewT($mod, "TRec", function () {',
  7997. ' this.Int = 0;',
  7998. ' this.$eq = function (b) {',
  7999. ' return this.Int === b.Int;',
  8000. ' };',
  8001. ' this.$assign = function (s) {',
  8002. ' this.Int = s.Int;',
  8003. ' return this;',
  8004. ' };',
  8005. '});',
  8006. 'this.DoIt = function (vd, vc, vv) {',
  8007. '};',
  8008. 'this.Arr = [];',
  8009. 'this.r = $mod.TRec.$new();',
  8010. 'this.i = 0;'
  8011. ]),
  8012. LinesToStr([ // $mod.$main
  8013. '$mod.Arr = rtl.arraySetLength($mod.Arr,$mod.TRec,3);',
  8014. '$mod.Arr[0].Int = 4;',
  8015. '$mod.Arr[1].Int = rtl.length($mod.Arr)+$mod.Arr[2].Int;',
  8016. '$mod.Arr[$mod.Arr[$mod.i].Int].Int = $mod.Arr[5].Int;',
  8017. '$mod.Arr[7].$assign($mod.r);',
  8018. '$mod.r.$assign($mod.Arr[8]);',
  8019. '$mod.i = 0;',
  8020. '$mod.i = rtl.length($mod.Arr)-1;',
  8021. '$mod.DoIt($mod.TRec.$clone($mod.Arr[9]), $mod.Arr[10], $mod.Arr[11]);',
  8022. '']));
  8023. end;
  8024. procedure TTestModule.TestArray_StaticRecord;
  8025. begin
  8026. StartProgram(false);
  8027. Add([
  8028. 'type',
  8029. ' TRec = record',
  8030. ' Int: longint;',
  8031. ' end;',
  8032. ' TArrayRec = array[1..2] of TRec;',
  8033. 'var',
  8034. ' Arr: TArrayRec;',
  8035. 'begin',
  8036. ' arr[1].int:=length(arr)+low(arr)+high(arr);',
  8037. '']);
  8038. ConvertProgram;
  8039. CheckSource('TestArray_StaticRecord',
  8040. LinesToStr([ // statements
  8041. 'rtl.recNewT($mod, "TRec", function () {',
  8042. ' this.Int = 0;',
  8043. ' this.$eq = function (b) {',
  8044. ' return this.Int === b.Int;',
  8045. ' };',
  8046. ' this.$assign = function (s) {',
  8047. ' this.Int = s.Int;',
  8048. ' return this;',
  8049. ' };',
  8050. '});',
  8051. 'this.TArrayRec$clone = function (a) {',
  8052. ' var r = [];',
  8053. ' for (var i = 0; i < 2; i++) r.push($mod.TRec.$clone(a[i]));',
  8054. ' return r;',
  8055. '};',
  8056. 'this.Arr = rtl.arraySetLength(null, $mod.TRec, 2);',
  8057. '']),
  8058. LinesToStr([ // $mod.$main
  8059. '$mod.Arr[0].Int = 2 + 1 + 2;']));
  8060. end;
  8061. procedure TTestModule.TestArrayOfSet;
  8062. begin
  8063. StartProgram(false);
  8064. Add([
  8065. 'type',
  8066. ' TFlag = (big,small);',
  8067. ' TSetOfFlag = set of tflag;',
  8068. ' TArrayFlag = array of TSetOfFlag;',
  8069. 'procedure DoIt(const a: Tarrayflag);',
  8070. 'begin',
  8071. 'end;',
  8072. 'var',
  8073. ' f: TFlag;',
  8074. ' s: TSetOfFlag;',
  8075. ' Arr: TArrayFlag;',
  8076. ' i: longint;',
  8077. 'begin',
  8078. ' SetLength(arr,3);',
  8079. ' arr[0]:=s;',
  8080. ' arr[1]:=[big];',
  8081. ' arr[2]:=[big]+s;',
  8082. ' arr[3]:=s+[big];',
  8083. ' arr[4]:=arr[5];',
  8084. ' s:=arr[6];',
  8085. ' i:=low(arr);',
  8086. ' i:=high(arr);',
  8087. ' DoIt(arr);',
  8088. ' DoIt([s]);',
  8089. ' DoIt([[],s]);',
  8090. ' DoIt([s,[]]);',
  8091. '']);
  8092. ConvertProgram;
  8093. CheckSource('TestArrayOfSet',
  8094. LinesToStr([ // statements
  8095. 'this.TFlag = {',
  8096. ' "0": "big",',
  8097. ' big: 0,',
  8098. ' "1": "small",',
  8099. ' small: 1',
  8100. '};',
  8101. 'this.DoIt = function (a) {',
  8102. '};',
  8103. 'this.f = 0;',
  8104. 'this.s = {};',
  8105. 'this.Arr = [];',
  8106. 'this.i = 0;',
  8107. '']),
  8108. LinesToStr([ // $mod.$main
  8109. '$mod.Arr = rtl.arraySetLength($mod.Arr, {}, 3);',
  8110. '$mod.Arr[0] = rtl.refSet($mod.s);',
  8111. '$mod.Arr[1] = rtl.createSet($mod.TFlag.big);',
  8112. '$mod.Arr[2] = rtl.unionSet(rtl.createSet($mod.TFlag.big), $mod.s);',
  8113. '$mod.Arr[3] = rtl.unionSet($mod.s, rtl.createSet($mod.TFlag.big));',
  8114. '$mod.Arr[4] = rtl.refSet($mod.Arr[5]);',
  8115. '$mod.s = rtl.refSet($mod.Arr[6]);',
  8116. '$mod.i = 0;',
  8117. '$mod.i = rtl.length($mod.Arr) - 1;',
  8118. '$mod.DoIt($mod.Arr);',
  8119. '$mod.DoIt([rtl.refSet($mod.s)]);',
  8120. '$mod.DoIt([{}, rtl.refSet($mod.s)]);',
  8121. '$mod.DoIt([rtl.refSet($mod.s), {}]);',
  8122. '']));
  8123. end;
  8124. procedure TTestModule.TestArray_DynAsParam;
  8125. begin
  8126. StartProgram(false);
  8127. Add([
  8128. 'type integer = longint;',
  8129. 'type TArrInt = array of integer;',
  8130. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  8131. 'var vJ: TArrInt;',
  8132. 'begin',
  8133. ' vg:=vg;',
  8134. ' vj:=vh;',
  8135. ' vi:=vi;',
  8136. ' doit(vg,vg,vg);',
  8137. ' doit(vh,vh,vj);',
  8138. ' doit(vi,vi,vi);',
  8139. ' doit(vj,vj,vj);',
  8140. 'end;',
  8141. 'var i: TArrInt;',
  8142. 'begin',
  8143. ' doit(i,i,i);']);
  8144. ConvertProgram;
  8145. CheckSource('TestArray_DynAsParams',
  8146. LinesToStr([ // statements
  8147. 'this.DoIt = function (vG,vH,vI) {',
  8148. ' var vJ = [];',
  8149. ' vG = vG;',
  8150. ' vJ = vH;',
  8151. ' vI.set(vI.get());',
  8152. ' $mod.DoIt(vG, vG, {',
  8153. ' get: function () {',
  8154. ' return vG;',
  8155. ' },',
  8156. ' set: function (v) {',
  8157. ' vG = v;',
  8158. ' }',
  8159. ' });',
  8160. ' $mod.DoIt(vH, vH, {',
  8161. ' get: function () {',
  8162. ' return vJ;',
  8163. ' },',
  8164. ' set: function (v) {',
  8165. ' vJ = v;',
  8166. ' }',
  8167. ' });',
  8168. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  8169. ' $mod.DoIt(vJ, vJ, {',
  8170. ' get: function () {',
  8171. ' return vJ;',
  8172. ' },',
  8173. ' set: function (v) {',
  8174. ' vJ = v;',
  8175. ' }',
  8176. ' });',
  8177. '};',
  8178. 'this.i = [];'
  8179. ]),
  8180. LinesToStr([
  8181. '$mod.DoIt($mod.i,$mod.i,{',
  8182. ' p: $mod,',
  8183. ' get: function () {',
  8184. ' return this.p.i;',
  8185. ' },',
  8186. ' set: function (v) {',
  8187. ' this.p.i = v;',
  8188. ' }',
  8189. '});'
  8190. ]));
  8191. end;
  8192. procedure TTestModule.TestArray_StaticAsParam;
  8193. begin
  8194. StartProgram(false);
  8195. Add([
  8196. 'type integer = longint;',
  8197. 'type TArrInt = array[1..2] of integer;',
  8198. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  8199. 'var vJ: TArrInt;',
  8200. 'begin',
  8201. ' vg:=vg;',
  8202. ' vj:=vh;',
  8203. ' vi:=vi;',
  8204. ' doit(vg,vg,vg);',
  8205. ' doit(vh,vh,vj);',
  8206. ' doit(vi,vi,vi);',
  8207. ' doit(vj,vj,vj);',
  8208. 'end;',
  8209. 'var i: TArrInt;',
  8210. 'begin',
  8211. ' doit(i,i,i);']);
  8212. ConvertProgram;
  8213. CheckSource('TestArray_StaticAsParams',
  8214. LinesToStr([ // statements
  8215. 'this.DoIt = function (vG,vH,vI) {',
  8216. ' var vJ = rtl.arraySetLength(null, 0, 2);',
  8217. ' vG = vG.slice(0);',
  8218. ' vJ = vH.slice(0);',
  8219. ' vI.set(vI.get().slice(0));',
  8220. ' $mod.DoIt(vG.slice(0), vG, {',
  8221. ' get: function () {',
  8222. ' return vG;',
  8223. ' },',
  8224. ' set: function (v) {',
  8225. ' vG = v;',
  8226. ' }',
  8227. ' });',
  8228. ' $mod.DoIt(vH.slice(0), vH, {',
  8229. ' get: function () {',
  8230. ' return vJ;',
  8231. ' },',
  8232. ' set: function (v) {',
  8233. ' vJ = v;',
  8234. ' }',
  8235. ' });',
  8236. ' $mod.DoIt(vI.get().slice(0), vI.get(), vI);',
  8237. ' $mod.DoIt(vJ.slice(0), vJ, {',
  8238. ' get: function () {',
  8239. ' return vJ;',
  8240. ' },',
  8241. ' set: function (v) {',
  8242. ' vJ = v;',
  8243. ' }',
  8244. ' });',
  8245. '};',
  8246. 'this.i = rtl.arraySetLength(null, 0, 2);'
  8247. ]),
  8248. LinesToStr([
  8249. '$mod.DoIt($mod.i.slice(0),$mod.i,{',
  8250. ' p: $mod,',
  8251. ' get: function () {',
  8252. ' return this.p.i;',
  8253. ' },',
  8254. ' set: function (v) {',
  8255. ' this.p.i = v;',
  8256. ' }',
  8257. '});'
  8258. ]));
  8259. end;
  8260. procedure TTestModule.TestArrayElement_AsParams;
  8261. begin
  8262. StartProgram(false);
  8263. Add('type integer = longint;');
  8264. Add('type TArrayInt = array of integer;');
  8265. Add('procedure DoIt(vG: Integer; const vH: Integer; var vI: Integer);');
  8266. Add('var vJ: tarrayint;');
  8267. Add('begin');
  8268. Add(' vi:=vi;');
  8269. Add(' doit(vi,vi,vi);');
  8270. Add(' doit(vj[1+1],vj[1+2],vj[1+3]);');
  8271. Add('end;');
  8272. Add('var a: TArrayInt;');
  8273. Add('begin');
  8274. Add(' doit(a[1+4],a[1+5],a[1+6]);');
  8275. ConvertProgram;
  8276. CheckSource('TestArrayElement_AsParams',
  8277. LinesToStr([ // statements
  8278. 'this.DoIt = function (vG,vH,vI) {',
  8279. ' var vJ = [];',
  8280. ' vI.set(vI.get());',
  8281. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  8282. ' $mod.DoIt(vJ[1+1], vJ[1+2], {',
  8283. ' a:1+3,',
  8284. ' p:vJ,',
  8285. ' get: function () {',
  8286. ' return this.p[this.a];',
  8287. ' },',
  8288. ' set: function (v) {',
  8289. ' this.p[this.a] = v;',
  8290. ' }',
  8291. ' });',
  8292. '};',
  8293. 'this.a = [];'
  8294. ]),
  8295. LinesToStr([
  8296. '$mod.DoIt($mod.a[1+4],$mod.a[1+5],{',
  8297. ' a: 1+6,',
  8298. ' p: $mod.a,',
  8299. ' get: function () {',
  8300. ' return this.p[this.a];',
  8301. ' },',
  8302. ' set: function (v) {',
  8303. ' this.p[this.a] = v;',
  8304. ' }',
  8305. '});'
  8306. ]));
  8307. end;
  8308. procedure TTestModule.TestArrayElementFromFuncResult_AsParams;
  8309. begin
  8310. StartProgram(false);
  8311. Add('type Integer = longint;');
  8312. Add('type TArrayInt = array of integer;');
  8313. Add('function GetArr(vB: integer = 0): tarrayint;');
  8314. Add('begin');
  8315. Add('end;');
  8316. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  8317. Add('begin');
  8318. Add('end;');
  8319. Add('begin');
  8320. Add(' doit(getarr[1+1],getarr[1+2],getarr[1+3]);');
  8321. Add(' doit(getarr()[2+1],getarr()[2+2],getarr()[2+3]);');
  8322. Add(' doit(getarr(7)[3+1],getarr(8)[3+2],getarr(9)[3+3]);');
  8323. ConvertProgram;
  8324. CheckSource('TestArrayElementFromFuncResult_AsParams',
  8325. LinesToStr([ // statements
  8326. 'this.GetArr = function (vB) {',
  8327. ' var Result = [];',
  8328. ' return Result;',
  8329. '};',
  8330. 'this.DoIt = function (vG,vH,vI) {',
  8331. '};'
  8332. ]),
  8333. LinesToStr([
  8334. '$mod.DoIt($mod.GetArr(0)[1+1],$mod.GetArr(0)[1+2],{',
  8335. ' a: 1+3,',
  8336. ' p: $mod.GetArr(0),',
  8337. ' get: function () {',
  8338. ' return this.p[this.a];',
  8339. ' },',
  8340. ' set: function (v) {',
  8341. ' this.p[this.a] = v;',
  8342. ' }',
  8343. '});',
  8344. '$mod.DoIt($mod.GetArr(0)[2+1],$mod.GetArr(0)[2+2],{',
  8345. ' a: 2+3,',
  8346. ' p: $mod.GetArr(0),',
  8347. ' get: function () {',
  8348. ' return this.p[this.a];',
  8349. ' },',
  8350. ' set: function (v) {',
  8351. ' this.p[this.a] = v;',
  8352. ' }',
  8353. '});',
  8354. '$mod.DoIt($mod.GetArr(7)[3+1],$mod.GetArr(8)[3+2],{',
  8355. ' a: 3+3,',
  8356. ' p: $mod.GetArr(9),',
  8357. ' get: function () {',
  8358. ' return this.p[this.a];',
  8359. ' },',
  8360. ' set: function (v) {',
  8361. ' this.p[this.a] = v;',
  8362. ' }',
  8363. '});',
  8364. '']));
  8365. end;
  8366. procedure TTestModule.TestArrayEnumTypeRange;
  8367. begin
  8368. StartProgram(false);
  8369. Add([
  8370. 'type',
  8371. ' TEnum = (red,blue);',
  8372. ' TEnumArray = array[TEnum] of longint;',
  8373. 'var',
  8374. ' e: TEnum;',
  8375. ' i: longint;',
  8376. ' a: TEnumArray;',
  8377. ' numbers: TEnumArray = (1,2);',
  8378. ' names: array[TEnum] of string = (''red'',''blue'');',
  8379. 'begin',
  8380. ' e:=low(a);',
  8381. ' e:=high(a);',
  8382. ' i:=a[red];',
  8383. ' a[e]:=a[e];']);
  8384. ConvertProgram;
  8385. CheckSource('TestArrayEnumTypeRange',
  8386. LinesToStr([ // statements
  8387. ' this.TEnum = {',
  8388. ' "0": "red",',
  8389. ' red: 0,',
  8390. ' "1": "blue",',
  8391. ' blue: 1',
  8392. '};',
  8393. 'this.e = 0;',
  8394. 'this.i = 0;',
  8395. 'this.a = rtl.arraySetLength(null,0,2);',
  8396. 'this.numbers = [1, 2];',
  8397. 'this.names = ["red", "blue"];',
  8398. '']),
  8399. LinesToStr([ // $mod.$main
  8400. '$mod.e = $mod.TEnum.red;',
  8401. '$mod.e = $mod.TEnum.blue;',
  8402. '$mod.i = $mod.a[$mod.TEnum.red];',
  8403. '$mod.a[$mod.e] = $mod.a[$mod.e];',
  8404. '']));
  8405. end;
  8406. procedure TTestModule.TestArray_SetLengthOutArg;
  8407. begin
  8408. StartProgram(false);
  8409. Add([
  8410. 'type TArrInt = array of longint;',
  8411. 'procedure DoIt(out a: TArrInt);',
  8412. 'begin',
  8413. ' SetLength(a,2);',
  8414. 'end;',
  8415. 'begin',
  8416. '']);
  8417. ConvertProgram;
  8418. CheckSource('TestArray_SetLengthOutArg',
  8419. LinesToStr([ // statements
  8420. 'this.DoIt = function (a) {',
  8421. ' a.set(rtl.arraySetLength(a.get(), 0, 2));',
  8422. '};',
  8423. '']),
  8424. LinesToStr([
  8425. '']));
  8426. end;
  8427. procedure TTestModule.TestArray_SetLengthProperty;
  8428. begin
  8429. StartProgram(false);
  8430. Add('type');
  8431. Add(' TArrInt = array of longint;');
  8432. Add(' TObject = class');
  8433. Add(' function GetColors: TArrInt; external name ''GetColors'';');
  8434. Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
  8435. Add(' property Colors: TArrInt read GetColors write SetColors;');
  8436. Add(' end;');
  8437. Add('var Obj: TObject;');
  8438. Add('begin');
  8439. Add(' SetLength(Obj.Colors,2);');
  8440. ConvertProgram;
  8441. CheckSource('TestArray_SetLengthProperty',
  8442. LinesToStr([ // statements
  8443. 'rtl.createClass($mod, "TObject", null, function () {',
  8444. ' this.$init = function () {',
  8445. ' };',
  8446. ' this.$final = function () {',
  8447. ' };',
  8448. '});',
  8449. 'this.Obj = null;',
  8450. '']),
  8451. LinesToStr([
  8452. '$mod.Obj.SetColors(rtl.arraySetLength($mod.Obj.GetColors(), 0, 2));',
  8453. '']));
  8454. end;
  8455. procedure TTestModule.TestArray_SetLengthMultiDim;
  8456. begin
  8457. StartProgram(false);
  8458. Add([
  8459. 'type',
  8460. ' TArrArrInt = array of array of longint;',
  8461. 'var',
  8462. ' a: TArrArrInt;',
  8463. 'begin',
  8464. ' SetLength(a,2);',
  8465. ' SetLength(a,3,4);',
  8466. '']);
  8467. ConvertProgram;
  8468. CheckSource('TestArray_SetLengthMultiDim',
  8469. LinesToStr([ // statements
  8470. 'this.a = [];']),
  8471. LinesToStr([
  8472. '$mod.a = rtl.arraySetLength($mod.a, [], 2);',
  8473. '$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
  8474. '']));
  8475. end;
  8476. procedure TTestModule.TestArray_OpenArrayOfString;
  8477. begin
  8478. StartProgram(false);
  8479. Add('procedure DoIt(const a: array of String);');
  8480. Add('var');
  8481. Add(' i: longint;');
  8482. Add(' s: string;');
  8483. Add('begin');
  8484. Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
  8485. Add('end;');
  8486. Add('var s: string;');
  8487. Add('begin');
  8488. Add(' DoIt([]);');
  8489. Add(' DoIt([s,''foo'','''',s+s]);');
  8490. ConvertProgram;
  8491. CheckSource('TestArray_OpenArrayOfString',
  8492. LinesToStr([ // statements
  8493. 'this.DoIt = function (a) {',
  8494. ' var i = 0;',
  8495. ' var s = "";',
  8496. ' for (var $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
  8497. ' i = $l1;',
  8498. ' s = a[rtl.length(a) - i - 1];',
  8499. ' };',
  8500. '};',
  8501. 'this.s = "";',
  8502. '']),
  8503. LinesToStr([
  8504. '$mod.DoIt([]);',
  8505. '$mod.DoIt([$mod.s, "foo", "", $mod.s + $mod.s]);',
  8506. '']));
  8507. end;
  8508. procedure TTestModule.TestArray_Concat;
  8509. begin
  8510. StartProgram(false);
  8511. Add([
  8512. 'type',
  8513. ' integer = longint;',
  8514. ' TFlag = (big,small);',
  8515. ' TFlags = set of TFlag;',
  8516. ' TRec = record',
  8517. ' i: integer;',
  8518. ' end;',
  8519. ' TArrInt = array of integer;',
  8520. ' TArrRec = array of TRec;',
  8521. ' TArrFlag = array of TFlag;',
  8522. ' TArrSet = array of TFlags;',
  8523. ' TArrJSValue = array of jsvalue;',
  8524. 'var',
  8525. ' ArrInt: tarrint;',
  8526. ' ArrRec: tarrrec;',
  8527. ' ArrFlag: tarrflag;',
  8528. ' ArrSet: tarrset;',
  8529. ' ArrJSValue: tarrjsvalue;',
  8530. 'begin',
  8531. ' arrint:=concat(arrint);',
  8532. ' arrint:=concat(arrint,arrint);',
  8533. ' arrint:=concat(arrint,arrint,arrint);',
  8534. ' arrrec:=concat(arrrec);',
  8535. ' arrrec:=concat(arrrec,arrrec);',
  8536. ' arrrec:=concat(arrrec,arrrec,arrrec);',
  8537. ' arrset:=concat(arrset);',
  8538. ' arrset:=concat(arrset,arrset);',
  8539. ' arrset:=concat(arrset,arrset,arrset);',
  8540. ' arrjsvalue:=concat(arrjsvalue);',
  8541. ' arrjsvalue:=concat(arrjsvalue,arrjsvalue);',
  8542. ' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);',
  8543. ' arrint:=concat([1],arrint);',
  8544. ' arrflag:=concat([big]);',
  8545. ' arrflag:=concat([big],arrflag);',
  8546. ' arrflag:=concat(arrflag,[small]);',
  8547. '']);
  8548. ConvertProgram;
  8549. CheckSource('TestArray_Concat',
  8550. LinesToStr([ // statements
  8551. 'this.TFlag = {',
  8552. ' "0": "big",',
  8553. ' big: 0,',
  8554. ' "1": "small",',
  8555. ' small: 1',
  8556. '};',
  8557. 'rtl.recNewT($mod, "TRec", function () {',
  8558. ' this.i = 0;',
  8559. ' this.$eq = function (b) {',
  8560. ' return this.i === b.i;',
  8561. ' };',
  8562. ' this.$assign = function (s) {',
  8563. ' this.i = s.i;',
  8564. ' return this;',
  8565. ' };',
  8566. '});',
  8567. 'this.ArrInt = [];',
  8568. 'this.ArrRec = [];',
  8569. 'this.ArrFlag = [];',
  8570. 'this.ArrSet = [];',
  8571. 'this.ArrJSValue = [];',
  8572. '']),
  8573. LinesToStr([ // $mod.$main
  8574. '$mod.ArrInt = $mod.ArrInt;',
  8575. '$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt);',
  8576. '$mod.ArrInt = rtl.arrayConcatN($mod.ArrInt, $mod.ArrInt, $mod.ArrInt);',
  8577. '$mod.ArrRec = $mod.ArrRec;',
  8578. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
  8579. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec, $mod.ArrRec);',
  8580. '$mod.ArrSet = $mod.ArrSet;',
  8581. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
  8582. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet, $mod.ArrSet);',
  8583. '$mod.ArrJSValue = $mod.ArrJSValue;',
  8584. '$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue);',
  8585. '$mod.ArrJSValue = rtl.arrayConcatN($mod.ArrJSValue, $mod.ArrJSValue, $mod.ArrJSValue);',
  8586. '$mod.ArrInt = rtl.arrayConcatN([1], $mod.ArrInt);',
  8587. '$mod.ArrFlag = [$mod.TFlag.big];',
  8588. '$mod.ArrFlag = rtl.arrayConcatN([$mod.TFlag.big], $mod.ArrFlag);',
  8589. '$mod.ArrFlag = rtl.arrayConcatN($mod.ArrFlag, [$mod.TFlag.small]);',
  8590. '']));
  8591. end;
  8592. procedure TTestModule.TestArray_Copy;
  8593. begin
  8594. StartProgram(false);
  8595. Add([
  8596. 'type',
  8597. ' integer = longint;',
  8598. ' TFlag = (big,small);',
  8599. ' TFlags = set of TFlag;',
  8600. ' TRec = record',
  8601. ' i: integer;',
  8602. ' end;',
  8603. ' TArrInt = array of integer;',
  8604. ' TArrRec = array of TRec;',
  8605. ' TArrSet = array of TFlags;',
  8606. ' TArrJSValue = array of jsvalue;',
  8607. 'var',
  8608. ' ArrInt: tarrint;',
  8609. ' ArrRec: tarrrec;',
  8610. ' ArrSet: tarrset;',
  8611. ' ArrJSValue: tarrjsvalue;',
  8612. 'begin',
  8613. ' arrint:=copy(arrint);',
  8614. ' arrint:=copy(arrint,2);',
  8615. ' arrint:=copy(arrint,3,4);',
  8616. ' arrint:=copy([1,1],1,2);',
  8617. ' arrrec:=copy(arrrec);',
  8618. ' arrrec:=copy(arrrec,5);',
  8619. ' arrrec:=copy(arrrec,6,7);',
  8620. ' arrset:=copy(arrset);',
  8621. ' arrset:=copy(arrset,8);',
  8622. ' arrset:=copy(arrset,9,10);',
  8623. ' arrjsvalue:=copy(arrjsvalue);',
  8624. ' arrjsvalue:=copy(arrjsvalue,11);',
  8625. ' arrjsvalue:=copy(arrjsvalue,12,13);',
  8626. ' ']);
  8627. ConvertProgram;
  8628. CheckSource('TestArray_Copy',
  8629. LinesToStr([ // statements
  8630. 'this.TFlag = {',
  8631. ' "0": "big",',
  8632. ' big: 0,',
  8633. ' "1": "small",',
  8634. ' small: 1',
  8635. '};',
  8636. 'rtl.recNewT($mod, "TRec", function () {',
  8637. ' this.i = 0;',
  8638. ' this.$eq = function (b) {',
  8639. ' return this.i === b.i;',
  8640. ' };',
  8641. ' this.$assign = function (s) {',
  8642. ' this.i = s.i;',
  8643. ' return this;',
  8644. ' };',
  8645. '});',
  8646. 'this.ArrInt = [];',
  8647. 'this.ArrRec = [];',
  8648. 'this.ArrSet = [];',
  8649. 'this.ArrJSValue = [];',
  8650. '']),
  8651. LinesToStr([ // $mod.$main
  8652. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 0);',
  8653. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 2);',
  8654. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 3, 4);',
  8655. '$mod.ArrInt = rtl.arrayCopy(0, [1, 1], 1, 2);',
  8656. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 0);',
  8657. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 5);',
  8658. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 6, 7);',
  8659. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 0);',
  8660. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 8);',
  8661. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 9, 10);',
  8662. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 0);',
  8663. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 11);',
  8664. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 12, 13);',
  8665. '']));
  8666. end;
  8667. procedure TTestModule.TestArray_InsertDelete;
  8668. begin
  8669. StartProgram(false);
  8670. Add([
  8671. 'type',
  8672. ' integer = longint;',
  8673. ' TFlag = (big,small);',
  8674. ' TFlags = set of TFlag;',
  8675. ' TRec = record',
  8676. ' i: integer;',
  8677. ' end;',
  8678. ' TArrInt = array of integer;',
  8679. ' TArrRec = array of TRec;',
  8680. ' TArrSet = array of TFlags;',
  8681. ' TArrJSValue = array of jsvalue;',
  8682. ' TArrArrInt = array of TArrInt;',
  8683. 'var',
  8684. ' ArrInt: tarrint;',
  8685. ' ArrRec: tarrrec;',
  8686. ' ArrSet: tarrset;',
  8687. ' ArrJSValue: tarrjsvalue;',
  8688. ' ArrArrInt: TArrArrInt;',
  8689. 'begin',
  8690. ' Insert(1,arrint,2);',
  8691. ' Insert(arrint[3],arrint,4);',
  8692. ' Insert(arrrec[5],arrrec,6);',
  8693. ' Insert(arrset[7],arrset,7);',
  8694. ' Insert(arrjsvalue[8],arrjsvalue,9);',
  8695. ' Insert(10,arrjsvalue,11);',
  8696. ' Insert([23],arrarrint,22);',
  8697. ' Delete(arrint,12,13);',
  8698. ' Delete(arrrec,14,15);',
  8699. ' Delete(arrset,17,18);',
  8700. ' Delete(arrjsvalue,19,10);']);
  8701. ConvertProgram;
  8702. CheckSource('TestArray_InsertDelete',
  8703. LinesToStr([ // statements
  8704. 'this.TFlag = {',
  8705. ' "0": "big",',
  8706. ' big: 0,',
  8707. ' "1": "small",',
  8708. ' small: 1',
  8709. '};',
  8710. 'rtl.recNewT($mod, "TRec", function () {',
  8711. ' this.i = 0;',
  8712. ' this.$eq = function (b) {',
  8713. ' return this.i === b.i;',
  8714. ' };',
  8715. ' this.$assign = function (s) {',
  8716. ' this.i = s.i;',
  8717. ' return this;',
  8718. ' };',
  8719. '});',
  8720. 'this.ArrInt = [];',
  8721. 'this.ArrRec = [];',
  8722. 'this.ArrSet = [];',
  8723. 'this.ArrJSValue = [];',
  8724. 'this.ArrArrInt = [];',
  8725. '']),
  8726. LinesToStr([ // $mod.$main
  8727. '$mod.ArrInt.splice(2, 0, 1);',
  8728. '$mod.ArrInt.splice(4, 0, $mod.ArrInt[3]);',
  8729. '$mod.ArrRec.splice(6, 0, $mod.ArrRec[5]);',
  8730. '$mod.ArrSet.splice(7, 0, $mod.ArrSet[7]);',
  8731. '$mod.ArrJSValue.splice(9, 0, $mod.ArrJSValue[8]);',
  8732. '$mod.ArrJSValue.splice(11, 0, 10);',
  8733. '$mod.ArrArrInt.splice(22, 0, [23]);',
  8734. '$mod.ArrInt.splice(12, 13);',
  8735. '$mod.ArrRec.splice(14, 15);',
  8736. '$mod.ArrSet.splice(17, 18);',
  8737. '$mod.ArrJSValue.splice(19, 10);',
  8738. '']));
  8739. end;
  8740. procedure TTestModule.TestArray_DynArrayConstObjFPC;
  8741. begin
  8742. StartProgram(false);
  8743. Add([
  8744. '{$modeswitch arrayoperators}',
  8745. 'type',
  8746. ' integer = longint;',
  8747. ' TArrInt = array of integer;',
  8748. ' TArrStr = array of string;',
  8749. 'const',
  8750. ' Ints: TArrInt = (1,2,3);',
  8751. ' Aliases: TarrStr = (''foo'',''b'');',
  8752. ' OneInt: TArrInt = (7);',
  8753. ' OneStr: array of integer = (7);',
  8754. ' Chars: array of char = ''aoc'';',
  8755. ' Names: array of string = (''a'',''foo'');',
  8756. ' NameCount = low(Names)+high(Names)+length(Names);',
  8757. 'var i: integer;',
  8758. 'begin',
  8759. ' Ints:=[];',
  8760. ' Ints:=[1,1];',
  8761. ' Ints:=[1]+[2];',
  8762. ' Ints:=[2];',
  8763. ' Ints:=[]+ints;',
  8764. ' Ints:=Ints+[];',
  8765. ' Ints:=Ints+OneInt;',
  8766. ' Ints:=Ints+[1,1];',
  8767. ' Ints:=[i,i]+Ints;',
  8768. ' Ints:=[1]+[i]+[3];',
  8769. '']);
  8770. ConvertProgram;
  8771. CheckSource('TestArray_DynArrayConstObjFPC',
  8772. LinesToStr([ // statements
  8773. 'this.Ints = [1, 2, 3];',
  8774. 'this.Aliases = ["foo", "b"];',
  8775. 'this.OneInt = [7];',
  8776. 'this.OneStr = [7];',
  8777. 'this.Chars = ["a", "o", "c"];',
  8778. 'this.Names = ["a", "foo"];',
  8779. 'this.NameCount = 0 + (rtl.length($mod.Names) - 1) + rtl.length($mod.Names);',
  8780. 'this.i = 0;',
  8781. '']),
  8782. LinesToStr([ // $mod.$main
  8783. '$mod.Ints = [];',
  8784. '$mod.Ints = [1, 1];',
  8785. '$mod.Ints = rtl.arrayConcatN([1], [2]);',
  8786. '$mod.Ints = [2];',
  8787. '$mod.Ints = rtl.arrayConcatN([], $mod.Ints);',
  8788. '$mod.Ints = rtl.arrayConcatN($mod.Ints, []);',
  8789. '$mod.Ints = rtl.arrayConcatN($mod.Ints, $mod.OneInt);',
  8790. '$mod.Ints = rtl.arrayConcatN($mod.Ints, [1, 1]);',
  8791. '$mod.Ints = rtl.arrayConcatN([$mod.i, $mod.i], $mod.Ints);',
  8792. '$mod.Ints = rtl.arrayConcatN(rtl.arrayConcatN([1], [$mod.i]), [3]);',
  8793. '']));
  8794. end;
  8795. procedure TTestModule.TestArray_DynArrayConstDelphi;
  8796. begin
  8797. StartProgram(false);
  8798. // Note: const c = [1,1]; defines a set!
  8799. Add([
  8800. '{$mode delphi}',
  8801. 'type',
  8802. ' integer = longint;',
  8803. ' TArrInt = array of integer;',
  8804. ' TArrStr = array of string;',
  8805. 'const',
  8806. ' Ints: TArrInt = [1,1,2];',
  8807. ' Aliases: TarrStr = [''foo'',''b''];',
  8808. ' OneInt: TArrInt = [7];',
  8809. ' OneStr: array of integer = [7]+[8];',
  8810. ' Chars: array of char = ''aoc'';',
  8811. ' Names: array of string = [''a'',''a''];',
  8812. ' NameCount = low(Names)+high(Names)+length(Names);',
  8813. 'begin',
  8814. '']);
  8815. ConvertProgram;
  8816. CheckSource('TestArray_DynArrayConstDelphi',
  8817. LinesToStr([ // statements
  8818. 'this.Ints = [1, 1, 2];',
  8819. 'this.Aliases = ["foo", "b"];',
  8820. 'this.OneInt = [7];',
  8821. 'this.OneStr = rtl.arrayConcatN([7],[8]);',
  8822. 'this.Chars = ["a", "o", "c"];',
  8823. 'this.Names = ["a", "a"];',
  8824. 'this.NameCount = 0 + (rtl.length($mod.Names) - 1) + rtl.length($mod.Names);',
  8825. '']),
  8826. LinesToStr([ // $mod.$main
  8827. '']));
  8828. end;
  8829. procedure TTestModule.TestArray_ArrayLitAsParam;
  8830. begin
  8831. StartProgram(false);
  8832. Add([
  8833. '{$modeswitch arrayoperators}',
  8834. 'type',
  8835. ' integer = longint;',
  8836. ' TArrInt = array of integer;',
  8837. ' TArrSet = array of (red,green,blue);',
  8838. 'procedure DoOpenInt(a: array of integer); forward;',
  8839. 'procedure DoInt(a: TArrInt);',
  8840. 'begin',
  8841. ' DoInt(a+[1]);',
  8842. ' DoInt([1]+a);',
  8843. ' DoOpenInt(a);',
  8844. ' DoOpenInt(a+[1]);',
  8845. ' DoOpenInt([1]+a);',
  8846. 'end;',
  8847. 'procedure DoOpenInt(a: array of integer);',
  8848. 'begin',
  8849. ' DoOpenInt(a+[1]);',
  8850. ' DoOpenInt([1]+a);',
  8851. ' DoInt(a);',
  8852. ' DoInt(a+[1]);',
  8853. ' DoInt([1]+a);',
  8854. 'end;',
  8855. 'procedure DoSet(a: TArrSet);',
  8856. 'begin',
  8857. ' DoSet(a+[red]);',
  8858. ' DoSet([blue]+a);',
  8859. 'end;',
  8860. 'var',
  8861. ' i: TArrInt;',
  8862. ' s: TArrSet;',
  8863. 'begin',
  8864. ' DoInt([1]);',
  8865. ' DoInt([1]+[2]);',
  8866. ' DoInt(i+[1]);',
  8867. ' DoInt([1]+i);',
  8868. ' DoOpenInt([1]);',
  8869. ' DoOpenInt([1]+[2]);',
  8870. ' DoOpenInt(i+[1]);',
  8871. ' DoOpenInt([1]+i);',
  8872. ' DoSet([red]);',
  8873. ' DoSet([blue]+[green]);',
  8874. ' DoSet(s+[blue]);',
  8875. ' DoSet([red]+s);',
  8876. '']);
  8877. ConvertProgram;
  8878. CheckSource('TestArray_ArrayLitAsParam',
  8879. LinesToStr([ // statements
  8880. 'this.TArrSet$a = {',
  8881. ' "0": "red",',
  8882. ' red: 0,',
  8883. ' "1": "green",',
  8884. ' green: 1,',
  8885. ' "2": "blue",',
  8886. ' blue: 2',
  8887. '};',
  8888. 'this.DoInt = function (a) {',
  8889. ' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
  8890. ' $mod.DoInt(rtl.arrayConcatN([1], a));',
  8891. ' $mod.DoOpenInt(a);',
  8892. ' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
  8893. ' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
  8894. '};',
  8895. 'this.DoOpenInt = function (a) {',
  8896. ' $mod.DoOpenInt(rtl.arrayConcatN(a, [1]));',
  8897. ' $mod.DoOpenInt(rtl.arrayConcatN([1], a));',
  8898. ' $mod.DoInt(a);',
  8899. ' $mod.DoInt(rtl.arrayConcatN(a, [1]));',
  8900. ' $mod.DoInt(rtl.arrayConcatN([1], a));',
  8901. '};',
  8902. 'this.DoSet = function (a) {',
  8903. ' $mod.DoSet(rtl.arrayConcatN(a, [$mod.TArrSet$a.red]));',
  8904. ' $mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], a));',
  8905. '};',
  8906. 'this.i = [];',
  8907. 'this.s = [];',
  8908. '']),
  8909. LinesToStr([ // $mod.$main
  8910. '$mod.DoInt([1]);',
  8911. '$mod.DoInt(rtl.arrayConcatN([1], [2]));',
  8912. '$mod.DoInt(rtl.arrayConcatN($mod.i, [1]));',
  8913. '$mod.DoInt(rtl.arrayConcatN([1], $mod.i));',
  8914. '$mod.DoOpenInt([1]);',
  8915. '$mod.DoOpenInt(rtl.arrayConcatN([1], [2]));',
  8916. '$mod.DoOpenInt(rtl.arrayConcatN($mod.i, [1]));',
  8917. '$mod.DoOpenInt(rtl.arrayConcatN([1], $mod.i));',
  8918. '$mod.DoSet([$mod.TArrSet$a.red]);',
  8919. '$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.blue], [$mod.TArrSet$a.green]));',
  8920. '$mod.DoSet(rtl.arrayConcatN($mod.s, [$mod.TArrSet$a.blue]));',
  8921. '$mod.DoSet(rtl.arrayConcatN([$mod.TArrSet$a.red], $mod.s));',
  8922. '']));
  8923. end;
  8924. procedure TTestModule.TestArray_ArrayLitMultiDimAsParam;
  8925. begin
  8926. StartProgram(false);
  8927. Add([
  8928. '{$modeswitch arrayoperators}',
  8929. 'type',
  8930. ' integer = longint;',
  8931. ' TArrInt = array of integer;',
  8932. ' TArrArrInt = array of TArrInt;',
  8933. 'procedure DoInt(a: TArrArrInt);',
  8934. 'begin',
  8935. ' DoInt(a+[[1]]);',
  8936. ' DoInt([[1]]+a);',
  8937. ' DoInt(a);',
  8938. 'end;',
  8939. 'var',
  8940. ' i: TArrInt;',
  8941. ' a: TArrArrInt;',
  8942. 'begin',
  8943. ' a:=[[1]];',
  8944. ' a:=[i];',
  8945. ' a:=a+[i];',
  8946. ' a:=[i]+a;',
  8947. ' a:=[[1]+i];',
  8948. ' a:=[[1]+[2]];',
  8949. ' a:=[i+[2]];',
  8950. ' DoInt([[1]]);',
  8951. ' DoInt([[1]+[2],[3,4],[5]]);',
  8952. ' DoInt([i+[1]]+a);',
  8953. ' DoInt([i]+a);',
  8954. '']);
  8955. ConvertProgram;
  8956. CheckSource('TestArray_ArrayLitMultiDimAsParam',
  8957. LinesToStr([ // statements
  8958. 'this.DoInt = function (a) {',
  8959. ' $mod.DoInt(rtl.arrayConcatN(a, [[1]]));',
  8960. ' $mod.DoInt(rtl.arrayConcatN([[1]], a));',
  8961. ' $mod.DoInt(a);',
  8962. '};',
  8963. 'this.i = [];',
  8964. 'this.a = [];',
  8965. '']),
  8966. LinesToStr([ // $mod.$main
  8967. '$mod.a = [[1]];',
  8968. '$mod.a = [$mod.i];',
  8969. '$mod.a = rtl.arrayConcatN($mod.a, [$mod.i]);',
  8970. '$mod.a = rtl.arrayConcatN([$mod.i], $mod.a);',
  8971. '$mod.a = [rtl.arrayConcatN([1], $mod.i)];',
  8972. '$mod.a = [rtl.arrayConcatN([1], [2])];',
  8973. '$mod.a = [rtl.arrayConcatN($mod.i, [2])];',
  8974. '$mod.DoInt([[1]]);',
  8975. '$mod.DoInt([rtl.arrayConcatN([1], [2]), [3, 4], [5]]);',
  8976. '$mod.DoInt(rtl.arrayConcatN([rtl.arrayConcatN($mod.i, [1])], $mod.a));',
  8977. '$mod.DoInt(rtl.arrayConcatN([$mod.i], $mod.a));',
  8978. '']));
  8979. end;
  8980. procedure TTestModule.TestArray_ArrayLitStaticAsParam;
  8981. begin
  8982. StartProgram(false);
  8983. Add([
  8984. '{$modeswitch arrayoperators}',
  8985. 'type',
  8986. ' integer = longint;',
  8987. ' TArrInt = array[1..2] of integer;',
  8988. ' TArrArrInt = array of TArrInt;',
  8989. 'procedure DoInt(a: TArrArrInt);',
  8990. 'begin',
  8991. ' DoInt(a+[[1,2]]);',
  8992. ' DoInt([[1,2]]+a);',
  8993. ' DoInt(a);',
  8994. 'end;',
  8995. 'var',
  8996. ' i: TArrInt;',
  8997. ' a: TArrArrInt;',
  8998. 'begin',
  8999. ' a:=[[1,1]];',
  9000. ' a:=[i];',
  9001. ' a:=a+[i];',
  9002. ' a:=[i]+a;',
  9003. ' DoInt([[1,1]]);',
  9004. ' DoInt([[1,2],[3,4]]);',
  9005. '']);
  9006. ConvertProgram;
  9007. CheckSource('TestArray_ArrayLitStaticAsParam',
  9008. LinesToStr([ // statements
  9009. 'this.DoInt = function (a) {',
  9010. ' $mod.DoInt(rtl.arrayConcatN(a, [[1, 2]]));',
  9011. ' $mod.DoInt(rtl.arrayConcatN([[1, 2]], a));',
  9012. ' $mod.DoInt(a);',
  9013. '};',
  9014. 'this.i = rtl.arraySetLength(null, 0, 2);',
  9015. 'this.a = [];',
  9016. '']),
  9017. LinesToStr([ // $mod.$main
  9018. '$mod.a = [[1, 1]];',
  9019. '$mod.a = [$mod.i.slice(0)];',
  9020. '$mod.a = rtl.arrayConcatN($mod.a, [$mod.i.slice(0)]);',
  9021. '$mod.a = rtl.arrayConcatN([$mod.i.slice(0)], $mod.a);',
  9022. '$mod.DoInt([[1, 1]]);',
  9023. '$mod.DoInt([[1, 2], [3, 4]]);',
  9024. '']));
  9025. end;
  9026. procedure TTestModule.TestArray_ForInArrOfString;
  9027. begin
  9028. StartProgram(false);
  9029. Add([
  9030. 'type',
  9031. 'type',
  9032. ' TMonthNameArray = array [1..12] of string;',
  9033. ' TMonthNames = TMonthNameArray;',
  9034. ' TObject = class',
  9035. ' private',
  9036. ' function GetLongMonthNames: TMonthNames; virtual; abstract;',
  9037. ' public',
  9038. ' Property LongMonthNames : TMonthNames Read GetLongMonthNames;',
  9039. ' end;',
  9040. 'var f: TObject;',
  9041. ' Month: string;',
  9042. 'begin',
  9043. ' for Month in f.LongMonthNames do ;',
  9044. '']);
  9045. ConvertProgram;
  9046. CheckSource('TestArray_ForInArrOfString',
  9047. LinesToStr([ // statements
  9048. 'rtl.createClass($mod, "TObject", null, function () {',
  9049. ' this.$init = function () {',
  9050. ' };',
  9051. ' this.$final = function () {',
  9052. ' };',
  9053. '});',
  9054. 'this.f = null;',
  9055. 'this.Month = "";',
  9056. '']),
  9057. LinesToStr([ // $mod.$main
  9058. 'for (var $in1 = $mod.f.GetLongMonthNames(), $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.Month = $in1[$l2];',
  9059. '']));
  9060. end;
  9061. procedure TTestModule.TestExternalClass_TypeCastArrayToExternalClass;
  9062. begin
  9063. StartProgram(false);
  9064. Add([
  9065. '{$modeswitch externalclass}',
  9066. 'type',
  9067. ' TJSObject = class external name ''Object''',
  9068. ' end;',
  9069. ' TJSArray = class external name ''Array''',
  9070. ' class function isArray(Value: JSValue) : boolean;',
  9071. ' function concat() : TJSArray; varargs;',
  9072. ' end;',
  9073. 'var',
  9074. ' aObj: TJSArray;',
  9075. ' a: array of longint;',
  9076. ' o: TJSObject;',
  9077. 'begin',
  9078. ' if TJSArray.isArray(65) then ;',
  9079. ' aObj:=TJSArray(a).concat(a);',
  9080. ' o:=TJSObject(a);']);
  9081. ConvertProgram;
  9082. CheckSource('TestExternalClass_TypeCastArrayToExternalClass',
  9083. LinesToStr([ // statements
  9084. 'this.aObj = null;',
  9085. 'this.a = [];',
  9086. 'this.o = null;',
  9087. '']),
  9088. LinesToStr([ // $mod.$main
  9089. 'if (Array.isArray(65)) ;',
  9090. '$mod.aObj = $mod.a.concat($mod.a);',
  9091. '$mod.o = $mod.a;',
  9092. '']));
  9093. end;
  9094. procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalClass;
  9095. begin
  9096. StartProgram(false);
  9097. Add([
  9098. '{$modeswitch externalclass}',
  9099. 'type',
  9100. ' TArrStr = array of string;',
  9101. ' TJSArray = class external name ''Array''',
  9102. ' end;',
  9103. ' TJSObject = class external name ''Object''',
  9104. ' end;',
  9105. 'var',
  9106. ' aObj: TJSArray;',
  9107. ' a: TArrStr;',
  9108. ' jo: TJSObject;',
  9109. 'begin',
  9110. ' a:=TArrStr(aObj);',
  9111. ' TArrStr(aObj)[1]:=TArrStr(aObj)[2];',
  9112. ' a:=TarrStr(jo);',
  9113. '']);
  9114. ConvertProgram;
  9115. CheckSource('TestExternalClass_TypeCastArrayFromExternalClass',
  9116. LinesToStr([ // statements
  9117. 'this.aObj = null;',
  9118. 'this.a = [];',
  9119. 'this.jo = null;',
  9120. '']),
  9121. LinesToStr([ // $mod.$main
  9122. '$mod.a = $mod.aObj;',
  9123. '$mod.aObj[1] = $mod.aObj[2];',
  9124. '$mod.a = $mod.jo;',
  9125. '']));
  9126. end;
  9127. procedure TTestModule.TestRecord_Empty;
  9128. begin
  9129. StartProgram(false);
  9130. Add(['type',
  9131. ' TRecA = record',
  9132. ' end;',
  9133. 'var a,b: TRecA;',
  9134. 'begin',
  9135. ' if a=b then ;']);
  9136. ConvertProgram;
  9137. CheckSource('TestRecord_Empty',
  9138. LinesToStr([ // statements
  9139. 'rtl.recNewT($mod, "TRecA", function () {',
  9140. ' this.$eq = function (b) {',
  9141. ' return true;',
  9142. ' };',
  9143. ' this.$assign = function (s) {',
  9144. ' return this;',
  9145. ' };',
  9146. '});',
  9147. 'this.a = $mod.TRecA.$new();',
  9148. 'this.b = $mod.TRecA.$new();',
  9149. '']),
  9150. LinesToStr([ // $mod.$main
  9151. 'if ($mod.a.$eq($mod.b)) ;'
  9152. ]));
  9153. end;
  9154. procedure TTestModule.TestRecord_Var;
  9155. begin
  9156. StartProgram(false);
  9157. Add('type');
  9158. Add(' TRecA = record');
  9159. Add(' Bold: longint;');
  9160. Add(' end;');
  9161. Add('var Rec: TRecA;');
  9162. Add('begin');
  9163. Add(' rec.bold:=123');
  9164. ConvertProgram;
  9165. CheckSource('TestRecord_Var',
  9166. LinesToStr([ // statements
  9167. 'rtl.recNewT($mod, "TRecA", function () {',
  9168. ' this.Bold = 0;',
  9169. ' this.$eq = function (b) {',
  9170. ' return this.Bold === b.Bold;',
  9171. ' };',
  9172. ' this.$assign = function (s) {',
  9173. ' this.Bold = s.Bold;',
  9174. ' return this;',
  9175. ' };',
  9176. '});',
  9177. 'this.Rec = $mod.TRecA.$new();',
  9178. '']),
  9179. LinesToStr([ // $mod.$main
  9180. '$mod.Rec.Bold = 123;'
  9181. ]));
  9182. end;
  9183. procedure TTestModule.TestRecord_VarExternal;
  9184. begin
  9185. StartProgram(false);
  9186. Add([
  9187. '{$modeswitch externalclass}',
  9188. 'type',
  9189. ' TRecA = record',
  9190. ' i: byte;',
  9191. ' length_: longint external name ''length'';',
  9192. ' end;',
  9193. 'var Rec: TRecA;',
  9194. 'begin',
  9195. ' rec.length_ := rec.length_',
  9196. '']);
  9197. ConvertProgram;
  9198. CheckSource('TestRecord_VarExternal',
  9199. LinesToStr([ // statements
  9200. 'rtl.recNewT($mod, "TRecA", function () {',
  9201. ' this.i = 0;',
  9202. ' this.$eq = function (b) {',
  9203. ' return (this.i === b.i) && (this.length === b.length);',
  9204. ' };',
  9205. ' this.$assign = function (s) {',
  9206. ' this.i = s.i;',
  9207. ' this.length = s.length;',
  9208. ' return this;',
  9209. ' };',
  9210. '});',
  9211. 'this.Rec = $mod.TRecA.$new();',
  9212. '']),
  9213. LinesToStr([ // $mod.$main
  9214. '$mod.Rec.length = $mod.Rec.length;'
  9215. ]));
  9216. end;
  9217. procedure TTestModule.TestRecord_WithDo;
  9218. begin
  9219. StartProgram(false);
  9220. Add('type');
  9221. Add(' TRec = record');
  9222. Add(' vI: longint;');
  9223. Add(' end;');
  9224. Add('var');
  9225. Add(' Int: longint;');
  9226. Add(' r: TRec;');
  9227. Add('begin');
  9228. Add(' with r do');
  9229. Add(' int:=vi;');
  9230. Add(' with r do begin');
  9231. Add(' int:=vi;');
  9232. Add(' vi:=int;');
  9233. Add(' end;');
  9234. ConvertProgram;
  9235. CheckSource('TestWithRecordDo',
  9236. LinesToStr([ // statements
  9237. 'rtl.recNewT($mod, "TRec", function () {',
  9238. ' this.vI = 0;',
  9239. ' this.$eq = function (b) {',
  9240. ' return this.vI === b.vI;',
  9241. ' };',
  9242. ' this.$assign = function (s) {',
  9243. ' this.vI = s.vI;',
  9244. ' return this;',
  9245. ' };',
  9246. '});',
  9247. 'this.Int = 0;',
  9248. 'this.r = $mod.TRec.$new();',
  9249. '']),
  9250. LinesToStr([ // $mod.$main
  9251. 'var $with1 = $mod.r;',
  9252. '$mod.Int = $with1.vI;',
  9253. 'var $with2 = $mod.r;',
  9254. '$mod.Int = $with2.vI;',
  9255. '$with2.vI = $mod.Int;'
  9256. ]));
  9257. end;
  9258. procedure TTestModule.TestRecord_Assign;
  9259. begin
  9260. StartProgram(false);
  9261. Add('type');
  9262. Add(' TEnum = (red,green);');
  9263. Add(' TEnums = set of TEnum;');
  9264. Add(' TSmallRec = record');
  9265. Add(' N: longint;');
  9266. Add(' end;');
  9267. Add(' TBigRec = record');
  9268. Add(' Int: longint;');
  9269. Add(' D: double;');
  9270. Add(' Arr: array of longint;');
  9271. Add(' Arr2: array[1..2] of longint;');
  9272. Add(' Small: TSmallRec;');
  9273. Add(' Enums: TEnums;');
  9274. Add(' end;');
  9275. Add('var');
  9276. Add(' r, s: TBigRec;');
  9277. Add('begin');
  9278. Add(' r:=s;');
  9279. Add(' r:=default(TBigRec);');
  9280. Add(' r:=default(s);');
  9281. ConvertProgram;
  9282. CheckSource('TestRecord_Assign',
  9283. LinesToStr([ // statements
  9284. 'this.TEnum = {',
  9285. ' "0": "red",',
  9286. ' red: 0,',
  9287. ' "1": "green",',
  9288. ' green: 1',
  9289. '};',
  9290. 'rtl.recNewT($mod, "TSmallRec", function () {',
  9291. ' this.N = 0;',
  9292. ' this.$eq = function (b) {',
  9293. ' return this.N === b.N;',
  9294. ' };',
  9295. ' this.$assign = function (s) {',
  9296. ' this.N = s.N;',
  9297. ' return this;',
  9298. ' };',
  9299. '});',
  9300. 'rtl.recNewT($mod, "TBigRec", function () {',
  9301. ' this.Int = 0;',
  9302. ' this.D = 0.0;',
  9303. ' this.Arr = [];',
  9304. ' this.$new = function () {',
  9305. ' var r = Object.create(this);',
  9306. ' r.Arr2 = rtl.arraySetLength(null, 0, 2);',
  9307. ' r.Small = $mod.TSmallRec.$new();',
  9308. ' r.Enums = {};',
  9309. ' return r;',
  9310. ' };',
  9311. ' this.$eq = function (b) {',
  9312. ' 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);',
  9313. ' };',
  9314. ' this.$assign = function (s) {',
  9315. ' this.Int = s.Int;',
  9316. ' this.D = s.D;',
  9317. ' this.Arr = s.Arr;',
  9318. ' this.Arr2 = s.Arr2.slice(0);',
  9319. ' this.Small.$assign(s.Small);',
  9320. ' this.Enums = rtl.refSet(s.Enums);',
  9321. ' return this;',
  9322. ' };',
  9323. '});',
  9324. 'this.r = $mod.TBigRec.$new();',
  9325. 'this.s = $mod.TBigRec.$new();',
  9326. '']),
  9327. LinesToStr([ // $mod.$main
  9328. '$mod.r.$assign($mod.s);',
  9329. '$mod.r.$assign($mod.TBigRec.$new());',
  9330. '$mod.r.$assign($mod.TBigRec.$new());',
  9331. '']));
  9332. end;
  9333. procedure TTestModule.TestRecord_AsParams;
  9334. begin
  9335. StartProgram(false);
  9336. Add([
  9337. 'type',
  9338. ' integer = longint;',
  9339. ' TRecord = record',
  9340. ' i: integer;',
  9341. ' end;',
  9342. 'procedure DoIt(vD: TRecord; const vC: TRecord; var vV: TRecord; var U);',
  9343. 'var vL: TRecord;',
  9344. 'begin',
  9345. ' vd:=vd;',
  9346. ' vd.i:=vd.i;',
  9347. ' vl:=vc;',
  9348. ' vv:=vv;',
  9349. ' vv.i:=vv.i;',
  9350. ' U:=vl;',
  9351. ' U:=vd;',
  9352. ' U:=vc;',
  9353. ' U:=vv;',
  9354. ' doit(vd,vd,vd,vd);',
  9355. ' doit(vc,vc,vl,vl);',
  9356. ' doit(vv,vv,vv,vv);',
  9357. ' doit(vl,vl,vl,vl);',
  9358. 'end;',
  9359. 'var i: TRecord;',
  9360. 'begin',
  9361. ' doit(i,i,i,i);']);
  9362. ConvertProgram;
  9363. CheckSource('TestRecord_AsParams',
  9364. LinesToStr([ // statements
  9365. 'rtl.recNewT($mod, "TRecord", function () {',
  9366. ' this.i = 0;',
  9367. ' this.$eq = function (b) {',
  9368. ' return this.i === b.i;',
  9369. ' };',
  9370. ' this.$assign = function (s) {',
  9371. ' this.i = s.i;',
  9372. ' return this;',
  9373. ' };',
  9374. '});',
  9375. 'this.DoIt = function (vD, vC, vV, U) {',
  9376. ' var vL = $mod.TRecord.$new();',
  9377. ' vD.$assign(vD);',
  9378. ' vD.i = vD.i;',
  9379. ' vL.$assign(vC);',
  9380. ' vV.$assign(vV);',
  9381. ' vV.i = vV.i;',
  9382. ' U.set(vL);',
  9383. ' U.set(vD);',
  9384. ' U.set(vC);',
  9385. ' U.set(vV);',
  9386. ' $mod.DoIt($mod.TRecord.$clone(vD), vD, vD, {',
  9387. ' get: function () {',
  9388. ' return vD;',
  9389. ' },',
  9390. ' set: function (v) {',
  9391. ' vD.$assign(v);',
  9392. ' }',
  9393. ' });',
  9394. ' $mod.DoIt($mod.TRecord.$clone(vC), vC, vL, {',
  9395. ' get: function () {',
  9396. ' return vL;',
  9397. ' },',
  9398. ' set: function (v) {',
  9399. ' vL.$assign(v);',
  9400. ' }',
  9401. ' });',
  9402. ' $mod.DoIt($mod.TRecord.$clone(vV), vV, vV, {',
  9403. ' get: function () {',
  9404. ' return vV;',
  9405. ' },',
  9406. ' set: function (v) {',
  9407. ' vV.$assign(v);',
  9408. ' }',
  9409. ' });',
  9410. ' $mod.DoIt($mod.TRecord.$clone(vL), vL, vL, {',
  9411. ' get: function () {',
  9412. ' return vL;',
  9413. ' },',
  9414. ' set: function (v) {',
  9415. ' vL.$assign(v);',
  9416. ' }',
  9417. ' });',
  9418. '};',
  9419. 'this.i = $mod.TRecord.$new();'
  9420. ]),
  9421. LinesToStr([
  9422. '$mod.DoIt($mod.TRecord.$clone($mod.i), $mod.i, $mod.i, {',
  9423. ' p: $mod,',
  9424. ' get: function () {',
  9425. ' return this.p.i;',
  9426. ' },',
  9427. ' set: function (v) {',
  9428. ' this.p.i.$assign(v);',
  9429. ' }',
  9430. '});',
  9431. '']));
  9432. end;
  9433. procedure TTestModule.TestRecordElement_AsParams;
  9434. begin
  9435. StartProgram(false);
  9436. Add('type');
  9437. Add(' integer = longint;');
  9438. Add(' TRecord = record');
  9439. Add(' i: integer;');
  9440. Add(' end;');
  9441. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  9442. Add('var vJ: TRecord;');
  9443. Add('begin');
  9444. Add(' doit(vj.i,vj.i,vj.i);');
  9445. Add('end;');
  9446. Add('var r: TRecord;');
  9447. Add('begin');
  9448. Add(' doit(r.i,r.i,r.i);');
  9449. ConvertProgram;
  9450. CheckSource('TestRecordElement_AsParams',
  9451. LinesToStr([ // statements
  9452. 'rtl.recNewT($mod, "TRecord", function () {',
  9453. ' this.i = 0;',
  9454. ' this.$eq = function (b) {',
  9455. ' return this.i === b.i;',
  9456. ' };',
  9457. ' this.$assign = function (s) {',
  9458. ' this.i = s.i;',
  9459. ' return this;',
  9460. ' };',
  9461. '});',
  9462. 'this.DoIt = function (vG,vH,vI) {',
  9463. ' var vJ = $mod.TRecord.$new();',
  9464. ' $mod.DoIt(vJ.i, vJ.i, {',
  9465. ' p: vJ,',
  9466. ' get: function () {',
  9467. ' return this.p.i;',
  9468. ' },',
  9469. ' set: function (v) {',
  9470. ' this.p.i = v;',
  9471. ' }',
  9472. ' });',
  9473. '};',
  9474. 'this.r = $mod.TRecord.$new();'
  9475. ]),
  9476. LinesToStr([
  9477. '$mod.DoIt($mod.r.i,$mod.r.i,{',
  9478. ' p: $mod.r,',
  9479. ' get: function () {',
  9480. ' return this.p.i;',
  9481. ' },',
  9482. ' set: function (v) {',
  9483. ' this.p.i = v;',
  9484. ' }',
  9485. '});'
  9486. ]));
  9487. end;
  9488. procedure TTestModule.TestRecordElementFromFuncResult_AsParams;
  9489. begin
  9490. StartProgram(false);
  9491. Add('type');
  9492. Add(' integer = longint;');
  9493. Add(' TRecord = record');
  9494. Add(' i: integer;');
  9495. Add(' end;');
  9496. Add('function GetRec(vB: integer = 0): TRecord;');
  9497. Add('begin');
  9498. Add('end;');
  9499. Add('procedure DoIt(vG: integer; const vH: integer);');
  9500. Add('begin');
  9501. Add('end;');
  9502. Add('begin');
  9503. Add(' doit(getrec.i,getrec.i);');
  9504. Add(' doit(getrec().i,getrec().i);');
  9505. Add(' doit(getrec(1).i,getrec(2).i);');
  9506. ConvertProgram;
  9507. CheckSource('TestRecordElementFromFuncResult_AsParams',
  9508. LinesToStr([ // statements
  9509. 'rtl.recNewT($mod, "TRecord", function () {',
  9510. ' this.i = 0;',
  9511. ' this.$eq = function (b) {',
  9512. ' return this.i === b.i;',
  9513. ' };',
  9514. ' this.$assign = function (s) {',
  9515. ' this.i = s.i;',
  9516. ' return this;',
  9517. ' };',
  9518. '});',
  9519. 'this.GetRec = function (vB) {',
  9520. ' var Result = $mod.TRecord.$new();',
  9521. ' return Result;',
  9522. '};',
  9523. 'this.DoIt = function (vG, vH) {',
  9524. '};',
  9525. '']),
  9526. LinesToStr([
  9527. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  9528. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  9529. '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);',
  9530. '']));
  9531. end;
  9532. procedure TTestModule.TestRecordElementFromWith_AsParams;
  9533. begin
  9534. StartProgram(false);
  9535. Add('type');
  9536. Add(' integer = longint;');
  9537. Add(' TRecord = record');
  9538. Add(' i: integer;');
  9539. Add(' end;');
  9540. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  9541. Add('begin');
  9542. Add('end;');
  9543. Add('var r: trecord;');
  9544. Add('begin');
  9545. Add(' with r do ');
  9546. Add(' doit(i,i,i);');
  9547. ConvertProgram;
  9548. CheckSource('TestRecordElementFromWith_AsParams',
  9549. LinesToStr([ // statements
  9550. 'rtl.recNewT($mod, "TRecord", function () {',
  9551. ' this.i = 0;',
  9552. ' this.$eq = function (b) {',
  9553. ' return this.i === b.i;',
  9554. ' };',
  9555. ' this.$assign = function (s) {',
  9556. ' this.i = s.i;',
  9557. ' return this;',
  9558. ' };',
  9559. '});',
  9560. 'this.DoIt = function (vG,vH,vI) {',
  9561. '};',
  9562. 'this.r = $mod.TRecord.$new();'
  9563. ]),
  9564. LinesToStr([
  9565. 'var $with1 = $mod.r;',
  9566. '$mod.DoIt($with1.i,$with1.i,{',
  9567. ' p: $with1,',
  9568. ' get: function () {',
  9569. ' return this.p.i;',
  9570. ' },',
  9571. ' set: function (v) {',
  9572. ' this.p.i = v;',
  9573. ' }',
  9574. '});',
  9575. '']));
  9576. end;
  9577. procedure TTestModule.TestRecord_Equal;
  9578. begin
  9579. StartProgram(false);
  9580. Add('type');
  9581. Add(' integer = longint;');
  9582. Add(' TFlag = (red,blue);');
  9583. Add(' TFlags = set of TFlag;');
  9584. Add(' TProc = procedure;');
  9585. Add(' TRecord = record');
  9586. Add(' i: integer;');
  9587. Add(' Event: TProc;');
  9588. Add(' f: TFlags;');
  9589. Add(' end;');
  9590. Add(' TNested = record');
  9591. Add(' r: TRecord;');
  9592. Add(' end;');
  9593. Add('var');
  9594. Add(' b: boolean;');
  9595. Add(' r,s: trecord;');
  9596. Add('begin');
  9597. Add(' b:=r=s;');
  9598. Add(' b:=r<>s;');
  9599. ConvertProgram;
  9600. CheckSource('TestRecord_Equal',
  9601. LinesToStr([ // statements
  9602. 'this.TFlag = {',
  9603. ' "0": "red",',
  9604. ' red: 0,',
  9605. ' "1": "blue",',
  9606. ' blue: 1',
  9607. '};',
  9608. 'rtl.recNewT($mod, "TRecord", function () {',
  9609. ' this.i = 0;',
  9610. ' this.Event = null;',
  9611. ' this.$new = function () {',
  9612. ' var r = Object.create(this);',
  9613. ' r.f = {};',
  9614. ' return r;',
  9615. ' };',
  9616. ' this.$eq = function (b) {',
  9617. ' return (this.i === b.i) && rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f);',
  9618. ' };',
  9619. ' this.$assign = function (s) {',
  9620. ' this.i = s.i;',
  9621. ' this.Event = s.Event;',
  9622. ' this.f = rtl.refSet(s.f);',
  9623. ' return this;',
  9624. ' };',
  9625. '});',
  9626. 'rtl.recNewT($mod, "TNested", function () {',
  9627. ' this.$new = function () {',
  9628. ' var r = Object.create(this);',
  9629. ' r.r = $mod.TRecord.$new();',
  9630. ' return r;',
  9631. ' };',
  9632. ' this.$eq = function (b) {',
  9633. ' return this.r.$eq(b.r);',
  9634. ' };',
  9635. ' this.$assign = function (s) {',
  9636. ' this.r.$assign(s.r);',
  9637. ' return this;',
  9638. ' };',
  9639. '});',
  9640. 'this.b = false;',
  9641. 'this.r = $mod.TRecord.$new();',
  9642. 'this.s = $mod.TRecord.$new();',
  9643. '']),
  9644. LinesToStr([
  9645. '$mod.b = $mod.r.$eq($mod.s);',
  9646. '$mod.b = !$mod.r.$eq($mod.s);',
  9647. '']));
  9648. end;
  9649. procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
  9650. begin
  9651. StartProgram(false);
  9652. Add('type');
  9653. Add(' TRecord = record');
  9654. Add(' i: longint;');
  9655. Add(' end;');
  9656. Add('var');
  9657. Add(' Jv: jsvalue;');
  9658. Add(' Rec: trecord;');
  9659. Add('begin');
  9660. Add(' rec:=trecord(jv);');
  9661. ConvertProgram;
  9662. CheckSource('TestRecord_TypeCastJSValueToRecord',
  9663. LinesToStr([ // statements
  9664. 'rtl.recNewT($mod, "TRecord", function () {',
  9665. ' this.i = 0;',
  9666. ' this.$eq = function (b) {',
  9667. ' return this.i === b.i;',
  9668. ' };',
  9669. ' this.$assign = function (s) {',
  9670. ' this.i = s.i;',
  9671. ' return this;',
  9672. ' };',
  9673. '});',
  9674. 'this.Jv = undefined;',
  9675. 'this.Rec = $mod.TRecord.$new();',
  9676. '']),
  9677. LinesToStr([
  9678. '$mod.Rec.$assign(rtl.getObject($mod.Jv));',
  9679. '']));
  9680. end;
  9681. procedure TTestModule.TestRecord_VariantFail;
  9682. begin
  9683. StartProgram(false);
  9684. Add([
  9685. 'type',
  9686. ' TRec = record',
  9687. ' case word of',
  9688. ' 0: (b0, b1: Byte);',
  9689. ' 1: (i: word);',
  9690. ' end;',
  9691. 'begin']);
  9692. SetExpectedPasResolverError('variant record is not supported',
  9693. nXIsNotSupported);
  9694. ConvertProgram;
  9695. end;
  9696. procedure TTestModule.TestRecord_FieldArray;
  9697. begin
  9698. StartProgram(false);
  9699. Add([
  9700. 'type',
  9701. ' TArrInt = array[3..4] of longint;',
  9702. ' TArrArrInt = array[3..4] of longint;',
  9703. ' TRec = record',
  9704. ' a: array of longint;',
  9705. ' s: array[1..2] of longint;',
  9706. ' m: array[1..2,3..4] of longint;',
  9707. ' o: TArrArrInt;',
  9708. ' end;',
  9709. 'begin']);
  9710. ConvertProgram;
  9711. CheckSource('TestRecord_FieldArray',
  9712. LinesToStr([ // statements
  9713. 'rtl.recNewT($mod, "TRec", function () {',
  9714. ' this.a = [];',
  9715. ' this.$new = function () {',
  9716. ' var r = Object.create(this);',
  9717. ' r.s = rtl.arraySetLength(null, 0, 2);',
  9718. ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
  9719. ' r.o = rtl.arraySetLength(null, 0, 2);',
  9720. ' return r;',
  9721. ' };',
  9722. ' this.$eq = function (b) {',
  9723. ' return (this.a === b.a) && rtl.arrayEq(this.s, b.s) && rtl.arrayEq(this.m, b.m) && rtl.arrayEq(this.o, b.o);',
  9724. ' };',
  9725. ' this.$assign = function (s) {',
  9726. ' this.a = s.a;',
  9727. ' this.s = s.s.slice(0);',
  9728. ' this.m = s.m.slice(0);',
  9729. ' this.o = s.o.slice(0);',
  9730. ' return this;',
  9731. ' };',
  9732. '});',
  9733. '']),
  9734. LinesToStr([ // $mod.$main
  9735. '']));
  9736. end;
  9737. procedure TTestModule.TestRecord_Const;
  9738. begin
  9739. StartProgram(false);
  9740. Add([
  9741. 'type',
  9742. ' TArrInt = array[3..4] of longint;',
  9743. ' TPoint = record x,y: longint; end;',
  9744. ' TRec = record',
  9745. ' i: longint;',
  9746. ' a: array of longint;',
  9747. ' s: array[1..2] of longint;',
  9748. ' m: array[1..2,3..4] of longint;',
  9749. ' p: TPoint;',
  9750. ' end;',
  9751. ' TPoints = array of TPoint;',
  9752. 'const',
  9753. ' r: TRec = (',
  9754. ' i:1;',
  9755. ' a:(2,3);',
  9756. ' s:(4,5);',
  9757. ' m:( (11,12), (13,14) );',
  9758. ' p: (x:21; y:22)',
  9759. ' );',
  9760. ' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
  9761. 'begin']);
  9762. ConvertProgram;
  9763. CheckSource('TestRecord_Const',
  9764. LinesToStr([ // statements
  9765. 'rtl.recNewT($mod, "TPoint", function () {',
  9766. ' this.x = 0;',
  9767. ' this.y = 0;',
  9768. ' this.$eq = function (b) {',
  9769. ' return (this.x === b.x) && (this.y === b.y);',
  9770. ' };',
  9771. ' this.$assign = function (s) {',
  9772. ' this.x = s.x;',
  9773. ' this.y = s.y;',
  9774. ' return this;',
  9775. ' };',
  9776. '});',
  9777. 'rtl.recNewT($mod, "TRec", function () {',
  9778. ' this.i = 0;',
  9779. ' this.a = [];',
  9780. ' this.$new = function () {',
  9781. ' var r = Object.create(this);',
  9782. ' r.s = rtl.arraySetLength(null, 0, 2);',
  9783. ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
  9784. ' r.p = $mod.TPoint.$new();',
  9785. ' return r;',
  9786. ' };',
  9787. ' this.$eq = function (b) {',
  9788. ' 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);',
  9789. ' };',
  9790. ' this.$assign = function (s) {',
  9791. ' this.i = s.i;',
  9792. ' this.a = s.a;',
  9793. ' this.s = s.s.slice(0);',
  9794. ' this.m = s.m.slice(0);',
  9795. ' this.p.$assign(s.p);',
  9796. ' return this;',
  9797. ' };',
  9798. '});',
  9799. 'this.r = $mod.TRec.$clone({',
  9800. ' i: 1,',
  9801. ' a: [2, 3],',
  9802. ' s: [4, 5],',
  9803. ' m: [[11, 12], [13, 14]],',
  9804. ' p: $mod.TPoint.$clone({',
  9805. ' x: 21,',
  9806. ' y: 22',
  9807. ' })',
  9808. '});',
  9809. 'this.p = [$mod.TPoint.$clone({',
  9810. ' x: 1,',
  9811. ' y: 2',
  9812. '}), $mod.TPoint.$clone({',
  9813. ' x: 3,',
  9814. ' y: 4',
  9815. '})];',
  9816. '']),
  9817. LinesToStr([ // $mod.$main
  9818. '']));
  9819. end;
  9820. procedure TTestModule.TestRecord_TypecastFail;
  9821. begin
  9822. StartProgram(false);
  9823. Add([
  9824. 'type',
  9825. ' TPoint = record x,y: longint; end;',
  9826. ' TRec = record l: longint end;',
  9827. 'var p: TPoint;',
  9828. 'begin',
  9829. ' if TRec(p).l=2 then ;']);
  9830. SetExpectedPasResolverError('Illegal type conversion: "TPoint" to "record TRec"',
  9831. nIllegalTypeConversionTo);
  9832. ConvertProgram;
  9833. end;
  9834. procedure TTestModule.TestRecord_InFunction;
  9835. begin
  9836. StartProgram(false);
  9837. Add([
  9838. 'var TPoint: longint = 3;',
  9839. 'procedure DoIt;',
  9840. 'type',
  9841. ' TPoint = record x,y: longint; end;',
  9842. ' TPoints = array of TPoint;',
  9843. 'var',
  9844. ' r: TPoint;',
  9845. ' p: TPoints;',
  9846. 'begin',
  9847. ' SetLength(p,2);',
  9848. 'end;',
  9849. 'begin']);
  9850. ConvertProgram;
  9851. CheckSource('TestRecord_InFunction',
  9852. LinesToStr([ // statements
  9853. 'this.TPoint = 3;',
  9854. 'var TPoint$1 = rtl.recNewT(null, "", function () {',
  9855. ' this.x = 0;',
  9856. ' this.y = 0;',
  9857. ' this.$eq = function (b) {',
  9858. ' return (this.x === b.x) && (this.y === b.y);',
  9859. ' };',
  9860. ' this.$assign = function (s) {',
  9861. ' this.x = s.x;',
  9862. ' this.y = s.y;',
  9863. ' return this;',
  9864. ' };',
  9865. '});',
  9866. 'this.DoIt = function () {',
  9867. ' var r = TPoint$1.$new();',
  9868. ' var p = [];',
  9869. ' p = rtl.arraySetLength(p, TPoint$1, 2);',
  9870. '};',
  9871. '']),
  9872. LinesToStr([ // $mod.$main
  9873. '']));
  9874. end;
  9875. procedure TTestModule.TestAdvRecord_Function;
  9876. begin
  9877. StartProgram(false);
  9878. Parser.Options:=Parser.Options+[po_cassignments];
  9879. Add([
  9880. '{$modeswitch AdvancedRecords}',
  9881. 'type',
  9882. ' TPoint = record',
  9883. ' x,y: word;',
  9884. ' function Add(const apt: TPoint): TPoint;',
  9885. ' end;',
  9886. 'function TPoint.Add(const apt: TPoint): TPoint;',
  9887. 'begin',
  9888. ' Result:=Self;',
  9889. ' Result.x+=apt.x;',
  9890. ' Result.y:=Result.y+apt.y;',
  9891. ' Self:=apt;',
  9892. 'end;',
  9893. 'var p,q: TPoint;',
  9894. 'begin',
  9895. ' p.add(q);',
  9896. ' p:=default(TPoint);',
  9897. ' p:=q;',
  9898. '']);
  9899. ConvertProgram;
  9900. CheckSource('TestAdvRecord_Function',
  9901. LinesToStr([ // statements
  9902. 'rtl.recNewT($mod, "TPoint", function () {',
  9903. ' this.x = 0;',
  9904. ' this.y = 0;',
  9905. ' this.$eq = function (b) {',
  9906. ' return (this.x === b.x) && (this.y === b.y);',
  9907. ' };',
  9908. ' this.$assign = function (s) {',
  9909. ' this.x = s.x;',
  9910. ' this.y = s.y;',
  9911. ' return this;',
  9912. ' };',
  9913. ' this.Add = function (apt) {',
  9914. ' var Result = $mod.TPoint.$new();',
  9915. ' Result.$assign(this);',
  9916. ' Result.x += apt.x;',
  9917. ' Result.y = Result.y + apt.y;',
  9918. ' this.$assign(apt);',
  9919. ' return Result;',
  9920. ' };',
  9921. '});',
  9922. 'this.p = $mod.TPoint.$new();',
  9923. 'this.q = $mod.TPoint.$new();',
  9924. '']),
  9925. LinesToStr([ // $mod.$main
  9926. '$mod.p.Add($mod.q);',
  9927. '$mod.p.$assign($mod.TPoint.$new());',
  9928. '$mod.p.$assign($mod.q);',
  9929. '']));
  9930. end;
  9931. procedure TTestModule.TestAdvRecord_Property;
  9932. begin
  9933. StartProgram(false);
  9934. Add([
  9935. '{$modeswitch AdvancedRecords}',
  9936. 'type',
  9937. ' TPoint = record',
  9938. ' x,y: word;',
  9939. ' strict private',
  9940. ' function GetSize: longword;',
  9941. ' procedure SetSize(Value: longword);',
  9942. ' public',
  9943. ' property Size: longword read GetSize write SetSize;',
  9944. ' property Left: word read x write y;',
  9945. ' end;',
  9946. 'procedure SetSize(Value: longword); begin end;',// check auto rename
  9947. 'function TPoint.GetSize: longword;',
  9948. 'begin',
  9949. ' x:=y;',
  9950. ' Size:=Size;',
  9951. ' Left:=Left;',
  9952. 'end;',
  9953. 'procedure TPoint.SetSize(Value: longword);',
  9954. 'begin',
  9955. 'end;',
  9956. 'var p,q: TPoint;',
  9957. 'begin',
  9958. ' p.Size:=q.Size;',
  9959. ' p.Left:=q.Left;',
  9960. '']);
  9961. ConvertProgram;
  9962. CheckSource('TestAdvRecord_Property',
  9963. LinesToStr([ // statements
  9964. 'rtl.recNewT($mod, "TPoint", function () {',
  9965. ' this.x = 0;',
  9966. ' this.y = 0;',
  9967. ' this.$eq = function (b) {',
  9968. ' return (this.x === b.x) && (this.y === b.y);',
  9969. ' };',
  9970. ' this.$assign = function (s) {',
  9971. ' this.x = s.x;',
  9972. ' this.y = s.y;',
  9973. ' return this;',
  9974. ' };',
  9975. ' this.GetSize = function () {',
  9976. ' var Result = 0;',
  9977. ' this.x = this.y;',
  9978. ' this.SetSize(this.GetSize());',
  9979. ' this.y = this.x;',
  9980. ' return Result;',
  9981. ' };',
  9982. ' this.SetSize = function (Value) {',
  9983. ' };',
  9984. '});',
  9985. 'this.SetSize = function (Value) {',
  9986. '};',
  9987. 'this.p = $mod.TPoint.$new();',
  9988. 'this.q = $mod.TPoint.$new();',
  9989. '']),
  9990. LinesToStr([ // $mod.$main
  9991. '$mod.p.SetSize($mod.q.GetSize());',
  9992. '$mod.p.y = $mod.q.x;',
  9993. '']));
  9994. end;
  9995. procedure TTestModule.TestAdvRecord_PropertyDefault;
  9996. begin
  9997. StartProgram(false);
  9998. Add([
  9999. '{$modeswitch AdvancedRecords}',
  10000. 'type',
  10001. ' TPoint = record',
  10002. ' strict private',
  10003. ' function GetItems(Index: word): word;',
  10004. ' procedure SetItems(Index: word; Value: word);',
  10005. ' public',
  10006. ' property Items[Index: word]: word read GetItems write SetItems; default;',
  10007. ' end;',
  10008. 'function TPoint.GetItems(Index: word): word;',
  10009. 'begin',
  10010. ' Items[index]:=Items[index];',
  10011. ' self.Items[index]:=self.Items[index];',
  10012. 'end;',
  10013. 'procedure TPoint.SetItems(Index: word; Value: word);',
  10014. 'begin',
  10015. 'end;',
  10016. 'var p: TPoint;',
  10017. 'begin',
  10018. ' p[1]:=p[2];',
  10019. ' p.Items[3]:=p.Items[4];',
  10020. '']);
  10021. ConvertProgram;
  10022. CheckSource('TestAdvRecord_PropertyDefault',
  10023. LinesToStr([ // statements
  10024. 'rtl.recNewT($mod, "TPoint", function () {',
  10025. ' this.$eq = function (b) {',
  10026. ' return true;',
  10027. ' };',
  10028. ' this.$assign = function (s) {',
  10029. ' return this;',
  10030. ' };',
  10031. ' this.GetItems = function (Index) {',
  10032. ' var Result = 0;',
  10033. ' this.SetItems(Index, this.GetItems(Index));',
  10034. ' this.SetItems(Index, this.GetItems(Index));',
  10035. ' return Result;',
  10036. ' };',
  10037. ' this.SetItems = function (Index, Value) {',
  10038. ' };',
  10039. '});',
  10040. 'this.p = $mod.TPoint.$new();',
  10041. '']),
  10042. LinesToStr([ // $mod.$main
  10043. '$mod.p.SetItems(1, $mod.p.GetItems(2));',
  10044. '$mod.p.SetItems(3, $mod.p.GetItems(4));',
  10045. '']));
  10046. end;
  10047. procedure TTestModule.TestAdvRecord_Property_ClassMethod;
  10048. begin
  10049. StartProgram(false);
  10050. Add([
  10051. '{$modeswitch AdvancedRecords}',
  10052. 'type',
  10053. ' TRec = record',
  10054. ' class var Fx: longint;',
  10055. ' class var Fy: longint;',
  10056. ' class function GetInt: longint; static;',
  10057. ' class procedure SetInt(Value: longint); static;',
  10058. ' class procedure DoIt; static;',
  10059. ' class property IntA: longint read Fx write Fy;',
  10060. ' class property IntB: longint read GetInt write SetInt;',
  10061. ' end;',
  10062. 'class function trec.getint: longint;',
  10063. 'begin',
  10064. ' result:=fx;',
  10065. 'end;',
  10066. 'class procedure trec.setint(value: longint);',
  10067. 'begin',
  10068. 'end;',
  10069. 'class procedure trec.doit;',
  10070. 'begin',
  10071. ' IntA:=IntA+1;',
  10072. ' IntB:=IntB+1;',
  10073. 'end;',
  10074. 'var r: trec;',
  10075. 'begin',
  10076. ' trec.inta:=trec.inta+1;',
  10077. ' if trec.intb=2 then;',
  10078. ' trec.intb:=trec.intb+2;',
  10079. ' trec.setint(trec.inta);',
  10080. ' r.inta:=r.inta+1;',
  10081. ' if r.intb=2 then;',
  10082. ' r.intb:=r.intb+2;',
  10083. ' r.setint(r.inta);']);
  10084. ConvertProgram;
  10085. CheckSource('TestAdvRecord_Property_ClassMethod',
  10086. LinesToStr([ // statements
  10087. 'rtl.recNewT($mod, "TRec", function () {',
  10088. ' this.Fx = 0;',
  10089. ' this.Fy = 0;',
  10090. ' this.$eq = function (b) {',
  10091. ' return true;',
  10092. ' };',
  10093. ' this.$assign = function (s) {',
  10094. ' return this;',
  10095. ' };',
  10096. ' this.GetInt = function () {',
  10097. ' var Result = 0;',
  10098. ' Result = this.Fx;',
  10099. ' return Result;',
  10100. ' };',
  10101. ' this.SetInt = function (Value) {',
  10102. ' };',
  10103. ' this.DoIt = function () {',
  10104. ' $mod.TRec.Fy = this.Fx + 1;',
  10105. ' this.SetInt(this.GetInt() + 1);',
  10106. ' };',
  10107. '}, true);',
  10108. 'this.r = $mod.TRec.$new();',
  10109. '']),
  10110. LinesToStr([ // $mod.$main
  10111. '$mod.TRec.Fy = $mod.TRec.Fx + 1;',
  10112. 'if ($mod.TRec.GetInt() === 2) ;',
  10113. '$mod.TRec.SetInt($mod.TRec.GetInt() + 2);',
  10114. '$mod.TRec.SetInt($mod.TRec.Fx);',
  10115. '$mod.TRec.Fy = $mod.r.Fx + 1;',
  10116. 'if ($mod.r.$record.GetInt() === 2) ;',
  10117. '$mod.r.$record.SetInt($mod.r.$record.GetInt() + 2);',
  10118. '$mod.r.$record.SetInt($mod.r.Fx);',
  10119. '']));
  10120. end;
  10121. procedure TTestModule.TestAdvRecord_Const;
  10122. begin
  10123. StartProgram(false);
  10124. Add([
  10125. '{$modeswitch AdvancedRecords}',
  10126. 'type',
  10127. ' TArrInt = array[3..4] of longint;',
  10128. ' TPoint = record',
  10129. ' x,y: longint;',
  10130. ' class var Count: nativeint;',
  10131. ' end;',
  10132. ' TRec = record',
  10133. ' i: longint;',
  10134. ' a: array of longint;',
  10135. ' s: array[1..2] of longint;',
  10136. ' m: array[1..2,3..4] of longint;',
  10137. ' p: TPoint;',
  10138. ' end;',
  10139. ' TPoints = array of TPoint;',
  10140. 'const',
  10141. ' r: TRec = (',
  10142. ' i:1;',
  10143. ' a:(2,3);',
  10144. ' s:(4,5);',
  10145. ' m:( (11,12), (13,14) );',
  10146. ' p: (x:21)',
  10147. ' );',
  10148. ' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
  10149. 'begin']);
  10150. ConvertProgram;
  10151. CheckSource('TestAdvRecord_Const',
  10152. LinesToStr([ // statements
  10153. 'rtl.recNewT($mod, "TPoint", function () {',
  10154. ' this.x = 0;',
  10155. ' this.y = 0;',
  10156. ' this.Count = 0;',
  10157. ' this.$eq = function (b) {',
  10158. ' return (this.x === b.x) && (this.y === b.y);',
  10159. ' };',
  10160. ' this.$assign = function (s) {',
  10161. ' this.x = s.x;',
  10162. ' this.y = s.y;',
  10163. ' return this;',
  10164. ' };',
  10165. '}, true);',
  10166. 'rtl.recNewT($mod, "TRec", function () {',
  10167. ' this.i = 0;',
  10168. ' this.a = [];',
  10169. ' this.$new = function () {',
  10170. ' var r = Object.create(this);',
  10171. ' r.s = rtl.arraySetLength(null, 0, 2);',
  10172. ' r.m = rtl.arraySetLength(null, 0, 2, 2);',
  10173. ' r.p = $mod.TPoint.$new();',
  10174. ' return r;',
  10175. ' };',
  10176. ' this.$eq = function (b) {',
  10177. ' 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);',
  10178. ' };',
  10179. ' this.$assign = function (s) {',
  10180. ' this.i = s.i;',
  10181. ' this.a = s.a;',
  10182. ' this.s = s.s.slice(0);',
  10183. ' this.m = s.m.slice(0);',
  10184. ' this.p.$assign(s.p);',
  10185. ' return this;',
  10186. ' };',
  10187. '});',
  10188. 'this.r = $mod.TRec.$clone({',
  10189. ' i: 1,',
  10190. ' a: [2, 3],',
  10191. ' s: [4, 5],',
  10192. ' m: [[11, 12], [13, 14]],',
  10193. ' p: $mod.TPoint.$clone({',
  10194. ' x: 21,',
  10195. ' y: 0',
  10196. ' })',
  10197. '});',
  10198. 'this.p = [$mod.TPoint.$clone({',
  10199. ' x: 1,',
  10200. ' y: 2',
  10201. '}), $mod.TPoint.$clone({',
  10202. ' x: 3,',
  10203. ' y: 4',
  10204. '})];',
  10205. '']),
  10206. LinesToStr([ // $mod.$main
  10207. '']));
  10208. end;
  10209. procedure TTestModule.TestAdvRecord_ExternalField;
  10210. begin
  10211. StartProgram(false);
  10212. Add([
  10213. '{$modeswitch AdvancedRecords}',
  10214. '{$modeswitch externalclass}',
  10215. 'type',
  10216. ' TCar = record',
  10217. ' public',
  10218. ' Intern: longint external name ''$Intern'';',
  10219. ' Intern2: longint external name ''$Intern2'';',
  10220. ' Bracket: longint external name ''["A B"]'';',
  10221. ' procedure DoIt;',
  10222. ' end;',
  10223. 'implementation',
  10224. 'procedure tcar.doit;',
  10225. 'begin',
  10226. ' Intern:=Intern+1;',
  10227. ' Intern2:=Intern2+2;',
  10228. ' Bracket:=Bracket+3;',
  10229. 'end;',
  10230. 'var Rec: TCar = (intern: 11; intern2: 12; bracket: 13);',
  10231. 'begin',
  10232. ' Rec.intern:=Rec.intern+1;',
  10233. ' Rec.intern2:=Rec.intern2+2;',
  10234. ' Rec.Bracket:=Rec.Bracket+3;',
  10235. ' with Rec do begin',
  10236. ' intern:=intern+1;',
  10237. ' intern2:=intern2+2;',
  10238. ' Bracket:=Bracket+3;',
  10239. ' end;']);
  10240. ConvertProgram;
  10241. CheckSource('TestAdvRecord_ExternalField',
  10242. LinesToStr([ // statements
  10243. 'rtl.recNewT($mod, "TCar", function () {',
  10244. ' this.$eq = function (b) {',
  10245. ' return (this.$Intern === b.$Intern) && (this.$Intern2 === b.$Intern2) && (this["A B"] === b["A B"]);',
  10246. ' };',
  10247. ' this.$assign = function (s) {',
  10248. ' this.$Intern = s.$Intern;',
  10249. ' this.$Intern2 = s.$Intern2;',
  10250. ' this["A B"] = s["A B"];',
  10251. ' return this;',
  10252. ' };',
  10253. ' this.DoIt = function () {',
  10254. ' this.$Intern = this.$Intern + 1;',
  10255. ' this.$Intern2 = this.$Intern2 + 2;',
  10256. ' this["A B"] = this["A B"] + 3;',
  10257. ' };',
  10258. '});',
  10259. 'this.Rec = $mod.TCar.$clone({',
  10260. ' $Intern: 11,',
  10261. ' $Intern2: 12,',
  10262. ' "A B": 13',
  10263. '});',
  10264. '']),
  10265. LinesToStr([ // $mod.$main
  10266. '$mod.Rec.$Intern = $mod.Rec.$Intern + 1;',
  10267. '$mod.Rec.$Intern2 = $mod.Rec.$Intern2 + 2;',
  10268. '$mod.Rec["A B"] = $mod.Rec["A B"] + 3;',
  10269. 'var $with1 = $mod.Rec;',
  10270. '$with1.$Intern = $with1.$Intern + 1;',
  10271. '$with1.$Intern2 = $with1.$Intern2 + 2;',
  10272. '$with1["A B"] = $with1["A B"] + 3;',
  10273. '']));
  10274. end;
  10275. procedure TTestModule.TestAdvRecord_SubRecord;
  10276. begin
  10277. StartProgram(false);
  10278. Add([
  10279. '{$modeswitch AdvancedRecords}',
  10280. 'type',
  10281. ' TRec = record',
  10282. ' type',
  10283. ' TPoint = record',
  10284. ' x,y: longint;',
  10285. ' class var Count: nativeint;',
  10286. ' procedure DoIt;',
  10287. ' class procedure DoThat; static;',
  10288. ' end;',
  10289. ' var',
  10290. ' i: longint;',
  10291. ' p: TPoint;',
  10292. ' procedure DoSome;',
  10293. ' end;',
  10294. 'const',
  10295. ' r: TRec = (',
  10296. ' i:1;',
  10297. ' p: (x:21;y:22)',
  10298. ' );',
  10299. 'procedure TRec.DoSome;',
  10300. 'begin',
  10301. ' p.x:=p.y+1;',
  10302. ' p.Count:=p.Count+2;',
  10303. 'end;',
  10304. 'procedure TRec.TPoint.DoIt;',
  10305. 'begin',
  10306. ' Count:=Count+3;',
  10307. 'end;',
  10308. 'class procedure TRec.TPoint.DoThat;',
  10309. 'begin',
  10310. ' Count:=Count+4;',
  10311. 'end;',
  10312. 'begin']);
  10313. ConvertProgram;
  10314. CheckSource('TestAdvRecord_SubRecord',
  10315. LinesToStr([ // statements
  10316. 'rtl.recNewT($mod, "TRec", function () {',
  10317. ' rtl.recNewT(this, "TPoint", function () {',
  10318. ' this.x = 0;',
  10319. ' this.y = 0;',
  10320. ' this.Count = 0;',
  10321. ' this.$eq = function (b) {',
  10322. ' return (this.x === b.x) && (this.y === b.y);',
  10323. ' };',
  10324. ' this.$assign = function (s) {',
  10325. ' this.x = s.x;',
  10326. ' this.y = s.y;',
  10327. ' return this;',
  10328. ' };',
  10329. ' this.DoIt = function () {',
  10330. ' $mod.TRec.TPoint.Count = this.Count + 3;',
  10331. ' };',
  10332. ' this.DoThat = function () {',
  10333. ' $mod.TRec.TPoint.Count = this.Count + 4;',
  10334. ' };',
  10335. ' }, true);',
  10336. ' this.i = 0;',
  10337. ' this.$new = function () {',
  10338. ' var r = Object.create(this);',
  10339. ' r.p = this.TPoint.$new();',
  10340. ' return r;',
  10341. ' };',
  10342. ' this.$eq = function (b) {',
  10343. ' return (this.i === b.i) && this.p.$eq(b.p);',
  10344. ' };',
  10345. ' this.$assign = function (s) {',
  10346. ' this.i = s.i;',
  10347. ' this.p.$assign(s.p);',
  10348. ' return this;',
  10349. ' };',
  10350. ' this.DoSome = function () {',
  10351. ' this.p.x = this.p.y + 1;',
  10352. ' this.TPoint.Count = this.p.Count + 2;',
  10353. ' };',
  10354. '}, true);',
  10355. 'this.r = $mod.TRec.$clone({',
  10356. ' i: 1,',
  10357. ' p: $mod.TRec.TPoint.$clone({',
  10358. ' x: 21,',
  10359. ' y: 22',
  10360. ' })',
  10361. '});',
  10362. '']),
  10363. LinesToStr([ // $mod.$main
  10364. '']));
  10365. end;
  10366. procedure TTestModule.TestAdvRecord_SubClass;
  10367. begin
  10368. StartProgram(false);
  10369. Add([
  10370. '{$modeswitch AdvancedRecords}',
  10371. 'type',
  10372. ' TObject = class end;',
  10373. ' TPoint = record',
  10374. ' type',
  10375. ' TBird = class',
  10376. ' procedure DoIt;',
  10377. ' class procedure Glob;',
  10378. ' end;',
  10379. ' procedure DoIt(b: TBird);',
  10380. ' end;',
  10381. 'procedure TPoint.TBird.DoIt;',
  10382. 'begin',
  10383. ' doit;',
  10384. ' self.doit;',
  10385. ' glob;',
  10386. ' self.glob;',
  10387. 'end;',
  10388. 'class procedure TPoint.TBird.Glob;',
  10389. 'begin',
  10390. ' glob;',
  10391. ' self.glob;',
  10392. 'end;',
  10393. 'procedure TPoint.DoIt(b: TBird);',
  10394. 'begin',
  10395. ' b.doit;',
  10396. ' b.glob;',
  10397. ' TBird.glob;',
  10398. 'end;',
  10399. 'begin',
  10400. '']);
  10401. ConvertProgram;
  10402. CheckSource('TestAdvRecord_SubClass',
  10403. LinesToStr([ // statements
  10404. 'rtl.createClass($mod, "TObject", null, function () {',
  10405. ' this.$init = function () {',
  10406. ' };',
  10407. ' this.$final = function () {',
  10408. ' };',
  10409. '});',
  10410. 'rtl.recNewT($mod, "TPoint", function () {',
  10411. ' rtl.createClass(this, "TBird", $mod.TObject, function () {',
  10412. ' this.DoIt = function () {',
  10413. ' this.DoIt();',
  10414. ' this.DoIt();',
  10415. ' this.$class.Glob();',
  10416. ' this.$class.Glob();',
  10417. ' };',
  10418. ' this.Glob = function () {',
  10419. ' this.Glob();',
  10420. ' this.Glob();',
  10421. ' };',
  10422. ' });',
  10423. ' this.$eq = function (b) {',
  10424. ' return true;',
  10425. ' };',
  10426. ' this.$assign = function (s) {',
  10427. ' return this;',
  10428. ' };',
  10429. ' this.DoIt = function (b) {',
  10430. ' b.DoIt();',
  10431. ' b.$class.Glob();',
  10432. ' this.TBird.Glob();',
  10433. ' };',
  10434. '}, true);',
  10435. '']),
  10436. LinesToStr([ // $mod.$main
  10437. '']));
  10438. end;
  10439. procedure TTestModule.TestAdvRecord_SubInterfaceFail;
  10440. begin
  10441. StartProgram(false);
  10442. Add([
  10443. '{$modeswitch AdvancedRecords}',
  10444. 'type',
  10445. ' IUnknown = interface end;',
  10446. ' TPoint = record',
  10447. ' type IBird = interface end;',
  10448. ' end;',
  10449. 'begin',
  10450. '']);
  10451. SetExpectedPasResolverError('not yet implemented: IBird:TPasClassType [20190105143752] interface inside record',
  10452. nNotYetImplemented);
  10453. ParseProgram;
  10454. end;
  10455. procedure TTestModule.TestAdvRecord_Constructor;
  10456. begin
  10457. StartProgram(false);
  10458. Add([
  10459. '{$modeswitch AdvancedRecords}',
  10460. 'type',
  10461. ' TPoint = record',
  10462. ' x,y: longint;',
  10463. ' constructor Create(ax: longint; ay: longint = -1);',
  10464. ' end;',
  10465. 'constructor tpoint.create(ax,ay: longint);',
  10466. 'begin',
  10467. ' x:=ax;',
  10468. ' self.y:=ay;',
  10469. 'end;',
  10470. 'var r: TPoint;',
  10471. 'begin',
  10472. ' r:=TPoint.Create(1,2);',
  10473. ' r.Create(3);',
  10474. ' r:=r.Create(4);',
  10475. '']);
  10476. ConvertProgram;
  10477. CheckSource('TestAdvRecord_Constructor',
  10478. LinesToStr([ // statements
  10479. 'rtl.recNewT($mod, "TPoint", function () {',
  10480. ' this.x = 0;',
  10481. ' this.y = 0;',
  10482. ' this.$eq = function (b) {',
  10483. ' return (this.x === b.x) && (this.y === b.y);',
  10484. ' };',
  10485. ' this.$assign = function (s) {',
  10486. ' this.x = s.x;',
  10487. ' this.y = s.y;',
  10488. ' return this;',
  10489. ' };',
  10490. ' this.Create = function (ax, ay) {',
  10491. ' this.x = ax;',
  10492. ' this.y = ay;',
  10493. ' return this;',
  10494. ' };',
  10495. '}, true);',
  10496. 'this.r = $mod.TPoint.$new();',
  10497. '']),
  10498. LinesToStr([ // $mod.$main
  10499. '$mod.r.$assign($mod.TPoint.$create("Create", [1, 2]));',
  10500. '$mod.r.Create(3, -1);',
  10501. '$mod.r.$assign($mod.r.Create(4, -1));',
  10502. '']));
  10503. end;
  10504. procedure TTestModule.TestClass_TObjectDefaultConstructor;
  10505. begin
  10506. StartProgram(false);
  10507. Add(['type',
  10508. ' TObject = class',
  10509. ' public',
  10510. ' constructor Create;',
  10511. ' destructor Destroy;',
  10512. ' end;',
  10513. ' TBird = TObject;',
  10514. 'constructor tobject.create;',
  10515. 'begin end;',
  10516. 'destructor tobject.destroy;',
  10517. 'begin end;',
  10518. 'var Obj: tobject;',
  10519. 'begin',
  10520. ' obj:=tobject.create;',
  10521. ' obj:=tobject.create();',
  10522. ' obj:=tbird.create;',
  10523. ' obj:=tbird.create();',
  10524. ' obj:=obj.create();',
  10525. ' obj.destroy;',
  10526. '']);
  10527. ConvertProgram;
  10528. CheckSource('TestClass_TObjectDefaultConstructor',
  10529. LinesToStr([ // statements
  10530. 'rtl.createClass($mod,"TObject",null,function(){',
  10531. ' this.$init = function () {',
  10532. ' };',
  10533. ' this.$final = function () {',
  10534. ' };',
  10535. ' this.Create = function(){',
  10536. ' return this;',
  10537. ' };',
  10538. ' this.Destroy = function(){',
  10539. ' };',
  10540. '});',
  10541. 'this.Obj = null;'
  10542. ]),
  10543. LinesToStr([ // $mod.$main
  10544. '$mod.Obj = $mod.TObject.$create("Create");',
  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.Obj.Create();',
  10549. '$mod.Obj.$destroy("Destroy");',
  10550. '']));
  10551. end;
  10552. procedure TTestModule.TestClass_TObjectConstructorWithParams;
  10553. begin
  10554. StartProgram(false);
  10555. Add('type');
  10556. Add(' TObject = class');
  10557. Add(' public');
  10558. Add(' constructor Create(Par: longint);');
  10559. Add(' end;');
  10560. Add('constructor tobject.create(par: longint);');
  10561. Add('begin end;');
  10562. Add('var Obj: tobject;');
  10563. Add('begin');
  10564. Add(' obj:=tobject.create(3);');
  10565. ConvertProgram;
  10566. CheckSource('TestClass_TObjectConstructorWithParams',
  10567. LinesToStr([ // statements
  10568. 'rtl.createClass($mod,"TObject",null,function(){',
  10569. ' this.$init = function () {',
  10570. ' };',
  10571. ' this.$final = function () {',
  10572. ' };',
  10573. ' this.Create = function(Par){',
  10574. ' return this;',
  10575. ' };',
  10576. '});',
  10577. 'this.Obj = null;'
  10578. ]),
  10579. LinesToStr([ // $mod.$main
  10580. '$mod.Obj = $mod.TObject.$create("Create",[3]);'
  10581. ]));
  10582. end;
  10583. procedure TTestModule.TestClass_TObjectConstructorWithDefaultParam;
  10584. begin
  10585. StartProgram(false);
  10586. Add('type');
  10587. Add(' TObject = class');
  10588. Add(' public');
  10589. Add(' constructor Create;');
  10590. Add(' end;');
  10591. Add(' TTest = class(TObject)');
  10592. Add(' public');
  10593. Add(' constructor Create(const Par: longint = 1);');
  10594. Add(' end;');
  10595. Add('constructor tobject.create;');
  10596. Add('begin end;');
  10597. Add('constructor ttest.create(const par: longint);');
  10598. Add('begin end;');
  10599. Add('var t: ttest;');
  10600. Add('begin');
  10601. Add(' t:=ttest.create;');
  10602. Add(' t:=ttest.create(2);');
  10603. ConvertProgram;
  10604. CheckSource('TestClass_TObjectConstructorWithDefaultParam',
  10605. LinesToStr([ // statements
  10606. 'rtl.createClass($mod,"TObject",null,function(){',
  10607. ' this.$init = function () {',
  10608. ' };',
  10609. ' this.$final = function () {',
  10610. ' };',
  10611. ' this.Create = function(){',
  10612. ' return this;',
  10613. ' };',
  10614. '});',
  10615. 'rtl.createClass($mod, "TTest", $mod.TObject, function () {',
  10616. ' this.Create$1 = function (Par) {',
  10617. ' return this;',
  10618. ' };',
  10619. '});',
  10620. 'this.t = null;'
  10621. ]),
  10622. LinesToStr([ // $mod.$main
  10623. '$mod.t = $mod.TTest.$create("Create$1", [1]);',
  10624. '$mod.t = $mod.TTest.$create("Create$1", [2]);'
  10625. ]));
  10626. end;
  10627. procedure TTestModule.TestClass_Var;
  10628. begin
  10629. StartProgram(false);
  10630. Add([
  10631. 'type',
  10632. ' TObject = class',
  10633. ' public',
  10634. ' vI: longint;',
  10635. ' constructor Create(Par: longint);',
  10636. ' end;',
  10637. 'constructor tobject.create(par: longint);',
  10638. 'begin',
  10639. ' vi:=par+3',
  10640. 'end;',
  10641. 'var Obj: tobject;',
  10642. 'begin',
  10643. ' obj:=tobject.create(4);',
  10644. ' obj.vi:=obj.VI+5;']);
  10645. ConvertProgram;
  10646. CheckSource('TestClass_Var',
  10647. LinesToStr([ // statements
  10648. 'rtl.createClass($mod,"TObject",null,function(){',
  10649. ' this.$init = function () {',
  10650. ' this.vI = 0;',
  10651. ' };',
  10652. ' this.$final = function () {',
  10653. ' };',
  10654. ' this.Create = function(Par){',
  10655. ' this.vI = Par+3;',
  10656. ' return this;',
  10657. ' };',
  10658. '});',
  10659. 'this.Obj = null;'
  10660. ]),
  10661. LinesToStr([ // $mod.$main
  10662. '$mod.Obj = $mod.TObject.$create("Create",[4]);',
  10663. '$mod.Obj.vI = $mod.Obj.vI + 5;'
  10664. ]));
  10665. end;
  10666. procedure TTestModule.TestClass_Method;
  10667. begin
  10668. StartProgram(false);
  10669. Add('type');
  10670. Add(' TObject = class');
  10671. Add(' public');
  10672. Add(' vI: longint;');
  10673. Add(' Sub: TObject;');
  10674. Add(' constructor Create;');
  10675. Add(' function GetIt(Par: longint): tobject;');
  10676. Add(' end;');
  10677. Add('constructor tobject.create; begin end;');
  10678. Add('function tobject.getit(par: longint): tobject;');
  10679. Add('begin');
  10680. Add(' Self.vi:=par+3;');
  10681. Add(' Result:=self.sub;');
  10682. Add('end;');
  10683. Add('var Obj: tobject;');
  10684. Add('begin');
  10685. Add(' obj:=tobject.create;');
  10686. Add(' obj.getit(4);');
  10687. Add(' obj.sub.sub:=nil;');
  10688. Add(' obj.sub.getit(5);');
  10689. Add(' obj.sub.getit(6).SUB:=nil;');
  10690. Add(' obj.sub.getit(7).GETIT(8);');
  10691. Add(' obj.sub.getit(9).SuB.getit(10);');
  10692. ConvertProgram;
  10693. CheckSource('TestClass_Method',
  10694. LinesToStr([ // statements
  10695. 'rtl.createClass($mod,"TObject",null,function(){',
  10696. ' this.$init = function () {',
  10697. ' this.vI = 0;',
  10698. ' this.Sub = null;',
  10699. ' };',
  10700. ' this.$final = function () {',
  10701. ' this.Sub = undefined;',
  10702. ' };',
  10703. ' this.Create = function(){',
  10704. ' return this;',
  10705. ' };',
  10706. ' this.GetIt = function(Par){',
  10707. ' var Result = null;',
  10708. ' this.vI = Par + 3;',
  10709. ' Result = this.Sub;',
  10710. ' return Result;',
  10711. ' };',
  10712. '});',
  10713. 'this.Obj = null;'
  10714. ]),
  10715. LinesToStr([ // $mod.$main
  10716. '$mod.Obj = $mod.TObject.$create("Create");',
  10717. '$mod.Obj.GetIt(4);',
  10718. '$mod.Obj.Sub.Sub=null;',
  10719. '$mod.Obj.Sub.GetIt(5);',
  10720. '$mod.Obj.Sub.GetIt(6).Sub=null;',
  10721. '$mod.Obj.Sub.GetIt(7).GetIt(8);',
  10722. '$mod.Obj.Sub.GetIt(9).Sub.GetIt(10);'
  10723. ]));
  10724. end;
  10725. procedure TTestModule.TestClass_Implementation;
  10726. begin
  10727. StartUnit(false);
  10728. Add([
  10729. 'interface',
  10730. 'type',
  10731. ' TObject = class',
  10732. ' constructor Create;',
  10733. ' end;',
  10734. 'implementation',
  10735. 'type',
  10736. ' TIntClass = class',
  10737. ' constructor Create; reintroduce;',
  10738. ' class procedure DoGlob;',
  10739. ' end;',
  10740. 'constructor tintclass.create;',
  10741. 'begin',
  10742. ' inherited;',
  10743. ' inherited create;',
  10744. ' doglob;',
  10745. 'end;',
  10746. 'class procedure tintclass.doglob;',
  10747. 'begin',
  10748. 'end;',
  10749. 'constructor tobject.create;',
  10750. 'var',
  10751. ' iC: tintclass;',
  10752. 'begin',
  10753. ' ic:=tintclass.create;',
  10754. ' tintclass.doglob;',
  10755. ' ic.doglob;',
  10756. 'end;',
  10757. 'initialization',
  10758. ' tintclass.doglob;',
  10759. '']);
  10760. ConvertUnit;
  10761. CheckSource('TestClass_Implementation',
  10762. LinesToStr([ // statements
  10763. 'var $impl = $mod.$impl;',
  10764. 'rtl.createClass($mod, "TObject", null, function () {',
  10765. ' this.$init = function () {',
  10766. ' };',
  10767. ' this.$final = function () {',
  10768. ' };',
  10769. ' this.Create = function () {',
  10770. ' var iC = null;',
  10771. ' iC = $impl.TIntClass.$create("Create$1");',
  10772. ' $impl.TIntClass.DoGlob();',
  10773. ' iC.$class.DoGlob();',
  10774. ' return this;',
  10775. ' };',
  10776. '});',
  10777. '']),
  10778. LinesToStr([ // $mod.$main
  10779. '$impl.TIntClass.DoGlob();',
  10780. '']),
  10781. LinesToStr([
  10782. 'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
  10783. ' this.Create$1 = function () {',
  10784. ' $mod.TObject.Create.call(this);',
  10785. ' $mod.TObject.Create.call(this);',
  10786. ' this.$class.DoGlob();',
  10787. ' return this;',
  10788. ' };',
  10789. ' this.DoGlob = function () {',
  10790. ' };',
  10791. '});',
  10792. '']));
  10793. end;
  10794. procedure TTestModule.TestClass_Inheritance;
  10795. begin
  10796. StartProgram(false);
  10797. Add('type');
  10798. Add(' TObject = class');
  10799. Add(' public');
  10800. Add(' constructor Create;');
  10801. Add(' end;');
  10802. Add(' TClassA = class');
  10803. Add(' end;');
  10804. Add(' TClassB = class(TObject)');
  10805. Add(' procedure ProcB;');
  10806. Add(' end;');
  10807. Add('constructor tobject.create; begin end;');
  10808. Add('procedure tclassb.procb; begin end;');
  10809. Add('var');
  10810. Add(' oO: TObject;');
  10811. Add(' oA: TClassA;');
  10812. Add(' oB: TClassB;');
  10813. Add('begin');
  10814. Add(' oO:=tobject.Create;');
  10815. Add(' oA:=tclassa.Create;');
  10816. Add(' ob:=tclassb.Create;');
  10817. Add(' if oo is tclassa then ;');
  10818. Add(' ob:=oo as tclassb;');
  10819. Add(' (oo as tclassb).procb;');
  10820. ConvertProgram;
  10821. CheckSource('TestClass_Inheritance',
  10822. LinesToStr([ // statements
  10823. 'rtl.createClass($mod,"TObject",null,function(){',
  10824. ' this.$init = function () {',
  10825. ' };',
  10826. ' this.$final = function () {',
  10827. ' };',
  10828. ' this.Create = function () {',
  10829. ' return this;',
  10830. ' };',
  10831. '});',
  10832. 'rtl.createClass($mod,"TClassA",$mod.TObject,function(){',
  10833. '});',
  10834. 'rtl.createClass($mod,"TClassB",$mod.TObject,function(){',
  10835. ' this.ProcB = function () {',
  10836. ' };',
  10837. '});',
  10838. 'this.oO = null;',
  10839. 'this.oA = null;',
  10840. 'this.oB = null;'
  10841. ]),
  10842. LinesToStr([ // $mod.$main
  10843. '$mod.oO = $mod.TObject.$create("Create");',
  10844. '$mod.oA = $mod.TClassA.$create("Create");',
  10845. '$mod.oB = $mod.TClassB.$create("Create");',
  10846. 'if ($mod.TClassA.isPrototypeOf($mod.oO));',
  10847. '$mod.oB = rtl.as($mod.oO, $mod.TClassB);',
  10848. 'rtl.as($mod.oO, $mod.TClassB).ProcB();'
  10849. ]));
  10850. end;
  10851. procedure TTestModule.TestClass_TypeAlias;
  10852. begin
  10853. StartProgram(false);
  10854. Add([
  10855. '{$interfaces corba}',
  10856. 'type',
  10857. ' IObject = interface',
  10858. ' end;',
  10859. ' IBird = type IObject;',
  10860. ' TObject = class',
  10861. ' end;',
  10862. ' TBird = type TObject;',
  10863. 'var',
  10864. ' oObj: TObject;',
  10865. ' oBird: TBird;',
  10866. ' IntfObj: IObject;',
  10867. ' IntfBird: IBird;',
  10868. 'begin',
  10869. ' oObj:=oBird;',
  10870. '']);
  10871. ConvertProgram;
  10872. CheckSource('TestClass_TypeAlias',
  10873. LinesToStr([ // statements
  10874. 'rtl.createInterface($mod, "IObject", "{B92D5841-6F2A-306A-8000-000000000000}", [], null);',
  10875. 'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-387B-AE88-F10981585074}", [], $mod.IObject);',
  10876. 'rtl.createClass($mod, "TObject", null, function () {',
  10877. ' this.$init = function () {',
  10878. ' };',
  10879. ' this.$final = function () {',
  10880. ' };',
  10881. '});',
  10882. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  10883. '});',
  10884. 'this.oObj = null;',
  10885. 'this.oBird = null;',
  10886. 'this.IntfObj = null;',
  10887. 'this.IntfBird = null;',
  10888. '']),
  10889. LinesToStr([ // $mod.$main
  10890. '$mod.oObj = $mod.oBird;',
  10891. '']));
  10892. end;
  10893. procedure TTestModule.TestClass_AbstractMethod;
  10894. begin
  10895. StartProgram(false);
  10896. Add('type');
  10897. Add(' TObject = class');
  10898. Add(' public');
  10899. Add(' procedure DoIt; virtual; abstract;');
  10900. Add(' end;');
  10901. Add('begin');
  10902. ConvertProgram;
  10903. CheckSource('TestClass_AbstractMethod',
  10904. LinesToStr([ // statements
  10905. 'rtl.createClass($mod,"TObject",null,function(){',
  10906. ' this.$init = function () {',
  10907. ' };',
  10908. ' this.$final = function () {',
  10909. ' };',
  10910. '});'
  10911. ]),
  10912. LinesToStr([ // this.$main
  10913. ''
  10914. ]));
  10915. end;
  10916. procedure TTestModule.TestClass_CallInherited_ProcNoParams;
  10917. begin
  10918. StartProgram(false);
  10919. Add([
  10920. 'type',
  10921. ' TObject = class',
  10922. ' procedure DoAbstract; virtual; abstract;',
  10923. ' procedure DoVirtual; virtual;',
  10924. ' procedure DoIt;',
  10925. ' end;',
  10926. ' TA = class',
  10927. ' procedure doabstract; override;',
  10928. ' procedure dovirtual; override;',
  10929. ' procedure DoSome;',
  10930. ' end;',
  10931. 'procedure tobject.dovirtual;',
  10932. 'begin',
  10933. ' inherited; // call non existing ancestor -> ignore silently',
  10934. 'end;',
  10935. 'procedure tobject.doit;',
  10936. 'begin',
  10937. 'end;',
  10938. 'procedure ta.doabstract;',
  10939. 'begin',
  10940. ' inherited dovirtual; // call TObject.DoVirtual',
  10941. 'end;',
  10942. 'procedure ta.dovirtual;',
  10943. 'begin',
  10944. ' inherited; // call TObject.DoVirtual',
  10945. ' inherited dovirtual; // call TObject.DoVirtual',
  10946. ' inherited dovirtual(); // call TObject.DoVirtual',
  10947. ' doit;',
  10948. ' doit();',
  10949. 'end;',
  10950. 'procedure ta.dosome;',
  10951. 'begin',
  10952. ' inherited; // call non existing ancestor method -> silently ignore',
  10953. 'end;',
  10954. 'begin']);
  10955. ConvertProgram;
  10956. CheckSource('TestClass_CallInherited_ProcNoParams',
  10957. LinesToStr([ // statements
  10958. 'rtl.createClass($mod,"TObject",null,function(){',
  10959. ' this.$init = function () {',
  10960. ' };',
  10961. ' this.$final = function () {',
  10962. ' };',
  10963. ' this.DoVirtual = function () {',
  10964. ' };',
  10965. ' this.DoIt = function () {',
  10966. ' };',
  10967. '});',
  10968. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  10969. ' this.DoAbstract = function () {',
  10970. ' $mod.TObject.DoVirtual.call(this);',
  10971. ' };',
  10972. ' this.DoVirtual = function () {',
  10973. ' $mod.TObject.DoVirtual.call(this);',
  10974. ' $mod.TObject.DoVirtual.call(this);',
  10975. ' $mod.TObject.DoVirtual.call(this);',
  10976. ' this.DoIt();',
  10977. ' this.DoIt();',
  10978. ' };',
  10979. ' this.DoSome = function () {',
  10980. ' };',
  10981. '});'
  10982. ]),
  10983. LinesToStr([ // this.$main
  10984. ''
  10985. ]));
  10986. end;
  10987. procedure TTestModule.TestClass_CallInherited_WithParams;
  10988. begin
  10989. StartProgram(false);
  10990. Add([
  10991. 'type',
  10992. ' TObject = class',
  10993. ' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;',
  10994. ' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;',
  10995. ' procedure DoIt(pA: longint; pB: longint = 0);',
  10996. ' procedure DoIt2(pA: longint = 1; pB: longint = 2);',
  10997. ' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
  10998. ' end;',
  10999. ' TClassA = class',
  11000. ' procedure DoAbstract(pA: longint; pB: longint = 0); override;',
  11001. ' procedure DoVirtual(pA: longint; pB: longint = 0); override;',
  11002. ' function GetIt(pA: longint = 1; pB: longint = 2): longint;',
  11003. ' end;',
  11004. 'procedure tobject.dovirtual(pa: longint; pb: longint = 0);',
  11005. 'begin',
  11006. 'end;',
  11007. 'procedure tobject.doit(pa: longint; pb: longint = 0);',
  11008. 'begin',
  11009. 'end;',
  11010. 'procedure tobject.doit2(pa: longint; pb: longint = 0);',
  11011. 'begin',
  11012. 'end;',
  11013. 'function tobject.getit(pa: longint; pb: longint = 0): longint;',
  11014. 'begin',
  11015. 'end;',
  11016. 'procedure tclassa.doabstract(pa: longint; pb: longint = 0);',
  11017. 'begin',
  11018. ' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
  11019. ' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
  11020. 'end;',
  11021. 'procedure tclassa.dovirtual(pa: longint; pb: longint = 0);',
  11022. 'begin',
  11023. ' inherited; // call TObject.DoVirtual(pA,pB)',
  11024. ' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)',
  11025. ' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)',
  11026. ' doit(pa,pb);',
  11027. ' doit(pa);',
  11028. ' doit2(pa);',
  11029. ' doit2;',
  11030. 'end;',
  11031. 'function tclassa.getit(pa: longint; pb: longint = 0): longint;',
  11032. 'begin',
  11033. ' pa:=inherited;',
  11034. 'end;',
  11035. 'begin']);
  11036. ConvertProgram;
  11037. CheckSource('TestClass_CallInherited_WithParams',
  11038. LinesToStr([ // statements
  11039. 'rtl.createClass($mod,"TObject",null,function(){',
  11040. ' this.$init = function () {',
  11041. ' };',
  11042. ' this.$final = function () {',
  11043. ' };',
  11044. ' this.DoVirtual = function (pA,pB) {',
  11045. ' };',
  11046. ' this.DoIt = function (pA,pB) {',
  11047. ' };',
  11048. ' this.DoIt2 = function (pA,pB) {',
  11049. ' };',
  11050. ' this.GetIt = function (pA, pB) {',
  11051. ' var Result = 0;',
  11052. ' return Result;',
  11053. ' };',
  11054. '});',
  11055. 'rtl.createClass($mod, "TClassA", $mod.TObject, function () {',
  11056. ' this.DoAbstract = function (pA,pB) {',
  11057. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  11058. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  11059. ' };',
  11060. ' this.DoVirtual = function (pA,pB) {',
  11061. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  11062. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  11063. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  11064. ' this.DoIt(pA,pB);',
  11065. ' this.DoIt(pA,0);',
  11066. ' this.DoIt2(pA,2);',
  11067. ' this.DoIt2(1,2);',
  11068. ' };',
  11069. ' this.GetIt$1 = function (pA, pB) {',
  11070. ' var Result = 0;',
  11071. ' pA = $mod.TObject.GetIt.apply(this, arguments);',
  11072. ' return Result;',
  11073. ' };',
  11074. '});'
  11075. ]),
  11076. LinesToStr([ // this.$main
  11077. ''
  11078. ]));
  11079. end;
  11080. procedure TTestModule.TestClasS_CallInheritedConstructor;
  11081. begin
  11082. StartProgram(false);
  11083. Add('type');
  11084. Add(' TObject = class');
  11085. Add(' constructor Create; virtual;');
  11086. Add(' constructor CreateWithB(b: boolean);');
  11087. Add(' end;');
  11088. Add(' TA = class');
  11089. Add(' constructor Create; override;');
  11090. Add(' constructor CreateWithC(c: char);');
  11091. Add(' procedure DoIt;');
  11092. Add(' class function DoSome: TObject;');
  11093. Add(' end;');
  11094. Add('constructor tobject.create;');
  11095. Add('begin');
  11096. Add(' inherited; // call non existing ancestor -> ignore silently');
  11097. Add('end;');
  11098. Add('constructor tobject.createwithb(b: boolean);');
  11099. Add('begin');
  11100. Add(' inherited; // call non existing ancestor -> ignore silently');
  11101. Add(' create; // normal call');
  11102. Add('end;');
  11103. Add('constructor ta.create;');
  11104. Add('begin');
  11105. Add(' inherited; // normal call TObject.Create');
  11106. Add(' inherited create; // normal call TObject.Create');
  11107. Add(' inherited createwithb(false); // normal call TObject.CreateWithB');
  11108. Add('end;');
  11109. Add('constructor ta.createwithc(c: char);');
  11110. Add('begin');
  11111. Add(' inherited create; // call TObject.Create');
  11112. Add(' inherited createwithb(true); // call TObject.CreateWithB');
  11113. Add(' doit;');
  11114. Add(' doit();');
  11115. Add(' dosome;');
  11116. Add('end;');
  11117. Add('procedure ta.doit;');
  11118. Add('begin');
  11119. Add(' create; // normal call');
  11120. Add(' createwithb(false); // normal call');
  11121. Add(' createwithc(''c''); // normal call');
  11122. Add('end;');
  11123. Add('class function ta.dosome: TObject;');
  11124. Add('begin');
  11125. Add(' Result:=create; // constructor');
  11126. Add(' Result:=createwithb(true); // constructor');
  11127. Add(' Result:=createwithc(''c''); // constructor');
  11128. Add('end;');
  11129. Add('begin');
  11130. ConvertProgram;
  11131. CheckSource('TestClass_CallInheritedConstructor',
  11132. LinesToStr([ // statements
  11133. 'rtl.createClass($mod,"TObject",null,function(){',
  11134. ' this.$init = function () {',
  11135. ' };',
  11136. ' this.$final = function () {',
  11137. ' };',
  11138. ' this.Create = function () {',
  11139. ' return this;',
  11140. ' };',
  11141. ' this.CreateWithB = function (b) {',
  11142. ' this.Create();',
  11143. ' return this;',
  11144. ' };',
  11145. '});',
  11146. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  11147. ' this.Create = function () {',
  11148. ' $mod.TObject.Create.call(this);',
  11149. ' $mod.TObject.Create.call(this);',
  11150. ' $mod.TObject.CreateWithB.call(this, false);',
  11151. ' return this;',
  11152. ' };',
  11153. ' this.CreateWithC = function (c) {',
  11154. ' $mod.TObject.Create.call(this);',
  11155. ' $mod.TObject.CreateWithB.call(this, true);',
  11156. ' this.DoIt();',
  11157. ' this.DoIt();',
  11158. ' this.$class.DoSome();',
  11159. ' return this;',
  11160. ' };',
  11161. ' this.DoIt = function () {',
  11162. ' this.Create();',
  11163. ' this.CreateWithB(false);',
  11164. ' this.CreateWithC("c");',
  11165. ' };',
  11166. ' this.DoSome = function () {',
  11167. ' var Result = null;',
  11168. ' Result = this.$create("Create");',
  11169. ' Result = this.$create("CreateWithB", [true]);',
  11170. ' Result = this.$create("CreateWithC", ["c"]);',
  11171. ' return Result;',
  11172. ' };',
  11173. '});'
  11174. ]),
  11175. LinesToStr([ // this.$main
  11176. ''
  11177. ]));
  11178. end;
  11179. procedure TTestModule.TestClass_ClassVar_Assign;
  11180. begin
  11181. StartProgram(false);
  11182. Add([
  11183. 'type',
  11184. ' TObject = class',
  11185. ' public',
  11186. ' class var vI: longint;',
  11187. ' class var Sub: TObject;',
  11188. ' constructor Create;',
  11189. ' class function GetIt(Par: longint): tobject;',
  11190. ' end;',
  11191. 'constructor tobject.create;',
  11192. 'begin',
  11193. ' vi:=vi+1;',
  11194. ' Self.vi:=Self.vi+1;',
  11195. ' inc(vi);',
  11196. 'end;',
  11197. 'class function tobject.getit(par: longint): tobject;',
  11198. 'begin',
  11199. ' vi:=vi+par;',
  11200. ' Self.vi:=Self.vi+par;',
  11201. ' inc(vi);',
  11202. ' Result:=self.sub;',
  11203. 'end;',
  11204. 'var Obj: tobject;',
  11205. 'begin',
  11206. ' obj:=tobject.create;',
  11207. ' tobject.vi:=3;',
  11208. ' if tobject.vi=4 then ;',
  11209. ' tobject.sub:=nil;',
  11210. ' obj.sub:=nil;',
  11211. ' obj.sub.sub:=nil;']);
  11212. ConvertProgram;
  11213. CheckSource('TestClass_ClassVar_Assign',
  11214. LinesToStr([ // statements
  11215. 'rtl.createClass($mod,"TObject",null,function(){',
  11216. ' this.vI = 0;',
  11217. ' this.Sub = null;',
  11218. ' this.$init = function () {',
  11219. ' };',
  11220. ' this.$final = function () {',
  11221. ' };',
  11222. ' this.Create = function(){',
  11223. ' $mod.TObject.vI = this.vI+1;',
  11224. ' $mod.TObject.vI = this.vI+1;',
  11225. ' $mod.TObject.vI += 1;',
  11226. ' return this;',
  11227. ' };',
  11228. ' this.GetIt = function(Par){',
  11229. ' var Result = null;',
  11230. ' $mod.TObject.vI = this.vI + Par;',
  11231. ' $mod.TObject.vI = this.vI + Par;',
  11232. ' $mod.TObject.vI += 1;',
  11233. ' Result = this.Sub;',
  11234. ' return Result;',
  11235. ' };',
  11236. '});',
  11237. 'this.Obj = null;'
  11238. ]),
  11239. LinesToStr([ // $mod.$main
  11240. '$mod.Obj = $mod.TObject.$create("Create");',
  11241. '$mod.TObject.vI = 3;',
  11242. 'if ($mod.TObject.vI === 4);',
  11243. '$mod.TObject.Sub=null;',
  11244. '$mod.TObject.Sub=null;',
  11245. '$mod.TObject.Sub=null;',
  11246. '']));
  11247. end;
  11248. procedure TTestModule.TestClass_CallClassMethod;
  11249. begin
  11250. StartProgram(false);
  11251. Add('type');
  11252. Add(' TObject = class');
  11253. Add(' public');
  11254. Add(' class var vI: longint;');
  11255. Add(' class var Sub: TObject;');
  11256. Add(' constructor Create;');
  11257. Add(' function GetMore(Par: longint): longint;');
  11258. Add(' class function GetIt(Par: longint): tobject;');
  11259. Add(' end;');
  11260. Add('constructor tobject.create;');
  11261. Add('begin');
  11262. Add(' sub:=getit(3);');
  11263. Add(' vi:=getmore(4);');
  11264. Add(' sub:=Self.getit(5);');
  11265. Add(' vi:=Self.getmore(6);');
  11266. Add('end;');
  11267. Add('function tobject.getmore(par: longint): longint;');
  11268. Add('begin');
  11269. Add(' sub:=getit(11);');
  11270. Add(' vi:=getmore(12);');
  11271. Add(' sub:=self.getit(13);');
  11272. Add(' vi:=self.getmore(14);');
  11273. Add('end;');
  11274. Add('class function tobject.getit(par: longint): tobject;');
  11275. Add('begin');
  11276. Add(' sub:=getit(21);');
  11277. Add(' vi:=sub.getmore(22);');
  11278. Add(' sub:=self.getit(23);');
  11279. Add(' vi:=self.sub.getmore(24);');
  11280. Add('end;');
  11281. Add('var Obj: tobject;');
  11282. Add('begin');
  11283. Add(' obj:=tobject.create;');
  11284. Add(' tobject.getit(5);');
  11285. Add(' obj.getit(6);');
  11286. Add(' obj.sub.getit(7);');
  11287. Add(' obj.sub.getit(8).SUB:=nil;');
  11288. Add(' obj.sub.getit(9).GETIT(10);');
  11289. Add(' obj.sub.getit(11).SuB.getit(12);');
  11290. ConvertProgram;
  11291. CheckSource('TestClass_CallClassMethod',
  11292. LinesToStr([ // statements
  11293. 'rtl.createClass($mod,"TObject",null,function(){',
  11294. ' this.vI = 0;',
  11295. ' this.Sub = null;',
  11296. ' this.$init = function () {',
  11297. ' };',
  11298. ' this.$final = function () {',
  11299. ' };',
  11300. ' this.Create = function(){',
  11301. ' $mod.TObject.Sub = this.$class.GetIt(3);',
  11302. ' $mod.TObject.vI = this.GetMore(4);',
  11303. ' $mod.TObject.Sub = this.$class.GetIt(5);',
  11304. ' $mod.TObject.vI = this.GetMore(6);',
  11305. ' return this;',
  11306. ' };',
  11307. ' this.GetMore = function(Par){',
  11308. ' var Result = 0;',
  11309. ' $mod.TObject.Sub = this.$class.GetIt(11);',
  11310. ' $mod.TObject.vI = this.GetMore(12);',
  11311. ' $mod.TObject.Sub = this.$class.GetIt(13);',
  11312. ' $mod.TObject.vI = this.GetMore(14);',
  11313. ' return Result;',
  11314. ' };',
  11315. ' this.GetIt = function(Par){',
  11316. ' var Result = null;',
  11317. ' $mod.TObject.Sub = this.GetIt(21);',
  11318. ' $mod.TObject.vI = this.Sub.GetMore(22);',
  11319. ' $mod.TObject.Sub = this.GetIt(23);',
  11320. ' $mod.TObject.vI = this.Sub.GetMore(24);',
  11321. ' return Result;',
  11322. ' };',
  11323. '});',
  11324. 'this.Obj = null;'
  11325. ]),
  11326. LinesToStr([ // $mod.$main
  11327. '$mod.Obj = $mod.TObject.$create("Create");',
  11328. '$mod.TObject.GetIt(5);',
  11329. '$mod.Obj.$class.GetIt(6);',
  11330. '$mod.Obj.Sub.$class.GetIt(7);',
  11331. '$mod.TObject.Sub=null;',
  11332. '$mod.Obj.Sub.$class.GetIt(9).$class.GetIt(10);',
  11333. '$mod.Obj.Sub.$class.GetIt(11).Sub.$class.GetIt(12);',
  11334. '']));
  11335. end;
  11336. procedure TTestModule.TestClass_Property;
  11337. begin
  11338. StartProgram(false);
  11339. Add('type');
  11340. Add(' TObject = class');
  11341. Add(' Fx: longint;');
  11342. Add(' Fy: longint;');
  11343. Add(' function GetInt: longint;');
  11344. Add(' procedure SetInt(Value: longint);');
  11345. Add(' procedure DoIt;');
  11346. Add(' property IntA: longint read Fx write Fy;');
  11347. Add(' property IntB: longint read GetInt write SetInt;');
  11348. Add(' end;');
  11349. Add('function tobject.getint: longint;');
  11350. Add('begin');
  11351. Add(' result:=fx;');
  11352. Add('end;');
  11353. Add('procedure tobject.setint(value: longint);');
  11354. Add('begin');
  11355. Add(' if value=fy then exit;');
  11356. Add(' fy:=value;');
  11357. Add('end;');
  11358. Add('procedure tobject.doit;');
  11359. Add('begin');
  11360. Add(' IntA:=IntA+1;');
  11361. Add(' Self.IntA:=Self.IntA+1;');
  11362. Add(' IntB:=IntB+1;');
  11363. Add(' Self.IntB:=Self.IntB+1;');
  11364. Add('end;');
  11365. Add('var Obj: tobject;');
  11366. Add('begin');
  11367. Add(' obj.inta:=obj.inta+1;');
  11368. Add(' if obj.intb=2 then;');
  11369. Add(' obj.intb:=obj.intb+2;');
  11370. Add(' obj.setint(obj.inta);');
  11371. ConvertProgram;
  11372. CheckSource('TestClass_Property',
  11373. LinesToStr([ // statements
  11374. 'rtl.createClass($mod, "TObject", null, function () {',
  11375. ' this.$init = function () {',
  11376. ' this.Fx = 0;',
  11377. ' this.Fy = 0;',
  11378. ' };',
  11379. ' this.$final = function () {',
  11380. ' };',
  11381. ' this.GetInt = function () {',
  11382. ' var Result = 0;',
  11383. ' Result = this.Fx;',
  11384. ' return Result;',
  11385. ' };',
  11386. ' this.SetInt = function (Value) {',
  11387. ' if (Value === this.Fy) return;',
  11388. ' this.Fy = Value;',
  11389. ' };',
  11390. ' this.DoIt = function () {',
  11391. ' this.Fy = this.Fx + 1;',
  11392. ' this.Fy = this.Fx + 1;',
  11393. ' this.SetInt(this.GetInt() + 1);',
  11394. ' this.SetInt(this.GetInt() + 1);',
  11395. ' };',
  11396. '});',
  11397. 'this.Obj = null;'
  11398. ]),
  11399. LinesToStr([ // $mod.$main
  11400. '$mod.Obj.Fy = $mod.Obj.Fx + 1;',
  11401. 'if ($mod.Obj.GetInt() === 2);',
  11402. '$mod.Obj.SetInt($mod.Obj.GetInt() + 2);',
  11403. '$mod.Obj.SetInt($mod.Obj.Fx);'
  11404. ]));
  11405. end;
  11406. procedure TTestModule.TestClass_Property_ClassMethod;
  11407. begin
  11408. StartProgram(false);
  11409. Add([
  11410. 'type',
  11411. ' TObject = class',
  11412. ' class var Fx: longint;',
  11413. ' class var Fy: longint;',
  11414. ' class function GetInt: longint;',
  11415. ' class procedure SetInt(Value: longint);',
  11416. ' end;',
  11417. ' TBird = class',
  11418. ' class procedure DoIt;',
  11419. ' class property IntA: longint read Fx write Fy;',
  11420. ' class property IntB: longint read GetInt write SetInt;',
  11421. ' end;',
  11422. 'class function tobject.getint: longint;',
  11423. 'begin',
  11424. ' result:=fx;',
  11425. 'end;',
  11426. 'class procedure tobject.setint(value: longint);',
  11427. 'begin',
  11428. 'end;',
  11429. 'class procedure tbird.doit;',
  11430. 'begin',
  11431. ' FX:=3;',
  11432. ' IntA:=IntA+1;',
  11433. ' Self.IntA:=Self.IntA+1;',
  11434. ' IntB:=IntB+1;',
  11435. ' Self.IntB:=Self.IntB+1;',
  11436. ' with Self do begin',
  11437. ' FX:=11;',
  11438. ' IntA:=IntA+12;',
  11439. ' IntB:=IntB+13;',
  11440. ' end;',
  11441. 'end;',
  11442. 'var Obj: tbird;',
  11443. 'begin',
  11444. ' tbird.fx:=tbird.fx+1;',
  11445. ' tbird.inta:=tbird.inta+1;',
  11446. ' if tbird.intb=2 then;',
  11447. ' tbird.intb:=tbird.intb+2;',
  11448. ' tbird.setint(tbird.inta);',
  11449. ' obj.inta:=obj.inta+1;',
  11450. ' if obj.intb=2 then;',
  11451. ' obj.intb:=obj.intb+2;',
  11452. ' obj.setint(obj.inta);',
  11453. ' with Tbird do begin',
  11454. ' FX:=FY+1;',
  11455. ' inta:=inta+2;',
  11456. ' intb:=intb+3;',
  11457. ' end;',
  11458. ' with Obj do begin',
  11459. ' FX:=FY+1;',
  11460. ' inta:=inta+2;',
  11461. ' intb:=intb+3;',
  11462. ' end;',
  11463. '']);
  11464. ConvertProgram;
  11465. CheckSource('TestClass_Property_ClassMethod',
  11466. LinesToStr([ // statements
  11467. 'rtl.createClass($mod, "TObject", null, function () {',
  11468. ' this.Fx = 0;',
  11469. ' this.Fy = 0;',
  11470. ' this.$init = function () {',
  11471. ' };',
  11472. ' this.$final = function () {',
  11473. ' };',
  11474. ' this.GetInt = function () {',
  11475. ' var Result = 0;',
  11476. ' Result = this.Fx;',
  11477. ' return Result;',
  11478. ' };',
  11479. ' this.SetInt = function (Value) {',
  11480. ' };',
  11481. '});',
  11482. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  11483. ' this.DoIt = function () {',
  11484. ' $mod.TObject.Fx = 3;',
  11485. ' $mod.TObject.Fy = this.Fx + 1;',
  11486. ' $mod.TObject.Fy = this.Fx + 1;',
  11487. ' this.SetInt(this.GetInt() + 1);',
  11488. ' this.SetInt(this.GetInt() + 1);',
  11489. ' $mod.TObject.Fx = 11;',
  11490. ' $mod.TObject.Fy = this.Fx + 12;',
  11491. ' this.SetInt(this.GetInt() + 13);',
  11492. ' };',
  11493. '});',
  11494. 'this.Obj = null;'
  11495. ]),
  11496. LinesToStr([ // $mod.$main
  11497. '$mod.TObject.Fx = $mod.TBird.Fx + 1;',
  11498. '$mod.TObject.Fy = $mod.TBird.Fx + 1;',
  11499. 'if ($mod.TBird.GetInt() === 2);',
  11500. '$mod.TBird.SetInt($mod.TBird.GetInt() + 2);',
  11501. '$mod.TBird.SetInt($mod.TBird.Fx);',
  11502. '$mod.TObject.Fy = $mod.Obj.Fx + 1;',
  11503. 'if ($mod.Obj.$class.GetInt() === 2);',
  11504. '$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
  11505. '$mod.Obj.$class.SetInt($mod.Obj.Fx);',
  11506. 'var $with1 = $mod.TBird;',
  11507. '$mod.TObject.Fx = $with1.Fy + 1;',
  11508. '$mod.TObject.Fy = $with1.Fx + 2;',
  11509. '$with1.SetInt($with1.GetInt() + 3);',
  11510. 'var $with2 = $mod.Obj;',
  11511. '$mod.TObject.Fx = $with2.Fy + 1;',
  11512. '$mod.TObject.Fy = $with2.Fx + 2;',
  11513. '$with2.SetInt($with2.GetInt() + 3);',
  11514. '']));
  11515. end;
  11516. procedure TTestModule.TestClass_Property_Indexed;
  11517. begin
  11518. StartProgram(false);
  11519. Add('type');
  11520. Add(' TObject = class');
  11521. Add(' FItems: array of longint;');
  11522. Add(' function GetItems(Index: longint): longint;');
  11523. Add(' procedure SetItems(Index: longint; Value: longint);');
  11524. Add(' procedure DoIt;');
  11525. Add(' property Items[Index: longint]: longint read getitems write setitems;');
  11526. Add(' end;');
  11527. Add('function tobject.getitems(index: longint): longint;');
  11528. Add('begin');
  11529. Add(' Result:=fitems[index];');
  11530. Add('end;');
  11531. Add('procedure tobject.setitems(index: longint; value: longint);');
  11532. Add('begin');
  11533. Add(' fitems[index]:=value;');
  11534. Add('end;');
  11535. Add('procedure tobject.doit;');
  11536. Add('begin');
  11537. Add(' items[1]:=2;');
  11538. Add(' items[3]:=items[4];');
  11539. Add(' self.items[5]:=self.items[6];');
  11540. Add(' items[items[7]]:=items[items[8]];');
  11541. Add('end;');
  11542. Add('var Obj: tobject;');
  11543. Add('begin');
  11544. Add(' obj.Items[11]:=obj.Items[12];');
  11545. ConvertProgram;
  11546. CheckSource('TestClass_Property_Indexed',
  11547. LinesToStr([ // statements
  11548. 'rtl.createClass($mod, "TObject", null, function () {',
  11549. ' this.$init = function () {',
  11550. ' this.FItems = [];',
  11551. ' };',
  11552. ' this.$final = function () {',
  11553. ' this.FItems = undefined;',
  11554. ' };',
  11555. ' this.GetItems = function (Index) {',
  11556. ' var Result = 0;',
  11557. ' Result = this.FItems[Index];',
  11558. ' return Result;',
  11559. ' };',
  11560. ' this.SetItems = function (Index, Value) {',
  11561. ' this.FItems[Index] = Value;',
  11562. ' };',
  11563. ' this.DoIt = function () {',
  11564. ' this.SetItems(1, 2);',
  11565. ' this.SetItems(3,this.GetItems(4));',
  11566. ' this.SetItems(5,this.GetItems(6));',
  11567. ' this.SetItems(this.GetItems(7), this.GetItems(this.GetItems(8)));',
  11568. ' };',
  11569. '});',
  11570. 'this.Obj = null;'
  11571. ]),
  11572. LinesToStr([ // $mod.$main
  11573. '$mod.Obj.SetItems(11,$mod.Obj.GetItems(12));'
  11574. ]));
  11575. end;
  11576. procedure TTestModule.TestClass_Property_IndexSpec;
  11577. begin
  11578. StartProgram(false);
  11579. Add([
  11580. 'type',
  11581. ' TEnum = (red, blue);',
  11582. ' TObject = class',
  11583. ' function GetIntBool(Index: longint): boolean; virtual; abstract;',
  11584. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  11585. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  11586. ' procedure SetEnumBool(Index: TEnum; b: boolean); virtual; abstract;',
  11587. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  11588. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  11589. ' property B1: boolean index 1 read GetIntBool write SetIntBool;',
  11590. ' property B2: boolean index TEnum.blue read GetEnumBool write SetEnumBool;',
  11591. ' property B3: boolean index ord(red) read GetIntBool write SetIntBool;',
  11592. ' property I1[A: String]: boolean index ord(blue) read GetStrIntBool write SetStrIntBool;',
  11593. ' end;',
  11594. 'procedure DoIt(b: boolean); begin end;',
  11595. 'var',
  11596. ' o: TObject;',
  11597. 'begin',
  11598. ' o.B1:=o.B1;',
  11599. ' o.B2:=o.B2;',
  11600. ' o.B3:=o.B3;',
  11601. ' o.I1[''a'']:=o.I1[''b''];',
  11602. ' doit(o.b1);',
  11603. ' doit(o.b2);',
  11604. ' doit(o.i1[''c'']);',
  11605. '']);
  11606. ConvertProgram;
  11607. CheckSource('TestClass_Property_IndexSpec',
  11608. LinesToStr([ // statements
  11609. 'this.TEnum = {',
  11610. ' "0": "red",',
  11611. ' red: 0,',
  11612. ' "1": "blue",',
  11613. ' blue: 1',
  11614. '};',
  11615. 'rtl.createClass($mod, "TObject", null, function () {',
  11616. ' this.$init = function () {',
  11617. ' };',
  11618. ' this.$final = function () {',
  11619. ' };',
  11620. '});',
  11621. 'this.DoIt = function (b) {',
  11622. '};',
  11623. 'this.o = null;',
  11624. '']),
  11625. LinesToStr([ // $mod.$main
  11626. '$mod.o.SetIntBool(1, $mod.o.GetIntBool(1));',
  11627. '$mod.o.SetEnumBool($mod.TEnum.blue, $mod.o.GetEnumBool($mod.TEnum.blue));',
  11628. '$mod.o.SetIntBool(0, $mod.o.GetIntBool(0));',
  11629. '$mod.o.SetStrIntBool("a", 1, $mod.o.GetStrIntBool("b", 1));',
  11630. '$mod.DoIt($mod.o.GetIntBool(1));',
  11631. '$mod.DoIt($mod.o.GetEnumBool($mod.TEnum.blue));',
  11632. '$mod.DoIt($mod.o.GetStrIntBool("c", 1));',
  11633. '']));
  11634. end;
  11635. procedure TTestModule.TestClass_PropertyOfTypeArray;
  11636. begin
  11637. StartProgram(false);
  11638. Add('type');
  11639. Add(' TArray = array of longint;');
  11640. Add(' TObject = class');
  11641. Add(' FItems: TArray;');
  11642. Add(' function GetItems: tarray;');
  11643. Add(' procedure SetItems(Value: tarray);');
  11644. Add(' property Items: tarray read getitems write setitems;');
  11645. Add(' end;');
  11646. Add('function tobject.getitems: tarray;');
  11647. Add('begin');
  11648. Add(' Result:=fitems;');
  11649. Add('end;');
  11650. Add('procedure tobject.setitems(value: tarray);');
  11651. Add('begin');
  11652. Add(' fitems:=value;');
  11653. Add(' fitems:=nil;');
  11654. Add(' Items:=nil;');
  11655. Add(' Items:=Items;');
  11656. Add(' Items[1]:=2;');
  11657. Add(' fitems[3]:=Items[4];');
  11658. Add(' Items[5]:=Items[6];');
  11659. Add(' Self.Items[7]:=8;');
  11660. Add(' Self.Items[9]:=Self.Items[10];');
  11661. Add(' Items[Items[11]]:=Items[Items[12]];');
  11662. Add('end;');
  11663. Add('var Obj: tobject;');
  11664. Add('begin');
  11665. Add(' obj.items:=nil;');
  11666. Add(' obj.items:=obj.items;');
  11667. Add(' obj.items[11]:=obj.items[12];');
  11668. ConvertProgram;
  11669. CheckSource('TestClass_PropertyOfTypeArray',
  11670. LinesToStr([ // statements
  11671. 'rtl.createClass($mod, "TObject", null, function () {',
  11672. ' this.$init = function () {',
  11673. ' this.FItems = [];',
  11674. ' };',
  11675. ' this.$final = function () {',
  11676. ' this.FItems = undefined;',
  11677. ' };',
  11678. ' this.GetItems = function () {',
  11679. ' var Result = [];',
  11680. ' Result = this.FItems;',
  11681. ' return Result;',
  11682. ' };',
  11683. ' this.SetItems = function (Value) {',
  11684. ' this.FItems = Value;',
  11685. ' this.FItems = [];',
  11686. ' this.SetItems([]);',
  11687. ' this.SetItems(this.GetItems());',
  11688. ' this.GetItems()[1] = 2;',
  11689. ' this.FItems[3] = this.GetItems()[4];',
  11690. ' this.GetItems()[5] = this.GetItems()[6];',
  11691. ' this.GetItems()[7] = 8;',
  11692. ' this.GetItems()[9] = this.GetItems()[10];',
  11693. ' this.GetItems()[this.GetItems()[11]] = this.GetItems()[this.GetItems()[12]];',
  11694. ' };',
  11695. '});',
  11696. 'this.Obj = null;'
  11697. ]),
  11698. LinesToStr([ // $mod.$main
  11699. '$mod.Obj.SetItems([]);',
  11700. '$mod.Obj.SetItems($mod.Obj.GetItems());',
  11701. '$mod.Obj.GetItems()[11] = $mod.Obj.GetItems()[12];'
  11702. ]));
  11703. end;
  11704. procedure TTestModule.TestClass_PropertyDefault;
  11705. begin
  11706. StartProgram(false);
  11707. Add([
  11708. 'type',
  11709. ' TArray = array of longint;',
  11710. ' TObject = class',
  11711. ' FItems: TArray;',
  11712. ' function GetItems(Index: longint): longint;',
  11713. ' procedure SetItems(Index, Value: longint);',
  11714. ' property Items[Index: longint]: longint read getitems write setitems; default;',
  11715. ' end;',
  11716. 'function tobject.getitems(index: longint): longint;',
  11717. 'begin',
  11718. 'end;',
  11719. 'procedure tobject.setitems(index, value: longint);',
  11720. 'begin',
  11721. ' Self[1]:=2;',
  11722. ' Self[3]:=Self[index];',
  11723. ' Self[index]:=Self[Self[value]];',
  11724. ' Self[Self[4]]:=value;',
  11725. 'end;',
  11726. 'var Obj: tobject;',
  11727. 'begin',
  11728. ' obj[11]:=12;',
  11729. ' obj[13]:=obj[14];',
  11730. ' obj[obj[15]]:=obj[obj[15]];',
  11731. ' TObject(obj)[16]:=TObject(obj)[17];']);
  11732. ConvertProgram;
  11733. CheckSource('TestClass_PropertyDefault',
  11734. LinesToStr([ // statements
  11735. 'rtl.createClass($mod, "TObject", null, function () {',
  11736. ' this.$init = function () {',
  11737. ' this.FItems = [];',
  11738. ' };',
  11739. ' this.$final = function () {',
  11740. ' this.FItems = undefined;',
  11741. ' };',
  11742. ' this.GetItems = function (Index) {',
  11743. ' var Result = 0;',
  11744. ' return Result;',
  11745. ' };',
  11746. ' this.SetItems = function (Index, Value) {',
  11747. ' this.SetItems(1, 2);',
  11748. ' this.SetItems(3, this.GetItems(Index));',
  11749. ' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
  11750. ' this.SetItems(this.GetItems(4), Value);',
  11751. ' };',
  11752. '});',
  11753. 'this.Obj = null;'
  11754. ]),
  11755. LinesToStr([ // $mod.$main
  11756. '$mod.Obj.SetItems(11, 12);',
  11757. '$mod.Obj.SetItems(13, $mod.Obj.GetItems(14));',
  11758. '$mod.Obj.SetItems($mod.Obj.GetItems(15), $mod.Obj.GetItems($mod.Obj.GetItems(15)));',
  11759. '$mod.Obj.SetItems(16, $mod.Obj.GetItems(17));',
  11760. '']));
  11761. end;
  11762. procedure TTestModule.TestClass_PropertyDefault2;
  11763. begin
  11764. StartProgram(false);
  11765. Add([
  11766. 'type',
  11767. ' TObject = class end;',
  11768. ' TAlphaList = class',
  11769. ' function GetAlphas(Index: boolean): Pointer; virtual; abstract;',
  11770. ' procedure SetAlphas(Index: boolean; Value: Pointer); virtual; abstract;',
  11771. ' property Alphas[Index: boolean]: Pointer read getAlphas write setAlphas; default;',
  11772. ' end;',
  11773. ' TBetaList = class',
  11774. ' function GetBetas(Index: longint): Pointer; virtual; abstract;',
  11775. ' procedure SetBetas(Index: longint; Value: Pointer); virtual; abstract;',
  11776. ' property Betas[Index: longint]: Pointer read getBetas write setBetas; default;',
  11777. ' end;',
  11778. ' TBird = class',
  11779. ' procedure DoIt;',
  11780. ' end;',
  11781. 'procedure TBird.DoIt;',
  11782. 'var',
  11783. ' List: TAlphaList;',
  11784. 'begin',
  11785. ' if TBetaList(List[true])[3]=nil then ;',
  11786. ' TBetaList(List[false])[5]:=nil;',
  11787. 'end;',
  11788. 'var',
  11789. ' List: TAlphaList;',
  11790. 'begin',
  11791. ' if TBetaList(List[true])[3]=nil then ;',
  11792. ' TBetaList(List[false])[5]:=nil;',
  11793. '']);
  11794. ConvertProgram;
  11795. CheckSource('TestClass_PropertyDefault2',
  11796. LinesToStr([ // statements
  11797. 'rtl.createClass($mod, "TObject", null, function () {',
  11798. ' this.$init = function () {',
  11799. ' };',
  11800. ' this.$final = function () {',
  11801. ' };',
  11802. '});',
  11803. 'rtl.createClass($mod, "TAlphaList", $mod.TObject, function () {',
  11804. '});',
  11805. 'rtl.createClass($mod, "TBetaList", $mod.TObject, function () {',
  11806. '});',
  11807. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  11808. ' this.DoIt = function () {',
  11809. ' var List = null;',
  11810. ' if (List.GetAlphas(true).GetBetas(3) === null) ;',
  11811. ' List.GetAlphas(false).SetBetas(5, null);',
  11812. ' };',
  11813. '});',
  11814. 'this.List = null;',
  11815. '']),
  11816. LinesToStr([ // $mod.$main
  11817. 'if ($mod.List.GetAlphas(true).GetBetas(3) === null) ;',
  11818. '$mod.List.GetAlphas(false).SetBetas(5, null);',
  11819. '']));
  11820. end;
  11821. procedure TTestModule.TestClass_PropertyOverride;
  11822. begin
  11823. StartProgram(false);
  11824. Add('type');
  11825. Add(' integer = longint;');
  11826. Add(' TObject = class');
  11827. Add(' FItem: integer;');
  11828. Add(' function GetItem: integer; external name ''GetItem'';');
  11829. Add(' procedure SetItem(Value: integer); external name ''SetItem'';');
  11830. Add(' property Item: integer read getitem write setitem;');
  11831. Add(' end;');
  11832. Add(' TCar = class');
  11833. Add(' FBag: integer;');
  11834. Add(' function GetBag: integer; external name ''GetBag'';');
  11835. Add(' property Item read getbag;');
  11836. Add(' end;');
  11837. Add('var');
  11838. Add(' Obj: tobject;');
  11839. Add(' Car: tcar;');
  11840. Add('begin');
  11841. Add(' Obj.Item:=Obj.Item;');
  11842. Add(' Car.Item:=Car.Item;');
  11843. ConvertProgram;
  11844. CheckSource('TestClass_PropertyOverride',
  11845. LinesToStr([ // statements
  11846. 'rtl.createClass($mod, "TObject", null, function () {',
  11847. ' this.$init = function () {',
  11848. ' this.FItem = 0;',
  11849. ' };',
  11850. ' this.$final = function () {',
  11851. ' };',
  11852. '});',
  11853. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  11854. ' this.$init = function () {',
  11855. ' $mod.TObject.$init.call(this);',
  11856. ' this.FBag = 0;',
  11857. ' };',
  11858. '});',
  11859. 'this.Obj = null;',
  11860. 'this.Car = null;',
  11861. '']),
  11862. LinesToStr([ // $mod.$main
  11863. '$mod.Obj.SetItem($mod.Obj.GetItem());',
  11864. '$mod.Car.SetItem($mod.Car.GetBag());',
  11865. '']));
  11866. end;
  11867. procedure TTestModule.TestClass_PropertyIncVisibility;
  11868. begin
  11869. AddModuleWithIntfImplSrc('unit1.pp',
  11870. LinesToStr([
  11871. 'type',
  11872. ' TNumber = longint;',
  11873. ' TInteger = longint;',
  11874. ' TObject = class',
  11875. ' private',
  11876. ' function GetItems(Index: TNumber): TInteger; virtual; abstract;',
  11877. ' procedure SetItems(Index: TInteger; Value: TNumber); virtual; abstract;',
  11878. ' protected',
  11879. ' property Items[Index: TNumber]: longint read GetItems write SetItems;',
  11880. ' end;']),
  11881. LinesToStr([
  11882. '']));
  11883. StartProgram(true);
  11884. Add([
  11885. 'uses unit1;',
  11886. 'type',
  11887. ' TBird = class',
  11888. ' public',
  11889. ' property Items;',
  11890. ' end;',
  11891. 'procedure DoIt(i: TInteger);',
  11892. 'begin',
  11893. 'end;',
  11894. 'var b: TBird;',
  11895. 'begin',
  11896. ' b.Items[1]:=2;',
  11897. ' b.Items[3]:=b.Items[4];',
  11898. ' DoIt(b.Items[5]);',
  11899. '']);
  11900. ConvertProgram;
  11901. CheckSource('TestClass_PropertyIncVisibility',
  11902. LinesToStr([ // statements
  11903. 'rtl.createClass($mod, "TBird", pas.unit1.TObject, function () {',
  11904. '});',
  11905. 'this.DoIt = function (i) {',
  11906. '};',
  11907. 'this.b = null;'
  11908. ]),
  11909. LinesToStr([ // $mod.$main
  11910. '$mod.b.SetItems(1, 2);',
  11911. '$mod.b.SetItems(3, $mod.b.GetItems(4));',
  11912. '$mod.DoIt($mod.b.GetItems(5));'
  11913. ]));
  11914. end;
  11915. procedure TTestModule.TestClass_Assigned;
  11916. begin
  11917. StartProgram(false);
  11918. Add('type');
  11919. Add(' TObject = class');
  11920. Add(' end;');
  11921. Add('var');
  11922. Add(' Obj: tobject;');
  11923. Add(' b: boolean;');
  11924. Add('begin');
  11925. Add(' if Assigned(obj) then ;');
  11926. Add(' b:=Assigned(obj) or false;');
  11927. ConvertProgram;
  11928. CheckSource('TestClass_Assigned',
  11929. LinesToStr([ // statements
  11930. 'rtl.createClass($mod, "TObject", null, function () {',
  11931. ' this.$init = function () {',
  11932. ' };',
  11933. ' this.$final = function () {',
  11934. ' };',
  11935. '});',
  11936. 'this.Obj = null;',
  11937. 'this.b = false;'
  11938. ]),
  11939. LinesToStr([ // $mod.$main
  11940. 'if ($mod.Obj != null);',
  11941. '$mod.b = ($mod.Obj != null) || false;'
  11942. ]));
  11943. end;
  11944. procedure TTestModule.TestClass_WithClassDoCreate;
  11945. begin
  11946. StartProgram(false);
  11947. Add('type');
  11948. Add(' TObject = class');
  11949. Add(' aBool: boolean;');
  11950. Add(' Arr: array of boolean;');
  11951. Add(' constructor Create;');
  11952. Add(' end;');
  11953. Add('constructor TObject.Create; begin end;');
  11954. Add('var');
  11955. Add(' Obj: tobject;');
  11956. Add(' b: boolean;');
  11957. Add('begin');
  11958. Add(' with tobject.create do begin');
  11959. Add(' b:=abool;');
  11960. Add(' abool:=b;');
  11961. Add(' b:=arr[1];');
  11962. Add(' arr[2]:=b;');
  11963. Add(' end;');
  11964. Add(' with tobject do');
  11965. Add(' obj:=create;');
  11966. Add(' with obj do begin');
  11967. Add(' create;');
  11968. Add(' b:=abool;');
  11969. Add(' abool:=b;');
  11970. Add(' b:=arr[3];');
  11971. Add(' arr[4]:=b;');
  11972. Add(' end;');
  11973. ConvertProgram;
  11974. CheckSource('TestClass_WithClassDoCreate',
  11975. LinesToStr([ // statements
  11976. 'rtl.createClass($mod, "TObject", null, function () {',
  11977. ' this.$init = function () {',
  11978. ' this.aBool = false;',
  11979. ' this.Arr = [];',
  11980. ' };',
  11981. ' this.$final = function () {',
  11982. ' this.Arr = undefined;',
  11983. ' };',
  11984. ' this.Create = function () {',
  11985. ' return this;',
  11986. ' };',
  11987. '});',
  11988. 'this.Obj = null;',
  11989. 'this.b = false;'
  11990. ]),
  11991. LinesToStr([ // $mod.$main
  11992. 'var $with1 = $mod.TObject.$create("Create");',
  11993. '$mod.b = $with1.aBool;',
  11994. '$with1.aBool = $mod.b;',
  11995. '$mod.b = $with1.Arr[1];',
  11996. '$with1.Arr[2] = $mod.b;',
  11997. 'var $with2 = $mod.TObject;',
  11998. '$mod.Obj = $with2.$create("Create");',
  11999. 'var $with3 = $mod.Obj;',
  12000. '$with3.Create();',
  12001. '$mod.b = $with3.aBool;',
  12002. '$with3.aBool = $mod.b;',
  12003. '$mod.b = $with3.Arr[3];',
  12004. '$with3.Arr[4] = $mod.b;',
  12005. '']));
  12006. end;
  12007. procedure TTestModule.TestClass_WithClassInstDoProperty;
  12008. begin
  12009. StartProgram(false);
  12010. Add('type');
  12011. Add(' TObject = class');
  12012. Add(' FInt: longint;');
  12013. Add(' constructor Create;');
  12014. Add(' function GetSize: longint;');
  12015. Add(' procedure SetSize(Value: longint);');
  12016. Add(' property Int: longint read FInt write FInt;');
  12017. Add(' property Size: longint read GetSize write SetSize;');
  12018. Add(' end;');
  12019. Add('constructor TObject.Create; begin end;');
  12020. Add('function TObject.GetSize: longint; begin; end;');
  12021. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  12022. Add('var');
  12023. Add(' Obj: tobject;');
  12024. Add(' i: longint;');
  12025. Add('begin');
  12026. Add(' with TObject.Create do begin');
  12027. Add(' i:=int;');
  12028. Add(' int:=i;');
  12029. Add(' i:=size;');
  12030. Add(' size:=i;');
  12031. Add(' end;');
  12032. Add(' with obj do begin');
  12033. Add(' i:=int;');
  12034. Add(' int:=i;');
  12035. Add(' i:=size;');
  12036. Add(' size:=i;');
  12037. Add(' end;');
  12038. ConvertProgram;
  12039. CheckSource('TestClass_WithClassInstDoProperty',
  12040. LinesToStr([ // statements
  12041. 'rtl.createClass($mod, "TObject", null, function () {',
  12042. ' this.$init = function () {',
  12043. ' this.FInt = 0;',
  12044. ' };',
  12045. ' this.$final = function () {',
  12046. ' };',
  12047. ' this.Create = function () {',
  12048. ' return this;',
  12049. ' };',
  12050. ' this.GetSize = function () {',
  12051. ' var Result = 0;',
  12052. ' return Result;',
  12053. ' };',
  12054. ' this.SetSize = function (Value) {',
  12055. ' };',
  12056. '});',
  12057. 'this.Obj = null;',
  12058. 'this.i = 0;'
  12059. ]),
  12060. LinesToStr([ // $mod.$main
  12061. 'var $with1 = $mod.TObject.$create("Create");',
  12062. '$mod.i = $with1.FInt;',
  12063. '$with1.FInt = $mod.i;',
  12064. '$mod.i = $with1.GetSize();',
  12065. '$with1.SetSize($mod.i);',
  12066. 'var $with2 = $mod.Obj;',
  12067. '$mod.i = $with2.FInt;',
  12068. '$with2.FInt = $mod.i;',
  12069. '$mod.i = $with2.GetSize();',
  12070. '$with2.SetSize($mod.i);',
  12071. '']));
  12072. end;
  12073. procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
  12074. begin
  12075. StartProgram(false);
  12076. Add('type');
  12077. Add(' TObject = class');
  12078. Add(' constructor Create;');
  12079. Add(' function GetItems(Index: longint): longint;');
  12080. Add(' procedure SetItems(Index, Value: longint);');
  12081. Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
  12082. Add(' end;');
  12083. Add('constructor TObject.Create; begin end;');
  12084. Add('function tobject.getitems(index: longint): longint; begin; end;');
  12085. Add('procedure tobject.setitems(index, value: longint); begin; end;');
  12086. Add('var');
  12087. Add(' Obj: tobject;');
  12088. Add(' i: longint;');
  12089. Add('begin');
  12090. Add(' with TObject.Create do begin');
  12091. Add(' i:=Items[1];');
  12092. Add(' Items[2]:=i;');
  12093. Add(' end;');
  12094. Add(' with obj do begin');
  12095. Add(' i:=Items[3];');
  12096. Add(' Items[4]:=i;');
  12097. Add(' end;');
  12098. ConvertProgram;
  12099. CheckSource('TestClass_WithClassInstDoPropertyWithParams',
  12100. LinesToStr([ // statements
  12101. 'rtl.createClass($mod, "TObject", null, function () {',
  12102. ' this.$init = function () {',
  12103. ' };',
  12104. ' this.$final = function () {',
  12105. ' };',
  12106. ' this.Create = function () {',
  12107. ' return this;',
  12108. ' };',
  12109. ' this.GetItems = function (Index) {',
  12110. ' var Result = 0;',
  12111. ' return Result;',
  12112. ' };',
  12113. ' this.SetItems = function (Index, Value) {',
  12114. ' };',
  12115. '});',
  12116. 'this.Obj = null;',
  12117. 'this.i = 0;'
  12118. ]),
  12119. LinesToStr([ // $mod.$main
  12120. 'var $with1 = $mod.TObject.$create("Create");',
  12121. '$mod.i = $with1.GetItems(1);',
  12122. '$with1.SetItems(2, $mod.i);',
  12123. 'var $with2 = $mod.Obj;',
  12124. '$mod.i = $with2.GetItems(3);',
  12125. '$with2.SetItems(4, $mod.i);',
  12126. '']));
  12127. end;
  12128. procedure TTestModule.TestClass_WithClassInstDoFunc;
  12129. begin
  12130. StartProgram(false);
  12131. Add('type');
  12132. Add(' TObject = class');
  12133. Add(' constructor Create;');
  12134. Add(' function GetSize: longint;');
  12135. Add(' procedure SetSize(Value: longint);');
  12136. Add(' end;');
  12137. Add('constructor TObject.Create; begin end;');
  12138. Add('function TObject.GetSize: longint; begin; end;');
  12139. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  12140. Add('var');
  12141. Add(' Obj: tobject;');
  12142. Add(' i: longint;');
  12143. Add('begin');
  12144. Add(' with TObject.Create do begin');
  12145. Add(' i:=GetSize;');
  12146. Add(' i:=GetSize();');
  12147. Add(' SetSize(i);');
  12148. Add(' end;');
  12149. Add(' with obj do begin');
  12150. Add(' i:=GetSize;');
  12151. Add(' i:=GetSize();');
  12152. Add(' SetSize(i);');
  12153. Add(' end;');
  12154. ConvertProgram;
  12155. CheckSource('TestClass_WithClassInstDoFunc',
  12156. LinesToStr([ // statements
  12157. 'rtl.createClass($mod, "TObject", null, function () {',
  12158. ' this.$init = function () {',
  12159. ' };',
  12160. ' this.$final = function () {',
  12161. ' };',
  12162. ' this.Create = function () {',
  12163. ' return this;',
  12164. ' };',
  12165. ' this.GetSize = function () {',
  12166. ' var Result = 0;',
  12167. ' return Result;',
  12168. ' };',
  12169. ' this.SetSize = function (Value) {',
  12170. ' };',
  12171. '});',
  12172. 'this.Obj = null;',
  12173. 'this.i = 0;'
  12174. ]),
  12175. LinesToStr([ // $mod.$main
  12176. 'var $with1 = $mod.TObject.$create("Create");',
  12177. '$mod.i = $with1.GetSize();',
  12178. '$mod.i = $with1.GetSize();',
  12179. '$with1.SetSize($mod.i);',
  12180. 'var $with2 = $mod.Obj;',
  12181. '$mod.i = $with2.GetSize();',
  12182. '$mod.i = $with2.GetSize();',
  12183. '$with2.SetSize($mod.i);',
  12184. '']));
  12185. end;
  12186. procedure TTestModule.TestClass_TypeCast;
  12187. begin
  12188. StartProgram(false);
  12189. Add('type');
  12190. Add(' TObject = class');
  12191. Add(' Next: TObject;');
  12192. Add(' constructor Create;');
  12193. Add(' end;');
  12194. Add(' TControl = class(TObject)');
  12195. Add(' Arr: array of TObject;');
  12196. Add(' function GetIt(vI: longint = 0): TObject;');
  12197. Add(' end;');
  12198. Add('constructor tobject.create; begin end;');
  12199. Add('function tcontrol.getit(vi: longint = 0): tobject; begin end;');
  12200. Add('var');
  12201. Add(' Obj: tobject;');
  12202. Add('begin');
  12203. Add(' obj:=tcontrol(obj).next;');
  12204. Add(' tcontrol(obj):=nil;');
  12205. Add(' obj:=tcontrol(obj);');
  12206. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
  12207. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
  12208. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
  12209. Add(' tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
  12210. ConvertProgram;
  12211. CheckSource('TestClass_TypeCast',
  12212. LinesToStr([ // statements
  12213. 'rtl.createClass($mod, "TObject", null, function () {',
  12214. ' this.$init = function () {',
  12215. ' this.Next = null;',
  12216. ' };',
  12217. ' this.$final = function () {',
  12218. ' this.Next = undefined;',
  12219. ' };',
  12220. ' this.Create = function () {',
  12221. ' return this;',
  12222. ' };',
  12223. '});',
  12224. 'rtl.createClass($mod, "TControl", $mod.TObject, function () {',
  12225. ' this.$init = function () {',
  12226. ' $mod.TObject.$init.call(this);',
  12227. ' this.Arr = [];',
  12228. ' };',
  12229. ' this.$final = function () {',
  12230. ' this.Arr = undefined;',
  12231. ' $mod.TObject.$final.call(this);',
  12232. ' };',
  12233. ' this.GetIt = function (vI) {',
  12234. ' var Result = null;',
  12235. ' return Result;',
  12236. ' };',
  12237. '});',
  12238. 'this.Obj = null;'
  12239. ]),
  12240. LinesToStr([ // $mod.$main
  12241. '$mod.Obj = $mod.Obj.Next;',
  12242. '$mod.Obj = null;',
  12243. '$mod.Obj = $mod.Obj;',
  12244. '$mod.Obj = $mod.Obj.GetIt(0);',
  12245. '$mod.Obj = $mod.Obj.GetIt(0);',
  12246. '$mod.Obj = $mod.Obj.GetIt(1);',
  12247. '$mod.Obj = $mod.Obj.GetIt(0).Arr[2];',
  12248. '']));
  12249. end;
  12250. procedure TTestModule.TestClass_TypeCastUntypedParam;
  12251. begin
  12252. StartProgram(false);
  12253. Add('type');
  12254. Add(' TObject = class end;');
  12255. Add('procedure ProcA(var A);');
  12256. Add('begin');
  12257. Add(' TObject(A):=nil;');
  12258. Add(' TObject(A):=TObject(A);');
  12259. Add(' if TObject(A)=nil then ;');
  12260. Add(' if nil=TObject(A) then ;');
  12261. Add('end;');
  12262. Add('procedure ProcB(out A);');
  12263. Add('begin');
  12264. Add(' TObject(A):=nil;');
  12265. Add(' TObject(A):=TObject(A);');
  12266. Add(' if TObject(A)=nil then ;');
  12267. Add(' if nil=TObject(A) then ;');
  12268. Add('end;');
  12269. Add('procedure ProcC(const A);');
  12270. Add('begin');
  12271. Add(' if TObject(A)=nil then ;');
  12272. Add(' if nil=TObject(A) then ;');
  12273. Add('end;');
  12274. Add('var o: TObject;');
  12275. Add('begin');
  12276. Add(' ProcA(o);');
  12277. Add(' ProcB(o);');
  12278. Add(' ProcC(o);');
  12279. ConvertProgram;
  12280. CheckSource('TestClass_TypeCastUntypedParam',
  12281. LinesToStr([ // statements
  12282. 'rtl.createClass($mod, "TObject", null, function () {',
  12283. ' this.$init = function () {',
  12284. ' };',
  12285. ' this.$final = function () {',
  12286. ' };',
  12287. '});',
  12288. 'this.ProcA = function (A) {',
  12289. ' A.set(null);',
  12290. ' A.set(A.get());',
  12291. ' if (A.get() === null);',
  12292. ' if (null === A.get());',
  12293. '};',
  12294. 'this.ProcB = function (A) {',
  12295. ' A.set(null);',
  12296. ' A.set(A.get());',
  12297. ' if (A.get() === null);',
  12298. ' if (null === A.get());',
  12299. '};',
  12300. 'this.ProcC = function (A) {',
  12301. ' if (A === null);',
  12302. ' if (null === A);',
  12303. '};',
  12304. 'this.o = null;',
  12305. '']),
  12306. LinesToStr([ // $mod.$main
  12307. '$mod.ProcA({',
  12308. ' p: $mod,',
  12309. ' get: function () {',
  12310. ' return this.p.o;',
  12311. ' },',
  12312. ' set: function (v) {',
  12313. ' this.p.o = v;',
  12314. ' }',
  12315. '});',
  12316. '$mod.ProcB({',
  12317. ' p: $mod,',
  12318. ' get: function () {',
  12319. ' return this.p.o;',
  12320. ' },',
  12321. ' set: function (v) {',
  12322. ' this.p.o = v;',
  12323. ' }',
  12324. '});',
  12325. '$mod.ProcC($mod.o);',
  12326. '']));
  12327. end;
  12328. procedure TTestModule.TestClass_Overloads;
  12329. begin
  12330. StartProgram(false);
  12331. Add('type');
  12332. Add(' TObject = class');
  12333. Add(' procedure DoIt;');
  12334. Add(' procedure DoIt(vI: longint);');
  12335. Add(' end;');
  12336. Add('procedure TObject.DoIt;');
  12337. Add('begin');
  12338. Add(' DoIt;');
  12339. Add(' DoIt(1);');
  12340. Add('end;');
  12341. Add('procedure TObject.DoIt(vI: longint); begin end;');
  12342. Add('begin');
  12343. ConvertProgram;
  12344. CheckSource('TestClass_Overloads',
  12345. LinesToStr([ // statements
  12346. 'rtl.createClass($mod, "TObject", null, function () {',
  12347. ' this.$init = function () {',
  12348. ' };',
  12349. ' this.$final = function () {',
  12350. ' };',
  12351. ' this.DoIt = function () {',
  12352. ' this.DoIt();',
  12353. ' this.DoIt$1(1);',
  12354. ' };',
  12355. ' this.DoIt$1 = function (vI) {',
  12356. ' };',
  12357. '});',
  12358. '']),
  12359. LinesToStr([ // $mod.$main
  12360. '']));
  12361. end;
  12362. procedure TTestModule.TestClass_OverloadsAncestor;
  12363. begin
  12364. StartProgram(false);
  12365. Add('type');
  12366. Add(' TObject = class;');
  12367. Add(' TObject = class');
  12368. Add(' procedure DoIt(vA: longint);');
  12369. Add(' procedure DoIt(vA, vB: longint);');
  12370. Add(' end;');
  12371. Add(' TCar = class;');
  12372. Add(' TCar = class');
  12373. Add(' procedure DoIt(vA: longint);');
  12374. Add(' procedure DoIt(vA, vB: longint);');
  12375. Add(' end;');
  12376. Add('procedure tobject.doit(va: longint);');
  12377. Add('begin');
  12378. Add(' doit(1);');
  12379. Add(' doit(1,2);');
  12380. Add('end;');
  12381. Add('procedure tobject.doit(va, vb: longint); begin end;');
  12382. Add('procedure tcar.doit(va: longint);');
  12383. Add('begin');
  12384. Add(' doit(1);');
  12385. Add(' doit(1,2);');
  12386. Add(' inherited doit(1);');
  12387. Add(' inherited doit(1,2);');
  12388. Add('end;');
  12389. Add('procedure tcar.doit(va, vb: longint); begin end;');
  12390. Add('begin');
  12391. ConvertProgram;
  12392. CheckSource('TestClass_OverloadsAncestor',
  12393. LinesToStr([ // statements
  12394. 'rtl.createClass($mod, "TObject", null, function () {',
  12395. ' this.$init = function () {',
  12396. ' };',
  12397. ' this.$final = function () {',
  12398. ' };',
  12399. ' this.DoIt = function (vA) {',
  12400. ' this.DoIt(1);',
  12401. ' this.DoIt$1(1,2);',
  12402. ' };',
  12403. ' this.DoIt$1 = function (vA, vB) {',
  12404. ' };',
  12405. '});',
  12406. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  12407. ' this.DoIt$2 = function (vA) {',
  12408. ' this.DoIt$2(1);',
  12409. ' this.DoIt$3(1, 2);',
  12410. ' $mod.TObject.DoIt.call(this, 1);',
  12411. ' $mod.TObject.DoIt$1.call(this, 1, 2);',
  12412. ' };',
  12413. ' this.DoIt$3 = function (vA, vB) {',
  12414. ' };',
  12415. '});',
  12416. '']),
  12417. LinesToStr([ // $mod.$main
  12418. '']));
  12419. end;
  12420. procedure TTestModule.TestClass_OverloadConstructor;
  12421. begin
  12422. StartProgram(false);
  12423. Add('type');
  12424. Add(' TObject = class');
  12425. Add(' constructor Create(vA: longint);');
  12426. Add(' constructor Create(vA, vB: longint);');
  12427. Add(' end;');
  12428. Add(' TCar = class');
  12429. Add(' constructor Create(vA: longint);');
  12430. Add(' constructor Create(vA, vB: longint);');
  12431. Add(' end;');
  12432. Add('constructor tobject.create(va: longint);');
  12433. Add('begin');
  12434. Add(' create(1);');
  12435. Add(' create(1,2);');
  12436. Add('end;');
  12437. Add('constructor tobject.create(va, vb: longint); begin end;');
  12438. Add('constructor tcar.create(va: longint);');
  12439. Add('begin');
  12440. Add(' create(1);');
  12441. Add(' create(1,2);');
  12442. Add(' inherited create(1);');
  12443. Add(' inherited create(1,2);');
  12444. Add('end;');
  12445. Add('constructor tcar.create(va, vb: longint); begin end;');
  12446. Add('begin');
  12447. Add(' tobject.create(1);');
  12448. Add(' tobject.create(1,2);');
  12449. Add(' tcar.create(1);');
  12450. Add(' tcar.create(1,2);');
  12451. ConvertProgram;
  12452. CheckSource('TestClass_OverloadConstructor',
  12453. LinesToStr([ // statements
  12454. 'rtl.createClass($mod, "TObject", null, function () {',
  12455. ' this.$init = function () {',
  12456. ' };',
  12457. ' this.$final = function () {',
  12458. ' };',
  12459. ' this.Create = function (vA) {',
  12460. ' this.Create(1);',
  12461. ' this.Create$1(1,2);',
  12462. ' return this;',
  12463. ' };',
  12464. ' this.Create$1 = function (vA, vB) {',
  12465. ' return this;',
  12466. ' };',
  12467. '});',
  12468. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  12469. ' this.Create$2 = function (vA) {',
  12470. ' this.Create$2(1);',
  12471. ' this.Create$3(1, 2);',
  12472. ' $mod.TObject.Create.call(this, 1);',
  12473. ' $mod.TObject.Create$1.call(this, 1, 2);',
  12474. ' return this;',
  12475. ' };',
  12476. ' this.Create$3 = function (vA, vB) {',
  12477. ' return this;',
  12478. ' };',
  12479. '});',
  12480. '']),
  12481. LinesToStr([ // $mod.$main
  12482. '$mod.TObject.$create("Create", [1]);',
  12483. '$mod.TObject.$create("Create$1", [1, 2]);',
  12484. '$mod.TCar.$create("Create$2", [1]);',
  12485. '$mod.TCar.$create("Create$3", [1, 2]);',
  12486. '']));
  12487. end;
  12488. procedure TTestModule.TestClass_OverloadDelphiOverride;
  12489. begin
  12490. StartProgram(false);
  12491. Add([
  12492. '{$mode delphi}',
  12493. 'type',
  12494. ' TObject = class end;',
  12495. ' TBird = class',
  12496. ' function {#a}GetValue: longint; overload; virtual;',
  12497. ' function {#b}GetValue(AValue: longint): longint; overload; virtual;',
  12498. ' end;',
  12499. ' TEagle = class(TBird)',
  12500. ' function {#c}GetValue: longint; overload; override;',
  12501. ' function {#d}GetValue(AValue: longint): longint; overload; override;',
  12502. ' end;',
  12503. 'function TBird.GetValue: longint;',
  12504. 'begin',
  12505. ' if 3={@a}GetValue then ;',
  12506. ' if 4={@b}GetValue(5) then ;',
  12507. 'end;',
  12508. 'function TBird.GetValue(AValue: longint): longint;',
  12509. 'begin',
  12510. 'end;',
  12511. 'function TEagle.GetValue: longint;',
  12512. 'begin',
  12513. ' if 13={@c}GetValue then ;',
  12514. ' if 14={@d}GetValue(15) then ;',
  12515. ' if 15=inherited {@a}GetValue then ;',
  12516. ' if 16=inherited {@b}GetValue(17) then ;',
  12517. 'end;',
  12518. 'function TEagle.GetValue(AValue: longint): longint;',
  12519. 'begin',
  12520. 'end;',
  12521. 'var',
  12522. ' e: TEagle;',
  12523. 'begin',
  12524. ' if 23=e.{@c}GetValue then ;',
  12525. ' if 24=e.{@d}GetValue(25) then ;']);
  12526. ConvertProgram;
  12527. CheckSource('TestClass_OverloadDelphiOverride',
  12528. LinesToStr([ // statements
  12529. 'rtl.createClass($mod, "TObject", null, function () {',
  12530. ' this.$init = function () {',
  12531. ' };',
  12532. ' this.$final = function () {',
  12533. ' };',
  12534. '});',
  12535. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  12536. ' this.GetValue = function () {',
  12537. ' var Result = 0;',
  12538. ' if (3 === this.GetValue()) ;',
  12539. ' if (4 === this.GetValue$1(5)) ;',
  12540. ' return Result;',
  12541. ' };',
  12542. ' this.GetValue$1 = function (AValue) {',
  12543. ' var Result = 0;',
  12544. ' return Result;',
  12545. ' };',
  12546. '});',
  12547. 'rtl.createClass($mod, "TEagle", $mod.TBird, function () {',
  12548. ' this.GetValue = function () {',
  12549. ' var Result = 0;',
  12550. ' if (13 === this.GetValue()) ;',
  12551. ' if (14 === this.GetValue$1(15)) ;',
  12552. ' if (15 === $mod.TBird.GetValue.call(this)) ;',
  12553. ' if (16 === $mod.TBird.GetValue$1.call(this, 17)) ;',
  12554. ' return Result;',
  12555. ' };',
  12556. ' this.GetValue$1 = function (AValue) {',
  12557. ' var Result = 0;',
  12558. ' return Result;',
  12559. ' };',
  12560. '});',
  12561. 'this.e = null;',
  12562. '']),
  12563. LinesToStr([ // $mod.$main
  12564. 'if (23 === $mod.e.GetValue()) ;',
  12565. 'if (24 === $mod.e.GetValue$1(25)) ;',
  12566. '']));
  12567. end;
  12568. procedure TTestModule.TestClass_ReintroducedVar;
  12569. begin
  12570. StartProgram(false);
  12571. Add('type');
  12572. Add(' TObject = class');
  12573. Add(' strict private');
  12574. Add(' Some: longint;');
  12575. Add(' end;');
  12576. Add(' TMobile = class');
  12577. Add(' strict private');
  12578. Add(' Some: string;');
  12579. Add(' end;');
  12580. Add(' TCar = class(tmobile)');
  12581. Add(' procedure Some;');
  12582. Add(' procedure Some(vA: longint);');
  12583. Add(' end;');
  12584. Add('procedure tcar.some;');
  12585. Add('begin');
  12586. Add(' Some;');
  12587. Add(' Some(1);');
  12588. Add('end;');
  12589. Add('procedure tcar.some(va: longint); begin end;');
  12590. Add('begin');
  12591. ConvertProgram;
  12592. CheckSource('TestClass_ReintroducedVar',
  12593. LinesToStr([ // statements
  12594. 'rtl.createClass($mod, "TObject", null, function () {',
  12595. ' this.$init = function () {',
  12596. ' this.Some = 0;',
  12597. ' };',
  12598. ' this.$final = function () {',
  12599. ' };',
  12600. '});',
  12601. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  12602. ' this.$init = function () {',
  12603. ' $mod.TObject.$init.call(this);',
  12604. ' this.Some$1 = "";',
  12605. ' };',
  12606. '});',
  12607. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  12608. ' this.Some$2 = function () {',
  12609. ' this.Some$2();',
  12610. ' this.Some$3(1);',
  12611. ' };',
  12612. ' this.Some$3 = function (vA) {',
  12613. ' };',
  12614. '});',
  12615. '']),
  12616. LinesToStr([ // $mod.$main
  12617. '']));
  12618. end;
  12619. procedure TTestModule.TestClass_RaiseDescendant;
  12620. begin
  12621. StartProgram(false);
  12622. Add([
  12623. 'type',
  12624. ' TObject = class',
  12625. ' constructor Create(Msg: string);',
  12626. ' end;',
  12627. ' Exception = class',
  12628. ' end;',
  12629. ' EConvertError = class(Exception)',
  12630. ' end;',
  12631. 'constructor TObject.Create(Msg: string); begin end;',
  12632. 'function AssertConv(Msg: string = ''def''): EConvertError; begin end;',
  12633. 'begin',
  12634. ' raise Exception.Create(''Bar1'');',
  12635. ' raise EConvertError.Create(''Bar2'');',
  12636. ' raise AssertConv(''Bar2'');',
  12637. ' raise AssertConv;',
  12638. '']);
  12639. ConvertProgram;
  12640. CheckSource('TestClass_RaiseDescendant',
  12641. LinesToStr([ // statements
  12642. 'rtl.createClass($mod, "TObject", null, function () {',
  12643. ' this.$init = function () {',
  12644. ' };',
  12645. ' this.$final = function () {',
  12646. ' };',
  12647. ' this.Create = function (Msg) {',
  12648. ' return this;',
  12649. ' };',
  12650. '});',
  12651. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  12652. '});',
  12653. 'rtl.createClass($mod, "EConvertError", $mod.Exception, function () {',
  12654. '});',
  12655. 'this.AssertConv = function (Msg) {',
  12656. ' var Result = null;',
  12657. ' return Result;',
  12658. '};',
  12659. '']),
  12660. LinesToStr([ // $mod.$main
  12661. 'throw $mod.Exception.$create("Create",["Bar1"]);',
  12662. 'throw $mod.EConvertError.$create("Create",["Bar2"]);',
  12663. 'throw $mod.AssertConv("Bar2");',
  12664. 'throw $mod.AssertConv("def");',
  12665. '']));
  12666. end;
  12667. procedure TTestModule.TestClass_ExternalMethod;
  12668. begin
  12669. AddModuleWithIntfImplSrc('unit2.pas',
  12670. LinesToStr([
  12671. 'type',
  12672. ' TObject = class',
  12673. ' public',
  12674. ' procedure Intern; external name ''$DoIntern'';',
  12675. ' end;',
  12676. '']),
  12677. LinesToStr([
  12678. '']));
  12679. StartUnit(true);
  12680. Add('interface');
  12681. Add('uses unit2;');
  12682. Add('type');
  12683. Add(' TCar = class(TObject)');
  12684. Add(' public');
  12685. Add(' procedure Intern2; external name ''$DoIntern2'';');
  12686. Add(' procedure DoIt;');
  12687. Add(' end;');
  12688. Add('implementation');
  12689. Add('procedure tcar.doit;');
  12690. Add('begin');
  12691. Add(' Intern;');
  12692. Add(' Intern();');
  12693. Add(' Intern2;');
  12694. Add(' Intern2();');
  12695. Add('end;');
  12696. Add('var Obj: TCar;');
  12697. Add('begin');
  12698. Add(' obj.intern;');
  12699. Add(' obj.intern();');
  12700. Add(' obj.intern2;');
  12701. Add(' obj.intern2();');
  12702. Add(' obj.doit;');
  12703. Add(' obj.doit();');
  12704. Add(' with obj do begin');
  12705. Add(' Intern;');
  12706. Add(' Intern();');
  12707. Add(' Intern2;');
  12708. Add(' Intern2();');
  12709. Add(' end;');
  12710. ConvertUnit;
  12711. CheckSource('TestClass_ExternalMethod',
  12712. LinesToStr([
  12713. 'var $impl = $mod.$impl;',
  12714. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  12715. ' this.DoIt = function () {',
  12716. ' this.$DoIntern();',
  12717. ' this.$DoIntern();',
  12718. ' this.$DoIntern2();',
  12719. ' this.$DoIntern2();',
  12720. ' };',
  12721. ' });',
  12722. '']),
  12723. LinesToStr([ // this.$init
  12724. '$impl.Obj.$DoIntern();',
  12725. '$impl.Obj.$DoIntern();',
  12726. '$impl.Obj.$DoIntern2();',
  12727. '$impl.Obj.$DoIntern2();',
  12728. '$impl.Obj.DoIt();',
  12729. '$impl.Obj.DoIt();',
  12730. 'var $with1 = $impl.Obj;',
  12731. '$with1.$DoIntern();',
  12732. '$with1.$DoIntern();',
  12733. '$with1.$DoIntern2();',
  12734. '$with1.$DoIntern2();',
  12735. '']),
  12736. LinesToStr([ // implementation
  12737. '$impl.Obj = null;',
  12738. '']) );
  12739. end;
  12740. procedure TTestModule.TestClass_ExternalVirtualNameMismatchFail;
  12741. begin
  12742. StartProgram(false);
  12743. Add('type');
  12744. Add(' TObject = class');
  12745. Add(' procedure DoIt; virtual; external name ''Foo'';');
  12746. Add(' end;');
  12747. Add('begin');
  12748. SetExpectedPasResolverError('Virtual method name must match external',
  12749. nVirtualMethodNameMustMatchExternal);
  12750. ConvertProgram;
  12751. end;
  12752. procedure TTestModule.TestClass_ExternalOverrideFail;
  12753. begin
  12754. StartProgram(false);
  12755. Add('type');
  12756. Add(' TObject = class');
  12757. Add(' procedure DoIt; virtual; external name ''DoIt'';');
  12758. Add(' end;');
  12759. Add(' TCar = class');
  12760. Add(' procedure DoIt; override; external name ''DoIt'';');
  12761. Add(' end;');
  12762. Add('begin');
  12763. SetExpectedPasResolverError('Invalid procedure modifier override,external',
  12764. nInvalidXModifierY);
  12765. ConvertProgram;
  12766. end;
  12767. procedure TTestModule.TestClass_ExternalVar;
  12768. begin
  12769. AddModuleWithIntfImplSrc('unit2.pas',
  12770. LinesToStr([
  12771. '{$modeswitch externalclass}',
  12772. 'type',
  12773. ' TObject = class',
  12774. ' public',
  12775. ' Intern: longint external name ''$Intern'';',
  12776. ' Bracket: longint external name ''["A B"]'';',
  12777. ' end;',
  12778. '']),
  12779. LinesToStr([
  12780. '']));
  12781. StartUnit(true);
  12782. Add([
  12783. 'interface',
  12784. 'uses unit2;',
  12785. '{$modeswitch externalclass}',
  12786. 'type',
  12787. ' TCar = class(tobject)',
  12788. ' public',
  12789. ' Intern2: longint external name ''$Intern2'';',
  12790. ' procedure DoIt;',
  12791. ' end;',
  12792. 'implementation',
  12793. 'procedure tcar.doit;',
  12794. 'begin',
  12795. ' Intern:=Intern+1;',
  12796. ' Intern2:=Intern2+2;',
  12797. ' Bracket:=Bracket+3;',
  12798. 'end;',
  12799. 'var Obj: TCar;',
  12800. 'begin',
  12801. ' obj.intern:=obj.intern+1;',
  12802. ' obj.intern2:=obj.intern2+2;',
  12803. ' obj.Bracket:=obj.Bracket+3;',
  12804. ' with obj do begin',
  12805. ' intern:=intern+1;',
  12806. ' intern2:=intern2+2;',
  12807. ' Bracket:=Bracket+3;',
  12808. ' end;']);
  12809. ConvertUnit;
  12810. CheckSource('TestClass_ExternalVar',
  12811. LinesToStr([
  12812. 'var $impl = $mod.$impl;',
  12813. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  12814. ' this.DoIt = function () {',
  12815. ' this.$Intern = this.$Intern + 1;',
  12816. ' this.$Intern2 = this.$Intern2 + 2;',
  12817. ' this["A B"] = this["A B"] + 3;',
  12818. ' };',
  12819. ' });',
  12820. '']),
  12821. LinesToStr([
  12822. '$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
  12823. '$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
  12824. '$impl.Obj["A B"] = $impl.Obj["A B"] + 3;',
  12825. 'var $with1 = $impl.Obj;',
  12826. '$with1.$Intern = $with1.$Intern + 1;',
  12827. '$with1.$Intern2 = $with1.$Intern2 + 2;',
  12828. '$with1["A B"] = $with1["A B"] + 3;',
  12829. '']),
  12830. LinesToStr([ // implementation
  12831. '$impl.Obj = null;',
  12832. '']));
  12833. end;
  12834. procedure TTestModule.TestClass_Const;
  12835. begin
  12836. StartProgram(false);
  12837. Add('type');
  12838. Add(' integer = longint;');
  12839. Add(' TClass = class of TObject;');
  12840. Add(' TObject = class');
  12841. Add(' public');
  12842. Add(' const cI: integer = 3;');
  12843. Add(' procedure DoIt;');
  12844. Add(' class procedure DoMore;');
  12845. Add(' end;');
  12846. Add('implementation');
  12847. Add('procedure tobject.doit;');
  12848. Add('begin');
  12849. Add(' if cI=4 then;');
  12850. Add(' if 5=cI then;');
  12851. Add(' if Self.cI=6 then;');
  12852. Add(' if 7=Self.cI then;');
  12853. Add(' with Self do begin');
  12854. Add(' if cI=11 then;');
  12855. Add(' if 12=cI then;');
  12856. Add(' end;');
  12857. Add('end;');
  12858. Add('class procedure tobject.domore;');
  12859. Add('begin');
  12860. Add(' if cI=8 then;');
  12861. Add(' if Self.cI=9 then;');
  12862. Add(' if 10=cI then;');
  12863. Add(' if 11=Self.cI then;');
  12864. Add(' with Self do begin');
  12865. Add(' if cI=13 then;');
  12866. Add(' if 14=cI then;');
  12867. Add(' end;');
  12868. Add('end;');
  12869. Add('var');
  12870. Add(' Obj: TObject;');
  12871. Add(' Cla: TClass;');
  12872. Add('begin');
  12873. Add(' if TObject.cI=21 then ;');
  12874. Add(' if Obj.cI=22 then ;');
  12875. Add(' if Cla.cI=23 then ;');
  12876. Add(' with obj do if ci=24 then;');
  12877. Add(' with TObject do if ci=25 then;');
  12878. Add(' with Cla do if ci=26 then;');
  12879. ConvertProgram;
  12880. CheckSource('TestClass_Const',
  12881. LinesToStr([
  12882. 'rtl.createClass($mod, "TObject", null, function () {',
  12883. ' this.cI = 3;',
  12884. ' this.$init = function () {',
  12885. ' };',
  12886. ' this.$final = function () {',
  12887. ' };',
  12888. ' this.DoIt = function () {',
  12889. ' if (this.cI === 4) ;',
  12890. ' if (5 === this.cI) ;',
  12891. ' if (this.cI === 6) ;',
  12892. ' if (7 === this.cI) ;',
  12893. ' if (this.cI === 11) ;',
  12894. ' if (12 === this.cI) ;',
  12895. ' };',
  12896. ' this.DoMore = function () {',
  12897. ' if (this.cI === 8) ;',
  12898. ' if (this.cI === 9) ;',
  12899. ' if (10 === this.cI) ;',
  12900. ' if (11 === this.cI) ;',
  12901. ' if (this.cI === 13) ;',
  12902. ' if (14 === this.cI) ;',
  12903. ' };',
  12904. '});',
  12905. 'this.Obj = null;',
  12906. 'this.Cla = null;',
  12907. '']),
  12908. LinesToStr([
  12909. 'if ($mod.TObject.cI === 21) ;',
  12910. 'if ($mod.Obj.cI === 22) ;',
  12911. 'if ($mod.Cla.cI === 23) ;',
  12912. 'var $with1 = $mod.Obj;',
  12913. 'if ($with1.cI === 24) ;',
  12914. 'var $with2 = $mod.TObject;',
  12915. 'if ($with2.cI === 25) ;',
  12916. 'var $with3 = $mod.Cla;',
  12917. 'if ($with3.cI === 26) ;',
  12918. '']));
  12919. end;
  12920. procedure TTestModule.TestClass_LocalVarSelfFail;
  12921. begin
  12922. StartProgram(false);
  12923. Add([
  12924. 'type',
  12925. ' TObject = class',
  12926. ' constructor Create;',
  12927. ' end;',
  12928. 'constructor tobject.create;',
  12929. 'var self: longint;',
  12930. 'begin',
  12931. 'end',
  12932. 'begin',
  12933. '']);
  12934. SetExpectedPasResolverError('Duplicate identifier "self" at (0)',nDuplicateIdentifier);
  12935. ConvertProgram;
  12936. end;
  12937. procedure TTestModule.TestClass_ArgSelfFail;
  12938. begin
  12939. StartProgram(false);
  12940. Add([
  12941. 'type',
  12942. ' TObject = class',
  12943. ' procedure DoIt(Self: longint);',
  12944. ' end;',
  12945. 'procedure tobject.doit(self: longint);',
  12946. 'begin',
  12947. 'end',
  12948. 'begin',
  12949. '']);
  12950. SetExpectedPasResolverError('Duplicate identifier "Self" at test1.pp(5,24)',nDuplicateIdentifier);
  12951. ConvertProgram;
  12952. end;
  12953. procedure TTestModule.TestClass_NestedProcSelf;
  12954. begin
  12955. StartProgram(false);
  12956. Add([
  12957. 'type',
  12958. ' TObject = class',
  12959. ' Key: longint;',
  12960. ' class var State: longint;',
  12961. ' procedure DoIt;',
  12962. ' function GetSize: longint; virtual; abstract;',
  12963. ' procedure SetSize(Value: longint); virtual; abstract;',
  12964. ' property Size: longint read GetSize write SetSize;',
  12965. ' end;',
  12966. 'procedure tobject.doit;',
  12967. ' procedure Sub;',
  12968. ' begin',
  12969. ' key:=key+2;',
  12970. ' self.key:=self.key+3;',
  12971. ' state:=state+4;',
  12972. ' self.state:=self.state+5;',
  12973. ' tobject.state:=tobject.state+6;',
  12974. ' size:=size+7;',
  12975. ' self.size:=self.size+8;',
  12976. ' end;',
  12977. 'begin',
  12978. ' sub;',
  12979. ' key:=key+12;',
  12980. ' self.key:=self.key+13;',
  12981. ' state:=state+14;',
  12982. ' self.state:=self.state+15;',
  12983. ' tobject.state:=tobject.state+16;',
  12984. ' size:=size+17;',
  12985. ' self.size:=self.size+18;',
  12986. 'end;',
  12987. 'begin',
  12988. '']);
  12989. ConvertProgram;
  12990. CheckSource('TestClass_NestedProcSelf',
  12991. LinesToStr([ // statements
  12992. 'rtl.createClass($mod, "TObject", null, function () {',
  12993. ' this.State = 0;',
  12994. ' this.$init = function () {',
  12995. ' this.Key = 0;',
  12996. ' };',
  12997. ' this.$final = function () {',
  12998. ' };',
  12999. ' this.DoIt = function () {',
  13000. ' var $Self = this;',
  13001. ' function Sub() {',
  13002. ' $Self.Key = $Self.Key + 2;',
  13003. ' $Self.Key = $Self.Key + 3;',
  13004. ' $mod.TObject.State = $Self.State + 4;',
  13005. ' $mod.TObject.State = $Self.State + 5;',
  13006. ' $mod.TObject.State = $mod.TObject.State + 6;',
  13007. ' $Self.SetSize($Self.GetSize() + 7);',
  13008. ' $Self.SetSize($Self.GetSize() + 8);',
  13009. ' };',
  13010. ' Sub();',
  13011. ' $Self.Key = $Self.Key + 12;',
  13012. ' $Self.Key = $Self.Key + 13;',
  13013. ' $mod.TObject.State = $Self.State + 14;',
  13014. ' $mod.TObject.State = $Self.State + 15;',
  13015. ' $mod.TObject.State = $mod.TObject.State + 16;',
  13016. ' $Self.SetSize($Self.GetSize() + 17);',
  13017. ' $Self.SetSize($Self.GetSize() + 18);',
  13018. ' };',
  13019. '});',
  13020. '']),
  13021. LinesToStr([ // $mod.$main
  13022. '']));
  13023. end;
  13024. procedure TTestModule.TestClass_NestedProcSelf2;
  13025. begin
  13026. StartProgram(false);
  13027. Add([
  13028. 'type',
  13029. ' TObject = class',
  13030. ' Key: longint;',
  13031. ' class var State: longint;',
  13032. ' function GetSize: longint; virtual; abstract;',
  13033. ' procedure SetSize(Value: longint); virtual; abstract;',
  13034. ' property Size: longint read GetSize write SetSize;',
  13035. ' end;',
  13036. ' TBird = class',
  13037. ' procedure DoIt;',
  13038. ' end;',
  13039. 'procedure tbird.doit;',
  13040. ' procedure Sub;',
  13041. ' begin',
  13042. ' key:=key+2;',
  13043. ' self.key:=self.key+3;',
  13044. ' state:=state+4;',
  13045. ' self.state:=self.state+5;',
  13046. ' tobject.state:=tobject.state+6;',
  13047. ' size:=size+7;',
  13048. ' self.size:=self.size+8;',
  13049. ' end;',
  13050. 'begin',
  13051. ' sub;',
  13052. ' key:=key+12;',
  13053. ' self.key:=self.key+13;',
  13054. ' state:=state+14;',
  13055. ' self.state:=self.state+15;',
  13056. ' tobject.state:=tobject.state+16;',
  13057. ' size:=size+17;',
  13058. ' self.size:=self.size+18;',
  13059. 'end;',
  13060. 'begin',
  13061. '']);
  13062. ConvertProgram;
  13063. CheckSource('TestClass_NestedProcSelf2',
  13064. LinesToStr([ // statements
  13065. 'rtl.createClass($mod, "TObject", null, function () {',
  13066. ' this.State = 0;',
  13067. ' this.$init = function () {',
  13068. ' this.Key = 0;',
  13069. ' };',
  13070. ' this.$final = function () {',
  13071. ' };',
  13072. '});',
  13073. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13074. ' this.DoIt = function () {',
  13075. ' var $Self = this;',
  13076. ' function Sub() {',
  13077. ' $Self.Key = $Self.Key + 2;',
  13078. ' $Self.Key = $Self.Key + 3;',
  13079. ' $mod.TObject.State = $Self.State + 4;',
  13080. ' $mod.TObject.State = $Self.State + 5;',
  13081. ' $mod.TObject.State = $mod.TObject.State + 6;',
  13082. ' $Self.SetSize($Self.GetSize() + 7);',
  13083. ' $Self.SetSize($Self.GetSize() + 8);',
  13084. ' };',
  13085. ' Sub();',
  13086. ' $Self.Key = $Self.Key + 12;',
  13087. ' $Self.Key = $Self.Key + 13;',
  13088. ' $mod.TObject.State = $Self.State + 14;',
  13089. ' $mod.TObject.State = $Self.State + 15;',
  13090. ' $mod.TObject.State = $mod.TObject.State + 16;',
  13091. ' $Self.SetSize($Self.GetSize() + 17);',
  13092. ' $Self.SetSize($Self.GetSize() + 18);',
  13093. ' };',
  13094. '});',
  13095. '']),
  13096. LinesToStr([ // $mod.$main
  13097. '']));
  13098. end;
  13099. procedure TTestModule.TestClass_NestedProcClassSelf;
  13100. begin
  13101. StartProgram(false);
  13102. Add([
  13103. 'type',
  13104. ' TObject = class',
  13105. ' class var State: longint;',
  13106. ' class procedure DoIt;',
  13107. ' class function GetSize: longint; virtual; abstract;',
  13108. ' class procedure SetSize(Value: longint); virtual; abstract;',
  13109. ' class property Size: longint read GetSize write SetSize;',
  13110. ' end;',
  13111. 'class procedure tobject.doit;',
  13112. ' procedure Sub;',
  13113. ' begin',
  13114. ' state:=state+2;',
  13115. ' self.state:=self.state+3;',
  13116. ' tobject.state:=tobject.state+4;',
  13117. ' size:=size+5;',
  13118. ' self.size:=self.size+6;',
  13119. ' tobject.size:=tobject.size+7;',
  13120. ' end;',
  13121. 'begin',
  13122. ' sub;',
  13123. ' state:=state+12;',
  13124. ' self.state:=self.state+13;',
  13125. ' tobject.state:=tobject.state+14;',
  13126. ' size:=size+15;',
  13127. ' self.size:=self.size+16;',
  13128. ' tobject.size:=tobject.size+17;',
  13129. 'end;',
  13130. 'begin',
  13131. '']);
  13132. ConvertProgram;
  13133. CheckSource('TestClass_NestedProcClassSelf',
  13134. LinesToStr([ // statements
  13135. 'rtl.createClass($mod, "TObject", null, function () {',
  13136. ' this.State = 0;',
  13137. ' this.$init = function () {',
  13138. ' };',
  13139. ' this.$final = function () {',
  13140. ' };',
  13141. ' this.DoIt = function () {',
  13142. ' var $Self = this;',
  13143. ' function Sub() {',
  13144. ' $mod.TObject.State = $Self.State + 2;',
  13145. ' $mod.TObject.State = $Self.State + 3;',
  13146. ' $mod.TObject.State = $mod.TObject.State + 4;',
  13147. ' $Self.SetSize($Self.GetSize() + 5);',
  13148. ' $Self.SetSize($Self.GetSize() + 6);',
  13149. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 7);',
  13150. ' };',
  13151. ' Sub();',
  13152. ' $mod.TObject.State = $Self.State + 12;',
  13153. ' $mod.TObject.State = $Self.State + 13;',
  13154. ' $mod.TObject.State = $mod.TObject.State + 14;',
  13155. ' $Self.SetSize($Self.GetSize() + 15);',
  13156. ' $Self.SetSize($Self.GetSize() + 16);',
  13157. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
  13158. ' };',
  13159. '});',
  13160. '']),
  13161. LinesToStr([ // $mod.$main
  13162. '']));
  13163. end;
  13164. procedure TTestModule.TestClass_NestedProcCallInherited;
  13165. begin
  13166. StartProgram(false);
  13167. Add([
  13168. 'type',
  13169. ' TObject = class',
  13170. ' function DoIt(k: boolean): longint; virtual;',
  13171. ' end;',
  13172. ' TBird = class',
  13173. ' function DoIt(k: boolean): longint; override;',
  13174. ' end;',
  13175. 'function tobject.doit(k: boolean): longint;',
  13176. 'begin',
  13177. 'end;',
  13178. 'function tbird.doit(k: boolean): longint;',
  13179. ' procedure Sub;',
  13180. ' begin',
  13181. ' inherited DoIt(true);',
  13182. //' if inherited DoIt(false)=4 then ;',
  13183. ' end;',
  13184. 'begin',
  13185. ' Sub;',
  13186. ' inherited;',
  13187. ' inherited DoIt(true);',
  13188. //' if inherited DoIt(false)=14 then ;',
  13189. 'end;',
  13190. 'begin',
  13191. '']);
  13192. ConvertProgram;
  13193. CheckSource('TestClass_NestedProcCallInherited',
  13194. LinesToStr([ // statements
  13195. 'rtl.createClass($mod, "TObject", null, function () {',
  13196. ' this.$init = function () {',
  13197. ' };',
  13198. ' this.$final = function () {',
  13199. ' };',
  13200. ' this.DoIt = function (k) {',
  13201. ' var Result = 0;',
  13202. ' return Result;',
  13203. ' };',
  13204. '});',
  13205. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13206. ' this.DoIt = function (k) {',
  13207. ' var $Self = this;',
  13208. ' var Result = 0;',
  13209. ' function Sub() {',
  13210. ' $mod.TObject.DoIt.call($Self, true);',
  13211. ' };',
  13212. ' Sub();',
  13213. ' $mod.TObject.DoIt.apply($Self, arguments);',
  13214. ' $mod.TObject.DoIt.call($Self, true);',
  13215. ' return Result;',
  13216. ' };',
  13217. '});',
  13218. '']),
  13219. LinesToStr([ // $mod.$main
  13220. '']));
  13221. end;
  13222. procedure TTestModule.TestClass_TObjectFree;
  13223. begin
  13224. StartProgram(false);
  13225. Add([
  13226. 'type',
  13227. ' TObject = class',
  13228. ' Obj: tobject;',
  13229. ' procedure Free;',
  13230. ' procedure Release;',
  13231. ' end;',
  13232. 'procedure tobject.free;',
  13233. 'begin',
  13234. 'end;',
  13235. 'procedure tobject.release;',
  13236. 'begin',
  13237. ' free;',
  13238. ' if true then free;',
  13239. 'end;',
  13240. 'function DoIt(o: tobject): tobject;',
  13241. 'var l: tobject;',
  13242. 'begin',
  13243. ' o.free;',
  13244. ' o.free();',
  13245. ' l.free;',
  13246. ' l.free();',
  13247. ' o.obj.free;',
  13248. ' o.obj.free();',
  13249. ' with o do obj.free;',
  13250. ' with o do obj.free();',
  13251. ' result.Free;',
  13252. ' result.Free();',
  13253. 'end;',
  13254. 'var o: tobject;',
  13255. ' a: array of tobject;',
  13256. 'begin',
  13257. ' o.free;',
  13258. ' o.obj.free;',
  13259. ' a[1+2].free;',
  13260. '']);
  13261. ConvertProgram;
  13262. CheckSource('TestClass_TObjectFree',
  13263. LinesToStr([ // statements
  13264. 'rtl.createClass($mod, "TObject", null, function () {',
  13265. ' this.$init = function () {',
  13266. ' this.Obj = null;',
  13267. ' };',
  13268. ' this.$final = function () {',
  13269. ' this.Obj = undefined;',
  13270. ' };',
  13271. ' this.Free = function () {',
  13272. ' };',
  13273. ' this.Release = function () {',
  13274. ' this.Free();',
  13275. ' if (true) this.Free();',
  13276. ' };',
  13277. '});',
  13278. 'this.DoIt = function (o) {',
  13279. ' var Result = null;',
  13280. ' var l = null;',
  13281. ' o = rtl.freeLoc(o);',
  13282. ' o = rtl.freeLoc(o);',
  13283. ' l = rtl.freeLoc(l);',
  13284. ' l = rtl.freeLoc(l);',
  13285. ' rtl.free(o, "Obj");',
  13286. ' rtl.free(o, "Obj");',
  13287. ' rtl.free(o, "Obj");',
  13288. ' rtl.free(o, "Obj");',
  13289. ' Result = rtl.freeLoc(Result);',
  13290. ' Result = rtl.freeLoc(Result);',
  13291. ' return Result;',
  13292. '};',
  13293. 'this.o = null;',
  13294. 'this.a = [];',
  13295. '']),
  13296. LinesToStr([ // $mod.$main
  13297. 'rtl.free($mod, "o");',
  13298. 'rtl.free($mod.o, "Obj");',
  13299. 'rtl.free($mod.a, 1 + 2);',
  13300. '']));
  13301. end;
  13302. procedure TTestModule.TestClass_TObjectFreeNewInstance;
  13303. begin
  13304. StartProgram(false);
  13305. Add([
  13306. 'type',
  13307. ' TObject = class',
  13308. ' constructor Create;',
  13309. ' procedure Free;',
  13310. ' end;',
  13311. 'constructor TObject.Create; begin end;',
  13312. 'procedure tobject.free; begin end;',
  13313. 'begin',
  13314. ' with tobject.create do free;',
  13315. '']);
  13316. ConvertProgram;
  13317. CheckSource('TestClass_TObjectFreeNewInstance',
  13318. LinesToStr([ // statements
  13319. 'rtl.createClass($mod, "TObject", null, function () {',
  13320. ' this.$init = function () {',
  13321. ' };',
  13322. ' this.$final = function () {',
  13323. ' };',
  13324. ' this.Create = function () {',
  13325. ' return this;',
  13326. ' };',
  13327. ' this.Free = function () {',
  13328. ' };',
  13329. '});',
  13330. '']),
  13331. LinesToStr([ // $mod.$main
  13332. 'var $with1 = $mod.TObject.$create("Create");',
  13333. '$with1=rtl.freeLoc($with1);',
  13334. '']));
  13335. end;
  13336. procedure TTestModule.TestClass_TObjectFreeLowerCase;
  13337. begin
  13338. StartProgram(false);
  13339. Add([
  13340. 'type',
  13341. ' TObject = class',
  13342. ' destructor Destroy;',
  13343. ' procedure Free;',
  13344. ' end;',
  13345. 'destructor TObject.Destroy; begin end;',
  13346. 'procedure tobject.free; begin end;',
  13347. 'var o: tobject;',
  13348. 'begin',
  13349. ' o.free;',
  13350. '']);
  13351. Converter.UseLowerCase:=true;
  13352. ConvertProgram;
  13353. CheckSource('TestClass_TObjectFreeLowerCase',
  13354. LinesToStr([ // statements
  13355. 'rtl.createClass($mod, "tobject", null, function () {',
  13356. ' this.$init = function () {',
  13357. ' };',
  13358. ' this.$final = function () {',
  13359. ' };',
  13360. ' rtl.tObjectDestroy = "destroy";',
  13361. ' this.destroy = function () {',
  13362. ' };',
  13363. ' this.free = function () {',
  13364. ' };',
  13365. '});',
  13366. 'this.o = null;',
  13367. '']),
  13368. LinesToStr([ // $mod.$main
  13369. 'rtl.free($mod, "o");',
  13370. '']));
  13371. end;
  13372. procedure TTestModule.TestClass_TObjectFreeFunctionFail;
  13373. begin
  13374. StartProgram(false);
  13375. Add([
  13376. 'type',
  13377. ' TObject = class',
  13378. ' procedure Free;',
  13379. ' function GetObj: tobject; virtual; abstract;',
  13380. ' end;',
  13381. 'procedure tobject.free;',
  13382. 'begin',
  13383. 'end;',
  13384. 'var o: tobject;',
  13385. 'begin',
  13386. ' o.getobj.free;',
  13387. '']);
  13388. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  13389. ConvertProgram;
  13390. end;
  13391. procedure TTestModule.TestClass_TObjectFreePropertyFail;
  13392. begin
  13393. StartProgram(false);
  13394. Add([
  13395. 'type',
  13396. ' TObject = class',
  13397. ' procedure Free;',
  13398. ' FObj: TObject;',
  13399. ' property Obj: tobject read FObj write FObj;',
  13400. ' end;',
  13401. 'procedure tobject.free;',
  13402. 'begin',
  13403. 'end;',
  13404. 'var o: tobject;',
  13405. 'begin',
  13406. ' o.obj.free;',
  13407. '']);
  13408. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  13409. ConvertProgram;
  13410. end;
  13411. procedure TTestModule.TestClass_ForIn;
  13412. begin
  13413. StartProgram(false);
  13414. Add([
  13415. 'type',
  13416. ' TObject = class end;',
  13417. ' TItem = TObject;',
  13418. ' TEnumerator = class',
  13419. ' FCurrent: TItem;',
  13420. ' property Current: TItem read FCurrent;',
  13421. ' function MoveNext: boolean;',
  13422. ' end;',
  13423. ' TBird = class',
  13424. ' function GetEnumerator: TEnumerator;',
  13425. ' end;',
  13426. 'function TEnumerator.MoveNext: boolean;',
  13427. 'begin',
  13428. 'end;',
  13429. 'function TBird.GetEnumerator: TEnumerator;',
  13430. 'begin',
  13431. 'end;',
  13432. 'var',
  13433. ' b: TBird;',
  13434. ' i, i2: TItem;',
  13435. 'begin',
  13436. ' for i in b do i2:=i;']);
  13437. ConvertProgram;
  13438. CheckSource('TestClass_ForIn',
  13439. LinesToStr([ // statements
  13440. 'rtl.createClass($mod, "TObject", null, function () {',
  13441. ' this.$init = function () {',
  13442. ' };',
  13443. ' this.$final = function () {',
  13444. ' };',
  13445. '});',
  13446. 'rtl.createClass($mod, "TEnumerator", $mod.TObject, function () {',
  13447. ' this.$init = function () {',
  13448. ' $mod.TObject.$init.call(this);',
  13449. ' this.FCurrent = null;',
  13450. ' };',
  13451. ' this.$final = function () {',
  13452. ' this.FCurrent = undefined;',
  13453. ' $mod.TObject.$final.call(this);',
  13454. ' };',
  13455. ' this.MoveNext = function () {',
  13456. ' var Result = false;',
  13457. ' return Result;',
  13458. ' };',
  13459. '});',
  13460. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13461. ' this.GetEnumerator = function () {',
  13462. ' var Result = null;',
  13463. ' return Result;',
  13464. ' };',
  13465. '});',
  13466. 'this.b = null;',
  13467. 'this.i = null;',
  13468. 'this.i2 = null;'
  13469. ]),
  13470. LinesToStr([ // $mod.$main
  13471. 'var $in1 = $mod.b.GetEnumerator();',
  13472. 'try {',
  13473. ' while ($in1.MoveNext()){',
  13474. ' $mod.i = $in1.FCurrent;',
  13475. ' $mod.i2 = $mod.i;',
  13476. ' }',
  13477. '} finally {',
  13478. ' $in1 = rtl.freeLoc($in1)',
  13479. '};',
  13480. '']));
  13481. end;
  13482. procedure TTestModule.TestClassOf_Create;
  13483. begin
  13484. StartProgram(false);
  13485. Add('type');
  13486. Add(' TObject = class');
  13487. Add(' constructor Create;');
  13488. Add(' end;');
  13489. Add(' TClass = class of TObject;');
  13490. Add('constructor tobject.create; begin end;');
  13491. Add('var');
  13492. Add(' Obj: tobject;');
  13493. Add(' C: tclass;');
  13494. Add('begin');
  13495. Add(' obj:=C.create;');
  13496. Add(' with c do obj:=create;');
  13497. ConvertProgram;
  13498. CheckSource('TestClassOf_Create',
  13499. LinesToStr([ // statements
  13500. 'rtl.createClass($mod, "TObject", null, function () {',
  13501. ' this.$init = function () {',
  13502. ' };',
  13503. ' this.$final = function () {',
  13504. ' };',
  13505. ' this.Create = function () {',
  13506. ' return this;',
  13507. ' };',
  13508. '});',
  13509. 'this.Obj = null;',
  13510. 'this.C = null;'
  13511. ]),
  13512. LinesToStr([ // $mod.$main
  13513. '$mod.Obj = $mod.C.$create("Create");',
  13514. 'var $with1 = $mod.C;',
  13515. '$mod.Obj = $with1.$create("Create");',
  13516. '']));
  13517. end;
  13518. procedure TTestModule.TestClassOf_Call;
  13519. begin
  13520. StartProgram(false);
  13521. Add('type');
  13522. Add(' TObject = class');
  13523. Add(' class procedure DoIt;');
  13524. Add(' end;');
  13525. Add(' TClass = class of TObject;');
  13526. Add('class procedure tobject.doit; begin end;');
  13527. Add('var');
  13528. Add(' C: tclass;');
  13529. Add('begin');
  13530. Add(' c.doit;');
  13531. Add(' with c do doit;');
  13532. ConvertProgram;
  13533. CheckSource('TestClassOf_Call',
  13534. LinesToStr([ // statements
  13535. 'rtl.createClass($mod, "TObject", null, function () {',
  13536. ' this.$init = function () {',
  13537. ' };',
  13538. ' this.$final = function () {',
  13539. ' };',
  13540. ' this.DoIt = function () {',
  13541. ' };',
  13542. '});',
  13543. 'this.C = null;'
  13544. ]),
  13545. LinesToStr([ // $mod.$main
  13546. '$mod.C.DoIt();',
  13547. 'var $with1 = $mod.C;',
  13548. '$with1.DoIt();',
  13549. '']));
  13550. end;
  13551. procedure TTestModule.TestClassOf_Assign;
  13552. begin
  13553. StartProgram(false);
  13554. Add('type');
  13555. Add(' TClass = class of TObject;');
  13556. Add(' TObject = class');
  13557. Add(' ClassType: TClass; ');
  13558. Add(' end;');
  13559. Add('var');
  13560. Add(' Obj: tobject;');
  13561. Add(' C: tclass;');
  13562. Add('begin');
  13563. Add(' c:=nil;');
  13564. Add(' c:=obj.classtype;');
  13565. ConvertProgram;
  13566. CheckSource('TestClassOf_Assign',
  13567. LinesToStr([ // statements
  13568. 'rtl.createClass($mod, "TObject", null, function () {',
  13569. ' this.$init = function () {',
  13570. ' this.ClassType = null;',
  13571. ' };',
  13572. ' this.$final = function () {',
  13573. ' this.ClassType = undefined;',
  13574. ' };',
  13575. '});',
  13576. 'this.Obj = null;',
  13577. 'this.C = null;'
  13578. ]),
  13579. LinesToStr([ // $mod.$main
  13580. '$mod.C = null;',
  13581. '$mod.C = $mod.Obj.ClassType;',
  13582. '']));
  13583. end;
  13584. procedure TTestModule.TestClassOf_Is;
  13585. begin
  13586. StartProgram(false);
  13587. Add('type');
  13588. Add(' TClass = class of TObject;');
  13589. Add(' TObject = class');
  13590. Add(' end;');
  13591. Add(' TCar = class');
  13592. Add(' end;');
  13593. Add(' TCars = class of TCar;');
  13594. Add('var');
  13595. Add(' Obj: tobject;');
  13596. Add(' C: tclass;');
  13597. Add(' Cars: tcars;');
  13598. Add('begin');
  13599. Add(' if c is tcar then ;');
  13600. Add(' if c is tcars then ;');
  13601. ConvertProgram;
  13602. CheckSource('TestClassOf_Is',
  13603. LinesToStr([ // statements
  13604. 'rtl.createClass($mod, "TObject", null, function () {',
  13605. ' this.$init = function () {',
  13606. ' };',
  13607. ' this.$final = function () {',
  13608. ' };',
  13609. '});',
  13610. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  13611. '});',
  13612. 'this.Obj = null;',
  13613. 'this.C = null;',
  13614. 'this.Cars = null;'
  13615. ]),
  13616. LinesToStr([ // $mod.$main
  13617. 'if(rtl.is($mod.C,$mod.TCar));',
  13618. 'if(rtl.is($mod.C,$mod.TCar));',
  13619. '']));
  13620. end;
  13621. procedure TTestModule.TestClassOf_Compare;
  13622. begin
  13623. StartProgram(false);
  13624. Add('type');
  13625. Add(' TClass = class of TObject;');
  13626. Add(' TObject = class');
  13627. Add(' ClassType: TClass; ');
  13628. Add(' end;');
  13629. Add('var');
  13630. Add(' b: boolean;');
  13631. Add(' Obj: tobject;');
  13632. Add(' C: tclass;');
  13633. Add('begin');
  13634. Add(' b:=c=nil;');
  13635. Add(' b:=nil=c;');
  13636. Add(' b:=c=obj.classtype;');
  13637. Add(' b:=obj.classtype=c;');
  13638. Add(' b:=c=TObject;');
  13639. Add(' b:=TObject=c;');
  13640. Add(' b:=c<>nil;');
  13641. Add(' b:=nil<>c;');
  13642. Add(' b:=c<>obj.classtype;');
  13643. Add(' b:=obj.classtype<>c;');
  13644. Add(' b:=c<>TObject;');
  13645. Add(' b:=TObject<>c;');
  13646. ConvertProgram;
  13647. CheckSource('TestClassOf_Compare',
  13648. LinesToStr([ // statements
  13649. 'rtl.createClass($mod, "TObject", null, function () {',
  13650. ' this.$init = function () {',
  13651. ' this.ClassType = null;',
  13652. ' };',
  13653. ' this.$final = function () {',
  13654. ' this.ClassType = undefined;',
  13655. ' };',
  13656. '});',
  13657. 'this.b = false;',
  13658. 'this.Obj = null;',
  13659. 'this.C = null;'
  13660. ]),
  13661. LinesToStr([ // $mod.$main
  13662. '$mod.b = $mod.C === null;',
  13663. '$mod.b = null === $mod.C;',
  13664. '$mod.b = $mod.C === $mod.Obj.ClassType;',
  13665. '$mod.b = $mod.Obj.ClassType === $mod.C;',
  13666. '$mod.b = $mod.C === $mod.TObject;',
  13667. '$mod.b = $mod.TObject === $mod.C;',
  13668. '$mod.b = $mod.C !== null;',
  13669. '$mod.b = null !== $mod.C;',
  13670. '$mod.b = $mod.C !== $mod.Obj.ClassType;',
  13671. '$mod.b = $mod.Obj.ClassType !== $mod.C;',
  13672. '$mod.b = $mod.C !== $mod.TObject;',
  13673. '$mod.b = $mod.TObject !== $mod.C;',
  13674. '']));
  13675. end;
  13676. procedure TTestModule.TestClassOf_ClassVar;
  13677. begin
  13678. StartProgram(false);
  13679. Add('type');
  13680. Add(' TObject = class');
  13681. Add(' class var id: longint;');
  13682. Add(' end;');
  13683. Add(' TClass = class of TObject;');
  13684. Add('var');
  13685. Add(' C: tclass;');
  13686. Add('begin');
  13687. Add(' C.id:=C.id;');
  13688. ConvertProgram;
  13689. CheckSource('TestClassOf_ClassVar',
  13690. LinesToStr([ // statements
  13691. 'rtl.createClass($mod, "TObject", null, function () {',
  13692. ' this.id = 0;',
  13693. ' this.$init = function () {',
  13694. ' };',
  13695. ' this.$final = function () {',
  13696. ' };',
  13697. '});',
  13698. 'this.C = null;'
  13699. ]),
  13700. LinesToStr([ // $mod.$main
  13701. '$mod.TObject.id = $mod.C.id;',
  13702. '']));
  13703. end;
  13704. procedure TTestModule.TestClassOf_ClassMethod;
  13705. begin
  13706. StartProgram(false);
  13707. Add('type');
  13708. Add(' TObject = class');
  13709. Add(' class function DoIt(i: longint = 0): longint;');
  13710. Add(' end;');
  13711. Add(' TClass = class of TObject;');
  13712. Add('class function tobject.doit(i: longint = 0): longint; begin end;');
  13713. Add('var');
  13714. Add(' i: longint;');
  13715. Add(' C: tclass;');
  13716. Add('begin');
  13717. Add(' C.DoIt;');
  13718. Add(' C.DoIt();');
  13719. Add(' i:=C.DoIt;');
  13720. Add(' i:=C.DoIt();');
  13721. ConvertProgram;
  13722. CheckSource('TestClassOf_ClassMethod',
  13723. LinesToStr([ // statements
  13724. 'rtl.createClass($mod, "TObject", null, function () {',
  13725. ' this.$init = function () {',
  13726. ' };',
  13727. ' this.$final = function () {',
  13728. ' };',
  13729. ' this.DoIt = function (i) {',
  13730. ' var Result = 0;',
  13731. ' return Result;',
  13732. ' };',
  13733. '});',
  13734. 'this.i = 0;',
  13735. 'this.C = null;'
  13736. ]),
  13737. LinesToStr([ // $mod.$main
  13738. '$mod.C.DoIt(0);',
  13739. '$mod.C.DoIt(0);',
  13740. '$mod.i = $mod.C.DoIt(0);',
  13741. '$mod.i = $mod.C.DoIt(0);',
  13742. '']));
  13743. end;
  13744. procedure TTestModule.TestClassOf_ClassProperty;
  13745. begin
  13746. StartProgram(false);
  13747. Add([
  13748. 'type',
  13749. ' TObject = class',
  13750. ' class var FA: longint;',
  13751. ' class function GetA: longint;',
  13752. ' class procedure SetA(Value: longint);',
  13753. ' class property pA: longint read fa write fa;',
  13754. ' class property pB: longint read geta write seta;',
  13755. ' end;',
  13756. ' TObjectClass = class of tobject;',
  13757. 'class function tobject.geta: longint; begin end;',
  13758. 'class procedure tobject.seta(value: longint); begin end;',
  13759. 'var',
  13760. ' b: boolean;',
  13761. ' Obj: tobject;',
  13762. ' Cla: tobjectclass;',
  13763. 'begin',
  13764. ' obj.pa:=obj.pa;',
  13765. ' obj.pb:=obj.pb;',
  13766. ' b:=obj.pa=4;',
  13767. ' b:=obj.pb=obj.pb;',
  13768. ' b:=5=obj.pa;',
  13769. ' cla.pa:=6;',
  13770. ' cla.pa:=cla.pa;',
  13771. ' cla.pb:=cla.pb;',
  13772. ' b:=cla.pa=7;',
  13773. ' b:=cla.pb=cla.pb;',
  13774. ' b:=8=cla.pa;',
  13775. ' tobject.pa:=9;',
  13776. ' tobject.pb:=tobject.pb;',
  13777. ' b:=tobject.pa=10;',
  13778. ' b:=11=tobject.pa;',
  13779. '']);
  13780. ConvertProgram;
  13781. CheckSource('TestClassOf_ClassProperty',
  13782. LinesToStr([ // statements
  13783. 'rtl.createClass($mod, "TObject", null, function () {',
  13784. ' this.FA = 0;',
  13785. ' this.$init = function () {',
  13786. ' };',
  13787. ' this.$final = function () {',
  13788. ' };',
  13789. ' this.GetA = function () {',
  13790. ' var Result = 0;',
  13791. ' return Result;',
  13792. ' };',
  13793. ' this.SetA = function (Value) {',
  13794. ' };',
  13795. '});',
  13796. 'this.b = false;',
  13797. 'this.Obj = null;',
  13798. 'this.Cla = null;'
  13799. ]),
  13800. LinesToStr([ // $mod.$main
  13801. '$mod.TObject.FA = $mod.Obj.FA;',
  13802. '$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
  13803. '$mod.b = $mod.Obj.FA === 4;',
  13804. '$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
  13805. '$mod.b = 5 === $mod.Obj.FA;',
  13806. '$mod.TObject.FA = 6;',
  13807. '$mod.TObject.FA = $mod.Cla.FA;',
  13808. '$mod.Cla.SetA($mod.Cla.GetA());',
  13809. '$mod.b = $mod.Cla.FA === 7;',
  13810. '$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
  13811. '$mod.b = 8 === $mod.Cla.FA;',
  13812. '$mod.TObject.FA = 9;',
  13813. '$mod.TObject.SetA($mod.TObject.GetA());',
  13814. '$mod.b = $mod.TObject.FA === 10;',
  13815. '$mod.b = 11 === $mod.TObject.FA;',
  13816. '']));
  13817. end;
  13818. procedure TTestModule.TestClassOf_ClassMethodSelf;
  13819. begin
  13820. StartProgram(false);
  13821. Add('type');
  13822. Add(' TObject = class');
  13823. Add(' class var GlobalId: longint;');
  13824. Add(' class procedure ProcA;');
  13825. Add(' end;');
  13826. Add('class procedure tobject.proca;');
  13827. Add('var b: boolean;');
  13828. Add('begin');
  13829. Add(' b:=self=nil;');
  13830. Add(' b:=self.globalid=3;');
  13831. Add(' b:=4=self.globalid;');
  13832. Add(' self.globalid:=5;');
  13833. Add(' self.proca;');
  13834. Add('end;');
  13835. Add('begin');
  13836. ConvertProgram;
  13837. CheckSource('TestClassOf_ClassMethodSelf',
  13838. LinesToStr([ // statements
  13839. 'rtl.createClass($mod, "TObject", null, function () {',
  13840. ' this.GlobalId = 0;',
  13841. ' this.$init = function () {',
  13842. ' };',
  13843. ' this.$final = function () {',
  13844. ' };',
  13845. ' this.ProcA = function () {',
  13846. ' var b = false;',
  13847. ' b = this === null;',
  13848. ' b = this.GlobalId === 3;',
  13849. ' b = 4 === this.GlobalId;',
  13850. ' $mod.TObject.GlobalId = 5;',
  13851. ' this.ProcA();',
  13852. ' };',
  13853. '});'
  13854. ]),
  13855. LinesToStr([ // $mod.$main
  13856. '']));
  13857. end;
  13858. procedure TTestModule.TestClassOf_TypeCast;
  13859. begin
  13860. StartProgram(false);
  13861. Add('type');
  13862. Add(' TObject = class');
  13863. Add(' class procedure {#TObject_DoIt}DoIt;');
  13864. Add(' end;');
  13865. Add(' TClass = class of TObject;');
  13866. Add(' TMobile = class');
  13867. Add(' class procedure {#TMobile_DoIt}DoIt;');
  13868. Add(' end;');
  13869. Add(' TMobileClass = class of TMobile;');
  13870. Add(' TCar = class(TMobile)');
  13871. Add(' class procedure {#TCar_DoIt}DoIt;');
  13872. Add(' end;');
  13873. Add(' TCarClass = class of TCar;');
  13874. Add('class procedure TObject.DoIt;');
  13875. Add('begin');
  13876. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  13877. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  13878. Add('end;');
  13879. Add('class procedure TMobile.DoIt;');
  13880. Add('begin');
  13881. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  13882. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  13883. Add(' TCarClass(Self).{@TCar_DoIt}DoIt;');
  13884. Add('end;');
  13885. Add('class procedure TCar.DoIt; begin end;');
  13886. Add('var');
  13887. Add(' ObjC: TClass;');
  13888. Add(' MobileC: TMobileClass;');
  13889. Add(' CarC: TCarClass;');
  13890. Add('begin');
  13891. Add(' ObjC.{@TObject_DoIt}DoIt;');
  13892. Add(' MobileC.{@TMobile_DoIt}DoIt;');
  13893. Add(' CarC.{@TCar_DoIt}DoIt;');
  13894. Add(' TClass(ObjC).{@TObject_DoIt}DoIt;');
  13895. Add(' TMobileClass(ObjC).{@TMobile_DoIt}DoIt;');
  13896. Add(' TCarClass(ObjC).{@TCar_DoIt}DoIt;');
  13897. Add(' TClass(MobileC).{@TObject_DoIt}DoIt;');
  13898. Add(' TMobileClass(MobileC).{@TMobile_DoIt}DoIt;');
  13899. Add(' TCarClass(MobileC).{@TCar_DoIt}DoIt;');
  13900. Add(' TClass(CarC).{@TObject_DoIt}DoIt;');
  13901. Add(' TMobileClass(CarC).{@TMobile_DoIt}DoIt;');
  13902. Add(' TCarClass(CarC).{@TCar_DoIt}DoIt;');
  13903. ConvertProgram;
  13904. CheckSource('TestClassOf_TypeCast',
  13905. LinesToStr([ // statements
  13906. 'rtl.createClass($mod, "TObject", null, function () {',
  13907. ' this.$init = function () {',
  13908. ' };',
  13909. ' this.$final = function () {',
  13910. ' };',
  13911. ' this.DoIt = function () {',
  13912. ' this.DoIt();',
  13913. ' this.DoIt$1();',
  13914. ' };',
  13915. '});',
  13916. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  13917. ' this.DoIt$1 = function () {',
  13918. ' this.DoIt();',
  13919. ' this.DoIt$1();',
  13920. ' this.DoIt$2();',
  13921. ' };',
  13922. '});',
  13923. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  13924. ' this.DoIt$2 = function () {',
  13925. ' };',
  13926. '});',
  13927. 'this.ObjC = null;',
  13928. 'this.MobileC = null;',
  13929. 'this.CarC = null;',
  13930. '']),
  13931. LinesToStr([ // $mod.$main
  13932. '$mod.ObjC.DoIt();',
  13933. '$mod.MobileC.DoIt$1();',
  13934. '$mod.CarC.DoIt$2();',
  13935. '$mod.ObjC.DoIt();',
  13936. '$mod.ObjC.DoIt$1();',
  13937. '$mod.ObjC.DoIt$2();',
  13938. '$mod.MobileC.DoIt();',
  13939. '$mod.MobileC.DoIt$1();',
  13940. '$mod.MobileC.DoIt$2();',
  13941. '$mod.CarC.DoIt();',
  13942. '$mod.CarC.DoIt$1();',
  13943. '$mod.CarC.DoIt$2();',
  13944. '']));
  13945. end;
  13946. procedure TTestModule.TestClassOf_ImplicitFunctionCall;
  13947. begin
  13948. StartProgram(false);
  13949. Add('type');
  13950. Add(' TObject = class');
  13951. Add(' function CurNow: longint; ');
  13952. Add(' class function Now: longint; ');
  13953. Add(' end;');
  13954. Add('function TObject.CurNow: longint; begin end;');
  13955. Add('class function TObject.Now: longint; begin end;');
  13956. Add('var');
  13957. Add(' Obj: tobject;');
  13958. Add(' vI: longint;');
  13959. Add('begin');
  13960. Add(' obj.curnow;');
  13961. Add(' vi:=obj.curnow;');
  13962. Add(' tobject.now;');
  13963. Add(' vi:=tobject.now;');
  13964. ConvertProgram;
  13965. CheckSource('TestClassOf_ImplicitFunctionCall',
  13966. LinesToStr([ // statements
  13967. 'rtl.createClass($mod, "TObject", null, function () {',
  13968. ' this.$init = function () {',
  13969. ' };',
  13970. ' this.$final = function () {',
  13971. ' };',
  13972. ' this.CurNow = function () {',
  13973. ' var Result = 0;',
  13974. ' return Result;',
  13975. ' };',
  13976. ' this.Now = function () {',
  13977. ' var Result = 0;',
  13978. ' return Result;',
  13979. ' };',
  13980. '});',
  13981. 'this.Obj = null;',
  13982. 'this.vI = 0;',
  13983. '']),
  13984. LinesToStr([ // $mod.$main
  13985. '$mod.Obj.CurNow();',
  13986. '$mod.vI = $mod.Obj.CurNow();',
  13987. '$mod.TObject.Now();',
  13988. '$mod.vI = $mod.TObject.Now();',
  13989. '']));
  13990. end;
  13991. procedure TTestModule.TestClassOf_Const;
  13992. begin
  13993. StartProgram(false);
  13994. Add([
  13995. 'type',
  13996. ' TObject = class',
  13997. ' end;',
  13998. ' TBird = TObject;',
  13999. ' TBirds = class of TBird;',
  14000. ' TEagles = TBirds;',
  14001. ' THawk = class(TBird);',
  14002. 'const',
  14003. ' Hawk: TEagles = THawk;',
  14004. ' DefaultBirdClasses : Array [1..2] of TEagles = (',
  14005. ' TBird,',
  14006. ' THawk',
  14007. ' );',
  14008. 'begin']);
  14009. ConvertProgram;
  14010. CheckSource('TestClassOf_Const',
  14011. LinesToStr([ // statements
  14012. 'rtl.createClass($mod, "TObject", null, function () {',
  14013. ' this.$init = function () {',
  14014. ' };',
  14015. ' this.$final = function () {',
  14016. ' };',
  14017. '});',
  14018. 'rtl.createClass($mod, "THawk", $mod.TObject, function () {',
  14019. '});',
  14020. 'this.Hawk = $mod.THawk;',
  14021. 'this.DefaultBirdClasses = [$mod.TObject, $mod.THawk];',
  14022. '']),
  14023. LinesToStr([ // $mod.$main
  14024. '']));
  14025. end;
  14026. procedure TTestModule.TestNestedClass_Alias;
  14027. begin
  14028. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14029. StartProgram(false);
  14030. Add([
  14031. 'type',
  14032. ' TObject = class',
  14033. ' type TNested = type longint;',
  14034. ' end;',
  14035. 'type TAlias = type tobject.tnested;',
  14036. 'var i: tobject.tnested = 3;',
  14037. 'var j: TAlias = 4;',
  14038. 'begin',
  14039. ' if typeinfo(TAlias)=nil then ;',
  14040. ' if typeinfo(tobject.tnested)=nil then ;',
  14041. '']);
  14042. ConvertProgram;
  14043. CheckSource('TestNestedClass_Alias',
  14044. LinesToStr([ // statements
  14045. 'rtl.createClass($mod, "TObject", null, function () {',
  14046. ' $mod.$rtti.$inherited("TObject.TNested", rtl.longint, {});',
  14047. ' this.$init = function () {',
  14048. ' };',
  14049. ' this.$final = function () {',
  14050. ' };',
  14051. '});',
  14052. '$mod.$rtti.$inherited("TAlias", $mod.$rtti["TObject.TNested"], {});',
  14053. 'this.i = 3;',
  14054. 'this.j = 4;',
  14055. '']),
  14056. LinesToStr([ // $mod.$main
  14057. 'if ($mod.$rtti["TAlias"] === null) ;',
  14058. 'if ($mod.$rtti["TObject.TNested"] === null) ;',
  14059. '']));
  14060. end;
  14061. procedure TTestModule.TestNestedClass_Record;
  14062. begin
  14063. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14064. StartProgram(false);
  14065. Add([
  14066. 'type',
  14067. ' TObject = class',
  14068. ' type TPoint = record',
  14069. ' x,y: byte;',
  14070. ' end;',
  14071. ' procedure DoIt(t: TPoint);',
  14072. ' end;',
  14073. 'procedure tobject.DoIt(t: TPoint);',
  14074. 'var p: TPoint;',
  14075. 'begin',
  14076. ' t.x:=t.y;',
  14077. ' p:=t;',
  14078. 'end;',
  14079. 'var',
  14080. ' p: tobject.tpoint = (x:2; y:4);',
  14081. ' o: TObject;',
  14082. 'begin',
  14083. ' p:=p;',
  14084. ' o.doit(p);',
  14085. '']);
  14086. ConvertProgram;
  14087. CheckSource('TestNestedClass_Record',
  14088. LinesToStr([ // statements
  14089. 'rtl.createClass($mod, "TObject", null, function () {',
  14090. ' rtl.recNewT(this, "TPoint", function () {',
  14091. ' this.x = 0;',
  14092. ' this.y = 0;',
  14093. ' this.$eq = function (b) {',
  14094. ' return (this.x === b.x) && (this.y === b.y);',
  14095. ' };',
  14096. ' this.$assign = function (s) {',
  14097. ' this.x = s.x;',
  14098. ' this.y = s.y;',
  14099. ' return this;',
  14100. ' };',
  14101. ' var $r = $mod.$rtti.$Record("TObject.TPoint", {});',
  14102. ' $r.addField("x", rtl.byte);',
  14103. ' $r.addField("y", rtl.byte);',
  14104. ' });',
  14105. ' this.$init = function () {',
  14106. ' };',
  14107. ' this.$final = function () {',
  14108. ' };',
  14109. ' this.DoIt = function (t) {',
  14110. ' var p = this.TPoint.$new();',
  14111. ' t.x = t.y;',
  14112. ' p.$assign(t);',
  14113. ' };',
  14114. '});',
  14115. 'this.p = $mod.TObject.TPoint.$clone({',
  14116. ' x: 2,',
  14117. ' y: 4',
  14118. '});',
  14119. 'this.o = null;',
  14120. '']),
  14121. LinesToStr([ // $mod.$main
  14122. '$mod.p.$assign($mod.p);',
  14123. '$mod.o.DoIt($mod.TObject.TPoint.$clone($mod.p));',
  14124. '']));
  14125. end;
  14126. procedure TTestModule.TestNestedClass_Class;
  14127. begin
  14128. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14129. StartProgram(false);
  14130. Add([
  14131. 'type',
  14132. ' TObject = class end;',
  14133. ' TBird = class',
  14134. ' type TLeg = class',
  14135. ' FId: longint;',
  14136. ' constructor Create;',
  14137. ' function Create(i: longint): TLeg;',
  14138. ' end;',
  14139. ' function DoIt(b: TBird): Tleg;',
  14140. ' end;',
  14141. 'constructor tbird.tleg.create;',
  14142. 'begin',
  14143. ' FId:=3;',
  14144. 'end;',
  14145. 'function tbird.tleg.Create(i: longint): TLeg;',
  14146. 'begin',
  14147. ' Create;',
  14148. ' Result:=TLeg.Create;',
  14149. ' Result:=TBird.TLeg.Create;',
  14150. ' Result:=Create(3);',
  14151. ' FId:=i;',
  14152. 'end;',
  14153. 'function tbird.DoIt(b: tbird): tleg;',
  14154. 'begin',
  14155. ' Result.Create;',
  14156. ' Result:=TLeg.Create;',
  14157. ' Result:=TBird.TLeg.Create;',
  14158. ' Result:=Result.Create(3);',
  14159. 'end;',
  14160. 'var',
  14161. ' b: Tbird.tleg;',
  14162. 'begin',
  14163. ' b.Create;',
  14164. ' b:=TBird.TLeg.Create;',
  14165. ' b:=b.Create(3);',
  14166. '']);
  14167. ConvertProgram;
  14168. CheckSource('TestNestedClass_Class',
  14169. LinesToStr([ // statements
  14170. 'rtl.createClass($mod, "TObject", null, function () {',
  14171. ' this.$init = function () {',
  14172. ' };',
  14173. ' this.$final = function () {',
  14174. ' };',
  14175. '});',
  14176. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  14177. ' rtl.createClass(this, "TLeg", $mod.TObject, function () {',
  14178. ' this.$init = function () {',
  14179. ' $mod.TObject.$init.call(this);',
  14180. ' this.FId = 0;',
  14181. ' };',
  14182. ' this.Create = function () {',
  14183. ' this.FId = 3;',
  14184. ' return this;',
  14185. ' };',
  14186. ' this.Create$1 = function (i) {',
  14187. ' var Result = null;',
  14188. ' this.Create();',
  14189. ' Result = $mod.TBird.TLeg.$create("Create");',
  14190. ' Result = $mod.TBird.TLeg.$create("Create");',
  14191. ' Result = this.Create$1(3);',
  14192. ' this.FId = i;',
  14193. ' return Result;',
  14194. ' };',
  14195. ' });',
  14196. ' this.DoIt = function (b) {',
  14197. ' var Result = null;',
  14198. ' Result.Create();',
  14199. ' Result = this.TLeg.$create("Create");',
  14200. ' Result = $mod.TBird.TLeg.$create("Create");',
  14201. ' Result = Result.Create$1(3);',
  14202. ' return Result;',
  14203. ' };',
  14204. '});',
  14205. 'this.b = null;',
  14206. '']),
  14207. LinesToStr([ // $mod.$main
  14208. '$mod.b.Create();',
  14209. '$mod.b = $mod.TBird.TLeg.$create("Create");',
  14210. '$mod.b = $mod.b.Create$1(3);',
  14211. '']));
  14212. end;
  14213. procedure TTestModule.TestExternalClass_Var;
  14214. begin
  14215. StartProgram(false);
  14216. Add([
  14217. '{$modeswitch externalclass}',
  14218. 'type',
  14219. ' TExtA = class external name ''ExtObj''',
  14220. ' Id: longint external name ''$Id'';',
  14221. ' B: longint;',
  14222. ' end;',
  14223. 'var Obj: TExtA;',
  14224. 'begin',
  14225. ' obj.id:=obj.id+1;',
  14226. ' obj.B:=obj.B+1;']);
  14227. ConvertProgram;
  14228. CheckSource('TestExternalClass_Var',
  14229. LinesToStr([ // statements
  14230. 'this.Obj = null;',
  14231. '']),
  14232. LinesToStr([ // $mod.$main
  14233. '$mod.Obj.$Id = $mod.Obj.$Id + 1;',
  14234. '$mod.Obj.B = $mod.Obj.B + 1;',
  14235. '']));
  14236. end;
  14237. procedure TTestModule.TestExternalClass_Const;
  14238. begin
  14239. StartProgram(false);
  14240. Add([
  14241. '{$modeswitch externalclass}',
  14242. 'type',
  14243. ' TExtA = class external name ''ExtObj''',
  14244. ' const Two: longint = 2;',
  14245. ' const Three = 3;',
  14246. ' const Id: longint;',
  14247. ' end;',
  14248. ' TExtB = class external name ''ExtB''',
  14249. ' A: TExtA;',
  14250. ' end;',
  14251. 'var',
  14252. ' A: texta;',
  14253. ' B: textb;',
  14254. ' i: longint;',
  14255. 'begin',
  14256. ' i:=a.two;',
  14257. ' i:=texta.two;',
  14258. ' i:=a.three;',
  14259. ' i:=texta.three;',
  14260. ' i:=a.id;',
  14261. ' i:=texta.id;',
  14262. '']);
  14263. ConvertProgram;
  14264. CheckSource('TestExternalClass_Const',
  14265. LinesToStr([ // statements
  14266. 'this.A = null;',
  14267. 'this.B = null;',
  14268. 'this.i = 0;',
  14269. '']),
  14270. LinesToStr([ // $mod.$main
  14271. '$mod.i = 2;',
  14272. '$mod.i = 2;',
  14273. '$mod.i = 3;',
  14274. '$mod.i = 3;',
  14275. '$mod.i = $mod.A.Id;',
  14276. '$mod.i = ExtObj.Id;',
  14277. '']));
  14278. end;
  14279. procedure TTestModule.TestExternalClass_Dollar;
  14280. begin
  14281. StartProgram(false);
  14282. Add([
  14283. '{$modeswitch externalclass}',
  14284. 'type',
  14285. ' TExtA = class external name ''$''',
  14286. ' Id: longint external name ''$'';',
  14287. ' function Bla(i: longint): longint; external name ''$'';',
  14288. ' end;',
  14289. 'function dollar(k: longint): longint; external name ''$'';',
  14290. 'var Obj: TExtA;',
  14291. 'begin',
  14292. ' dollar(1);',
  14293. ' obj.id:=obj.id+2;',
  14294. ' obj.Bla(3);',
  14295. '']);
  14296. ConvertProgram;
  14297. CheckSource('TestExternalClass_Dollar',
  14298. LinesToStr([ // statements
  14299. 'this.Obj = null;',
  14300. '']),
  14301. LinesToStr([ // $mod.$main
  14302. '$(1);',
  14303. '$mod.Obj.$ = $mod.Obj.$ + 2;',
  14304. '$mod.Obj.$(3);',
  14305. '']));
  14306. end;
  14307. procedure TTestModule.TestExternalClass_DuplicateVarFail;
  14308. begin
  14309. StartProgram(false);
  14310. Add('{$modeswitch externalclass}');
  14311. Add('type');
  14312. Add(' TExtA = class external name ''ExtA''');
  14313. Add(' Id: longint external name ''$Id'';');
  14314. Add(' end;');
  14315. Add(' TExtB = class external ''lib'' name ''ExtB''(TExtA)');
  14316. Add(' Id: longint;');
  14317. Add(' end;');
  14318. Add('begin');
  14319. SetExpectedPasResolverError('Duplicate identifier "Id" at test1.pp(6,5)',nDuplicateIdentifier);
  14320. ConvertProgram;
  14321. end;
  14322. procedure TTestModule.TestExternalClass_Method;
  14323. begin
  14324. StartProgram(false);
  14325. Add('{$modeswitch externalclass}');
  14326. Add('type');
  14327. Add(' TExtA = class external name ''ExtObj''');
  14328. Add(' procedure DoIt(Id: longint = 1); external name ''$Execute'';');
  14329. Add(' procedure DoSome(Id: longint = 1);');
  14330. Add(' end;');
  14331. Add('var Obj: texta;');
  14332. Add('begin');
  14333. Add(' obj.doit;');
  14334. Add(' obj.doit();');
  14335. Add(' obj.doit(2);');
  14336. Add(' with obj do begin');
  14337. Add(' doit;');
  14338. Add(' doit();');
  14339. Add(' doit(3);');
  14340. Add(' end;');
  14341. ConvertProgram;
  14342. CheckSource('TestExternalClass_Method',
  14343. LinesToStr([ // statements
  14344. 'this.Obj = null;',
  14345. '']),
  14346. LinesToStr([ // $mod.$main
  14347. '$mod.Obj.$Execute(1);',
  14348. '$mod.Obj.$Execute(1);',
  14349. '$mod.Obj.$Execute(2);',
  14350. 'var $with1 = $mod.Obj;',
  14351. '$with1.$Execute(1);',
  14352. '$with1.$Execute(1);',
  14353. '$with1.$Execute(3);',
  14354. '']));
  14355. end;
  14356. procedure TTestModule.TestExternalClass_ClassMethod;
  14357. begin
  14358. StartProgram(false);
  14359. Add([
  14360. '{$modeswitch externalclass}',
  14361. 'type',
  14362. ' TExtA = class external name ''ExtObj''',
  14363. ' class procedure DoIt(Id: longint = 1); external name ''$Execute'';',
  14364. ' end;',
  14365. ' TExtB = TExtA;',
  14366. 'begin',
  14367. ' texta.doit;',
  14368. ' texta.doit();',
  14369. ' texta.doit(2);',
  14370. ' with texta do begin',
  14371. ' doit;',
  14372. ' doit();',
  14373. ' doit(3);',
  14374. ' end;',
  14375. ' textb.doit;',
  14376. ' textb.doit();',
  14377. ' textb.doit(4);',
  14378. ' with textb do begin',
  14379. ' doit;',
  14380. ' doit();',
  14381. ' doit(5);',
  14382. ' end;',
  14383. '']);
  14384. ConvertProgram;
  14385. CheckSource('TestExternalClass_ClassMethod',
  14386. LinesToStr([ // statements
  14387. '']),
  14388. LinesToStr([ // $mod.$main
  14389. 'ExtObj.$Execute(1);',
  14390. 'ExtObj.$Execute(1);',
  14391. 'ExtObj.$Execute(2);',
  14392. 'ExtObj.$Execute(1);',
  14393. 'ExtObj.$Execute(1);',
  14394. 'ExtObj.$Execute(3);',
  14395. 'ExtObj.$Execute(1);',
  14396. 'ExtObj.$Execute(1);',
  14397. 'ExtObj.$Execute(4);',
  14398. 'ExtObj.$Execute(1);',
  14399. 'ExtObj.$Execute(1);',
  14400. 'ExtObj.$Execute(5);',
  14401. '']));
  14402. end;
  14403. procedure TTestModule.TestExternalClass_FunctionResultInTypeCast;
  14404. begin
  14405. StartProgram(false);
  14406. Add([
  14407. '{$modeswitch externalclass}',
  14408. 'type',
  14409. ' TBird = class external name ''Array''',
  14410. ' end;',
  14411. 'function GetPtr: Pointer;',
  14412. 'begin',
  14413. 'end;',
  14414. 'procedure Write(const p);',
  14415. 'begin',
  14416. 'end;',
  14417. 'procedure WriteLn; varargs;',
  14418. 'begin',
  14419. 'end;',
  14420. 'begin',
  14421. ' if TBird(GetPtr)=nil then ;',
  14422. ' Write(GetPtr);',
  14423. ' WriteLn(GetPtr);',
  14424. ' Write(TBird(GetPtr));',
  14425. ' WriteLn(TBird(GetPtr));',
  14426. '']);
  14427. ConvertProgram;
  14428. CheckSource('TestFunctionResultInTypeCast',
  14429. LinesToStr([ // statements
  14430. 'this.GetPtr = function () {',
  14431. ' var Result = null;',
  14432. ' return Result;',
  14433. '};',
  14434. 'this.Write = function (p) {',
  14435. '};',
  14436. 'this.WriteLn = function () {',
  14437. '};',
  14438. '']),
  14439. LinesToStr([
  14440. 'if ($mod.GetPtr() === null) ;',
  14441. '$mod.Write($mod.GetPtr());',
  14442. '$mod.WriteLn($mod.GetPtr());',
  14443. '$mod.Write($mod.GetPtr());',
  14444. '$mod.WriteLn($mod.GetPtr());',
  14445. '']));
  14446. end;
  14447. procedure TTestModule.TestExternalClass_NonExternalOverride;
  14448. begin
  14449. StartProgram(false);
  14450. Add('{$modeswitch externalclass}');
  14451. Add('type');
  14452. Add(' TExtA = class external name ''ExtObjA''');
  14453. Add(' procedure ProcA; virtual;');
  14454. Add(' procedure ProcB; virtual;');
  14455. Add(' end;');
  14456. Add(' TExtB = class external name ''ExtObjB'' (TExtA)');
  14457. Add(' end;');
  14458. Add(' TExtC = class (TExtB)');
  14459. Add(' procedure ProcA; override;');
  14460. Add(' end;');
  14461. Add('procedure TExtC.ProcA;');
  14462. Add('begin');
  14463. Add(' ProcA;');
  14464. Add(' Self.ProcA;');
  14465. Add(' ProcB;');
  14466. Add(' Self.ProcB;');
  14467. Add('end;');
  14468. Add('var');
  14469. Add(' A: texta;');
  14470. Add(' B: textb;');
  14471. Add(' C: textc;');
  14472. Add('begin');
  14473. Add(' a.proca;');
  14474. Add(' b.proca;');
  14475. Add(' c.proca;');
  14476. ConvertProgram;
  14477. CheckSource('TestExternalClass_NonExternalOverride',
  14478. LinesToStr([ // statements
  14479. 'rtl.createClassExt($mod, "TExtC", ExtObjB, "", function () {',
  14480. ' this.$init = function () {',
  14481. ' };',
  14482. ' this.$final = function () {',
  14483. ' };',
  14484. ' this.ProcA = function () {',
  14485. ' this.ProcA();',
  14486. ' this.ProcA();',
  14487. ' this.ProcB();',
  14488. ' this.ProcB();',
  14489. ' };',
  14490. '});',
  14491. 'this.A = null;',
  14492. 'this.B = null;',
  14493. 'this.C = null;',
  14494. '']),
  14495. LinesToStr([ // $mod.$main
  14496. '$mod.A.ProcA();',
  14497. '$mod.B.ProcA();',
  14498. '$mod.C.ProcA();',
  14499. '']));
  14500. end;
  14501. procedure TTestModule.TestExternalClass_OverloadHint;
  14502. begin
  14503. StartProgram(false);
  14504. Add([
  14505. '{$modeswitch externalclass}',
  14506. 'type',
  14507. ' TExtA = class external name ''ExtObjA''',
  14508. ' procedure DoIt;',
  14509. ' procedure DoIt(i: longint);',
  14510. ' end;',
  14511. 'begin',
  14512. '']);
  14513. ConvertProgram;
  14514. CheckResolverUnexpectedHints(true);
  14515. CheckSource('TestExternalClass_OverloadHint',
  14516. LinesToStr([ // statements
  14517. '']),
  14518. LinesToStr([ // $mod.$main
  14519. '']));
  14520. end;
  14521. procedure TTestModule.TestExternalClass_SameNamePublishedProperty;
  14522. begin
  14523. StartProgram(false);
  14524. Add([
  14525. '{$modeswitch externalclass}',
  14526. 'type',
  14527. ' JSwiper = class external name ''Swiper''',
  14528. ' constructor New;',
  14529. ' end;',
  14530. ' TObject = class',
  14531. ' private',
  14532. ' FSwiper: JSwiper;',
  14533. ' published',
  14534. ' property Swiper: JSwiper read FSwiper write FSwiper;',
  14535. ' end;',
  14536. 'begin',
  14537. ' JSwiper.new;',
  14538. '']);
  14539. ConvertProgram;
  14540. CheckSource('TestExternalClass_SameNamePublishedProperty',
  14541. LinesToStr([ // statements
  14542. 'rtl.createClass($mod, "TObject", null, function () {',
  14543. ' this.$init = function () {',
  14544. ' this.FSwiper = null;',
  14545. ' };',
  14546. ' this.$final = function () {',
  14547. ' this.FSwiper = undefined;',
  14548. ' };',
  14549. ' var $r = this.$rtti;',
  14550. ' $r.addProperty("Swiper", 0, $mod.$rtti["JSwiper"], "FSwiper", "FSwiper");',
  14551. '});',
  14552. '']),
  14553. LinesToStr([ // $mod.$main
  14554. 'new Swiper();',
  14555. '']));
  14556. end;
  14557. procedure TTestModule.TestExternalClass_Property;
  14558. begin
  14559. StartProgram(false);
  14560. Add([
  14561. '{$modeswitch externalclass}',
  14562. 'type',
  14563. ' TExtA = class external name ''ExtA''',
  14564. ' function getYear: longint;',
  14565. ' procedure setYear(Value: longint);',
  14566. ' property Year: longint read getyear write setyear;',
  14567. ' end;',
  14568. ' TExtB = class (TExtA)',
  14569. ' procedure OtherSetYear(Value: longint);',
  14570. ' property year write othersetyear;',
  14571. ' end;',
  14572. 'procedure textb.othersetyear(value: longint);',
  14573. 'begin',
  14574. ' setYear(Value+4);',
  14575. 'end;',
  14576. 'var',
  14577. ' A: texta;',
  14578. ' B: textb;',
  14579. 'begin',
  14580. ' a.year:=a.year+1;',
  14581. ' b.year:=b.year+2;']);
  14582. ConvertProgram;
  14583. CheckSource('TestExternalClass_NonExternalOverride',
  14584. LinesToStr([ // statements
  14585. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  14586. ' this.$init = function () {',
  14587. ' };',
  14588. ' this.$final = function () {',
  14589. ' };',
  14590. ' this.OtherSetYear = function (Value) {',
  14591. ' this.setYear(Value+4);',
  14592. ' };',
  14593. '});',
  14594. 'this.A = null;',
  14595. 'this.B = null;',
  14596. '']),
  14597. LinesToStr([ // $mod.$main
  14598. '$mod.A.setYear($mod.A.getYear()+1);',
  14599. '$mod.B.OtherSetYear($mod.B.getYear()+2);',
  14600. '']));
  14601. end;
  14602. procedure TTestModule.TestExternalClass_PropertyDate;
  14603. begin
  14604. StartProgram(false);
  14605. Add([
  14606. '{$modeswitch externalclass}',
  14607. 'type',
  14608. ' TExtA = class external name ''ExtA''',
  14609. ' end;',
  14610. ' TExtB = class (TExtA)',
  14611. ' FDate: string;',
  14612. ' property Date: string read FDate write FDate;',
  14613. ' property ExtA: string read FDate write FDate;',
  14614. ' end;',
  14615. ' {$M+}',
  14616. ' TObject = class',
  14617. ' FDate: string;',
  14618. ' published',
  14619. ' property Date: string read FDate write FDate;',
  14620. ' property ExtA: string read FDate write FDate;',
  14621. ' end;',
  14622. 'var',
  14623. ' B: textb;',
  14624. ' o: TObject;',
  14625. 'begin',
  14626. ' b.date:=b.exta;',
  14627. ' o.date:=o.exta;']);
  14628. ConvertProgram;
  14629. CheckSource('TestExternalClass_PropertyDate',
  14630. LinesToStr([ // statements
  14631. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  14632. ' this.$init = function () {',
  14633. ' this.FDate = "";',
  14634. ' };',
  14635. ' this.$final = function () {',
  14636. ' };',
  14637. '});',
  14638. 'rtl.createClass($mod, "TObject", null, function () {',
  14639. ' this.$init = function () {',
  14640. ' this.FDate = "";',
  14641. ' };',
  14642. ' this.$final = function () {',
  14643. ' };',
  14644. ' var $r = this.$rtti;',
  14645. ' $r.addField("FDate", rtl.string);',
  14646. ' $r.addProperty("Date", 0, rtl.string, "FDate", "FDate");',
  14647. ' $r.addProperty("ExtA", 0, rtl.string, "FDate", "FDate");',
  14648. '});',
  14649. 'this.B = null;',
  14650. 'this.o = null;',
  14651. '']),
  14652. LinesToStr([ // $mod.$main
  14653. '$mod.B.FDate = $mod.B.FDate;',
  14654. '$mod.o.FDate = $mod.o.FDate;',
  14655. '']));
  14656. end;
  14657. procedure TTestModule.TestExternalClass_ClassProperty;
  14658. begin
  14659. StartProgram(false);
  14660. Add('{$modeswitch externalclass}');
  14661. Add('type');
  14662. Add(' TExtA = class external name ''ExtA''');
  14663. Add(' class function getYear: longint;');
  14664. Add(' class procedure setYear(Value: longint);');
  14665. Add(' class property Year: longint read getyear write setyear;');
  14666. Add(' end;');
  14667. Add(' TExtB = class (TExtA)');
  14668. Add(' class function GetCentury: longint;');
  14669. Add(' class procedure SetCentury(Value: longint);');
  14670. Add(' class property Century: longint read getcentury write setcentury;');
  14671. Add(' end;');
  14672. Add('class function textb.getcentury: longint;');
  14673. Add('begin');
  14674. Add('end;');
  14675. Add('class procedure textb.setcentury(value: longint);');
  14676. Add('begin');
  14677. Add(' setyear(value+11);');
  14678. Add(' texta.year:=texta.year+12;');
  14679. Add(' year:=year+13;');
  14680. Add(' textb.century:=textb.century+14;');
  14681. Add(' century:=century+15;');
  14682. Add('end;');
  14683. Add('var');
  14684. Add(' A: texta;');
  14685. Add(' B: textb;');
  14686. Add('begin');
  14687. Add(' texta.year:=texta.year+1;');
  14688. Add(' textb.year:=textb.year+2;');
  14689. Add(' TextA.year:=TextA.year+3;');
  14690. Add(' b.year:=b.year+4;');
  14691. Add(' textb.century:=textb.century+5;');
  14692. Add(' b.century:=b.century+6;');
  14693. ConvertProgram;
  14694. CheckSource('TestExternalClass_ClassProperty',
  14695. LinesToStr([ // statements
  14696. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  14697. ' this.$init = function () {',
  14698. ' };',
  14699. ' this.$final = function () {',
  14700. ' };',
  14701. ' this.GetCentury = function () {',
  14702. ' var Result = 0;',
  14703. ' return Result;',
  14704. ' };',
  14705. ' this.SetCentury = function (Value) {',
  14706. ' this.setYear(Value + 11);',
  14707. ' ExtA.setYear(ExtA.getYear() + 12);',
  14708. ' this.setYear(this.getYear() + 13);',
  14709. ' $mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 14);',
  14710. ' this.SetCentury(this.GetCentury() + 15);',
  14711. ' };',
  14712. '});',
  14713. 'this.A = null;',
  14714. 'this.B = null;',
  14715. '']),
  14716. LinesToStr([ // $mod.$main
  14717. 'ExtA.setYear(ExtA.getYear() + 1);',
  14718. '$mod.TExtB.setYear($mod.TExtB.getYear() + 2);',
  14719. 'ExtA.setYear(ExtA.getYear() + 3);',
  14720. '$mod.B.setYear($mod.B.getYear() + 4);',
  14721. '$mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 5);',
  14722. '$mod.B.$class.SetCentury($mod.B.$class.GetCentury() + 6);',
  14723. '']));
  14724. end;
  14725. procedure TTestModule.TestExternalClass_ClassOf;
  14726. begin
  14727. StartProgram(false);
  14728. Add('{$modeswitch externalclass}');
  14729. Add('type');
  14730. Add(' TExtA = class external name ''ExtA''');
  14731. Add(' procedure ProcA; virtual;');
  14732. Add(' procedure ProcB; virtual;');
  14733. Add(' end;');
  14734. Add(' TExtAClass = class of TExtA;');
  14735. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  14736. Add(' end;');
  14737. Add(' TExtBClass = class of TExtB;');
  14738. Add(' TExtC = class (TExtB)');
  14739. Add(' procedure ProcA; override;');
  14740. Add(' end;');
  14741. Add(' TExtCClass = class of TExtC;');
  14742. Add('procedure TExtC.ProcA; begin end;');
  14743. Add('var');
  14744. Add(' A: texta; ClA: TExtAClass;');
  14745. Add(' B: textb; ClB: TExtBClass;');
  14746. Add(' C: textc; ClC: TExtCClass;');
  14747. Add('begin');
  14748. Add(' ClA:=texta;');
  14749. Add(' ClA:=textb;');
  14750. Add(' ClA:=textc;');
  14751. Add(' ClB:=textb;');
  14752. Add(' ClB:=textc;');
  14753. Add(' ClC:=textc;');
  14754. ConvertProgram;
  14755. CheckSource('TestExternalClass_ClassOf',
  14756. LinesToStr([ // statements
  14757. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  14758. ' this.$init = function () {',
  14759. ' };',
  14760. ' this.$final = function () {',
  14761. ' };',
  14762. ' this.ProcA = function () {',
  14763. ' };',
  14764. '});',
  14765. 'this.A = null;',
  14766. 'this.ClA = null;',
  14767. 'this.B = null;',
  14768. 'this.ClB = null;',
  14769. 'this.C = null;',
  14770. 'this.ClC = null;',
  14771. '']),
  14772. LinesToStr([ // $mod.$main
  14773. '$mod.ClA = ExtA;',
  14774. '$mod.ClA = ExtB;',
  14775. '$mod.ClA = $mod.TExtC;',
  14776. '$mod.ClB = ExtB;',
  14777. '$mod.ClB = $mod.TExtC;',
  14778. '$mod.ClC = $mod.TExtC;',
  14779. '']));
  14780. end;
  14781. procedure TTestModule.TestExternalClass_ClassOtherUnit;
  14782. begin
  14783. AddModuleWithIntfImplSrc('unit2.pas',
  14784. LinesToStr([
  14785. '{$modeswitch externalclass}',
  14786. 'type',
  14787. ' TExtA = class external name ''ExtA''',
  14788. ' class var Id: longint;',
  14789. ' end;',
  14790. '']),
  14791. '');
  14792. StartUnit(true);
  14793. Add('interface');
  14794. Add('uses unit2;');
  14795. Add('implementation');
  14796. Add('begin');
  14797. Add(' unit2.texta.id:=unit2.texta.id+1;');
  14798. ConvertUnit;
  14799. CheckSource('TestExternalClass_ClassOtherUnit',
  14800. LinesToStr([
  14801. '']),
  14802. LinesToStr([
  14803. 'ExtA.Id = ExtA.Id + 1;',
  14804. '']));
  14805. end;
  14806. procedure TTestModule.TestExternalClass_Is;
  14807. begin
  14808. StartProgram(false);
  14809. Add('{$modeswitch externalclass}');
  14810. Add('type');
  14811. Add(' TExtA = class external name ''ExtA''');
  14812. Add(' end;');
  14813. Add(' TExtAClass = class of TExtA;');
  14814. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  14815. Add(' end;');
  14816. Add(' TExtBClass = class of TExtB;');
  14817. Add(' TExtC = class (TExtB)');
  14818. Add(' end;');
  14819. Add(' TExtCClass = class of TExtC;');
  14820. Add('var');
  14821. Add(' A: texta; ClA: TExtAClass;');
  14822. Add(' B: textb; ClB: TExtBClass;');
  14823. Add(' C: textc; ClC: TExtCClass;');
  14824. Add('begin');
  14825. Add(' if a is textb then ;');
  14826. Add(' if a is textc then ;');
  14827. Add(' if b is textc then ;');
  14828. Add(' if cla is textb then ;');
  14829. Add(' if cla is textc then ;');
  14830. Add(' if clb is textc then ;');
  14831. ConvertProgram;
  14832. CheckSource('TestExternalClass_Is',
  14833. LinesToStr([ // statements
  14834. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  14835. ' this.$init = function () {',
  14836. ' };',
  14837. ' this.$final = function () {',
  14838. ' };',
  14839. '});',
  14840. 'this.A = null;',
  14841. 'this.ClA = null;',
  14842. 'this.B = null;',
  14843. 'this.ClB = null;',
  14844. 'this.C = null;',
  14845. 'this.ClC = null;',
  14846. '']),
  14847. LinesToStr([ // $mod.$main
  14848. 'if (rtl.isExt($mod.A, ExtB)) ;',
  14849. 'if ($mod.TExtC.isPrototypeOf($mod.A)) ;',
  14850. 'if ($mod.TExtC.isPrototypeOf($mod.B)) ;',
  14851. 'if (rtl.isExt($mod.ClA, ExtB)) ;',
  14852. 'if (rtl.is($mod.ClA, $mod.TExtC)) ;',
  14853. 'if (rtl.is($mod.ClB, $mod.TExtC)) ;',
  14854. '']));
  14855. end;
  14856. procedure TTestModule.TestExternalClass_As;
  14857. begin
  14858. StartProgram(false);
  14859. Add('{$modeswitch externalclass}');
  14860. Add('type');
  14861. Add(' TExtA = class external name ''ExtA''');
  14862. Add(' end;');
  14863. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  14864. Add(' end;');
  14865. Add(' TExtC = class (TExtB)');
  14866. Add(' end;');
  14867. Add('var');
  14868. Add(' A: texta;');
  14869. Add(' B: textb;');
  14870. Add(' C: textc;');
  14871. Add('begin');
  14872. Add(' b:=a as textb;');
  14873. Add(' c:=a as textc;');
  14874. Add(' c:=b as textc;');
  14875. ConvertProgram;
  14876. CheckSource('TestExternalClass_Is',
  14877. LinesToStr([ // statements
  14878. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  14879. ' this.$init = function () {',
  14880. ' };',
  14881. ' this.$final = function () {',
  14882. ' };',
  14883. '});',
  14884. 'this.A = null;',
  14885. 'this.B = null;',
  14886. 'this.C = null;',
  14887. '']),
  14888. LinesToStr([ // $mod.$main
  14889. '$mod.B = rtl.asExt($mod.A, ExtB);',
  14890. '$mod.C = rtl.as($mod.A, $mod.TExtC);',
  14891. '$mod.C = rtl.as($mod.B, $mod.TExtC);',
  14892. '']));
  14893. end;
  14894. procedure TTestModule.TestExternalClass_DestructorFail;
  14895. begin
  14896. StartProgram(false);
  14897. Add('{$modeswitch externalclass}');
  14898. Add('type');
  14899. Add(' TExtA = class external name ''ExtA''');
  14900. Add(' destructor Free;');
  14901. Add(' end;');
  14902. SetExpectedPasResolverError('Pascal element not supported: destructor',
  14903. nPasElementNotSupported);
  14904. ConvertProgram;
  14905. end;
  14906. procedure TTestModule.TestExternalClass_New;
  14907. begin
  14908. StartProgram(false);
  14909. Add('{$modeswitch externalclass}');
  14910. Add('type');
  14911. Add(' TExtA = class external name ''ExtA''');
  14912. Add(' constructor New;');
  14913. Add(' constructor New(i: longint; j: longint = 2);');
  14914. Add(' end;');
  14915. Add('var');
  14916. Add(' A: texta;');
  14917. Add('begin');
  14918. Add(' a:=texta.new;');
  14919. Add(' a:=texta.new();');
  14920. Add(' a:=texta.new(1);');
  14921. Add(' with texta do begin');
  14922. Add(' a:=new;');
  14923. Add(' a:=new();');
  14924. Add(' a:=new(2);');
  14925. Add(' end;');
  14926. Add(' a:=test1.texta.new;');
  14927. Add(' a:=test1.texta.new();');
  14928. Add(' a:=test1.texta.new(3);');
  14929. ConvertProgram;
  14930. CheckSource('TestExternalClass_New',
  14931. LinesToStr([ // statements
  14932. 'this.A = null;',
  14933. '']),
  14934. LinesToStr([ // $mod.$main
  14935. '$mod.A = new ExtA();',
  14936. '$mod.A = new ExtA();',
  14937. '$mod.A = new ExtA(1,2);',
  14938. '$mod.A = new ExtA();',
  14939. '$mod.A = new ExtA();',
  14940. '$mod.A = new ExtA(2,2);',
  14941. '$mod.A = new ExtA();',
  14942. '$mod.A = new ExtA();',
  14943. '$mod.A = new ExtA(3,2);',
  14944. '']));
  14945. end;
  14946. procedure TTestModule.TestExternalClass_ClassOf_New;
  14947. begin
  14948. StartProgram(false);
  14949. Add('{$modeswitch externalclass}');
  14950. Add('type');
  14951. Add(' TExtAClass = class of TExtA;');
  14952. Add(' TExtA = class external name ''ExtA''');
  14953. Add(' C: TExtAClass;');
  14954. Add(' constructor New;');
  14955. Add(' end;');
  14956. Add('var');
  14957. Add(' A: texta;');
  14958. Add(' C: textaclass;');
  14959. Add('begin');
  14960. Add(' a:=c.new;');
  14961. Add(' a:=c.new();');
  14962. Add(' with C do begin');
  14963. Add(' a:=new;');
  14964. Add(' a:=new();');
  14965. Add(' end;');
  14966. Add(' a:=test1.c.new;');
  14967. Add(' a:=test1.c.new();');
  14968. Add(' a:=A.c.new();');
  14969. ConvertProgram;
  14970. CheckSource('TestExternalClass_ClassOf_New',
  14971. LinesToStr([ // statements
  14972. 'this.A = null;',
  14973. 'this.C = null;',
  14974. '']),
  14975. LinesToStr([ // $mod.$main
  14976. '$mod.A = new $mod.C();',
  14977. '$mod.A = new $mod.C();',
  14978. 'var $with1 = $mod.C;',
  14979. '$mod.A = new $with1();',
  14980. '$mod.A = new $with1();',
  14981. '$mod.A = new $mod.C();',
  14982. '$mod.A = new $mod.C();',
  14983. '$mod.A = new $mod.A.C();',
  14984. '']));
  14985. end;
  14986. procedure TTestModule.TestExternalClass_FuncClassOf_New;
  14987. begin
  14988. StartProgram(false);
  14989. Add([
  14990. '{$modeswitch externalclass}',
  14991. 'type',
  14992. ' TExtAClass = class of TExtA;',
  14993. ' TExtA = class external name ''ExtA''',
  14994. ' constructor New;',
  14995. ' end;',
  14996. 'function GetCreator: TExtAClass;',
  14997. 'begin',
  14998. ' Result:=TExtA;',
  14999. 'end;',
  15000. 'var',
  15001. ' A: texta;',
  15002. 'begin',
  15003. ' a:=getcreator.new;',
  15004. ' a:=getcreator().new;',
  15005. ' a:=getcreator().new();',
  15006. ' a:=getcreator.new();',
  15007. ' with getcreator do begin',
  15008. ' a:=new;',
  15009. ' a:=new();',
  15010. ' end;']);
  15011. ConvertProgram;
  15012. CheckSource('TestExternalClass_FuncClassOf_New',
  15013. LinesToStr([ // statements
  15014. 'this.GetCreator = function () {',
  15015. ' var Result = null;',
  15016. ' Result = ExtA;',
  15017. ' return Result;',
  15018. '};',
  15019. 'this.A = null;',
  15020. '']),
  15021. LinesToStr([ // $mod.$main
  15022. '$mod.A = new ($mod.GetCreator())();',
  15023. '$mod.A = new ($mod.GetCreator())();',
  15024. '$mod.A = new ($mod.GetCreator())();',
  15025. '$mod.A = new ($mod.GetCreator())();',
  15026. 'var $with1 = $mod.GetCreator();',
  15027. '$mod.A = new $with1();',
  15028. '$mod.A = new $with1();',
  15029. '']));
  15030. end;
  15031. procedure TTestModule.TestExternalClass_New_PasClassFail;
  15032. begin
  15033. StartProgram(false);
  15034. Add([
  15035. '{$modeswitch externalclass}',
  15036. 'type',
  15037. ' TExtA = class external name ''ExtA''',
  15038. ' constructor New;',
  15039. ' end;',
  15040. ' TBird = class(TExtA)',
  15041. ' end;',
  15042. 'begin',
  15043. ' TBird.new;',
  15044. '']);
  15045. SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
  15046. ConvertProgram;
  15047. end;
  15048. procedure TTestModule.TestExternalClass_New_PasClassBracketsFail;
  15049. begin
  15050. StartProgram(false);
  15051. Add([
  15052. '{$modeswitch externalclass}',
  15053. 'type',
  15054. ' TExtA = class external name ''ExtA''',
  15055. ' constructor New;',
  15056. ' end;',
  15057. ' TBird = class(TExtA)',
  15058. ' end;',
  15059. 'begin',
  15060. ' TBird.new();',
  15061. '']);
  15062. SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
  15063. ConvertProgram;
  15064. end;
  15065. procedure TTestModule.TestExternalClass_LocalConstSameName;
  15066. begin
  15067. StartProgram(false);
  15068. Add('{$modeswitch externalclass}');
  15069. Add('type');
  15070. Add(' TExtA = class external name ''ExtA''');
  15071. Add(' constructor New;');
  15072. Add(' end;');
  15073. Add('function DoIt: longint;');
  15074. Add('const ExtA: longint = 3;');
  15075. Add('begin');
  15076. Add(' Result:=ExtA;');
  15077. Add('end;');
  15078. Add('var');
  15079. Add(' A: texta;');
  15080. Add('begin');
  15081. Add(' a:=texta.new;');
  15082. ConvertProgram;
  15083. CheckSource('TestExternalClass_LocalConstSameName',
  15084. LinesToStr([ // statements
  15085. 'var ExtA$1 = 3;',
  15086. 'this.DoIt = function () {',
  15087. ' var Result = 0;',
  15088. ' Result = ExtA$1;',
  15089. ' return Result;',
  15090. '};',
  15091. 'this.A = null;',
  15092. '']),
  15093. LinesToStr([ // $mod.$main
  15094. '$mod.A = new ExtA();',
  15095. '']));
  15096. end;
  15097. procedure TTestModule.TestExternalClass_ReintroduceOverload;
  15098. begin
  15099. StartProgram(false);
  15100. Add('{$modeswitch externalclass}');
  15101. Add('type');
  15102. Add(' TExtA = class external name ''ExtA''');
  15103. Add(' procedure DoIt;');
  15104. Add(' end;');
  15105. Add(' TMyA = class(TExtA)');
  15106. Add(' procedure DoIt;');
  15107. Add(' end;');
  15108. Add('procedure TMyA.DoIt; begin end;');
  15109. Add('begin');
  15110. ConvertProgram;
  15111. CheckSource('TestExternalClass_ReintroduceOverload',
  15112. LinesToStr([ // statements
  15113. 'rtl.createClassExt($mod, "TMyA", ExtA, "", function () {',
  15114. ' this.$init = function () {',
  15115. ' };',
  15116. ' this.$final = function () {',
  15117. ' };',
  15118. ' this.DoIt$1 = function () {',
  15119. ' };',
  15120. '});',
  15121. '']),
  15122. LinesToStr([ // $mod.$main
  15123. '']));
  15124. end;
  15125. procedure TTestModule.TestExternalClass_Inherited;
  15126. begin
  15127. StartProgram(false);
  15128. Add('{$modeswitch externalclass}');
  15129. Add('type');
  15130. Add(' TExtA = class external name ''ExtA''');
  15131. Add(' procedure DoIt(i: longint = 1); virtual;');
  15132. Add(' procedure DoSome(j: longint = 2);');
  15133. Add(' end;');
  15134. Add(' TExtB = class external name ''ExtB''(TExtA)');
  15135. Add(' end;');
  15136. Add(' TMyC = class(TExtB)');
  15137. Add(' procedure DoIt(i: longint = 1); override;');
  15138. Add(' procedure DoSome(j: longint = 2); reintroduce;');
  15139. Add(' end;');
  15140. Add('procedure TMyC.DoIt(i: longint);');
  15141. Add('begin');
  15142. Add(' inherited;');
  15143. Add(' inherited DoIt;');
  15144. Add(' inherited DoIt();');
  15145. Add(' inherited DoIt(3);');
  15146. Add(' inherited DoSome;');
  15147. Add(' inherited DoSome();');
  15148. Add(' inherited DoSome(4);');
  15149. Add('end;');
  15150. Add('procedure TMyC.DoSome(j: longint);');
  15151. Add('begin');
  15152. Add(' inherited;');
  15153. Add('end;');
  15154. Add('begin');
  15155. ConvertProgram;
  15156. CheckSource('TestExternalClass_ReintroduceOverload',
  15157. LinesToStr([ // statements
  15158. 'rtl.createClassExt($mod, "TMyC", ExtB, "", function () {',
  15159. ' this.$init = function () {',
  15160. ' };',
  15161. ' this.$final = function () {',
  15162. ' };',
  15163. ' this.DoIt = function (i) {',
  15164. ' ExtB.DoIt.apply(this, arguments);',
  15165. ' ExtB.DoIt.call(this, 1);',
  15166. ' ExtB.DoIt.call(this, 1);',
  15167. ' ExtB.DoIt.call(this, 3);',
  15168. ' ExtB.DoSome.call(this, 2);',
  15169. ' ExtB.DoSome.call(this, 2);',
  15170. ' ExtB.DoSome.call(this, 4);',
  15171. ' };',
  15172. ' this.DoSome$1 = function (j) {',
  15173. ' ExtB.DoSome.apply(this, arguments);',
  15174. ' };',
  15175. '});',
  15176. '']),
  15177. LinesToStr([ // $mod.$main
  15178. '']));
  15179. end;
  15180. procedure TTestModule.TestExternalClass_PascalAncestorFail;
  15181. begin
  15182. StartProgram(false);
  15183. Add('{$modeswitch externalclass}');
  15184. Add('type');
  15185. Add(' TObject = class');
  15186. Add(' end;');
  15187. Add(' TExtA = class external name ''ExtA''(TObject)');
  15188. Add(' end;');
  15189. Add('begin');
  15190. SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
  15191. ConvertProgram;
  15192. end;
  15193. procedure TTestModule.TestExternalClass_NewInstance;
  15194. begin
  15195. StartProgram(false);
  15196. Add('{$modeswitch externalclass}');
  15197. Add('type');
  15198. Add(' TExtA = class external name ''ExtA''');
  15199. Add(' end;');
  15200. Add(' TMyB = class(TExtA)');
  15201. Add(' protected');
  15202. Add(' class function NewInstance(fnname: string; const paramarray): TMyB; virtual;');
  15203. Add(' end;');
  15204. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  15205. Add('begin end;');
  15206. Add('begin');
  15207. ConvertProgram;
  15208. CheckSource('TestExternalClass_NewInstance',
  15209. LinesToStr([ // statements
  15210. 'rtl.createClassExt($mod, "TMyB", ExtA, "NewInstance", function () {',
  15211. ' this.$init = function () {',
  15212. ' };',
  15213. ' this.$final = function () {',
  15214. ' };',
  15215. ' this.NewInstance = function (fnname, paramarray) {',
  15216. ' var Result = null;',
  15217. ' return Result;',
  15218. ' };',
  15219. '});',
  15220. '']),
  15221. LinesToStr([ // $mod.$main
  15222. '']));
  15223. end;
  15224. procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
  15225. begin
  15226. StartProgram(false);
  15227. Add('{$modeswitch externalclass}');
  15228. Add('type');
  15229. Add(' TExtA = class external name ''ExtA''');
  15230. Add(' end;');
  15231. Add(' TMyB = class(TExtA)');
  15232. Add(' protected');
  15233. Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
  15234. Add(' end;');
  15235. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  15236. Add('begin end;');
  15237. Add('begin');
  15238. SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
  15239. ConvertProgram;
  15240. end;
  15241. procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
  15242. begin
  15243. StartProgram(false);
  15244. Add('{$modeswitch externalclass}');
  15245. Add('type');
  15246. Add(' TExtA = class external name ''ExtA''');
  15247. Add(' end;');
  15248. Add(' TMyB = class(TExtA)');
  15249. Add(' protected');
  15250. Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
  15251. Add(' end;');
  15252. Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
  15253. Add('begin end;');
  15254. Add('begin');
  15255. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
  15256. nIncompatibleTypeArgNo);
  15257. ConvertProgram;
  15258. end;
  15259. procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
  15260. begin
  15261. StartProgram(false);
  15262. Add('{$modeswitch externalclass}');
  15263. Add('type');
  15264. Add(' TExtA = class external name ''ExtA''');
  15265. Add(' end;');
  15266. Add(' TMyB = class(TExtA)');
  15267. Add(' protected');
  15268. Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
  15269. Add(' end;');
  15270. Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
  15271. Add('begin end;');
  15272. Add('begin');
  15273. SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
  15274. nIncompatibleTypeArgNo);
  15275. ConvertProgram;
  15276. end;
  15277. procedure TTestModule.TestExternalClass_PascalProperty;
  15278. begin
  15279. StartProgram(false);
  15280. Add('{$modeswitch externalclass}');
  15281. Add('type');
  15282. Add(' TJSElement = class;');
  15283. Add(' TJSNotifyEvent = procedure(Sender: TJSElement) of object;');
  15284. Add(' TJSElement = class external name ''ExtA''');
  15285. Add(' end;');
  15286. Add(' TControl = class(TJSElement)');
  15287. Add(' private');
  15288. Add(' FOnClick: TJSNotifyEvent;');
  15289. Add(' property OnClick: TJSNotifyEvent read FOnClick write FOnClick;');
  15290. Add(' procedure Click(Sender: TJSElement);');
  15291. Add(' end;');
  15292. Add('procedure TControl.Click(Sender: TJSElement);');
  15293. Add('begin');
  15294. Add(' OnClick(Self);');
  15295. Add('end;');
  15296. Add('var');
  15297. Add(' Ctrl: TControl;');
  15298. Add('begin');
  15299. Add(' Ctrl.OnClick:[email protected];');
  15300. Add(' Ctrl.OnClick(Ctrl);');
  15301. ConvertProgram;
  15302. CheckSource('TestExternalClass_PascalProperty',
  15303. LinesToStr([ // statements
  15304. 'rtl.createClassExt($mod, "TControl", ExtA, "", function () {',
  15305. ' this.$init = function () {',
  15306. ' this.FOnClick = null;',
  15307. ' };',
  15308. ' this.$final = function () {',
  15309. ' this.FOnClick = undefined;',
  15310. ' };',
  15311. ' this.Click = function (Sender) {',
  15312. ' this.FOnClick(this);',
  15313. ' };',
  15314. '});',
  15315. 'this.Ctrl = null;',
  15316. '']),
  15317. LinesToStr([ // $mod.$main
  15318. '$mod.Ctrl.FOnClick = rtl.createCallback($mod.Ctrl, "Click");',
  15319. '$mod.Ctrl.FOnClick($mod.Ctrl);',
  15320. '']));
  15321. end;
  15322. procedure TTestModule.TestExternalClass_TypeCastToRootClass;
  15323. begin
  15324. StartProgram(false);
  15325. Add([
  15326. '{$modeswitch externalclass}',
  15327. 'type',
  15328. ' IUnknown = interface end;',
  15329. ' TObject = class',
  15330. ' end;',
  15331. ' TChild = class',
  15332. ' end;',
  15333. ' TExtRootA = class external name ''ExtRootA''',
  15334. ' end;',
  15335. ' TExtChildA = class external name ''ExtChildA''(TExtRootA)',
  15336. ' end;',
  15337. ' TExtRootB = class external name ''ExtRootB''',
  15338. ' end;',
  15339. ' TExtChildB = class external name ''ExtChildB''(TExtRootB)',
  15340. ' end;',
  15341. 'var',
  15342. ' Obj: TObject;',
  15343. ' Child: TChild;',
  15344. ' RootA: TExtRootA;',
  15345. ' ChildA: TExtChildA;',
  15346. ' RootB: TExtRootB;',
  15347. ' ChildB: TExtChildB;',
  15348. ' i: IUnknown;',
  15349. 'begin',
  15350. ' obj:=tobject(roota);',
  15351. ' obj:=tobject(childa);',
  15352. ' child:=tchild(tobject(roota));',
  15353. ' roota:=textroota(obj);',
  15354. ' roota:=textroota(child);',
  15355. ' roota:=textroota(rootb);',
  15356. ' roota:=textroota(childb);',
  15357. ' childa:=textchilda(textroota(obj));',
  15358. ' roota:=TExtRootA(i)',
  15359. '']);
  15360. ConvertProgram;
  15361. CheckSource('TestExternalClass_TypeCastToRootClass',
  15362. LinesToStr([ // statements
  15363. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  15364. 'rtl.createClass($mod, "TObject", null, function () {',
  15365. ' this.$init = function () {',
  15366. ' };',
  15367. ' this.$final = function () {',
  15368. ' };',
  15369. '});',
  15370. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  15371. '});',
  15372. 'this.Obj = null;',
  15373. 'this.Child = null;',
  15374. 'this.RootA = null;',
  15375. 'this.ChildA = null;',
  15376. 'this.RootB = null;',
  15377. 'this.ChildB = null;',
  15378. 'this.i = null;',
  15379. '']),
  15380. LinesToStr([ // $mod.$main
  15381. '$mod.Obj = $mod.RootA;',
  15382. '$mod.Obj = $mod.ChildA;',
  15383. '$mod.Child = $mod.RootA;',
  15384. '$mod.RootA = $mod.Obj;',
  15385. '$mod.RootA = $mod.Child;',
  15386. '$mod.RootA = $mod.RootB;',
  15387. '$mod.RootA = $mod.ChildB;',
  15388. '$mod.ChildA = $mod.Obj;',
  15389. '$mod.RootA = $mod.i;',
  15390. '']));
  15391. end;
  15392. procedure TTestModule.TestExternalClass_TypeCastToJSObject;
  15393. begin
  15394. StartProgram(false);
  15395. Add([
  15396. '{$modeswitch externalclass}',
  15397. 'type',
  15398. ' IUnknown = interface end;',
  15399. ' IBird = interface(IUnknown) end;',
  15400. ' TClass = class of TObject;',
  15401. ' TObject = class',
  15402. ' end;',
  15403. ' TChild = class',
  15404. ' end;',
  15405. ' TJSObject = class external name ''Object''',
  15406. ' end;',
  15407. ' TRec = record end;',
  15408. 'var',
  15409. ' Obj: TObject;',
  15410. ' Child: TChild;',
  15411. ' i: IUnknown;',
  15412. ' Bird: IBird;',
  15413. ' j: TJSObject;',
  15414. ' r: TRec;',
  15415. ' c: TClass;',
  15416. 'begin',
  15417. ' j:=tjsobject(IUnknown);',
  15418. ' j:=tjsobject(IBird);',
  15419. ' j:=tjsobject(TObject);',
  15420. ' j:=tjsobject(TChild);',
  15421. ' j:=tjsobject(TRec);',
  15422. ' j:=tjsobject(Obj);',
  15423. ' j:=tjsobject(Child);',
  15424. ' j:=tjsobject(i);',
  15425. ' j:=tjsobject(Bird);',
  15426. ' j:=tjsobject(r);',
  15427. ' j:=tjsobject(c);',
  15428. '']);
  15429. ConvertProgram;
  15430. CheckSource('TestExternalClass_TypeCastToJSObject',
  15431. LinesToStr([ // statements
  15432. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  15433. 'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], $mod.IUnknown);',
  15434. 'rtl.createClass($mod, "TObject", null, function () {',
  15435. ' this.$init = function () {',
  15436. ' };',
  15437. ' this.$final = function () {',
  15438. ' };',
  15439. '});',
  15440. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  15441. '});',
  15442. 'rtl.recNewT($mod, "TRec", function () {',
  15443. ' this.$eq = function (b) {',
  15444. ' return true;',
  15445. ' };',
  15446. ' this.$assign = function (s) {',
  15447. ' return this;',
  15448. ' };',
  15449. '});',
  15450. 'this.Obj = null;',
  15451. 'this.Child = null;',
  15452. 'this.i = null;',
  15453. 'this.Bird = null;',
  15454. 'this.j = null;',
  15455. 'this.r = $mod.TRec.$new();',
  15456. 'this.c = null;',
  15457. '']),
  15458. LinesToStr([ // $mod.$main
  15459. '$mod.j = $mod.IUnknown;',
  15460. '$mod.j = $mod.IBird;',
  15461. '$mod.j = $mod.TObject;',
  15462. '$mod.j = $mod.TChild;',
  15463. '$mod.j = $mod.TRec;',
  15464. '$mod.j = $mod.Obj;',
  15465. '$mod.j = $mod.Child;',
  15466. '$mod.j = $mod.i;',
  15467. '$mod.j = $mod.Bird;',
  15468. '$mod.j = $mod.r;',
  15469. '$mod.j = $mod.c;',
  15470. '']));
  15471. end;
  15472. procedure TTestModule.TestExternalClass_TypeCastStringToExternalString;
  15473. begin
  15474. StartProgram(false);
  15475. Add('{$modeswitch externalclass}');
  15476. Add('type');
  15477. Add(' TJSString = class external name ''String''');
  15478. Add(' class function fromCharCode() : string; varargs;');
  15479. Add(' function anchor(const aName : string) : string;');
  15480. Add(' end;');
  15481. Add('var');
  15482. Add(' s: string;');
  15483. Add('begin');
  15484. Add(' s:=TJSString.fromCharCode(65,66);');
  15485. Add(' s:=TJSString(s).anchor(s);');
  15486. Add(' s:=TJSString(''foo'').anchor(s);');
  15487. ConvertProgram;
  15488. CheckSource('TestExternalClass_TypeCastStringToExternalString',
  15489. LinesToStr([ // statements
  15490. 'this.s = "";',
  15491. '']),
  15492. LinesToStr([ // $mod.$main
  15493. '$mod.s = String.fromCharCode(65, 66);',
  15494. '$mod.s = $mod.s.anchor($mod.s);',
  15495. '$mod.s = "foo".anchor($mod.s);',
  15496. '']));
  15497. end;
  15498. procedure TTestModule.TestExternalClass_TypeCastToJSFunction;
  15499. begin
  15500. StartProgram(false);
  15501. Add([
  15502. '{$modeswitch externalclass}',
  15503. 'type',
  15504. ' TJSObject = class external name ''Object'' end;',
  15505. ' TJSFunction = class external name ''Function''',
  15506. ' function bind(thisArg: TJSObject): TJSFunction; varargs;',
  15507. ' function call(thisArg: TJSObject): JSValue; varargs;',
  15508. ' end;',
  15509. ' TObject = class',
  15510. ' procedure DoIt(i: longint);',
  15511. ' end;',
  15512. ' TFuncInt = function(o: TObject): longint;',
  15513. 'function GetIt(o: TObject): longint;',
  15514. ' procedure Sub; begin end;',
  15515. 'var',
  15516. ' f: TJSFunction;',
  15517. ' fi: TFuncInt;',
  15518. 'begin',
  15519. ' fi:=TFuncInt(f);',
  15520. ' f:=TJSFunction(fi);',
  15521. ' f:=TJSFunction(@GetIt);',
  15522. ' f:=TJSFunction(@GetIt).bind(nil,3);',
  15523. ' f:=TJSFunction(@Sub);',
  15524. ' f:=TJSFunction(@o.doit);',
  15525. ' f:=TJSFunction(fi).bind(nil,4)',
  15526. 'end;',
  15527. 'procedure TObject.DoIt(i: longint);',
  15528. ' procedure Sub; begin end;',
  15529. 'var f: TJSFunction;',
  15530. 'begin',
  15531. ' f:=TJSFunction(@DoIt);',
  15532. ' f:=TJSFunction(@DoIt).bind(nil,13);',
  15533. ' f:=TJSFunction(@Sub);',
  15534. ' f:=TJSFunction(@GetIt);',
  15535. 'end;',
  15536. 'begin']);
  15537. ConvertProgram;
  15538. CheckSource('TestExternalClass_TypeCastToJSFunction',
  15539. LinesToStr([ // statements
  15540. 'rtl.createClass($mod, "TObject", null, function () {',
  15541. ' this.$init = function () {',
  15542. ' };',
  15543. ' this.$final = function () {',
  15544. ' };',
  15545. ' this.DoIt = function (i) {',
  15546. ' var $Self = this;',
  15547. ' function Sub() {',
  15548. ' };',
  15549. ' var f = null;',
  15550. ' f = rtl.createCallback($Self, "DoIt");',
  15551. ' f = rtl.createCallback($Self, "DoIt").bind(null, 13);',
  15552. ' f = Sub;',
  15553. ' f = $mod.GetIt;',
  15554. ' };',
  15555. '});',
  15556. 'this.GetIt = function (o) {',
  15557. ' var Result = 0;',
  15558. ' function Sub() {',
  15559. ' };',
  15560. ' var f = null;',
  15561. ' var fi = null;',
  15562. ' fi = f;',
  15563. ' f = fi;',
  15564. ' f = $mod.GetIt;',
  15565. ' f = $mod.GetIt.bind(null, 3);',
  15566. ' f = Sub;',
  15567. ' f = rtl.createCallback(o, "DoIt");',
  15568. ' f = fi.bind(null, 4);',
  15569. ' return Result;',
  15570. '};',
  15571. '']),
  15572. LinesToStr([ // $mod.$main
  15573. '']));
  15574. end;
  15575. procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
  15576. begin
  15577. StartProgram(false);
  15578. Add('{$modeswitch externalclass}');
  15579. Add('type');
  15580. Add(' TJSString = class external name ''String''');
  15581. Add(' class function fromCharCode() : string; varargs;');
  15582. Add(' end;');
  15583. Add('var');
  15584. Add(' s: string;');
  15585. Add(' sObj: TJSString;');
  15586. Add('begin');
  15587. Add(' s:=sObj.fromCharCode(65,66);');
  15588. SetExpectedPasResolverError('External class instance cannot access static class function fromCharCode',
  15589. nExternalClassInstanceCannotAccessStaticX);
  15590. ConvertProgram;
  15591. end;
  15592. procedure TTestModule.TestExternalClass_BracketAccessor;
  15593. begin
  15594. StartProgram(false);
  15595. Add([
  15596. '{$modeswitch externalclass}',
  15597. 'type',
  15598. ' TJSArray = class external name ''Array2''',
  15599. ' function GetItems(Index: longint): jsvalue; external name ''[]'';',
  15600. ' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
  15601. ' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
  15602. ' end;',
  15603. 'procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);',
  15604. 'begin end;',
  15605. 'var',
  15606. ' Arr: tjsarray;',
  15607. ' s: string;',
  15608. ' i: longint;',
  15609. ' v: jsvalue;',
  15610. 'begin',
  15611. ' v:=arr[0];',
  15612. ' v:=arr.items[1];',
  15613. ' arr[2]:=s;',
  15614. ' arr.items[3]:=s;',
  15615. ' arr[4]:=i;',
  15616. ' arr[5]:=arr[6];',
  15617. ' arr.items[7]:=arr.items[8];',
  15618. ' with arr do items[9]:=items[10];',
  15619. ' doit(arr[7],arr[8],arr[9],arr[10]);',
  15620. ' with arr do begin',
  15621. ' v:=GetItems(14);',
  15622. ' setitems(15,16);',
  15623. ' end;',
  15624. ' v:=test1.arr.items[17];',
  15625. ' test1.arr.items[18]:=v;',
  15626. '']);
  15627. ConvertProgram;
  15628. CheckSource('TestExternalClass_BracketAccessor',
  15629. LinesToStr([ // statements
  15630. 'this.DoIt = function (vI, vJ, vK, vL) {',
  15631. '};',
  15632. 'this.Arr = null;',
  15633. 'this.s = "";',
  15634. 'this.i = 0;',
  15635. 'this.v = undefined;',
  15636. '']),
  15637. LinesToStr([ // $mod.$main
  15638. '$mod.v = $mod.Arr[0];',
  15639. '$mod.v = $mod.Arr[1];',
  15640. '$mod.Arr[2] = $mod.s;',
  15641. '$mod.Arr[3] = $mod.s;',
  15642. '$mod.Arr[4] = $mod.i;',
  15643. '$mod.Arr[5] = $mod.Arr[6];',
  15644. '$mod.Arr[7] = $mod.Arr[8];',
  15645. 'var $with1 = $mod.Arr;',
  15646. '$with1[9] = $with1[10];',
  15647. '$mod.DoIt($mod.Arr[7], $mod.Arr[8], {',
  15648. ' a: 9,',
  15649. ' p: $mod.Arr,',
  15650. ' get: function () {',
  15651. ' return this.p[this.a];',
  15652. ' },',
  15653. ' set: function (v) {',
  15654. ' this.p[this.a] = v;',
  15655. ' }',
  15656. '}, {',
  15657. ' a: 10,',
  15658. ' p: $mod.Arr,',
  15659. ' get: function () {',
  15660. ' return this.p[this.a];',
  15661. ' },',
  15662. ' set: function (v) {',
  15663. ' this.p[this.a] = v;',
  15664. ' }',
  15665. '});',
  15666. 'var $with2 = $mod.Arr;',
  15667. '$mod.v = $with2[14];',
  15668. '$with2[15] = 16;',
  15669. '$mod.v = $mod.Arr[17];',
  15670. '$mod.Arr[18] = $mod.v;',
  15671. '']));
  15672. end;
  15673. procedure TTestModule.TestExternalClass_BracketAccessor_Call;
  15674. begin
  15675. StartProgram(false);
  15676. Add([
  15677. '{$modeswitch externalclass}',
  15678. 'type',
  15679. ' TJSArray = class external name ''Array2''',
  15680. ' function GetItems(Index: longint): jsvalue; external name ''[]'';',
  15681. ' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';',
  15682. ' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;',
  15683. ' end;',
  15684. ' TMyArr = class(TJSArray)',
  15685. ' procedure DoIt;',
  15686. ' end;',
  15687. 'procedure tmyarr.DoIt;',
  15688. 'begin',
  15689. ' Items[1]:=Items[2];',
  15690. ' SetItems(3,getItems(4));',
  15691. 'end;',
  15692. 'var',
  15693. ' Arr: tmyarr;',
  15694. ' s: string;',
  15695. ' i: longint;',
  15696. ' v: jsvalue;',
  15697. 'begin',
  15698. ' v:=arr[0];',
  15699. ' v:=arr.items[1];',
  15700. ' arr[2]:=s;',
  15701. ' arr.items[3]:=s;',
  15702. ' arr[4]:=i;',
  15703. ' arr[5]:=arr[6];',
  15704. ' arr.items[7]:=arr.items[8];',
  15705. ' with arr do items[9]:=items[10];',
  15706. ' with arr do begin',
  15707. ' v:=GetItems(14);',
  15708. ' setitems(15,16);',
  15709. ' end;',
  15710. '']);
  15711. ConvertProgram;
  15712. CheckSource('TestExternalClass_BracketAccessor_Call',
  15713. LinesToStr([ // statements
  15714. 'rtl.createClassExt($mod, "TMyArr", Array2, "", function () {',
  15715. ' this.$init = function () {',
  15716. ' };',
  15717. ' this.$final = function () {',
  15718. ' };',
  15719. ' this.DoIt = function () {',
  15720. ' this[1] = this[2];',
  15721. ' this[3] = this[4];',
  15722. ' };',
  15723. '});',
  15724. 'this.Arr = null;',
  15725. 'this.s = "";',
  15726. 'this.i = 0;',
  15727. 'this.v = undefined;',
  15728. '']),
  15729. LinesToStr([ // $mod.$main
  15730. '$mod.v = $mod.Arr[0];',
  15731. '$mod.v = $mod.Arr[1];',
  15732. '$mod.Arr[2] = $mod.s;',
  15733. '$mod.Arr[3] = $mod.s;',
  15734. '$mod.Arr[4] = $mod.i;',
  15735. '$mod.Arr[5] = $mod.Arr[6];',
  15736. '$mod.Arr[7] = $mod.Arr[8];',
  15737. 'var $with1 = $mod.Arr;',
  15738. '$with1[9] = $with1[10];',
  15739. 'var $with2 = $mod.Arr;',
  15740. '$mod.v = $with2[14];',
  15741. '$with2[15] = 16;',
  15742. '']));
  15743. end;
  15744. procedure TTestModule.TestExternalClass_BracketAccessor_2ParamsFail;
  15745. begin
  15746. StartProgram(false);
  15747. Add('{$modeswitch externalclass}');
  15748. Add('type');
  15749. Add(' TJSArray = class external name ''Array2''');
  15750. Add(' function GetItems(Index1, Index2: longint): jsvalue; external name ''[]'';');
  15751. Add(' procedure SetItems(Index1, Index2: longint; Value: jsvalue); external name ''[]'';');
  15752. Add(' property Items[Index1, Index2: longint]: jsvalue read GetItems write SetItems; default;');
  15753. Add(' end;');
  15754. Add('begin');
  15755. SetExpectedPasResolverError(sBracketAccessorOfExternalClassMustHaveOneParameter,
  15756. nBracketAccessorOfExternalClassMustHaveOneParameter);
  15757. ConvertProgram;
  15758. end;
  15759. procedure TTestModule.TestExternalClass_BracketAccessor_ReadOnly;
  15760. begin
  15761. StartProgram(false);
  15762. Add('{$modeswitch externalclass}');
  15763. Add('type');
  15764. Add(' TJSArray = class external name ''Array2''');
  15765. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  15766. Add(' property Items[Index: longint]: jsvalue read GetItems; default;');
  15767. Add(' end;');
  15768. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue);');
  15769. Add('begin end;');
  15770. Add('var');
  15771. Add(' Arr: tjsarray;');
  15772. Add(' v: jsvalue;');
  15773. Add('begin');
  15774. Add(' v:=arr[0];');
  15775. Add(' v:=arr.items[1];');
  15776. Add(' with arr do v:=items[2];');
  15777. Add(' doit(arr[3],arr[4]);');
  15778. ConvertProgram;
  15779. CheckSource('TestExternalClass_BracketAccessor_ReadOnly',
  15780. LinesToStr([ // statements
  15781. 'this.DoIt = function (vI, vJ) {',
  15782. '};',
  15783. 'this.Arr = null;',
  15784. 'this.v = undefined;',
  15785. '']),
  15786. LinesToStr([ // $mod.$main
  15787. '$mod.v = $mod.Arr[0];',
  15788. '$mod.v = $mod.Arr[1];',
  15789. 'var $with1 = $mod.Arr;',
  15790. '$mod.v = $with1[2];',
  15791. '$mod.DoIt($mod.Arr[3], $mod.Arr[4]);',
  15792. '']));
  15793. end;
  15794. procedure TTestModule.TestExternalClass_BracketAccessor_WriteOnly;
  15795. begin
  15796. StartProgram(false);
  15797. Add('{$modeswitch externalclass}');
  15798. Add('type');
  15799. Add(' TJSArray = class external name ''Array2''');
  15800. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  15801. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  15802. Add(' end;');
  15803. Add('var');
  15804. Add(' Arr: tjsarray;');
  15805. Add(' s: string;');
  15806. Add(' i: longint;');
  15807. Add(' v: jsvalue;');
  15808. Add('begin');
  15809. Add(' arr[2]:=s;');
  15810. Add(' arr.items[3]:=s;');
  15811. Add(' arr[4]:=i;');
  15812. Add(' with arr do items[5]:=i;');
  15813. ConvertProgram;
  15814. CheckSource('TestExternalClass_BracketAccessor_WriteOnly',
  15815. LinesToStr([ // statements
  15816. 'this.Arr = null;',
  15817. 'this.s = "";',
  15818. 'this.i = 0;',
  15819. 'this.v = undefined;',
  15820. '']),
  15821. LinesToStr([ // $mod.$main
  15822. '$mod.Arr[2] = $mod.s;',
  15823. '$mod.Arr[3] = $mod.s;',
  15824. '$mod.Arr[4] = $mod.i;',
  15825. 'var $with1 = $mod.Arr;',
  15826. '$with1[5] = $mod.i;',
  15827. '']));
  15828. end;
  15829. procedure TTestModule.TestExternalClass_BracketAccessor_MultiType;
  15830. begin
  15831. StartProgram(false);
  15832. Add('{$modeswitch externalclass}');
  15833. Add('type');
  15834. Add(' TJSArray = class external name ''Array2''');
  15835. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  15836. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  15837. Add(' procedure SetNumbers(Index: longint; Value: longint); external name ''[]'';');
  15838. Add(' property Numbers[Index: longint]: longint write SetNumbers;');
  15839. Add(' end;');
  15840. Add('var');
  15841. Add(' Arr: tjsarray;');
  15842. Add(' s: string;');
  15843. Add(' i: longint;');
  15844. Add(' v: jsvalue;');
  15845. Add('begin');
  15846. Add(' arr[2]:=s;');
  15847. Add(' arr.items[3]:=s;');
  15848. Add(' arr.numbers[4]:=i;');
  15849. Add(' with arr do items[5]:=i;');
  15850. Add(' with arr do numbers[6]:=i;');
  15851. ConvertProgram;
  15852. CheckSource('TestExternalClass_BracketAccessor_MultiType',
  15853. LinesToStr([ // statements
  15854. 'this.Arr = null;',
  15855. 'this.s = "";',
  15856. 'this.i = 0;',
  15857. 'this.v = undefined;',
  15858. '']),
  15859. LinesToStr([ // $mod.$main
  15860. '$mod.Arr[2] = $mod.s;',
  15861. '$mod.Arr[3] = $mod.s;',
  15862. '$mod.Arr[4] = $mod.i;',
  15863. 'var $with1 = $mod.Arr;',
  15864. '$with1[5] = $mod.i;',
  15865. 'var $with2 = $mod.Arr;',
  15866. '$with2[6] = $mod.i;',
  15867. '']));
  15868. end;
  15869. procedure TTestModule.TestExternalClass_BracketAccessor_Index;
  15870. begin
  15871. StartProgram(false);
  15872. Add('{$modeswitch externalclass}');
  15873. Add('type');
  15874. Add(' TJSArray = class external name ''Array2''');
  15875. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  15876. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  15877. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  15878. Add(' end;');
  15879. Add('var');
  15880. Add(' Arr: tjsarray;');
  15881. Add(' i: longint;');
  15882. Add(' IntArr: array of longint;');
  15883. Add(' v: jsvalue;');
  15884. Add('begin');
  15885. Add(' v:=arr.items[i];');
  15886. Add(' arr[longint(v)]:=arr.items[intarr[0]];');
  15887. Add(' arr.items[intarr[1]]:=arr[IntArr[2]];');
  15888. ConvertProgram;
  15889. CheckSource('TestExternalClass_BracketAccessor_Index',
  15890. LinesToStr([ // statements
  15891. 'this.Arr = null;',
  15892. 'this.i = 0;',
  15893. 'this.IntArr = [];',
  15894. 'this.v = undefined;',
  15895. '']),
  15896. LinesToStr([ // $mod.$main
  15897. '$mod.v = $mod.Arr[$mod.i];',
  15898. '$mod.Arr[Math.floor($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
  15899. '$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
  15900. '']));
  15901. end;
  15902. procedure TTestModule.TestExternalClass_ForInJSObject;
  15903. begin
  15904. StartProgram(false);
  15905. Add([
  15906. '{$modeswitch externalclass}',
  15907. 'type',
  15908. ' TJSObject = class external name ''Object''',
  15909. ' end;',
  15910. 'var',
  15911. ' o: TJSObject;',
  15912. ' key: string;',
  15913. 'begin',
  15914. ' for key in o do',
  15915. ' if key=''abc'' then ;',
  15916. '']);
  15917. ConvertProgram;
  15918. CheckSource('TestExternalClass_ForInJSObject',
  15919. LinesToStr([ // statements
  15920. 'this.o = null;',
  15921. 'this.key = "";',
  15922. '']),
  15923. LinesToStr([ // $mod.$main
  15924. 'for ($mod.key in $mod.o) if ($mod.key === "abc") ;',
  15925. '']));
  15926. end;
  15927. procedure TTestModule.TestExternalClass_ForInJSArray;
  15928. begin
  15929. StartProgram(false);
  15930. Add([
  15931. '{$modeswitch externalclass}',
  15932. 'type',
  15933. ' TJSInt8Array = class external name ''Int8Array''',
  15934. ' private',
  15935. ' flength: NativeInt external name ''length'';',
  15936. ' function getValue(Index: NativeInt): shortint; external name ''[]'';',
  15937. ' public',
  15938. ' property values[Index: NativeInt]: Shortint Read getValue; default;',
  15939. ' property Length: NativeInt read flength;',
  15940. ' end;',
  15941. 'var',
  15942. ' a: TJSInt8Array;',
  15943. ' value: shortint;',
  15944. 'begin',
  15945. ' for value in a do',
  15946. ' if value=3 then ;',
  15947. '']);
  15948. ConvertProgram;
  15949. CheckSource('TestExternalClass_ForInJSArray',
  15950. LinesToStr([ // statements
  15951. 'this.a = null;',
  15952. 'this.value = 0;',
  15953. '']),
  15954. LinesToStr([ // $mod.$main
  15955. 'for (var $in1 = $mod.a, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) {',
  15956. ' $mod.value = $in1[$l2];',
  15957. ' if ($mod.value === 3) ;',
  15958. '};',
  15959. '']));
  15960. end;
  15961. procedure TTestModule.TestExternalClass_IncompatibleArgDuplicateIdentifier;
  15962. begin
  15963. AddModuleWithIntfImplSrc('unit2.pas',
  15964. LinesToStr([
  15965. '{$modeswitch externalclass}',
  15966. 'type',
  15967. ' TJSBufferSource = class external name ''BufferSource''',
  15968. ' end;',
  15969. 'procedure DoIt(s: TJSBufferSource); external name ''DoIt'';',
  15970. '']),
  15971. '');
  15972. AddModuleWithIntfImplSrc('unit3.pas',
  15973. LinesToStr([
  15974. '{$modeswitch externalclass}',
  15975. 'type',
  15976. ' TJSBufferSource = class external name ''BufferSource''',
  15977. ' end;',
  15978. '']),
  15979. '');
  15980. StartUnit(true);
  15981. Add([
  15982. 'interface',
  15983. 'uses unit2, unit3;',
  15984. 'procedure DoSome(s: TJSBufferSource);',
  15985. 'implementation',
  15986. 'procedure DoSome(s: TJSBufferSource);',
  15987. 'begin',
  15988. ' DoIt(s);',
  15989. 'end;',
  15990. '']);
  15991. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "unit3.TJSBufferSource", expected "unit2.TJSBufferSource"',
  15992. nIncompatibleTypeArgNo);
  15993. ConvertUnit;
  15994. end;
  15995. procedure TTestModule.TestClassInterface_Corba;
  15996. begin
  15997. StartProgram(false);
  15998. Add([
  15999. '{$interfaces corba}',
  16000. 'type',
  16001. ' IUnknown = interface;',
  16002. ' IUnknown = interface',
  16003. ' [''{00000000-0000-0000-C000-000000000046}'']',
  16004. ' end;',
  16005. ' IInterface = IUnknown;',
  16006. ' IBird = interface(IInterface)',
  16007. ' function GetSize: longint;',
  16008. ' procedure SetSize(i: longint);',
  16009. ' property Size: longint read GetSize write SetSize;',
  16010. ' procedure DoIt(i: longint);',
  16011. ' end;',
  16012. ' TObject = class',
  16013. ' end;',
  16014. ' TBird = class(TObject,IBird)',
  16015. ' function GetSize: longint; virtual; abstract;',
  16016. ' procedure SetSize(i: longint); virtual; abstract;',
  16017. ' procedure DoIt(i: longint); virtual; abstract;',
  16018. ' end;',
  16019. 'var',
  16020. ' BirdIntf: IBird;',
  16021. 'begin',
  16022. ' BirdIntf.Size:=BirdIntf.Size;',
  16023. '']);
  16024. ConvertProgram;
  16025. CheckSource('TestClassInterface_Corba',
  16026. LinesToStr([ // statements
  16027. 'rtl.createInterface($mod, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
  16028. 'rtl.createInterface($mod, "IBird", "{5BD1A53B-69BB-37EE-AF32-BEFB86D85B03}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
  16029. 'rtl.createClass($mod, "TObject", null, function () {',
  16030. ' this.$init = function () {',
  16031. ' };',
  16032. ' this.$final = function () {',
  16033. ' };',
  16034. '});',
  16035. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16036. ' rtl.addIntf(this, $mod.IBird);',
  16037. '});',
  16038. 'this.BirdIntf = null;',
  16039. '']),
  16040. LinesToStr([ // $mod.$main
  16041. ' $mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
  16042. '']));
  16043. end;
  16044. procedure TTestModule.TestClassInterface_ProcExternalFail;
  16045. begin
  16046. StartProgram(false);
  16047. Add([
  16048. '{$interfaces corba}',
  16049. 'type',
  16050. ' IUnknown = interface',
  16051. ' procedure DoIt; external name ''foo'';',
  16052. ' end;',
  16053. 'begin']);
  16054. SetExpectedParserError(
  16055. 'Fields are not allowed in interface at token "Identifier external" in file test1.pp at line 6 column 21',
  16056. nParserNoFieldsAllowed);
  16057. ConvertProgram;
  16058. end;
  16059. procedure TTestModule.TestClassInterface_Overloads;
  16060. begin
  16061. StartProgram(false);
  16062. Add([
  16063. '{$interfaces corba}',
  16064. 'type',
  16065. ' integer = longint;',
  16066. ' IUnknown = interface',
  16067. ' procedure DoIt(i: integer);',
  16068. ' procedure DoIt(s: string);',
  16069. ' end;',
  16070. ' IBird = interface(IUnknown)',
  16071. ' procedure DoIt(b: boolean); overload;',
  16072. ' end;',
  16073. ' TObject = class',
  16074. ' end;',
  16075. ' TBird = class(TObject,IBird)',
  16076. ' procedure DoIt(o: TObject);',
  16077. ' procedure DoIt(s: string);',
  16078. ' procedure DoIt(i: integer);',
  16079. ' procedure DoIt(b: boolean);',
  16080. ' end;',
  16081. 'procedure TBird.DoIt(o: TObject); begin end;',
  16082. 'procedure TBird.DoIt(s: string); begin end;',
  16083. 'procedure TBird.DoIt(i: integer); begin end;',
  16084. 'procedure TBird.DoIt(b: boolean); begin end;',
  16085. 'var',
  16086. ' BirdIntf: IBird;',
  16087. 'begin',
  16088. ' BirdIntf.DoIt(3);',
  16089. ' BirdIntf.DoIt(''abc'');',
  16090. ' BirdIntf.DoIt(true);',
  16091. '']);
  16092. ConvertProgram;
  16093. CheckSource('TestClassInterface_Overloads',
  16094. LinesToStr([ // statements
  16095. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2AE2C59400}", ["DoIt", "DoIt$1"], null);',
  16096. 'rtl.createInterface($mod, "IBird", "{8285DD5E-EA3E-396E-AE88-000B86AABF05}", ["DoIt$2"], $mod.IUnknown);',
  16097. 'rtl.createClass($mod, "TObject", null, function () {',
  16098. ' this.$init = function () {',
  16099. ' };',
  16100. ' this.$final = function () {',
  16101. ' };',
  16102. '});',
  16103. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16104. ' this.DoIt = function (o) {',
  16105. ' };',
  16106. ' this.DoIt$1 = function (s) {',
  16107. ' };',
  16108. ' this.DoIt$2 = function (i) {',
  16109. ' };',
  16110. ' this.DoIt$3 = function (b) {',
  16111. ' };',
  16112. ' rtl.addIntf(this, $mod.IBird, {',
  16113. ' DoIt$2: "DoIt$3",',
  16114. ' DoIt: "DoIt$2"',
  16115. ' });',
  16116. '});',
  16117. 'this.BirdIntf = null;',
  16118. '']),
  16119. LinesToStr([ // $mod.$main
  16120. '$mod.BirdIntf.DoIt(3);',
  16121. '$mod.BirdIntf.DoIt$1("abc");',
  16122. '$mod.BirdIntf.DoIt$2(true);',
  16123. '']));
  16124. end;
  16125. procedure TTestModule.TestClassInterface_DuplicateGUIInIntfListFail;
  16126. begin
  16127. StartProgram(false);
  16128. Add([
  16129. '{$interfaces corba}',
  16130. 'type',
  16131. ' IBird = interface',
  16132. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16133. ' end;',
  16134. ' IDog = interface',
  16135. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16136. ' end;',
  16137. ' TObject = class(IBird,IDog)',
  16138. ' end;',
  16139. 'begin']);
  16140. SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IDog and IBird',
  16141. nDuplicateGUIDXInYZ);
  16142. ConvertProgram;
  16143. end;
  16144. procedure TTestModule.TestClassInterface_DuplicateGUIInAncestorFail;
  16145. begin
  16146. StartProgram(false);
  16147. Add([
  16148. '{$interfaces corba}',
  16149. 'type',
  16150. ' IAnimal = interface',
  16151. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16152. ' end;',
  16153. ' IBird = interface(IAnimal)',
  16154. ' end;',
  16155. ' IHawk = interface(IBird)',
  16156. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  16157. ' end;',
  16158. 'begin']);
  16159. SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IHawk and IAnimal',
  16160. nDuplicateGUIDXInYZ);
  16161. ConvertProgram;
  16162. end;
  16163. procedure TTestModule.TestClassInterface_AncestorImpl;
  16164. begin
  16165. StartProgram(false);
  16166. Add([
  16167. '{$interfaces corba}',
  16168. 'type',
  16169. ' integer = longint;',
  16170. ' IUnknown = interface',
  16171. ' procedure DoIt(i: integer);',
  16172. ' end;',
  16173. ' IBird = interface',
  16174. ' procedure Fly(i: integer);',
  16175. ' end;',
  16176. ' TObject = class(IUnknown)',
  16177. ' procedure DoIt(i: integer);',
  16178. ' end;',
  16179. ' TBird = class(IBird)',
  16180. ' procedure Fly(i: integer);',
  16181. ' end;',
  16182. 'procedure TObject.DoIt(i: integer); begin end;',
  16183. 'procedure TBird.Fly(i: integer); begin end;',
  16184. 'begin',
  16185. '']);
  16186. ConvertProgram;
  16187. CheckSource('TestClassInterface_AncestorIntf',
  16188. LinesToStr([ // statements
  16189. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2800000000}", ["DoIt"], null);',
  16190. 'rtl.createInterface($mod, "IBird", "{B92D5841-6264-3AE3-BF20-000000000000}", ["Fly"], null);',
  16191. 'rtl.createClass($mod, "TObject", null, function () {',
  16192. ' this.$init = function () {',
  16193. ' };',
  16194. ' this.$final = function () {',
  16195. ' };',
  16196. ' this.DoIt = function (i) {',
  16197. ' };',
  16198. ' rtl.addIntf(this, $mod.IUnknown);',
  16199. '});',
  16200. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16201. ' this.Fly = function (i) {',
  16202. ' };',
  16203. ' rtl.addIntf(this, $mod.IBird);',
  16204. ' rtl.addIntf(this, $mod.IUnknown);',
  16205. '});',
  16206. '']),
  16207. LinesToStr([ // $mod.$main
  16208. '']));
  16209. end;
  16210. procedure TTestModule.TestClassInterface_ImplReintroduce;
  16211. begin
  16212. StartProgram(false);
  16213. Add([
  16214. '{$interfaces corba}',
  16215. 'type',
  16216. ' integer = longint;',
  16217. ' IBird = interface',
  16218. ' procedure DoIt(i: integer);',
  16219. ' end;',
  16220. ' TObject = class',
  16221. ' procedure DoIt(i: integer);',
  16222. ' end;',
  16223. ' TBird = class(IBird)',
  16224. ' procedure DoIt(i: integer); virtual; reintroduce;',
  16225. ' end;',
  16226. 'procedure TObject.DoIt(i: integer); begin end;',
  16227. 'procedure TBird.DoIt(i: integer); begin end;',
  16228. 'begin',
  16229. '']);
  16230. ConvertProgram;
  16231. CheckSource('TestClassInterface_ImplReintroduce',
  16232. LinesToStr([ // statements
  16233. 'rtl.createInterface($mod, "IBird", "{B92D5841-6264-3AE2-8594-000000000000}", ["DoIt"], null);',
  16234. 'rtl.createClass($mod, "TObject", null, function () {',
  16235. ' this.$init = function () {',
  16236. ' };',
  16237. ' this.$final = function () {',
  16238. ' };',
  16239. ' this.DoIt = function (i) {',
  16240. ' };',
  16241. '});',
  16242. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16243. ' this.DoIt$1 = function (i) {',
  16244. ' };',
  16245. ' rtl.addIntf(this, $mod.IBird, {',
  16246. ' DoIt: "DoIt$1"',
  16247. ' });',
  16248. '});',
  16249. '']),
  16250. LinesToStr([ // $mod.$main
  16251. '']));
  16252. end;
  16253. procedure TTestModule.TestClassInterface_MethodResolution;
  16254. begin
  16255. StartProgram(false);
  16256. Add([
  16257. '{$interfaces corba}',
  16258. 'type',
  16259. ' IUnknown = interface',
  16260. ' procedure Walk(i: longint);',
  16261. ' end;',
  16262. ' IBird = interface(IUnknown)',
  16263. ' procedure Walk(b: boolean); overload;',
  16264. ' procedure Fly(s: string);',
  16265. ' end;',
  16266. ' TObject = class',
  16267. ' end;',
  16268. ' TBird = class(TObject,IBird)',
  16269. ' procedure IBird.Fly = Move;',
  16270. ' procedure IBird.Walk = Hop;',
  16271. ' procedure Hop(i: longint);',
  16272. ' procedure Move(s: string);',
  16273. ' procedure Hop(b: boolean);',
  16274. ' end;',
  16275. 'procedure TBird.Move(s: string); begin end;',
  16276. 'procedure TBird.Hop(i: longint); begin end;',
  16277. 'procedure TBird.Hop(b: boolean); begin end;',
  16278. 'var',
  16279. ' BirdIntf: IBird;',
  16280. 'begin',
  16281. ' BirdIntf.Walk(3);',
  16282. ' BirdIntf.Walk(true);',
  16283. ' BirdIntf.Fly(''abc'');',
  16284. '']);
  16285. ConvertProgram;
  16286. CheckSource('TestClassInterface_MethodResolution',
  16287. LinesToStr([ // statements
  16288. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-BDD7-23D600000000}", ["Walk"], null);',
  16289. 'rtl.createInterface($mod, "IBird", "{CF8A4986-80F6-396E-AE88-000B86AAE208}", ["Walk$1", "Fly"], $mod.IUnknown);',
  16290. 'rtl.createClass($mod, "TObject", null, function () {',
  16291. ' this.$init = function () {',
  16292. ' };',
  16293. ' this.$final = function () {',
  16294. ' };',
  16295. '});',
  16296. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16297. ' this.Hop = function (i) {',
  16298. ' };',
  16299. ' this.Move = function (s) {',
  16300. ' };',
  16301. ' this.Hop$1 = function (b) {',
  16302. ' };',
  16303. ' rtl.addIntf(this, $mod.IBird, {',
  16304. ' Walk$1: "Hop$1",',
  16305. ' Fly: "Move",',
  16306. ' Walk: "Hop"',
  16307. ' });',
  16308. '});',
  16309. 'this.BirdIntf = null;',
  16310. '']),
  16311. LinesToStr([ // $mod.$main
  16312. '$mod.BirdIntf.Walk(3);',
  16313. '$mod.BirdIntf.Walk$1(true);',
  16314. '$mod.BirdIntf.Fly("abc");',
  16315. '']));
  16316. end;
  16317. procedure TTestModule.TestClassInterface_AncestorMoreInterfaces;
  16318. begin
  16319. StartProgram(false);
  16320. Add([
  16321. '{$interfaces com}',
  16322. 'type',
  16323. ' IUnknown = interface',
  16324. ' function _AddRef: longint;',
  16325. ' procedure Walk;',
  16326. ' end;',
  16327. ' IBird = interface end;',
  16328. ' IDog = interface end;',
  16329. ' TObject = class(IBird,IDog)',
  16330. ' function _AddRef: longint; virtual; abstract;',
  16331. ' procedure Walk; virtual; abstract;',
  16332. ' end;',
  16333. ' TBird = class(IUnknown)',
  16334. ' end;',
  16335. 'begin',
  16336. '']);
  16337. ConvertProgram;
  16338. CheckSource('TestClassInterface_COM_AncestorLess',
  16339. LinesToStr([ // statements
  16340. 'rtl.createInterface($mod, "IUnknown", "{8F2D5841-758A-322B-BDDF-21CD521DD723}", ["_AddRef", "Walk"], null);',
  16341. 'rtl.createInterface($mod, "IBird", "{CCE11D4C-6504-3AEE-AE88-000B86AAE675}", [], $mod.IUnknown);',
  16342. 'rtl.createInterface($mod, "IDog", "{CCE11D4C-6504-3AEE-AE88-000B8E5FC675}", [], $mod.IUnknown);',
  16343. 'rtl.createClass($mod, "TObject", null, function () {',
  16344. ' this.$init = function () {',
  16345. ' };',
  16346. ' this.$final = function () {',
  16347. ' };',
  16348. ' rtl.addIntf(this, $mod.IBird);',
  16349. ' rtl.addIntf(this, $mod.IDog);',
  16350. '});',
  16351. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16352. ' rtl.addIntf(this, $mod.IUnknown);',
  16353. ' rtl.addIntf(this, $mod.IBird);',
  16354. ' rtl.addIntf(this, $mod.IDog);',
  16355. '});',
  16356. '']),
  16357. LinesToStr([ // $mod.$main
  16358. '']));
  16359. end;
  16360. procedure TTestModule.TestClassInterface_MethodOverride;
  16361. begin
  16362. StartProgram(false);
  16363. Add([
  16364. '{$interfaces corba}',
  16365. 'type',
  16366. ' IUnknown = interface',
  16367. ' [''{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}'']',
  16368. ' procedure Go;',
  16369. ' end;',
  16370. ' TObject = class(IUnknown)',
  16371. ' procedure Go; virtual; abstract;',
  16372. ' end;',
  16373. ' TBird = class',
  16374. ' procedure Go; override;',
  16375. ' end;',
  16376. ' TCat = class(TObject)',
  16377. ' procedure Go; override;',
  16378. ' end;',
  16379. ' TDog = class(TObject, IUnknown)',
  16380. ' procedure Go; override;',
  16381. ' end;',
  16382. 'procedure TBird.Go; begin end;',
  16383. 'procedure TCat.Go; begin end;',
  16384. 'procedure TDog.Go; begin end;',
  16385. 'begin',
  16386. '']);
  16387. ConvertProgram;
  16388. CheckSource('TestClassInterface_MethodOverride',
  16389. LinesToStr([ // statements
  16390. 'rtl.createInterface($mod, "IUnknown", "{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}", ["Go"], null);',
  16391. 'rtl.createClass($mod, "TObject", null, function () {',
  16392. ' this.$init = function () {',
  16393. ' };',
  16394. ' this.$final = function () {',
  16395. ' };',
  16396. ' rtl.addIntf(this, $mod.IUnknown);',
  16397. '});',
  16398. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16399. ' this.Go = function () {',
  16400. ' };',
  16401. ' rtl.addIntf(this, $mod.IUnknown);',
  16402. '});',
  16403. 'rtl.createClass($mod, "TCat", $mod.TObject, function () {',
  16404. ' this.Go = function () {',
  16405. ' };',
  16406. ' rtl.addIntf(this, $mod.IUnknown);',
  16407. '});',
  16408. 'rtl.createClass($mod, "TDog", $mod.TObject, function () {',
  16409. ' this.Go = function () {',
  16410. ' };',
  16411. ' rtl.addIntf(this, $mod.IUnknown);',
  16412. '});',
  16413. '']),
  16414. LinesToStr([ // $mod.$main
  16415. '']));
  16416. end;
  16417. procedure TTestModule.TestClassInterface_Corba_Delegation;
  16418. begin
  16419. StartProgram(false);
  16420. Add([
  16421. '{$interfaces corba}',
  16422. 'type',
  16423. ' IUnknown = interface',
  16424. ' end;',
  16425. ' IBird = interface(IUnknown)',
  16426. ' procedure Fly(s: string);',
  16427. ' end;',
  16428. ' IEagle = interface(IBird)',
  16429. ' end;',
  16430. ' IDove = interface(IBird)',
  16431. ' end;',
  16432. ' ISwallow = interface(IBird)',
  16433. ' end;',
  16434. ' TObject = class',
  16435. ' end;',
  16436. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  16437. ' procedure Fly(s: string); virtual; abstract;',
  16438. ' end;',
  16439. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  16440. ' FBirdIntf: IBird;',
  16441. ' property BirdIntf: IBird read FBirdIntf implements IBird;',
  16442. ' function GetEagleIntf: IEagle; virtual; abstract;',
  16443. ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  16444. ' FDoveObj: TBird;',
  16445. ' property DoveObj: TBird read FDoveObj implements IDove;',
  16446. ' function GetSwallowObj: TBird; virtual; abstract;',
  16447. ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  16448. ' end;',
  16449. 'begin',
  16450. '']);
  16451. ConvertProgram;
  16452. CheckSource('TestClassInterface_Delegation',
  16453. LinesToStr([ // statements
  16454. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16455. 'rtl.createInterface($mod, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], $mod.IUnknown);',
  16456. 'rtl.createInterface($mod, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], $mod.IBird);',
  16457. 'rtl.createInterface($mod, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], $mod.IBird);',
  16458. 'rtl.createInterface($mod, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], $mod.IBird);',
  16459. 'rtl.createClass($mod, "TObject", null, function () {',
  16460. ' this.$init = function () {',
  16461. ' };',
  16462. ' this.$final = function () {',
  16463. ' };',
  16464. '});',
  16465. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16466. ' rtl.addIntf(this, $mod.IBird);',
  16467. ' rtl.addIntf(this, $mod.IEagle);',
  16468. ' rtl.addIntf(this, $mod.IDove);',
  16469. ' rtl.addIntf(this, $mod.ISwallow);',
  16470. '});',
  16471. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  16472. ' this.$init = function () {',
  16473. ' $mod.TObject.$init.call(this);',
  16474. ' this.FBirdIntf = null;',
  16475. ' this.FDoveObj = null;',
  16476. ' };',
  16477. ' this.$final = function () {',
  16478. ' this.FBirdIntf = undefined;',
  16479. ' this.FDoveObj = undefined;',
  16480. ' $mod.TObject.$final.call(this);',
  16481. ' };',
  16482. ' this.$intfmaps = {',
  16483. ' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
  16484. ' return this.FBirdIntf;',
  16485. ' },',
  16486. ' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
  16487. ' return this.GetEagleIntf();',
  16488. ' },',
  16489. ' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
  16490. ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
  16491. ' },',
  16492. ' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
  16493. ' return rtl.getIntfT(this.GetSwallowObj(), $mod.ISwallow);',
  16494. ' }',
  16495. ' };',
  16496. '});',
  16497. '']),
  16498. LinesToStr([ // $mod.$main
  16499. '']));
  16500. end;
  16501. procedure TTestModule.TestClassInterface_Corba_DelegationStatic;
  16502. begin
  16503. StartProgram(false);
  16504. Add([
  16505. '{$interfaces corba}',
  16506. 'type',
  16507. ' IUnknown = interface',
  16508. ' end;',
  16509. ' IBird = interface(IUnknown)',
  16510. ' procedure Fly(s: string);',
  16511. ' end;',
  16512. ' IEagle = interface(IBird)',
  16513. ' end;',
  16514. ' IDove = interface(IBird)',
  16515. ' end;',
  16516. ' ISwallow = interface(IBird)',
  16517. ' end;',
  16518. ' TObject = class',
  16519. ' end;',
  16520. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  16521. ' procedure Fly(s: string); virtual; abstract;',
  16522. ' end;',
  16523. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  16524. ' private',
  16525. ' class var FBirdIntf: IBird;',
  16526. ' class var FDoveObj: TBird;',
  16527. ' class function GetEagleIntf: IEagle; virtual; abstract;',
  16528. ' class function GetSwallowObj: TBird; virtual; abstract;',
  16529. ' protected',
  16530. ' class property BirdIntf: IBird read FBirdIntf implements IBird;',
  16531. ' class property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  16532. ' class property DoveObj: TBird read FDoveObj implements IDove;',
  16533. ' class property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  16534. ' end;',
  16535. 'begin',
  16536. '']);
  16537. ConvertProgram;
  16538. CheckSource('TestClassInterface_DelegationStatic',
  16539. LinesToStr([ // statements
  16540. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16541. 'rtl.createInterface($mod, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], $mod.IUnknown);',
  16542. 'rtl.createInterface($mod, "IEagle", "{489289DE-FDE2-34A6-8288-39119022B1B4}", [], $mod.IBird);',
  16543. 'rtl.createInterface($mod, "IDove", "{489289DE-FDE2-34A6-8288-39118EF16074}", [], $mod.IBird);',
  16544. 'rtl.createInterface($mod, "ISwallow", "{B89289DE-FDE2-34A6-8288-3911CBDCB359}", [], $mod.IBird);',
  16545. 'rtl.createClass($mod, "TObject", null, function () {',
  16546. ' this.$init = function () {',
  16547. ' };',
  16548. ' this.$final = function () {',
  16549. ' };',
  16550. '});',
  16551. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16552. ' rtl.addIntf(this, $mod.IBird);',
  16553. ' rtl.addIntf(this, $mod.IEagle);',
  16554. ' rtl.addIntf(this, $mod.IDove);',
  16555. ' rtl.addIntf(this, $mod.ISwallow);',
  16556. '});',
  16557. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  16558. ' this.FBirdIntf = null;',
  16559. ' this.FDoveObj = null;',
  16560. ' this.$intfmaps = {',
  16561. ' "{478D080B-C0F6-396E-AE88-000B87785B07}": function () {',
  16562. ' return this.FBirdIntf;',
  16563. ' },',
  16564. ' "{489289DE-FDE2-34A6-8288-39119022B1B4}": function () {',
  16565. ' return this.$class.GetEagleIntf();',
  16566. ' },',
  16567. ' "{489289DE-FDE2-34A6-8288-39118EF16074}": function () {',
  16568. ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
  16569. ' },',
  16570. ' "{B89289DE-FDE2-34A6-8288-3911CBDCB359}": function () {',
  16571. ' return rtl.getIntfT(this.$class.GetSwallowObj(), $mod.ISwallow);',
  16572. ' }',
  16573. ' };',
  16574. '});',
  16575. '']),
  16576. LinesToStr([ // $mod.$main
  16577. '']));
  16578. end;
  16579. procedure TTestModule.TestClassInterface_Corba_Operators;
  16580. begin
  16581. StartProgram(false);
  16582. Add([
  16583. '{$interfaces corba}',
  16584. 'type',
  16585. ' IUnknown = interface',
  16586. ' end;',
  16587. ' IBird = interface(IUnknown)',
  16588. ' function GetItems(Index: longint): longint;',
  16589. ' procedure SetItems(Index: longint; Value: longint);',
  16590. ' property Items[Index: longint]: longint read GetItems write SetItems; default;',
  16591. ' end;',
  16592. ' TObject = class',
  16593. ' end;',
  16594. ' TBird = class(TObject,IBird)',
  16595. ' function GetItems(Index: longint): longint; virtual; abstract;',
  16596. ' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
  16597. ' end;',
  16598. 'var',
  16599. ' IntfVar: IBird = nil;',
  16600. ' IntfVar2: IBird;',
  16601. ' ObjVar: TBird;',
  16602. ' v: JSValue;',
  16603. 'begin',
  16604. ' IntfVar:=nil;',
  16605. ' IntfVar[3]:=IntfVar[4];',
  16606. ' if Assigned(IntfVar) then ;',
  16607. ' IntfVar:=IntfVar2;',
  16608. ' IntfVar:=ObjVar;',
  16609. ' if IntfVar=IntfVar2 then ;',
  16610. ' if IntfVar<>IntfVar2 then ;',
  16611. ' if IntfVar is IBird then ;',
  16612. ' if IntfVar is TBird then ;',
  16613. ' if ObjVar is IBird then ;',
  16614. ' IntfVar:=IntfVar2 as IBird;',
  16615. ' ObjVar:=IntfVar2 as TBird;',
  16616. ' IntfVar:=ObjVar as IBird;',
  16617. ' IntfVar:=IBird(IntfVar2);',
  16618. ' ObjVar:=TBird(IntfVar);',
  16619. ' IntfVar:=IBird(ObjVar);',
  16620. ' v:=IntfVar;',
  16621. ' IntfVar:=IBird(v);',
  16622. ' if v is IBird then ;',
  16623. ' v:=JSValue(IntfVar);',
  16624. ' v:=IBird;',
  16625. '']);
  16626. ConvertProgram;
  16627. CheckSource('TestClassInterface_Corba_Operators',
  16628. LinesToStr([ // statements
  16629. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16630. 'rtl.createInterface($mod, "IBird", "{D53FED90-DE59-3202-B1AE-000B87785B08}", ["GetItems", "SetItems"], $mod.IUnknown);',
  16631. 'rtl.createClass($mod, "TObject", null, function () {',
  16632. ' this.$init = function () {',
  16633. ' };',
  16634. ' this.$final = function () {',
  16635. ' };',
  16636. '});',
  16637. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16638. ' rtl.addIntf(this, $mod.IBird);',
  16639. '});',
  16640. 'this.IntfVar = null;',
  16641. 'this.IntfVar2 = null;',
  16642. 'this.ObjVar = null;',
  16643. 'this.v = undefined;',
  16644. '']),
  16645. LinesToStr([ // $mod.$main
  16646. '$mod.IntfVar = null;',
  16647. '$mod.IntfVar.SetItems(3, $mod.IntfVar.GetItems(4));',
  16648. 'if ($mod.IntfVar != null) ;',
  16649. '$mod.IntfVar = $mod.IntfVar2;',
  16650. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar,$mod.IBird);',
  16651. 'if ($mod.IntfVar === $mod.IntfVar2) ;',
  16652. 'if ($mod.IntfVar !== $mod.IntfVar2) ;',
  16653. 'if ($mod.IBird.isPrototypeOf($mod.IntfVar)) ;',
  16654. 'if (rtl.intfIsClass($mod.IntfVar, $mod.TBird)) ;',
  16655. 'if (rtl.getIntfT($mod.ObjVar, $mod.IBird) !== null) ;',
  16656. '$mod.IntfVar = rtl.as($mod.IntfVar2, $mod.IBird);',
  16657. '$mod.ObjVar = rtl.intfAsClass($mod.IntfVar2, $mod.TBird);',
  16658. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
  16659. '$mod.IntfVar = $mod.IntfVar2;',
  16660. '$mod.ObjVar = rtl.intfToClass($mod.IntfVar, $mod.TBird);',
  16661. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
  16662. '$mod.v = $mod.IntfVar;',
  16663. '$mod.IntfVar = rtl.getObject($mod.v);',
  16664. 'if (rtl.isExt($mod.v, $mod.IBird, 1)) ;',
  16665. '$mod.v = rtl.getObject($mod.IntfVar);',
  16666. '$mod.v = $mod.IBird;',
  16667. '']));
  16668. end;
  16669. procedure TTestModule.TestClassInterface_Corba_Args;
  16670. begin
  16671. StartProgram(false);
  16672. Add([
  16673. '{$interfaces corba}',
  16674. 'type',
  16675. ' IUnknown = interface',
  16676. ' end;',
  16677. ' IBird = interface(IUnknown)',
  16678. ' end;',
  16679. ' TObject = class',
  16680. ' end;',
  16681. ' TBird = class(TObject,IBird)',
  16682. ' end;',
  16683. 'procedure DoIt(var u; i: IBird; const j: IBird);',
  16684. 'begin',
  16685. ' DoIt(i,i,i);',
  16686. 'end;',
  16687. 'procedure Change(var i: IBird; out j: IBird);',
  16688. 'begin',
  16689. ' DoIt(i,i,i);',
  16690. ' Change(i,i);',
  16691. 'end;',
  16692. 'var',
  16693. ' i: IBird;',
  16694. ' o: TBird;',
  16695. 'begin',
  16696. ' DoIt(i,i,i);',
  16697. ' Change(i,i);',
  16698. ' DoIt(o,o,o);',
  16699. '']);
  16700. ConvertProgram;
  16701. CheckSource('TestClassInterface_Corba_Args',
  16702. LinesToStr([ // statements
  16703. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16704. 'rtl.createInterface($mod, "IBird", "{4B0D080B-C0F6-396E-AE88-000B87785074}", [], $mod.IUnknown);',
  16705. 'rtl.createClass($mod, "TObject", null, function () {',
  16706. ' this.$init = function () {',
  16707. ' };',
  16708. ' this.$final = function () {',
  16709. ' };',
  16710. '});',
  16711. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16712. ' rtl.addIntf(this, $mod.IBird);',
  16713. '});',
  16714. 'this.DoIt = function (u, i, j) {',
  16715. ' $mod.DoIt({',
  16716. ' get: function () {',
  16717. ' return i;',
  16718. ' },',
  16719. ' set: function (v) {',
  16720. ' i = v;',
  16721. ' }',
  16722. ' }, i, i);',
  16723. '};',
  16724. 'this.Change = function (i, j) {',
  16725. ' $mod.DoIt(i, i.get(), i.get());',
  16726. ' $mod.Change(i, i);',
  16727. '};',
  16728. 'this.i = null;',
  16729. 'this.o = null;',
  16730. '']),
  16731. LinesToStr([ // $mod.$main
  16732. '$mod.DoIt({',
  16733. ' p: $mod,',
  16734. ' get: function () {',
  16735. ' return this.p.i;',
  16736. ' },',
  16737. ' set: function (v) {',
  16738. ' this.p.i = v;',
  16739. ' }',
  16740. '}, $mod.i, $mod.i);',
  16741. '$mod.Change({',
  16742. ' p: $mod,',
  16743. ' get: function () {',
  16744. ' return this.p.i;',
  16745. ' },',
  16746. ' set: function (v) {',
  16747. ' this.p.i = v;',
  16748. ' }',
  16749. '}, {',
  16750. ' p: $mod,',
  16751. ' get: function () {',
  16752. ' return this.p.i;',
  16753. ' },',
  16754. ' set: function (v) {',
  16755. ' this.p.i = v;',
  16756. ' }',
  16757. '});',
  16758. '$mod.DoIt({',
  16759. ' p: $mod,',
  16760. ' get: function () {',
  16761. ' return this.p.o;',
  16762. ' },',
  16763. ' set: function (v) {',
  16764. ' this.p.o = v;',
  16765. ' }',
  16766. '}, rtl.getIntfT($mod.o, $mod.IBird), rtl.getIntfT($mod.o, $mod.IBird));',
  16767. '']));
  16768. end;
  16769. procedure TTestModule.TestClassInterface_Corba_ForIn;
  16770. begin
  16771. StartProgram(false);
  16772. Add([
  16773. '{$interfaces corba}',
  16774. 'type',
  16775. ' IUnknown = interface end;',
  16776. ' TObject = class',
  16777. ' Id: longint;',
  16778. ' end;',
  16779. ' IEnumerator = interface(IUnknown)',
  16780. ' function GetCurrent: TObject;',
  16781. ' function MoveNext: Boolean;',
  16782. ' property Current: TObject read GetCurrent;',
  16783. ' end;',
  16784. ' IEnumerable = interface(IUnknown)',
  16785. ' function GetEnumerator: IEnumerator;',
  16786. ' end;',
  16787. 'var',
  16788. ' o: TObject;',
  16789. ' i: IEnumerable;',
  16790. 'begin',
  16791. ' for o in i do o.Id:=3;',
  16792. '']);
  16793. ConvertProgram;
  16794. CheckSource('TestClassInterface_Corba_ForIn',
  16795. LinesToStr([ // statements
  16796. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  16797. 'rtl.createClass($mod, "TObject", null, function () {',
  16798. ' this.$init = function () {',
  16799. ' this.Id = 0;',
  16800. ' };',
  16801. ' this.$final = function () {',
  16802. ' };',
  16803. '});',
  16804. 'rtl.createInterface($mod, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
  16805. 'rtl.createInterface($mod, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], $mod.IUnknown);',
  16806. 'this.o = null;',
  16807. 'this.i = null;',
  16808. '']),
  16809. LinesToStr([ // $mod.$main
  16810. 'var $in1 = $mod.i.GetEnumerator();',
  16811. 'while ($in1.MoveNext()) {',
  16812. ' $mod.o = $in1.GetCurrent();',
  16813. ' $mod.o.Id = 3;',
  16814. '};',
  16815. '']));
  16816. end;
  16817. procedure TTestModule.TestClassInterface_COM_AssignVar;
  16818. begin
  16819. StartProgram(false);
  16820. Add([
  16821. '{$interfaces com}',
  16822. 'type',
  16823. ' IUnknown = interface',
  16824. ' function _AddRef: longint;',
  16825. ' function _Release: longint;',
  16826. ' end;',
  16827. ' TObject = class(IUnknown)',
  16828. ' function _AddRef: longint; virtual; abstract;',
  16829. ' function _Release: longint; virtual; abstract;',
  16830. ' end;',
  16831. 'var',
  16832. ' i: IUnknown;',
  16833. 'procedure DoGlobal(o: TObject);',
  16834. 'begin',
  16835. ' i:=nil;',
  16836. ' i:=o;',
  16837. ' i:=i;',
  16838. 'end;',
  16839. 'procedure DoLocal(o: TObject);',
  16840. 'const k: IUnknown = nil;',
  16841. 'var j: IUnknown;',
  16842. 'begin',
  16843. ' k:=o;',
  16844. ' k:=i;',
  16845. ' j:=o;',
  16846. ' j:=i;',
  16847. 'end;',
  16848. 'var o: TObject;',
  16849. 'begin',
  16850. ' i:=nil;',
  16851. ' i:=o;',
  16852. '']);
  16853. ConvertProgram;
  16854. CheckSource('TestClassInterface_COM_AssignVar',
  16855. LinesToStr([ // statements
  16856. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  16857. 'rtl.createClass($mod, "TObject", null, function () {',
  16858. ' this.$init = function () {',
  16859. ' };',
  16860. ' this.$final = function () {',
  16861. ' };',
  16862. ' rtl.addIntf(this, $mod.IUnknown);',
  16863. '});',
  16864. 'this.i = null;',
  16865. 'this.DoGlobal = function (o) {',
  16866. ' rtl.setIntfP($mod, "i", null);',
  16867. ' rtl.setIntfP($mod, "i", rtl.queryIntfT(o, $mod.IUnknown), true);',
  16868. ' rtl.setIntfP($mod, "i", $mod.i);',
  16869. '};',
  16870. 'var k = null;',
  16871. 'this.DoLocal = function (o) {',
  16872. ' var j = null;',
  16873. ' try{',
  16874. ' k = rtl.setIntfL(k, rtl.queryIntfT(o, $mod.IUnknown), true);',
  16875. ' k = rtl.setIntfL(k, $mod.i);',
  16876. ' j = rtl.setIntfL(j, rtl.queryIntfT(o, $mod.IUnknown), true);',
  16877. ' j = rtl.setIntfL(j, $mod.i);',
  16878. ' }finally{',
  16879. ' rtl._Release(j);',
  16880. ' };',
  16881. '};',
  16882. 'this.o = null;',
  16883. '']),
  16884. LinesToStr([ // $mod.$main
  16885. 'rtl.setIntfP($mod, "i", null);',
  16886. 'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.o, $mod.IUnknown), true);',
  16887. '']));
  16888. end;
  16889. procedure TTestModule.TestClassInterface_COM_AssignArg;
  16890. begin
  16891. StartProgram(false);
  16892. Add([
  16893. '{$interfaces com}',
  16894. 'type',
  16895. ' IUnknown = interface',
  16896. ' function _AddRef: longint;',
  16897. ' function _Release: longint;',
  16898. ' end;',
  16899. ' TObject = class(IUnknown)',
  16900. ' function _AddRef: longint; virtual; abstract;',
  16901. ' function _Release: longint; virtual; abstract;',
  16902. ' end;',
  16903. 'procedure DoDefault(i, j: IUnknown);',
  16904. 'begin',
  16905. ' i:=nil;',
  16906. ' i:=j;',
  16907. 'end;',
  16908. 'begin',
  16909. '']);
  16910. ConvertProgram;
  16911. CheckSource('TestClassInterface_COM_AssignArg',
  16912. LinesToStr([ // statements
  16913. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  16914. 'rtl.createClass($mod, "TObject", null, function () {',
  16915. ' this.$init = function () {',
  16916. ' };',
  16917. ' this.$final = function () {',
  16918. ' };',
  16919. ' rtl.addIntf(this, $mod.IUnknown);',
  16920. '});',
  16921. 'this.DoDefault = function (i, j) {',
  16922. ' rtl._AddRef(i);',
  16923. ' try {',
  16924. ' i = rtl.setIntfL(i, null);',
  16925. ' i = rtl.setIntfL(i, j);',
  16926. ' } finally {',
  16927. ' rtl._Release(i);',
  16928. ' };',
  16929. '};',
  16930. '']),
  16931. LinesToStr([ // $mod.$main
  16932. '']));
  16933. end;
  16934. procedure TTestModule.TestClassInterface_COM_FunctionResult;
  16935. begin
  16936. StartProgram(false);
  16937. Add([
  16938. '{$interfaces com}',
  16939. 'type',
  16940. ' IUnknown = interface',
  16941. ' function _AddRef: longint;',
  16942. ' function _Release: longint;',
  16943. ' end;',
  16944. ' TObject = class(IUnknown)',
  16945. ' function _AddRef: longint; virtual; abstract;',
  16946. ' function _Release: longint; virtual; abstract;',
  16947. ' end;',
  16948. 'function DoDefault(i: IUnknown): IUnknown;',
  16949. 'begin',
  16950. ' Result:=i;',
  16951. ' if Result<>nil then exit;',
  16952. 'end;',
  16953. 'begin',
  16954. '']);
  16955. ConvertProgram;
  16956. CheckSource('TestClassInterface_COM_FunctionResult',
  16957. LinesToStr([ // statements
  16958. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  16959. 'rtl.createClass($mod, "TObject", null, function () {',
  16960. ' this.$init = function () {',
  16961. ' };',
  16962. ' this.$final = function () {',
  16963. ' };',
  16964. ' rtl.addIntf(this, $mod.IUnknown);',
  16965. '});',
  16966. 'this.DoDefault = function (i) {',
  16967. ' var Result = null;',
  16968. ' var $ok = false;',
  16969. ' try {',
  16970. ' Result = rtl.setIntfL(Result, i);',
  16971. ' if(Result !== null){',
  16972. ' $ok = true;',
  16973. ' return Result;',
  16974. ' };',
  16975. ' $ok = true;',
  16976. ' } finally {',
  16977. ' if(!$ok) rtl._Release(Result);',
  16978. ' };',
  16979. ' return Result;',
  16980. '};',
  16981. '']),
  16982. LinesToStr([ // $mod.$main
  16983. '']));
  16984. end;
  16985. procedure TTestModule.TestClassInterface_COM_InheritedFuncResult;
  16986. begin
  16987. StartProgram(false);
  16988. Add([
  16989. '{$interfaces com}',
  16990. 'type',
  16991. ' IUnknown = interface',
  16992. ' function _AddRef: longint;',
  16993. ' function _Release: longint;',
  16994. ' end;',
  16995. ' TObject = class(IUnknown)',
  16996. ' function _AddRef: longint; virtual; abstract;',
  16997. ' function _Release: longint; virtual; abstract;',
  16998. ' function GetIntf: IUnknown; virtual;',
  16999. ' end;',
  17000. ' TMouse = class',
  17001. ' function GetIntf: IUnknown; override;',
  17002. ' end;',
  17003. 'function TObject.GetIntf: IUnknown; begin end;',
  17004. 'function TMouse.GetIntf: IUnknown;',
  17005. 'var i: IUnknown;',
  17006. 'begin',
  17007. ' inherited;',
  17008. ' inherited GetIntf;',
  17009. ' inherited GetIntf();',
  17010. ' Result:=inherited GetIntf;',
  17011. ' Result:=inherited GetIntf();',
  17012. ' i:=inherited GetIntf;',
  17013. ' i:=inherited GetIntf();',
  17014. 'end;',
  17015. 'begin',
  17016. '']);
  17017. ConvertProgram;
  17018. CheckSource('TestClassInterface_COM_InheritedFuncResult',
  17019. LinesToStr([ // statements
  17020. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17021. 'rtl.createClass($mod, "TObject", null, function () {',
  17022. ' this.$init = function () {',
  17023. ' };',
  17024. ' this.$final = function () {',
  17025. ' };',
  17026. ' this.GetIntf = function () {',
  17027. ' var Result = null;',
  17028. ' return Result;',
  17029. ' };',
  17030. ' rtl.addIntf(this, $mod.IUnknown);',
  17031. '});',
  17032. 'rtl.createClass($mod, "TMouse", $mod.TObject, function () {',
  17033. ' this.GetIntf = function () {',
  17034. ' var Result = null;',
  17035. ' var i = null;',
  17036. ' var $ir = rtl.createIntfRefs();',
  17037. ' var $ok = false;',
  17038. ' try {',
  17039. ' $ir.ref(1, $mod.TObject.GetIntf.call(this));',
  17040. ' $ir.ref(2, $mod.TObject.GetIntf.call(this));',
  17041. ' $ir.ref(3, $mod.TObject.GetIntf.call(this));',
  17042. ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
  17043. ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
  17044. ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
  17045. ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
  17046. ' $ok = true;',
  17047. ' } finally {',
  17048. ' $ir.free();',
  17049. ' rtl._Release(i);',
  17050. ' if (!$ok) rtl._Release(Result);',
  17051. ' };',
  17052. ' return Result;',
  17053. ' };',
  17054. ' rtl.addIntf(this, $mod.IUnknown);',
  17055. '});',
  17056. '']),
  17057. LinesToStr([ // $mod.$main
  17058. '']));
  17059. end;
  17060. procedure TTestModule.TestClassInterface_COM_IsAsTypeCasts;
  17061. begin
  17062. StartProgram(false);
  17063. Add([
  17064. '{$interfaces com}',
  17065. 'type',
  17066. ' IUnknown = interface',
  17067. ' function _AddRef: longint;',
  17068. ' function _Release: longint;',
  17069. ' end;',
  17070. ' TObject = class(IUnknown)',
  17071. ' function _AddRef: longint; virtual; abstract;',
  17072. ' function _Release: longint; virtual; abstract;',
  17073. ' end;',
  17074. 'procedure DoDefault(i, j: IUnknown; o: TObject);',
  17075. 'begin',
  17076. ' if i is IUnknown then ;',
  17077. ' if o is IUnknown then ;',
  17078. ' if i is TObject then ;',
  17079. ' i:=j as IUnknown;',
  17080. ' i:=o as IUnknown;',
  17081. ' o:=j as TObject;',
  17082. ' i:=IUnknown(j);',
  17083. ' i:=IUnknown(o);',
  17084. ' o:=TObject(i);',
  17085. 'end;',
  17086. 'begin',
  17087. '']);
  17088. ConvertProgram;
  17089. CheckSource('TestClassInterface_COM_IsAsTypeCasts',
  17090. LinesToStr([ // statements
  17091. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17092. 'rtl.createClass($mod, "TObject", null, function () {',
  17093. ' this.$init = function () {',
  17094. ' };',
  17095. ' this.$final = function () {',
  17096. ' };',
  17097. ' rtl.addIntf(this, $mod.IUnknown);',
  17098. '});',
  17099. 'this.DoDefault = function (i, j, o) {',
  17100. ' rtl._AddRef(i);',
  17101. ' try {',
  17102. ' if ($mod.IUnknown.isPrototypeOf(i)) ;',
  17103. ' if (rtl.queryIntfIsT(o, $mod.IUnknown)) ;',
  17104. ' if (rtl.intfIsClass(i, $mod.TObject)) ;',
  17105. ' i = rtl.setIntfL(i, rtl.as(j, $mod.IUnknown));',
  17106. ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
  17107. ' o = rtl.intfAsClass(j, $mod.TObject);',
  17108. ' i = rtl.setIntfL(i, j);',
  17109. ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
  17110. ' o = rtl.intfToClass(i, $mod.TObject);',
  17111. ' } finally {',
  17112. ' rtl._Release(i);',
  17113. ' };',
  17114. '};',
  17115. '']),
  17116. LinesToStr([ // $mod.$main
  17117. '']));
  17118. end;
  17119. procedure TTestModule.TestClassInterface_COM_PassAsArg;
  17120. begin
  17121. StartProgram(false);
  17122. Add([
  17123. '{$interfaces com}',
  17124. 'type',
  17125. ' IUnknown = interface',
  17126. ' function _AddRef: longint;',
  17127. ' function _Release: longint;',
  17128. ' end;',
  17129. ' TObject = class(IUnknown)',
  17130. ' function _AddRef: longint; virtual; abstract;',
  17131. ' function _Release: longint; virtual; abstract;',
  17132. ' end;',
  17133. 'procedure DoIt(v: IUnknown; const j: IUnknown; var k: IUnknown; out l: IUnknown);',
  17134. 'var o: TObject;',
  17135. 'begin',
  17136. ' DoIt(v,v,v,v);',
  17137. ' DoIt(o,o,k,k);',
  17138. 'end;',
  17139. 'procedure DoSome;',
  17140. 'var v: IUnknown;',
  17141. 'begin',
  17142. ' DoIt(v,v,v,v);',
  17143. 'end;',
  17144. 'var i: IUnknown;',
  17145. 'begin',
  17146. ' DoIt(i,i,i,i);',
  17147. '']);
  17148. ConvertProgram;
  17149. CheckSource('TestClassInterface_COM_PassAsArg',
  17150. LinesToStr([ // statements
  17151. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17152. 'rtl.createClass($mod, "TObject", null, function () {',
  17153. ' this.$init = function () {',
  17154. ' };',
  17155. ' this.$final = function () {',
  17156. ' };',
  17157. ' rtl.addIntf(this, $mod.IUnknown);',
  17158. '});',
  17159. 'this.DoIt = function (v, j, k, l) {',
  17160. ' var o = null;',
  17161. ' var $ir = rtl.createIntfRefs();',
  17162. ' rtl._AddRef(v);',
  17163. ' try {',
  17164. ' $mod.DoIt(v, v, {',
  17165. ' get: function () {',
  17166. ' return v;',
  17167. ' },',
  17168. ' set: function (w) {',
  17169. ' v = rtl.setIntfL(v, w);',
  17170. ' }',
  17171. ' }, {',
  17172. ' get: function () {',
  17173. ' return v;',
  17174. ' },',
  17175. ' set: function (w) {',
  17176. ' v = rtl.setIntfL(v, w);',
  17177. ' }',
  17178. ' });',
  17179. ' $mod.DoIt($ir.ref(1, rtl.queryIntfT(o, $mod.IUnknown)), $ir.ref(2, rtl.queryIntfT(o, $mod.IUnknown)), k, k);',
  17180. ' } finally {',
  17181. ' $ir.free();',
  17182. ' rtl._Release(v);',
  17183. ' };',
  17184. '};',
  17185. 'this.DoSome = function () {',
  17186. ' var v = null;',
  17187. ' try {',
  17188. ' $mod.DoIt(v, v, {',
  17189. ' get: function () {',
  17190. ' return v;',
  17191. ' },',
  17192. ' set: function (w) {',
  17193. ' v = rtl.setIntfL(v, w);',
  17194. ' }',
  17195. ' }, {',
  17196. ' get: function () {',
  17197. ' return v;',
  17198. ' },',
  17199. ' set: function (w) {',
  17200. ' v = rtl.setIntfL(v, w);',
  17201. ' }',
  17202. ' });',
  17203. ' } finally {',
  17204. ' rtl._Release(v);',
  17205. ' };',
  17206. '};',
  17207. 'this.i = null;',
  17208. '']),
  17209. LinesToStr([ // $mod.$main
  17210. '$mod.DoIt($mod.i, $mod.i, {',
  17211. ' p: $mod,',
  17212. ' get: function () {',
  17213. ' return this.p.i;',
  17214. ' },',
  17215. ' set: function (v) {',
  17216. ' rtl.setIntfP(this.p, "i", v);',
  17217. ' }',
  17218. '}, {',
  17219. ' p: $mod,',
  17220. ' get: function () {',
  17221. ' return this.p.i;',
  17222. ' },',
  17223. ' set: function (v) {',
  17224. ' rtl.setIntfP(this.p, "i", v);',
  17225. ' }',
  17226. '});',
  17227. '']));
  17228. end;
  17229. procedure TTestModule.TestClassInterface_COM_PassToUntypedParam;
  17230. begin
  17231. StartProgram(false);
  17232. Add([
  17233. '{$interfaces com}',
  17234. 'type',
  17235. ' IUnknown = interface',
  17236. ' function _AddRef: longint;',
  17237. ' function _Release: longint;',
  17238. ' end;',
  17239. ' TObject = class(IUnknown)',
  17240. ' function _AddRef: longint; virtual; abstract;',
  17241. ' function _Release: longint; virtual; abstract;',
  17242. ' end;',
  17243. 'procedure DoIt(out i);',
  17244. 'begin end;',
  17245. 'procedure DoSome;',
  17246. 'var v: IUnknown;',
  17247. 'begin',
  17248. ' DoIt(v);',
  17249. 'end;',
  17250. 'function GetIt: IUnknown;',
  17251. 'begin',
  17252. ' DoIt(Result);',
  17253. 'end;',
  17254. 'var i: IUnknown;',
  17255. 'begin',
  17256. ' DoIt(i);',
  17257. '']);
  17258. ConvertProgram;
  17259. CheckSource('TestClassInterface_COM_PassToUntypedParam',
  17260. LinesToStr([ // statements
  17261. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17262. 'rtl.createClass($mod, "TObject", null, function () {',
  17263. ' this.$init = function () {',
  17264. ' };',
  17265. ' this.$final = function () {',
  17266. ' };',
  17267. ' rtl.addIntf(this, $mod.IUnknown);',
  17268. '});',
  17269. 'this.DoIt = function (i) {',
  17270. '};',
  17271. 'this.DoSome = function () {',
  17272. ' var v = null;',
  17273. ' try {',
  17274. ' $mod.DoIt({',
  17275. ' get: function () {',
  17276. ' return v;',
  17277. ' },',
  17278. ' set: function (w) {',
  17279. ' v = w;',
  17280. ' }',
  17281. ' });',
  17282. ' } finally {',
  17283. ' rtl._Release(v);',
  17284. ' };',
  17285. '};',
  17286. 'this.GetIt = function () {',
  17287. ' var Result = null;',
  17288. ' var $ok = false;',
  17289. ' try {',
  17290. ' $mod.DoIt({',
  17291. ' get: function () {',
  17292. ' return Result;',
  17293. ' },',
  17294. ' set: function (v) {',
  17295. ' Result = v;',
  17296. ' }',
  17297. ' });',
  17298. ' $ok = true;',
  17299. ' } finally {',
  17300. ' if (!$ok) rtl._Release(Result);',
  17301. ' };',
  17302. ' return Result;',
  17303. '};',
  17304. 'this.i = null;',
  17305. '']),
  17306. LinesToStr([ // $mod.$main
  17307. 'try {',
  17308. ' $mod.DoIt({',
  17309. ' p: $mod,',
  17310. ' get: function () {',
  17311. ' return this.p.i;',
  17312. ' },',
  17313. ' set: function (v) {',
  17314. ' this.p.i = v;',
  17315. ' }',
  17316. ' });',
  17317. '} finally {',
  17318. ' rtl._Release($mod.i);',
  17319. '};',
  17320. '']));
  17321. end;
  17322. procedure TTestModule.TestClassInterface_COM_FunctionInExpr;
  17323. begin
  17324. StartProgram(false);
  17325. Add([
  17326. '{$interfaces com}',
  17327. 'type',
  17328. ' IUnknown = interface',
  17329. ' function _AddRef: longint;',
  17330. ' function _Release: longint;',
  17331. ' end;',
  17332. ' TObject = class(IUnknown)',
  17333. ' function _AddRef: longint; virtual; abstract;',
  17334. ' function _Release: longint; virtual; abstract;',
  17335. ' end;',
  17336. 'function GetIt: IUnknown;',
  17337. 'begin',
  17338. 'end;',
  17339. 'procedure DoSome;',
  17340. 'var v: IUnknown;',
  17341. ' i: longint;',
  17342. 'begin',
  17343. ' v:=GetIt;',
  17344. ' v:=GetIt();',
  17345. ' GetIt()._AddRef;',
  17346. ' i:=GetIt()._AddRef;',
  17347. 'end;',
  17348. 'var v: IUnknown;',
  17349. ' i: longint;',
  17350. 'begin',
  17351. ' v:=GetIt;',
  17352. ' v:=GetIt();',
  17353. ' GetIt()._AddRef;',
  17354. ' i:=GetIt()._AddRef;',
  17355. '']);
  17356. ConvertProgram;
  17357. CheckSource('TestClassInterface_COM_FunctionInExpr',
  17358. LinesToStr([ // statements
  17359. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17360. 'rtl.createClass($mod, "TObject", null, function () {',
  17361. ' this.$init = function () {',
  17362. ' };',
  17363. ' this.$final = function () {',
  17364. ' };',
  17365. ' rtl.addIntf(this, $mod.IUnknown);',
  17366. '});',
  17367. 'this.GetIt = function () {',
  17368. ' var Result = null;',
  17369. ' return Result;',
  17370. '};',
  17371. 'this.DoSome = function () {',
  17372. ' var v = null;',
  17373. ' var i = 0;',
  17374. ' var $ir = rtl.createIntfRefs();',
  17375. ' try {',
  17376. ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
  17377. ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
  17378. ' $ir.ref(1, $mod.GetIt())._AddRef();',
  17379. ' i = $ir.ref(2, $mod.GetIt())._AddRef();',
  17380. ' } finally {',
  17381. ' $ir.free();',
  17382. ' rtl._Release(v);',
  17383. ' };',
  17384. '};',
  17385. 'this.v = null;',
  17386. 'this.i = 0;',
  17387. '']),
  17388. LinesToStr([ // $mod.$main
  17389. 'var $ir = rtl.createIntfRefs();',
  17390. 'try {',
  17391. ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
  17392. ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
  17393. ' $ir.ref(1, $mod.GetIt())._AddRef();',
  17394. ' $mod.i = $ir.ref(2, $mod.GetIt())._AddRef();',
  17395. '} finally {',
  17396. ' $ir.free();',
  17397. '};',
  17398. '']));
  17399. end;
  17400. procedure TTestModule.TestClassInterface_COM_Property;
  17401. begin
  17402. StartProgram(false);
  17403. Add([
  17404. '{$interfaces com}',
  17405. 'type',
  17406. ' IUnknown = interface',
  17407. ' function _AddRef: longint;',
  17408. ' function _Release: longint;',
  17409. ' end;',
  17410. ' TObject = class(IUnknown)',
  17411. ' FAnt: IUnknown;',
  17412. ' function _AddRef: longint; virtual; abstract;',
  17413. ' function _Release: longint; virtual; abstract;',
  17414. ' function GetBird: IUnknown; virtual; abstract;',
  17415. ' procedure SetBird(Value: IUnknown); virtual; abstract;',
  17416. ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
  17417. ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
  17418. ' property Ant: IUnknown read FAnt write FAnt;',
  17419. ' property Bird: IUnknown read GetBird write SetBird;',
  17420. ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
  17421. ' end;',
  17422. 'procedure DoIt;',
  17423. 'var',
  17424. ' o: TObject;',
  17425. ' v: IUnknown;',
  17426. 'begin',
  17427. ' v:=o.Ant;',
  17428. ' o.Ant:=v;',
  17429. ' o.Ant:=o.Ant;',
  17430. ' v:=o.Bird;',
  17431. ' o.Bird:=v;',
  17432. ' o.Bird:=o.Bird;',
  17433. ' v:=o.Items[1];',
  17434. ' o.Items[2]:=v;',
  17435. ' o.Items[3]:=o.Items[4];',
  17436. ' v:=o[5];',
  17437. ' o[6]:=v;',
  17438. ' o[7]:=o[8];',
  17439. 'end;',
  17440. 'begin',
  17441. '']);
  17442. ConvertProgram;
  17443. CheckSource('TestClassInterface_COM_Property',
  17444. LinesToStr([ // statements
  17445. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17446. 'rtl.createClass($mod, "TObject", null, function () {',
  17447. ' this.$init = function () {',
  17448. ' this.FAnt = null;',
  17449. ' };',
  17450. ' this.$final = function () {',
  17451. ' this.FAnt = undefined;',
  17452. ' };',
  17453. ' rtl.addIntf(this, $mod.IUnknown);',
  17454. '});',
  17455. 'this.DoIt = function () {',
  17456. ' var o = null;',
  17457. ' var v = null;',
  17458. ' var $ir = rtl.createIntfRefs();',
  17459. ' try {',
  17460. ' v = rtl.setIntfL(v, o.FAnt);',
  17461. ' rtl.setIntfP(o, "FAnt", v);',
  17462. ' rtl.setIntfP(o, "FAnt", o.FAnt);',
  17463. ' v = rtl.setIntfL(v, o.GetBird(), true);',
  17464. ' o.SetBird(v);',
  17465. ' o.SetBird($ir.ref(1, o.GetBird()));',
  17466. ' v = rtl.setIntfL(v, o.GetItems(1), true);',
  17467. ' o.SetItems(2, v);',
  17468. ' o.SetItems(3, $ir.ref(2, o.GetItems(4)));',
  17469. ' v = rtl.setIntfL(v, o.GetItems(5), true);',
  17470. ' o.SetItems(6, v);',
  17471. ' o.SetItems(7, $ir.ref(3, o.GetItems(8)));',
  17472. ' } finally {',
  17473. ' $ir.free();',
  17474. ' rtl._Release(v);',
  17475. ' };',
  17476. '};',
  17477. '']),
  17478. LinesToStr([ // $mod.$main
  17479. '']));
  17480. end;
  17481. procedure TTestModule.TestClassInterface_COM_IntfProperty;
  17482. begin
  17483. StartProgram(false);
  17484. Add([
  17485. '{$interfaces com}',
  17486. 'type',
  17487. ' IUnknown = interface',
  17488. ' function _AddRef: longint;',
  17489. ' function _Release: longint;',
  17490. ' function GetBird: IUnknown;',
  17491. ' procedure SetBird(Value: IUnknown);',
  17492. ' function GetItems(Index: longint): IUnknown;',
  17493. ' procedure SetItems(Index: longint; Value: IUnknown);',
  17494. ' property Bird: IUnknown read GetBird write SetBird;',
  17495. ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
  17496. ' end;',
  17497. ' TObject = class(IUnknown)',
  17498. ' function _AddRef: longint; virtual; abstract;',
  17499. ' function _Release: longint; virtual; abstract;',
  17500. ' function GetBird: IUnknown; virtual; abstract;',
  17501. ' procedure SetBird(Value: IUnknown); virtual; abstract;',
  17502. ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
  17503. ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
  17504. ' end;',
  17505. 'procedure DoIt;',
  17506. 'var',
  17507. ' o: TObject;',
  17508. ' v: IUnknown;',
  17509. 'begin',
  17510. ' v:=v.Items[1];',
  17511. ' v.Items[2]:=v;',
  17512. ' v.Items[3]:=v.Items[4];',
  17513. ' v:=v[5];',
  17514. ' v[6]:=v;',
  17515. ' v[7]:=v[8];',
  17516. ' v[9].Bird.Bird:=v;',
  17517. ' v:=v.Bird[10].Bird',
  17518. 'end;',
  17519. 'begin',
  17520. '']);
  17521. ConvertProgram;
  17522. CheckSource('TestClassInterface_COM_IntfProperty',
  17523. LinesToStr([ // statements
  17524. 'rtl.createInterface($mod, "IUnknown", "{385F5482-571B-338C-8130-4E97F330543B}", [',
  17525. ' "_AddRef",',
  17526. ' "_Release",',
  17527. ' "GetBird",',
  17528. ' "SetBird",',
  17529. ' "GetItems",',
  17530. ' "SetItems"',
  17531. '], null);',
  17532. 'rtl.createClass($mod, "TObject", null, function () {',
  17533. ' this.$init = function () {',
  17534. ' };',
  17535. ' this.$final = function () {',
  17536. ' };',
  17537. ' rtl.addIntf(this, $mod.IUnknown);',
  17538. '});',
  17539. 'this.DoIt = function () {',
  17540. ' var o = null;',
  17541. ' var v = null;',
  17542. ' var $ir = rtl.createIntfRefs();',
  17543. ' try {',
  17544. ' v = rtl.setIntfL(v, v.GetItems(1), true);',
  17545. ' v.SetItems(2, v);',
  17546. ' v.SetItems(3, $ir.ref(1, v.GetItems(4)));',
  17547. ' v = rtl.setIntfL(v, v.GetItems(5), true);',
  17548. ' v.SetItems(6, v);',
  17549. ' v.SetItems(7, $ir.ref(2, v.GetItems(8)));',
  17550. ' $ir.ref(4, $ir.ref(3, v.GetItems(9)).GetBird()).SetBird(v);',
  17551. ' v = rtl.setIntfL(v, $ir.ref(6, $ir.ref(5, v.GetBird()).GetItems(10)).GetBird(), true);',
  17552. ' } finally {',
  17553. ' $ir.free();',
  17554. ' rtl._Release(v);',
  17555. ' };',
  17556. '};',
  17557. '']),
  17558. LinesToStr([ // $mod.$main
  17559. '']));
  17560. end;
  17561. procedure TTestModule.TestClassInterface_COM_Delegation;
  17562. begin
  17563. StartProgram(false);
  17564. Add([
  17565. '{$interfaces com}',
  17566. 'type',
  17567. ' IUnknown = interface',
  17568. ' function _AddRef: longint;',
  17569. ' function _Release: longint;',
  17570. ' end;',
  17571. ' IBird = interface(IUnknown)',
  17572. ' procedure Fly(s: string);',
  17573. ' end;',
  17574. ' IEagle = interface(IBird) end;',
  17575. ' IDove = interface(IBird) end;',
  17576. ' ISwallow = interface(IBird) end;',
  17577. ' TObject = class',
  17578. ' end;',
  17579. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  17580. ' function _AddRef: longint; virtual; abstract;',
  17581. ' function _Release: longint; virtual; abstract;',
  17582. ' procedure Fly(s: string); virtual; abstract;',
  17583. ' end;',
  17584. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  17585. ' function _AddRef: longint; virtual; abstract;',
  17586. ' function _Release: longint; virtual; abstract;',
  17587. ' FBirdIntf: IBird;',
  17588. ' property BirdIntf: IBird read FBirdIntf implements IBird;',
  17589. ' function GetEagleIntf: IEagle; virtual; abstract;',
  17590. ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  17591. ' FDoveObj: TBird;',
  17592. ' property DoveObj: TBird read FDoveObj implements IDove;',
  17593. ' function GetSwallowObj: TBird; virtual; abstract;',
  17594. ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  17595. ' end;',
  17596. 'begin',
  17597. '']);
  17598. ConvertProgram;
  17599. CheckSource('TestClassInterface_COM_Delegation',
  17600. LinesToStr([ // statements
  17601. 'rtl.createInterface($mod, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
  17602. 'rtl.createInterface($mod, "IBird", "{CC440C7F-7623-3DEE-AE88-000B86AAF108}", ["Fly"], $mod.IUnknown);',
  17603. 'rtl.createInterface($mod, "IEagle", "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}", [], $mod.IBird);',
  17604. 'rtl.createInterface($mod, "IDove", "{4B6A41C9-B020-3D7C-B688-96D18EF16074}", [], $mod.IBird);',
  17605. 'rtl.createInterface($mod, "ISwallow", "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}", [], $mod.IBird);',
  17606. 'rtl.createClass($mod, "TObject", null, function () {',
  17607. ' this.$init = function () {',
  17608. ' };',
  17609. ' this.$final = function () {',
  17610. ' };',
  17611. '});',
  17612. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  17613. ' rtl.addIntf(this, $mod.IBird);',
  17614. ' rtl.addIntf(this, $mod.IEagle);',
  17615. ' rtl.addIntf(this, $mod.IDove);',
  17616. ' rtl.addIntf(this, $mod.ISwallow);',
  17617. '});',
  17618. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  17619. ' this.$init = function () {',
  17620. ' $mod.TObject.$init.call(this);',
  17621. ' this.FBirdIntf = null;',
  17622. ' this.FDoveObj = null;',
  17623. ' };',
  17624. ' this.$final = function () {',
  17625. ' this.FBirdIntf = undefined;',
  17626. ' this.FDoveObj = undefined;',
  17627. ' $mod.TObject.$final.call(this);',
  17628. ' };',
  17629. ' this.$intfmaps = {',
  17630. ' "{CC440C7F-7623-3DEE-AE88-000B86AAF108}": function () {',
  17631. ' return rtl._AddRef(this.FBirdIntf);',
  17632. ' },',
  17633. ' "{4B6A41C9-B020-3D7C-B688-96D19022B1B4}": function () {',
  17634. ' return this.GetEagleIntf();',
  17635. ' },',
  17636. ' "{4B6A41C9-B020-3D7C-B688-96D18EF16074}": function () {',
  17637. ' return rtl.queryIntfT(this.FDoveObj, $mod.IDove);',
  17638. ' },',
  17639. ' "{BB6A41C9-B020-3D7C-B688-96D1CBDCB359}": function () {',
  17640. ' return rtl.queryIntfT(this.GetSwallowObj(), $mod.ISwallow);',
  17641. ' }',
  17642. ' };',
  17643. '});',
  17644. '']),
  17645. LinesToStr([ // $mod.$main
  17646. '']));
  17647. end;
  17648. procedure TTestModule.TestClassInterface_COM_With;
  17649. begin
  17650. StartProgram(false);
  17651. Add([
  17652. '{$interfaces com}',
  17653. 'type',
  17654. ' IUnknown = interface',
  17655. ' function _AddRef: longint;',
  17656. ' function _Release: longint;',
  17657. ' function GetAnt: IUnknown;',
  17658. ' property Ant: IUnknown read GetAnt;',
  17659. ' end;',
  17660. ' TObject = class(IUnknown)',
  17661. ' function _AddRef: longint; virtual; abstract;',
  17662. ' function _Release: longint; virtual; abstract;',
  17663. ' function GetAnt: IUnknown; virtual; abstract;',
  17664. ' property Ant: IUnknown read GetAnt;',
  17665. ' end;',
  17666. 'procedure DoIt;',
  17667. 'var',
  17668. ' i: IUnknown;',
  17669. 'begin',
  17670. ' with i do ',
  17671. ' GetAnt;',
  17672. ' with i.Ant, Ant do ',
  17673. ' GetAnt;',
  17674. 'end;',
  17675. 'begin',
  17676. '']);
  17677. ConvertProgram;
  17678. CheckSource('TestClassInterface_COM_With',
  17679. LinesToStr([ // statements
  17680. 'rtl.createInterface($mod, "IUnknown", "{D7ADB00D-C6B6-39FB-BDDF-21CD521DDFA9}", ["_AddRef", "_Release", "GetAnt"], null);',
  17681. 'rtl.createClass($mod, "TObject", null, function () {',
  17682. ' this.$init = function () {',
  17683. ' };',
  17684. ' this.$final = function () {',
  17685. ' };',
  17686. ' rtl.addIntf(this, $mod.IUnknown);',
  17687. '});',
  17688. 'this.DoIt = function () {',
  17689. ' var i = null;',
  17690. ' var $ir = rtl.createIntfRefs();',
  17691. ' try {',
  17692. ' $ir.ref(1, i.GetAnt());',
  17693. ' var $with1 = $ir.ref(2, i.GetAnt());',
  17694. ' var $with2 = $ir.ref(3, $with1.GetAnt());',
  17695. ' $ir.ref(4, $with2.GetAnt());',
  17696. ' } finally {',
  17697. ' $ir.free();',
  17698. ' };',
  17699. '};',
  17700. '']),
  17701. LinesToStr([ // $mod.$main
  17702. '']));
  17703. end;
  17704. procedure TTestModule.TestClassInterface_COM_ForIn;
  17705. begin
  17706. StartProgram(false);
  17707. Add([
  17708. '{$interfaces com}',
  17709. 'type',
  17710. ' IUnknown = interface end;',
  17711. ' TObject = class',
  17712. ' Id: longint;',
  17713. ' end;',
  17714. ' IEnumerator = interface(IUnknown)',
  17715. ' function GetCurrent: TObject;',
  17716. ' function MoveNext: Boolean;',
  17717. ' property Current: TObject read GetCurrent;',
  17718. ' end;',
  17719. ' IEnumerable = interface(IUnknown)',
  17720. ' function GetEnumerator: IEnumerator;',
  17721. ' end;',
  17722. 'var',
  17723. ' o: TObject;',
  17724. ' i: IEnumerable;',
  17725. 'begin',
  17726. ' for o in i do o.Id:=3;',
  17727. '']);
  17728. ConvertProgram;
  17729. CheckSource('TestClassInterface_COM_ForIn',
  17730. LinesToStr([ // statements
  17731. 'rtl.createInterface($mod, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
  17732. 'rtl.createClass($mod, "TObject", null, function () {',
  17733. ' this.$init = function () {',
  17734. ' this.Id = 0;',
  17735. ' };',
  17736. ' this.$final = function () {',
  17737. ' };',
  17738. '});',
  17739. 'rtl.createInterface($mod, "IEnumerator", "{95D7745D-ED61-3F13-BBE4-07708161999E}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
  17740. 'rtl.createInterface($mod, "IEnumerable", "{8CC9D45D-ED7D-3B73-96B6-290B931BB19E}", ["GetEnumerator"], $mod.IUnknown);',
  17741. 'this.o = null;',
  17742. 'this.i = null;',
  17743. '']),
  17744. LinesToStr([ // $mod.$main
  17745. 'var $in1 = $mod.i.GetEnumerator();',
  17746. 'try {',
  17747. ' while ($in1.MoveNext()) {',
  17748. ' $mod.o = $in1.GetCurrent();',
  17749. ' $mod.o.Id = 3;',
  17750. ' }',
  17751. '} finally {',
  17752. ' rtl._Release($in1)',
  17753. '};',
  17754. '']));
  17755. end;
  17756. procedure TTestModule.TestClassInterface_COM_ArrayOfIntfFail;
  17757. begin
  17758. StartProgram(false);
  17759. Add([
  17760. '{$interfaces com}',
  17761. 'type',
  17762. ' IUnknown = interface',
  17763. ' function _AddRef: longint;',
  17764. ' function _Release: longint;',
  17765. ' end;',
  17766. ' TObject = class',
  17767. ' end;',
  17768. ' TArrOfIntf = array of IUnknown;',
  17769. 'begin',
  17770. '']);
  17771. SetExpectedPasResolverError('Not supported: array of COM-interface',nNotSupportedX);
  17772. ConvertProgram;
  17773. end;
  17774. procedure TTestModule.TestClassInterface_COM_RecordIntfFail;
  17775. begin
  17776. StartProgram(false);
  17777. Add([
  17778. '{$interfaces com}',
  17779. 'type',
  17780. ' IUnknown = interface',
  17781. ' function _AddRef: longint;',
  17782. ' function _Release: longint;',
  17783. ' end;',
  17784. ' TRec = record',
  17785. ' i: IUnknown;',
  17786. ' end;',
  17787. 'begin',
  17788. '']);
  17789. SetExpectedPasResolverError('Not supported: COM-interface as record member',nNotSupportedX);
  17790. ConvertProgram;
  17791. end;
  17792. procedure TTestModule.TestClassInterface_COM_UnitInitialization;
  17793. begin
  17794. StartUnit(false);
  17795. Add([
  17796. '{$interfaces com}',
  17797. 'interface',
  17798. 'implementation',
  17799. 'type',
  17800. ' IUnknown = interface',
  17801. ' function _AddRef: longint;',
  17802. ' end;',
  17803. ' TObject = class(IUnknown)',
  17804. ' function _AddRef: longint;',
  17805. ' end;',
  17806. 'function TObject._AddRef: longint; begin end;',
  17807. 'var i: IUnknown;',
  17808. ' o: TObject;',
  17809. 'initialization',
  17810. ' i:=nil;',
  17811. ' i:=i;',
  17812. ' i:=o;',
  17813. ' if (o as IUnknown)=nil then ;',
  17814. '']);
  17815. ConvertUnit;
  17816. CheckSource('TestClassInterface_COM_UnitInitialization',
  17817. LinesToStr([ // statements
  17818. 'var $impl = $mod.$impl;',
  17819. '']),
  17820. LinesToStr([ // this.$init
  17821. 'var $ir = rtl.createIntfRefs();',
  17822. 'try {',
  17823. ' rtl.setIntfP($impl, "i", null);',
  17824. ' rtl.setIntfP($impl, "i", $impl.i);',
  17825. ' rtl.setIntfP($impl, "i", rtl.queryIntfT($impl.o, $impl.IUnknown), true);',
  17826. ' if ($ir.ref(1, rtl.queryIntfT($impl.o, $impl.IUnknown)) === null) ;',
  17827. '} finally {',
  17828. ' $ir.free();',
  17829. '};',
  17830. '']),
  17831. LinesToStr([ // implementation
  17832. 'rtl.createInterface($impl, "IUnknown", "{B92D5841-758A-322B-BDDF-21CD52180000}", ["_AddRef"], null);',
  17833. 'rtl.createClass($impl, "TObject", null, function () {',
  17834. ' this.$init = function () {',
  17835. ' };',
  17836. ' this.$final = function () {',
  17837. ' };',
  17838. ' this._AddRef = function () {',
  17839. ' var Result = 0;',
  17840. ' return Result;',
  17841. ' };',
  17842. ' rtl.addIntf(this, $impl.IUnknown);',
  17843. '});',
  17844. '$impl.i = null;',
  17845. '$impl.o = null;',
  17846. ''])
  17847. );
  17848. end;
  17849. procedure TTestModule.TestClassInterface_GUID;
  17850. begin
  17851. StartProgram(false);
  17852. Add([
  17853. '{$interfaces corba}',
  17854. 'type',
  17855. ' IUnknown = interface',
  17856. ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
  17857. ' end;',
  17858. ' TObject = class end;',
  17859. ' TGUID = record D1, D2, D3, D4: word; end;',
  17860. ' TAliasGUID = TGUID;',
  17861. ' TGUIDString = type string;',
  17862. ' TAliasGUIDString = TGUIDString;',
  17863. 'procedure DoConstGUIDIt(const g: TAliasGUID); overload;',
  17864. 'begin end;',
  17865. 'procedure DoDefGUID(g: TAliasGUID); overload;',
  17866. 'begin end;',
  17867. 'procedure DoStr(const s: TAliasGUIDString); overload;',
  17868. 'begin end;',
  17869. 'var',
  17870. ' i: IUnknown;',
  17871. ' g: TAliasGUID = ''{d91c9af4-3C93-420F-A303-BF5BA82BFD23}'';',
  17872. ' s: TAliasGUIDString;',
  17873. 'begin',
  17874. ' DoConstGUIDIt(IUnknown);',
  17875. ' DoDefGUID(IUnknown);',
  17876. ' DoStr(IUnknown);',
  17877. ' DoConstGUIDIt(i);',
  17878. ' DoDefGUID(i);',
  17879. ' DoStr(i);',
  17880. ' DoConstGUIDIt(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
  17881. ' DoDefGUID(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
  17882. ' DoStr(g);',
  17883. ' g:=i;',
  17884. ' g:=IUnknown;',
  17885. ' g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
  17886. ' s:=i;',
  17887. ' s:=IUnknown;',
  17888. ' s:=g;',
  17889. ' if g=i then ;',
  17890. ' if i=g then ;',
  17891. ' if g=IUnknown then ;',
  17892. ' if IUnknown=g then ;',
  17893. ' if s=i then ;',
  17894. ' if i=s then ;',
  17895. ' if s=IUnknown then ;',
  17896. ' if IUnknown=s then ;',
  17897. ' if s=g then ;',
  17898. ' if g=s then ;',
  17899. '']);
  17900. ConvertProgram;
  17901. CheckSource('TestClassInterface_GUID',
  17902. LinesToStr([ // statements
  17903. 'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
  17904. 'rtl.createClass($mod, "TObject", null, function () {',
  17905. ' this.$init = function () {',
  17906. ' };',
  17907. ' this.$final = function () {',
  17908. ' };',
  17909. '});',
  17910. 'rtl.recNewT($mod, "TGUID", function () {',
  17911. ' this.D1 = 0;',
  17912. ' this.D2 = 0;',
  17913. ' this.D3 = 0;',
  17914. ' this.D4 = 0;',
  17915. ' this.$eq = function (b) {',
  17916. ' return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
  17917. ' };',
  17918. ' this.$assign = function (s) {',
  17919. ' this.D1 = s.D1;',
  17920. ' this.D2 = s.D2;',
  17921. ' this.D3 = s.D3;',
  17922. ' this.D4 = s.D4;',
  17923. ' return this;',
  17924. ' };',
  17925. '});',
  17926. 'this.DoConstGUIDIt = function (g) {',
  17927. '};',
  17928. 'this.DoDefGUID = function (g) {',
  17929. '};',
  17930. 'this.DoStr = function (s) {',
  17931. '};',
  17932. 'this.i = null;',
  17933. 'this.g = $mod.TGUID.$clone({',
  17934. ' D1: 0xD91C9AF4,',
  17935. ' D2: 0x3C93,',
  17936. ' D3: 0x420F,',
  17937. ' D4: [',
  17938. ' 0xA3,',
  17939. ' 0x03,',
  17940. ' 0xBF,',
  17941. ' 0x5B,',
  17942. ' 0xA8,',
  17943. ' 0x2B,',
  17944. ' 0xFD,',
  17945. ' 0x23',
  17946. ' ]',
  17947. '});',
  17948. 'this.s = "";',
  17949. '']),
  17950. LinesToStr([ // $mod.$main
  17951. '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.IUnknown));',
  17952. '$mod.DoDefGUID($mod.TGUID.$clone(rtl.getIntfGUIDR($mod.IUnknown)));',
  17953. '$mod.DoStr($mod.IUnknown.$guid);',
  17954. '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.i));',
  17955. '$mod.DoDefGUID($mod.TGUID.$clone(rtl.getIntfGUIDR($mod.i)));',
  17956. '$mod.DoStr($mod.i.$guid);',
  17957. '$mod.DoConstGUIDIt(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
  17958. '$mod.DoDefGUID(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
  17959. '$mod.DoStr(rtl.guidrToStr($mod.g));',
  17960. '$mod.g.$assign(rtl.getIntfGUIDR($mod.i));',
  17961. '$mod.g.$assign(rtl.getIntfGUIDR($mod.IUnknown));',
  17962. '$mod.g.$assign({',
  17963. ' D1: 0xD91C9AF4,',
  17964. ' D2: 0x3C93,',
  17965. ' D3: 0x420F,',
  17966. ' D4: [',
  17967. ' 0xA3,',
  17968. ' 0x03,',
  17969. ' 0xBF,',
  17970. ' 0x5B,',
  17971. ' 0xA8,',
  17972. ' 0x2B,',
  17973. ' 0xFD,',
  17974. ' 0x23',
  17975. ' ]',
  17976. '});',
  17977. '$mod.s = $mod.i.$guid;',
  17978. '$mod.s = $mod.IUnknown.$guid;',
  17979. '$mod.s = rtl.guidrToStr($mod.g);',
  17980. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.i))) ;',
  17981. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.i))) ;',
  17982. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.IUnknown))) ;',
  17983. 'if ($mod.g.$eq(rtl.getIntfGUIDR($mod.IUnknown))) ;',
  17984. 'if ($mod.s === $mod.i.$guid) ;',
  17985. 'if ($mod.i.$guid === $mod.s) ;',
  17986. 'if ($mod.s === $mod.IUnknown.$guid) ;',
  17987. 'if ($mod.IUnknown.$guid === $mod.s) ;',
  17988. 'if ($mod.g.$eq(rtl.createTGUID($mod.s))) ;',
  17989. 'if ($mod.g.$eq(rtl.createTGUID($mod.s))) ;',
  17990. '']));
  17991. end;
  17992. procedure TTestModule.TestClassInterface_GUIDProperty;
  17993. begin
  17994. StartProgram(false);
  17995. Add([
  17996. '{$interfaces corba}',
  17997. 'type',
  17998. ' IUnknown = interface',
  17999. ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
  18000. ' end;',
  18001. ' TGUID = record D1, D2, D3, D4: word; end;',
  18002. ' TAliasGUID = TGUID;',
  18003. ' TGUIDString = type string;',
  18004. ' TAliasGUIDString = TGUIDString;',
  18005. ' TObject = class',
  18006. ' function GetG: TAliasGUID; virtual; abstract;',
  18007. ' procedure SetG(const Value: TAliasGUID); virtual; abstract;',
  18008. ' function GetS: TAliasGUIDString; virtual; abstract;',
  18009. ' procedure SetS(const Value: TAliasGUIDString); virtual; abstract;',
  18010. ' property g: TAliasGUID read GetG write SetG;',
  18011. ' property s: TAliasGUIDString read GetS write SetS;',
  18012. ' end;',
  18013. 'var o: TObject;',
  18014. 'begin',
  18015. ' o.g:=IUnknown;',
  18016. ' o.g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
  18017. ' o.s:=IUnknown;',
  18018. ' o.s:=o.g;',
  18019. '']);
  18020. ConvertProgram;
  18021. CheckSource('TestClassInterface_GUIDProperty',
  18022. LinesToStr([ // statements
  18023. 'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
  18024. 'rtl.recNewT($mod, "TGUID", function () {',
  18025. ' this.D1 = 0;',
  18026. ' this.D2 = 0;',
  18027. ' this.D3 = 0;',
  18028. ' this.D4 = 0;',
  18029. ' this.$eq = function (b) {',
  18030. ' return (this.D1 === b.D1) && (this.D2 === b.D2) && (this.D3 === b.D3) && (this.D4 === b.D4);',
  18031. ' };',
  18032. ' this.$assign = function (s) {',
  18033. ' this.D1 = s.D1;',
  18034. ' this.D2 = s.D2;',
  18035. ' this.D3 = s.D3;',
  18036. ' this.D4 = s.D4;',
  18037. ' return this;',
  18038. ' };',
  18039. '});',
  18040. 'rtl.createClass($mod, "TObject", null, function () {',
  18041. ' this.$init = function () {',
  18042. ' };',
  18043. ' this.$final = function () {',
  18044. ' };',
  18045. '});',
  18046. 'this.o = null;',
  18047. '']),
  18048. LinesToStr([ // $mod.$main
  18049. '$mod.o.SetG(rtl.getIntfGUIDR($mod.IUnknown));',
  18050. '$mod.o.SetG({',
  18051. ' D1: 0xD91C9AF4,',
  18052. ' D2: 0x3C93,',
  18053. ' D3: 0x420F,',
  18054. ' D4: [',
  18055. ' 0xA3,',
  18056. ' 0x03,',
  18057. ' 0xBF,',
  18058. ' 0x5B,',
  18059. ' 0xA8,',
  18060. ' 0x2B,',
  18061. ' 0xFD,',
  18062. ' 0x23',
  18063. ' ]',
  18064. '});',
  18065. '$mod.o.SetS($mod.IUnknown.$guid);',
  18066. '$mod.o.SetS(rtl.guidrToStr($mod.o.GetG()));',
  18067. '']));
  18068. end;
  18069. procedure TTestModule.TestClassHelper_ClassVar;
  18070. begin
  18071. StartProgram(false);
  18072. Add([
  18073. 'type',
  18074. ' TObject = class',
  18075. ' end;',
  18076. ' THelper = class helper for TObject',
  18077. ' const',
  18078. ' One = 1;',
  18079. ' Two: word = 2;',
  18080. ' class var',
  18081. ' Glob: word;',
  18082. ' function Foo(w: word): word;',
  18083. ' class function Bar(w: word): word;',
  18084. ' end;',
  18085. 'function THelper.foo(w: word): word;',
  18086. 'begin',
  18087. ' Result:=w;',
  18088. ' Two:=One+w;',
  18089. ' Glob:=Glob;',
  18090. ' Result:=Self.Glob;',
  18091. ' Self.Glob:=Self.Glob;',
  18092. ' with Self do Glob:=Glob;',
  18093. 'end;',
  18094. 'class function THelper.bar(w: word): word;',
  18095. 'begin',
  18096. ' Result:=w;',
  18097. ' Two:=One;',
  18098. ' Glob:=Glob;',
  18099. ' Self.Glob:=Self.Glob;',
  18100. ' with Self do Glob:=Glob;',
  18101. 'end;',
  18102. 'var o: TObject;',
  18103. 'begin',
  18104. ' tobject.two:=tobject.one;',
  18105. ' tobject.Glob:=tobject.Glob;',
  18106. ' with tobject do begin',
  18107. ' two:=one;',
  18108. ' Glob:=Glob;',
  18109. ' end;',
  18110. ' o.two:=o.one;',
  18111. ' o.Glob:=o.Glob;',
  18112. ' with o do begin',
  18113. ' two:=one;',
  18114. ' Glob:=Glob;',
  18115. ' end;',
  18116. '']);
  18117. ConvertProgram;
  18118. CheckSource('TestClassHelper',
  18119. LinesToStr([ // statements
  18120. 'rtl.createClass($mod, "TObject", null, function () {',
  18121. ' this.$init = function () {',
  18122. ' };',
  18123. ' this.$final = function () {',
  18124. ' };',
  18125. '});',
  18126. 'rtl.createHelper($mod, "THelper", null, function () {',
  18127. ' this.One = 1;',
  18128. ' this.Two = 2;',
  18129. ' this.Glob = 0;',
  18130. ' this.Foo = function (w) {',
  18131. ' var Result = 0;',
  18132. ' Result = w;',
  18133. ' $mod.THelper.Two = 1 + w;',
  18134. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18135. ' Result = $mod.THelper.Glob;',
  18136. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18137. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18138. ' return Result;',
  18139. ' };',
  18140. ' this.Bar = function (w) {',
  18141. ' var Result = 0;',
  18142. ' Result = w;',
  18143. ' $mod.THelper.Two = 1;',
  18144. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18145. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18146. ' $mod.THelper.Glob = $mod.THelper.Glob;',
  18147. ' return Result;',
  18148. ' };',
  18149. '});',
  18150. 'this.o = null;',
  18151. '']),
  18152. LinesToStr([ // $mod.$main
  18153. '$mod.THelper.Two = 1;',
  18154. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18155. 'var $with1 = $mod.TObject;',
  18156. '$mod.THelper.Two = 1;',
  18157. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18158. '$mod.THelper.Two = 1;',
  18159. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18160. 'var $with2 = $mod.o;',
  18161. '$mod.THelper.Two = 1;',
  18162. '$mod.THelper.Glob = $mod.THelper.Glob;',
  18163. '']));
  18164. end;
  18165. procedure TTestModule.TestClassHelper_Method_AccessInstanceFields;
  18166. begin
  18167. StartProgram(false);
  18168. Add([
  18169. 'type',
  18170. ' TObject = class',
  18171. ' FSize: word;',
  18172. ' property Size: word read FSize write FSize;',
  18173. ' end;',
  18174. ' THelper = class helper for TObject',
  18175. ' function Foo(w: word = 1): word;',
  18176. ' end;',
  18177. 'function THelper.foo(w: word): word;',
  18178. 'begin',
  18179. ' Result:=Size;',
  18180. ' Size:=Size+2;',
  18181. ' Self.Size:=Self.Size+3;',
  18182. ' FSize:=FSize+4;',
  18183. ' Self.FSize:=Self.FSize+5;',
  18184. ' with Self do begin',
  18185. ' Size:=Size+6;',
  18186. ' FSize:=FSize+7;',
  18187. ' FSize:=FSize+8;',
  18188. ' end;',
  18189. 'end;',
  18190. 'begin',
  18191. '']);
  18192. ConvertProgram;
  18193. CheckSource('TestClassHelper_Method_AccessInstanceFields',
  18194. LinesToStr([ // statements
  18195. 'rtl.createClass($mod, "TObject", null, function () {',
  18196. ' this.$init = function () {',
  18197. ' this.FSize = 0;',
  18198. ' };',
  18199. ' this.$final = function () {',
  18200. ' };',
  18201. '});',
  18202. 'rtl.createHelper($mod, "THelper", null, function () {',
  18203. ' this.Foo = function (w) {',
  18204. ' var Result = 0;',
  18205. ' Result = this.FSize;',
  18206. ' this.FSize = this.FSize + 2;',
  18207. ' this.FSize = this.FSize + 3;',
  18208. ' this.FSize = this.FSize + 4;',
  18209. ' this.FSize = this.FSize + 5;',
  18210. ' this.FSize = this.FSize + 6;',
  18211. ' this.FSize = this.FSize + 7;',
  18212. ' this.FSize = this.FSize + 8;',
  18213. ' return Result;',
  18214. ' };',
  18215. '});',
  18216. '']),
  18217. LinesToStr([ // $mod.$main
  18218. '']));
  18219. end;
  18220. procedure TTestModule.TestClassHelper_Method_Call;
  18221. begin
  18222. StartProgram(false);
  18223. Add([
  18224. 'type',
  18225. ' TObject = class',
  18226. ' procedure Run(w: word = 10);',
  18227. ' end;',
  18228. ' THelper = class helper for TObject',
  18229. ' function Foo(w: word = 1): word;',
  18230. ' end;',
  18231. 'procedure TObject.Run(w: word);',
  18232. 'begin',
  18233. ' Foo;',
  18234. ' Foo();',
  18235. ' Foo(2);',
  18236. ' Self.Foo;',
  18237. ' Self.Foo();',
  18238. ' Self.Foo(3);',
  18239. ' with Self do begin',
  18240. ' Foo;',
  18241. ' Foo();',
  18242. ' Foo(4);',
  18243. ' end;',
  18244. 'end;',
  18245. 'function THelper.foo(w: word): word;',
  18246. 'begin',
  18247. ' Run;',
  18248. ' Run();',
  18249. ' Run(11);',
  18250. ' Foo;',
  18251. ' Foo();',
  18252. ' Foo(12);',
  18253. ' Self.Foo;',
  18254. ' Self.Foo();',
  18255. ' Self.Foo(13);',
  18256. ' with Self do begin',
  18257. ' Foo;',
  18258. ' Foo();',
  18259. ' Foo(14);',
  18260. ' end;',
  18261. 'end;',
  18262. 'var Obj: TObject;',
  18263. 'begin',
  18264. ' obj.Foo;',
  18265. ' obj.Foo();',
  18266. ' obj.Foo(21);',
  18267. ' with obj do begin',
  18268. ' Foo;',
  18269. ' Foo();',
  18270. ' Foo(22);',
  18271. ' end;',
  18272. '']);
  18273. ConvertProgram;
  18274. CheckSource('TestClassHelper_Method_Call',
  18275. LinesToStr([ // statements
  18276. 'rtl.createClass($mod, "TObject", null, function () {',
  18277. ' this.$init = function () {',
  18278. ' };',
  18279. ' this.$final = function () {',
  18280. ' };',
  18281. ' this.Run = function (w) {',
  18282. ' $mod.THelper.Foo.apply(this, 1);',
  18283. ' $mod.THelper.Foo.apply(this, 1);',
  18284. ' $mod.THelper.Foo.apply(this, 2);',
  18285. ' $mod.THelper.Foo.apply(this, 1);',
  18286. ' $mod.THelper.Foo.apply(this, 1);',
  18287. ' $mod.THelper.Foo.apply(this, 3);',
  18288. ' $mod.THelper.Foo.apply(this, 1);',
  18289. ' $mod.THelper.Foo.apply(this, 1);',
  18290. ' $mod.THelper.Foo.apply(this, 4);',
  18291. ' };',
  18292. '});',
  18293. 'rtl.createHelper($mod, "THelper", null, function () {',
  18294. ' this.Foo = function (w) {',
  18295. ' var Result = 0;',
  18296. ' this.Run(10);',
  18297. ' this.Run(10);',
  18298. ' this.Run(11);',
  18299. ' $mod.THelper.Foo.apply(this, 1);',
  18300. ' $mod.THelper.Foo.apply(this, 1);',
  18301. ' $mod.THelper.Foo.apply(this, 12);',
  18302. ' $mod.THelper.Foo.apply(this, 1);',
  18303. ' $mod.THelper.Foo.apply(this, 1);',
  18304. ' $mod.THelper.Foo.apply(this, 13);',
  18305. ' $mod.THelper.Foo.apply(this, 1);',
  18306. ' $mod.THelper.Foo.apply(this, 1);',
  18307. ' $mod.THelper.Foo.apply(this, 14);',
  18308. ' return Result;',
  18309. ' };',
  18310. '});',
  18311. 'this.Obj = null;',
  18312. '']),
  18313. LinesToStr([ // $mod.$main
  18314. '$mod.THelper.Foo.apply($mod.Obj, 1);',
  18315. '$mod.THelper.Foo.apply($mod.Obj, 1);',
  18316. '$mod.THelper.Foo.apply($mod.Obj, 21);',
  18317. 'var $with1 = $mod.Obj;',
  18318. '$mod.THelper.Foo.apply($with1, 1);',
  18319. '$mod.THelper.Foo.apply($with1, 1);',
  18320. '$mod.THelper.Foo.apply($with1, 22);',
  18321. '']));
  18322. end;
  18323. procedure TTestModule.TestClassHelper_Method_Nested_Call;
  18324. begin
  18325. StartProgram(false);
  18326. Add([
  18327. 'type',
  18328. ' TObject = class',
  18329. ' procedure Run(w: word = 10);',
  18330. ' end;',
  18331. ' THelper = class helper for TObject',
  18332. ' function Foo(w: word = 1): word;',
  18333. ' end;',
  18334. 'procedure TObject.Run(w: word);',
  18335. ' procedure Sub(Self: TObject);',
  18336. ' begin',
  18337. ' Foo;',
  18338. ' Foo();',
  18339. ' Self.Foo;',
  18340. ' Self.Foo();',
  18341. ' with Self do begin',
  18342. ' Foo;',
  18343. ' Foo();',
  18344. ' end;',
  18345. ' end;',
  18346. 'begin',
  18347. 'end;',
  18348. 'function THelper.foo(w: word): word;',
  18349. ' procedure Sub(Self: TObject);',
  18350. ' begin',
  18351. ' Run;',
  18352. ' Run();',
  18353. ' Foo;',
  18354. ' Foo();',
  18355. ' Self.Foo;',
  18356. ' Self.Foo();',
  18357. ' with Self do begin',
  18358. ' Foo;',
  18359. ' Foo();',
  18360. ' end;',
  18361. ' end;',
  18362. 'begin',
  18363. 'end;',
  18364. 'begin',
  18365. '']);
  18366. ConvertProgram;
  18367. CheckSource('TestClassHelper_Method_Nested_Call',
  18368. LinesToStr([ // statements
  18369. 'rtl.createClass($mod, "TObject", null, function () {',
  18370. ' this.$init = function () {',
  18371. ' };',
  18372. ' this.$final = function () {',
  18373. ' };',
  18374. ' this.Run = function (w) {',
  18375. ' var $Self = this;',
  18376. ' function Sub(Self) {',
  18377. ' $mod.THelper.Foo.apply($Self, 1);',
  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. ' };',
  18384. ' };',
  18385. '});',
  18386. 'rtl.createHelper($mod, "THelper", null, function () {',
  18387. ' this.Foo = function (w) {',
  18388. ' var $Self = this;',
  18389. ' var Result = 0;',
  18390. ' function Sub(Self) {',
  18391. ' $Self.Run(10);',
  18392. ' $Self.Run(10);',
  18393. ' $mod.THelper.Foo.apply($Self, 1);',
  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. ' };',
  18400. ' return Result;',
  18401. ' };',
  18402. '});',
  18403. '']),
  18404. LinesToStr([ // $mod.$main
  18405. '']));
  18406. end;
  18407. procedure TTestModule.TestClassHelper_ClassMethod_Call;
  18408. begin
  18409. StartProgram(false);
  18410. Add([
  18411. 'type',
  18412. ' TObject = class',
  18413. ' class procedure Run(w: word = 10);',
  18414. ' end;',
  18415. ' THelper = class helper for TObject',
  18416. ' class function Foo(w: word = 1): word;',
  18417. ' end;',
  18418. 'class procedure TObject.Run(w: word);',
  18419. 'begin',
  18420. ' Foo;',
  18421. ' Foo();',
  18422. ' Self.Foo;',
  18423. ' Self.Foo();',
  18424. ' with Self do begin',
  18425. ' Foo;',
  18426. ' Foo();',
  18427. ' end;',
  18428. 'end;',
  18429. 'class function THelper.foo(w: word): word;',
  18430. 'begin',
  18431. ' Run;',
  18432. ' Run();',
  18433. ' Foo;',
  18434. ' Foo();',
  18435. ' Self.Foo;',
  18436. ' Self.Foo();',
  18437. ' with Self do begin',
  18438. ' Foo;',
  18439. ' Foo();',
  18440. ' end;',
  18441. 'end;',
  18442. 'var',
  18443. ' Obj: TObject;',
  18444. 'begin',
  18445. ' obj.Foo;',
  18446. ' obj.Foo();',
  18447. ' with obj do begin',
  18448. ' Foo;',
  18449. ' Foo();',
  18450. ' end;',
  18451. ' tobject.Foo;',
  18452. ' tobject.Foo();',
  18453. ' with tobject do begin',
  18454. ' Foo;',
  18455. ' Foo();',
  18456. ' end;',
  18457. '']);
  18458. ConvertProgram;
  18459. CheckSource('TestClassHelper_ClassMethod_Call',
  18460. LinesToStr([ // statements
  18461. 'rtl.createClass($mod, "TObject", null, function () {',
  18462. ' this.$init = function () {',
  18463. ' };',
  18464. ' this.$final = function () {',
  18465. ' };',
  18466. ' this.Run = function (w) {',
  18467. ' $mod.THelper.Foo.apply(this, 1);',
  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. ' };',
  18474. '});',
  18475. 'rtl.createHelper($mod, "THelper", null, function () {',
  18476. ' this.Foo = function (w) {',
  18477. ' var Result = 0;',
  18478. ' this.Run(10);',
  18479. ' this.Run(10);',
  18480. ' $mod.THelper.Foo.apply(this, 1);',
  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. ' return Result;',
  18487. ' };',
  18488. '});',
  18489. 'this.Obj = null;',
  18490. '']),
  18491. LinesToStr([ // $mod.$main
  18492. '$mod.THelper.Foo.apply($mod.Obj.$class, 1);',
  18493. '$mod.THelper.Foo.apply($mod.Obj.$class, 1);',
  18494. 'var $with1 = $mod.Obj;',
  18495. '$mod.THelper.Foo.apply($with1.$class, 1);',
  18496. '$mod.THelper.Foo.apply($with1.$class, 1);',
  18497. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18498. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18499. 'var $with2 = $mod.TObject;',
  18500. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18501. '$mod.THelper.Foo.apply($mod.TObject, 1);',
  18502. '']));
  18503. end;
  18504. procedure TTestModule.TestClassHelper_ClassOf;
  18505. begin
  18506. StartProgram(false);
  18507. Add([
  18508. 'type',
  18509. ' TObject = class',
  18510. ' end;',
  18511. ' TClass = class of TObject;',
  18512. ' THelper = class helper for TObject',
  18513. ' class function Foo(w: word = 1): word;',
  18514. ' end;',
  18515. 'class function THelper.foo(w: word): word;',
  18516. 'begin',
  18517. 'end;',
  18518. 'var',
  18519. ' c: TClass;',
  18520. 'begin',
  18521. ' c.Foo;',
  18522. ' c.Foo();',
  18523. ' with c do begin',
  18524. ' Foo;',
  18525. ' Foo();',
  18526. ' end;',
  18527. '']);
  18528. ConvertProgram;
  18529. CheckSource('TestClassHelper_ClassOf',
  18530. LinesToStr([ // statements
  18531. 'rtl.createClass($mod, "TObject", null, function () {',
  18532. ' this.$init = function () {',
  18533. ' };',
  18534. ' this.$final = function () {',
  18535. ' };',
  18536. '});',
  18537. 'rtl.createHelper($mod, "THelper", null, function () {',
  18538. ' this.Foo = function (w) {',
  18539. ' var Result = 0;',
  18540. ' return Result;',
  18541. ' };',
  18542. '});',
  18543. 'this.c = null;',
  18544. '']),
  18545. LinesToStr([ // $mod.$main
  18546. '$mod.THelper.Foo.apply($mod.c, 1);',
  18547. '$mod.THelper.Foo.apply($mod.c, 1);',
  18548. 'var $with1 = $mod.c;',
  18549. '$mod.THelper.Foo.apply($with1, 1);',
  18550. '$mod.THelper.Foo.apply($with1, 1);',
  18551. '']));
  18552. end;
  18553. procedure TTestModule.TestClassHelper_MethodRefObjFPC;
  18554. begin
  18555. StartProgram(false);
  18556. Add([
  18557. '{$mode objfpc}',
  18558. 'type',
  18559. ' TObject = class',
  18560. ' procedure DoIt;',
  18561. ' end;',
  18562. ' THelper = class helper for TObject',
  18563. ' procedure Fly(w: word = 1);',
  18564. ' class procedure Glide(w: word = 1);',
  18565. ' class procedure Run(w: word = 1); static;',
  18566. ' end;',
  18567. ' TFly = procedure(w: word) of object;',
  18568. ' TGlide = TFly;',
  18569. ' TRun = procedure(w: word);',
  18570. 'var',
  18571. ' f: TFly;',
  18572. ' g: TGlide;',
  18573. ' r: TRun;',
  18574. 'procedure TObject.DoIt;',
  18575. 'begin',
  18576. ' f:=@fly;',
  18577. ' g:=@glide;',
  18578. ' r:=@run;',
  18579. ' f:[email protected];',
  18580. ' g:[email protected];',
  18581. ' r:[email protected];',
  18582. ' with self do begin',
  18583. ' f:=@fly;',
  18584. ' g:=@glide;',
  18585. ' r:=@run;',
  18586. ' end;',
  18587. 'end;',
  18588. 'procedure THelper.fly(w: word);',
  18589. 'begin',
  18590. ' f:=@fly;',
  18591. ' g:=@glide;',
  18592. ' r:=@run;',
  18593. 'end;',
  18594. 'class procedure THelper.glide(w: word);',
  18595. 'begin',
  18596. ' g:=@glide;',
  18597. ' r:=@run;',
  18598. 'end;',
  18599. 'class procedure THelper.run(w: word);',
  18600. 'begin',
  18601. ' g:=@glide;',
  18602. ' r:=@run;',
  18603. 'end;',
  18604. 'var',
  18605. ' Obj: TObject;',
  18606. 'begin',
  18607. ' f:[email protected];',
  18608. ' g:[email protected];',
  18609. ' r:[email protected];',
  18610. ' with obj do begin',
  18611. ' f:=@fly;',
  18612. ' g:=@glide;',
  18613. ' r:=@run;',
  18614. ' end;',
  18615. ' g:[email protected];',
  18616. ' r:[email protected];',
  18617. ' with tobject do begin',
  18618. ' g:=@glide;',
  18619. ' r:=@run;',
  18620. ' end;',
  18621. '']);
  18622. ConvertProgram;
  18623. CheckSource('TestClassHelper_MethodRefObjFPC',
  18624. LinesToStr([ // statements
  18625. 'rtl.createClass($mod, "TObject", null, function () {',
  18626. ' this.$init = function () {',
  18627. ' };',
  18628. ' this.$final = function () {',
  18629. ' };',
  18630. ' this.DoIt = function () {',
  18631. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18632. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18633. ' $mod.r = $mod.THelper.Run;',
  18634. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18635. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18636. ' $mod.r = $mod.THelper.Run;',
  18637. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18638. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18639. ' $mod.r = $mod.THelper.Run;',
  18640. ' };',
  18641. '});',
  18642. 'rtl.createHelper($mod, "THelper", null, function () {',
  18643. ' this.Fly = function (w) {',
  18644. ' $mod.f = rtl.createCallback(this, $mod.THelper.Fly);',
  18645. ' $mod.g = rtl.createCallback(this.$class, $mod.THelper.Glide);',
  18646. ' $mod.r = $mod.THelper.Run;',
  18647. ' };',
  18648. ' this.Glide = function (w) {',
  18649. ' $mod.g = rtl.createCallback(this, $mod.THelper.Glide);',
  18650. ' $mod.r = $mod.THelper.Run;',
  18651. ' };',
  18652. ' this.Run = function (w) {',
  18653. ' $mod.g = rtl.createCallback($mod.THelper, $mod.THelper.Glide);',
  18654. ' $mod.r = $mod.THelper.Run;',
  18655. ' };',
  18656. '});',
  18657. 'this.f = null;',
  18658. 'this.g = null;',
  18659. 'this.r = null;',
  18660. 'this.Obj = null;',
  18661. '']),
  18662. LinesToStr([ // $mod.$main
  18663. '$mod.f = rtl.createCallback($mod.Obj, $mod.THelper.Fly);',
  18664. '$mod.g = rtl.createCallback($mod.Obj.$class, $mod.THelper.Glide);',
  18665. '$mod.r = $mod.THelper.Run;',
  18666. 'var $with1 = $mod.Obj;',
  18667. '$mod.f = rtl.createCallback($with1, $mod.THelper.Fly);',
  18668. '$mod.g = rtl.createCallback($with1.$class, $mod.THelper.Glide);',
  18669. '$mod.r = $mod.THelper.Run;',
  18670. '$mod.g = rtl.createCallback($mod.TObject, $mod.THelper.Glide);',
  18671. '$mod.r = $mod.THelper.Run;',
  18672. 'var $with2 = $mod.TObject;',
  18673. '$mod.g = rtl.createCallback($with2, $mod.THelper.Glide);',
  18674. '$mod.r = $mod.THelper.Run;',
  18675. '']));
  18676. end;
  18677. procedure TTestModule.TestClassHelper_Constructor;
  18678. begin
  18679. StartProgram(false);
  18680. Add([
  18681. 'type',
  18682. ' TObject = class',
  18683. ' constructor Create;',
  18684. ' end;',
  18685. ' TClass = class of TObject;',
  18686. ' THelper = class helper for TObject',
  18687. ' constructor NewHlp(w: word);',
  18688. ' end;',
  18689. 'var',
  18690. ' obj: TObject;',
  18691. ' c: TClass;',
  18692. 'constructor TObject.Create;',
  18693. 'begin',
  18694. ' NewHlp(2);', // normal call
  18695. ' tobject.NewHlp(3);', // new instance
  18696. ' c.newhlp(4);', // new instance
  18697. 'end;',
  18698. 'constructor THelper.NewHlp(w: word);',
  18699. 'begin',
  18700. ' create;', // normal call
  18701. ' tobject.create;', // new instance
  18702. ' NewHlp(2);', // normal call
  18703. ' tobject.NewHlp(3);', // new instance
  18704. ' c.newhlp(4);', // new instance
  18705. 'end;',
  18706. 'begin',
  18707. ' obj.newhlp(2);', // normal call
  18708. ' with Obj do newhlp(12);', // normal call
  18709. ' tobject.newhlp(3);', // new instance
  18710. ' with tobject do newhlp(13);', // new instance
  18711. ' c.newhlp(4);', // new instance
  18712. ' with c do newhlp(14);', // new instance
  18713. '']);
  18714. ConvertProgram;
  18715. CheckSource('TestClassHelper_Constructor',
  18716. LinesToStr([ // statements
  18717. 'rtl.createClass($mod, "TObject", null, function () {',
  18718. ' this.$init = function () {',
  18719. ' };',
  18720. ' this.$final = function () {',
  18721. ' };',
  18722. ' this.Create = function () {',
  18723. ' $mod.THelper.NewHlp.apply(this, 2);',
  18724. ' $mod.TObject.$create($mod.THelper.NewHlp, [3]);',
  18725. ' $mod.c.$create($mod.THelper.NewHlp, [4]);',
  18726. ' return this;',
  18727. ' };',
  18728. '});',
  18729. 'rtl.createHelper($mod, "THelper", null, function () {',
  18730. ' this.NewHlp = function (w) {',
  18731. ' this.Create();',
  18732. ' $mod.TObject.$create("Create");',
  18733. ' $mod.THelper.NewHlp.apply(this, 2);',
  18734. ' $mod.TObject.$create($mod.THelper.NewHlp, [3]);',
  18735. ' $mod.c.$create($mod.THelper.NewHlp, [4]);',
  18736. ' return this;',
  18737. ' };',
  18738. '});',
  18739. 'this.obj = null;',
  18740. 'this.c = null;',
  18741. '']),
  18742. LinesToStr([ // $mod.$main
  18743. '$mod.THelper.NewHlp.apply($mod.obj, 2);',
  18744. 'var $with1 = $mod.obj;',
  18745. '$mod.THelper.NewHlp.apply($with1, 12);',
  18746. '$mod.TObject.$create($mod.THelper.NewHlp, [3]);',
  18747. 'var $with2 = $mod.TObject;',
  18748. '$with2.$create($mod.THelper.NewHlp, [13]);',
  18749. '$mod.c.$create($mod.THelper.NewHlp, [4]);',
  18750. 'var $with3 = $mod.c;',
  18751. '$with3.$create($mod.THelper.NewHlp, [14]);',
  18752. '']));
  18753. end;
  18754. procedure TTestModule.TestClassHelper_InheritedObjFPC;
  18755. begin
  18756. StartProgram(false);
  18757. Add([
  18758. 'type',
  18759. ' TObject = class',
  18760. ' procedure Fly;',
  18761. ' end;',
  18762. ' TObjHelper = class helper for TObject',
  18763. ' procedure Fly;',
  18764. ' end;',
  18765. ' TBird = class',
  18766. ' procedure Fly;',
  18767. ' end;',
  18768. ' TBirdHelper = class helper for TBird',
  18769. ' procedure Fly;',
  18770. ' procedure Walk(w: word);',
  18771. ' end;',
  18772. ' TEagleHelper = class helper(TBirdHelper) for TBird',
  18773. ' procedure Fly;',
  18774. ' procedure Walk(w: word);',
  18775. ' end;',
  18776. 'procedure Tobject.fly;',
  18777. 'begin',
  18778. ' inherited;', // ignore
  18779. 'end;',
  18780. 'procedure Tobjhelper.fly;',
  18781. 'begin',
  18782. ' {@TObject_Fly}inherited;',
  18783. ' inherited {@TObject_Fly}Fly;',
  18784. 'end;',
  18785. 'procedure Tbird.fly;',
  18786. 'begin',
  18787. ' {@TObjHelper_Fly}inherited;',
  18788. ' inherited {@TObjHelper_Fly}Fly;',
  18789. 'end;',
  18790. 'procedure Tbirdhelper.fly;',
  18791. 'begin',
  18792. ' {@TBird_Fly}inherited;',
  18793. ' inherited {@TBird_Fly}Fly;',
  18794. 'end;',
  18795. 'procedure Tbirdhelper.walk(w: word);',
  18796. 'begin',
  18797. 'end;',
  18798. 'procedure teagleHelper.fly;',
  18799. 'begin',
  18800. ' {@TBird_Fly}inherited;',
  18801. ' inherited {@TBird_Fly}Fly;',
  18802. 'end;',
  18803. 'procedure teagleHelper.walk(w: word);',
  18804. 'begin',
  18805. ' {@TBirdHelper_Walk}inherited;',
  18806. ' inherited {@TBirdHelper_Walk}Walk(3);',
  18807. 'end;',
  18808. 'begin',
  18809. '']);
  18810. ConvertProgram;
  18811. CheckSource('TestClassHelper_InheritedObjFPC',
  18812. LinesToStr([ // statements
  18813. 'rtl.createClass($mod, "TObject", null, function () {',
  18814. ' this.$init = function () {',
  18815. ' };',
  18816. ' this.$final = function () {',
  18817. ' };',
  18818. ' this.Fly = function () {',
  18819. ' };',
  18820. '});',
  18821. 'rtl.createHelper($mod, "TObjHelper", null, function () {',
  18822. ' this.Fly = function () {',
  18823. ' $mod.TObject.Fly.call(this);',
  18824. ' $mod.TObject.Fly.call(this);',
  18825. ' };',
  18826. '});',
  18827. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  18828. ' this.Fly$1 = function () {',
  18829. ' $mod.TObjHelper.Fly.call(this);',
  18830. ' $mod.TObjHelper.Fly.call(this);',
  18831. ' };',
  18832. '});',
  18833. 'rtl.createHelper($mod, "TBirdHelper", null, function () {',
  18834. ' this.Fly = function () {',
  18835. ' $mod.TBird.Fly$1.call(this);',
  18836. ' $mod.TBird.Fly$1.call(this);',
  18837. ' };',
  18838. ' this.Walk = function (w) {',
  18839. ' };',
  18840. '});',
  18841. 'rtl.createHelper($mod, "TEagleHelper", $mod.TBirdHelper, function () {',
  18842. ' this.Fly$1 = function () {',
  18843. ' $mod.TBird.Fly$1.call(this);',
  18844. ' $mod.TBird.Fly$1.call(this);',
  18845. ' };',
  18846. ' this.Walk$1 = function (w) {',
  18847. ' $mod.TBirdHelper.Walk.apply(this, arguments);',
  18848. ' $mod.TBirdHelper.Walk.call(this, 3);',
  18849. ' };',
  18850. '});',
  18851. '']),
  18852. LinesToStr([ // $mod.$main
  18853. '']));
  18854. end;
  18855. procedure TTestModule.TestClassHelper_Property;
  18856. begin
  18857. StartProgram(false);
  18858. Add([
  18859. 'type',
  18860. ' TObject = class',
  18861. ' FSize: word;',
  18862. ' function GetSpeed: word;',
  18863. ' procedure SetSpeed(Value: word);',
  18864. ' end;',
  18865. ' TObjHelper = class helper for TObject',
  18866. ' function GetLeft: word;',
  18867. ' procedure SetLeft(Value: word);',
  18868. ' property Size: word read FSize write FSize;',
  18869. ' property Speed: word read GetSpeed write SetSpeed;',
  18870. ' property Left: word read GetLeft write SetLeft;',
  18871. ' end;',
  18872. ' TBird = class',
  18873. ' property NotRight: word read GetLeft write SetLeft;',
  18874. ' procedure DoIt;',
  18875. ' end;',
  18876. 'var',
  18877. ' b: TBird;',
  18878. 'function Tobject.GetSpeed: word;',
  18879. 'begin',
  18880. ' Size:=Size+11;',
  18881. ' Speed:=Speed+12;',
  18882. ' Result:=Left+13;',
  18883. ' Left:=13;',
  18884. ' Left:=Left+13;',
  18885. ' Self.Size:=Self.Size+21;',
  18886. ' Self.Speed:=Self.Speed+22;',
  18887. ' Self.Left:=Self.Left+23;',
  18888. ' with Self do begin',
  18889. ' Size:=Size+31;',
  18890. ' Speed:=Speed+32;',
  18891. ' Left:=Left+33;',
  18892. ' end;',
  18893. 'end;',
  18894. 'procedure Tobject.SetSpeed(Value: word);',
  18895. 'begin',
  18896. 'end;',
  18897. 'function TObjHelper.GetLeft: word;',
  18898. 'begin',
  18899. ' Size:=Size+11;',
  18900. ' Speed:=Speed+12;',
  18901. ' Left:=Left+13;',
  18902. ' Self.Size:=Self.Size+21;',
  18903. ' Self.Speed:=Self.Speed+22;',
  18904. ' Self.Left:=Self.Left+23;',
  18905. ' with Self do begin',
  18906. ' Size:=Size+31;',
  18907. ' Speed:=Speed+32;',
  18908. ' Left:=Left+33;',
  18909. ' end;',
  18910. 'end;',
  18911. 'procedure TObjHelper.SetLeft(Value: word);',
  18912. 'begin',
  18913. 'end;',
  18914. 'procedure TBird.DoIt;',
  18915. 'begin',
  18916. ' NotRight:=NotRight+11;',
  18917. ' Self.NotRight:=Self.NotRight+21;',
  18918. ' with Self do begin',
  18919. ' NotRight:=NotRight+31;',
  18920. ' end;',
  18921. 'end;',
  18922. 'begin',
  18923. ' b.Size:=b.Size+11;',
  18924. ' b.Speed:=b.Speed+12;',
  18925. ' b.Left:=b.Left+13;',
  18926. ' b.NotRight:=b.NotRight+14;',
  18927. ' with b do begin',
  18928. ' Size:=Size+31;',
  18929. ' Speed:=Speed+32;',
  18930. ' Left:=Left+33;',
  18931. ' NotRight:=NotRight+34;',
  18932. ' end;',
  18933. '']);
  18934. ConvertProgram;
  18935. CheckSource('TestClassHelper_Property',
  18936. LinesToStr([ // statements
  18937. 'rtl.createClass($mod, "TObject", null, function () {',
  18938. ' this.$init = function () {',
  18939. ' this.FSize = 0;',
  18940. ' };',
  18941. ' this.$final = function () {',
  18942. ' };',
  18943. ' this.GetSpeed = function () {',
  18944. ' var Result = 0;',
  18945. ' this.FSize = this.FSize + 11;',
  18946. ' this.SetSpeed(this.GetSpeed() + 12);',
  18947. ' Result = $mod.TObjHelper.GetLeft.apply(this) + 13;',
  18948. ' $mod.TObjHelper.SetLeft.apply(this, 13);',
  18949. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 13);',
  18950. ' this.FSize = this.FSize + 21;',
  18951. ' this.SetSpeed(this.GetSpeed() + 22);',
  18952. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 23);',
  18953. ' this.FSize = this.FSize + 31;',
  18954. ' this.SetSpeed(this.GetSpeed() + 32);',
  18955. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 33);',
  18956. ' return Result;',
  18957. ' };',
  18958. ' this.SetSpeed = function (Value) {',
  18959. ' };',
  18960. '});',
  18961. 'rtl.createHelper($mod, "TObjHelper", null, function () {',
  18962. ' this.GetLeft = function () {',
  18963. ' var Result = 0;',
  18964. ' this.FSize = this.FSize + 11;',
  18965. ' this.SetSpeed(this.GetSpeed() + 12);',
  18966. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 13);',
  18967. ' this.FSize = this.FSize + 21;',
  18968. ' this.SetSpeed(this.GetSpeed() + 22);',
  18969. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 23);',
  18970. ' this.FSize = this.FSize + 31;',
  18971. ' this.SetSpeed(this.GetSpeed() + 32);',
  18972. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 33);',
  18973. ' return Result;',
  18974. ' };',
  18975. ' this.SetLeft = function (Value) {',
  18976. ' };',
  18977. '});',
  18978. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  18979. ' this.DoIt = function () {',
  18980. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 11);',
  18981. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 21);',
  18982. ' $mod.TObjHelper.SetLeft.apply(this, $mod.TObjHelper.GetLeft.apply(this) + 31);',
  18983. ' };',
  18984. '});',
  18985. 'this.b = null;',
  18986. '']),
  18987. LinesToStr([ // $mod.$main
  18988. '$mod.b.FSize = $mod.b.FSize + 11;',
  18989. '$mod.b.SetSpeed($mod.b.GetSpeed() + 12);',
  18990. '$mod.TObjHelper.SetLeft.apply($mod.b, $mod.TObjHelper.GetLeft.apply($mod.b) + 13);',
  18991. '$mod.TObjHelper.SetLeft.apply($mod.b, $mod.TObjHelper.GetLeft.apply($mod.b) + 14);',
  18992. 'var $with1 = $mod.b;',
  18993. '$with1.FSize = $with1.FSize + 31;',
  18994. '$with1.SetSpeed($with1.GetSpeed() + 32);',
  18995. '$mod.TObjHelper.SetLeft.apply($with1, $mod.TObjHelper.GetLeft.apply($with1) + 33);',
  18996. '$mod.TObjHelper.SetLeft.apply($with1, $mod.TObjHelper.GetLeft.apply($with1) + 34);',
  18997. '']));
  18998. end;
  18999. procedure TTestModule.TestClassHelper_Property_Array;
  19000. begin
  19001. StartProgram(false);
  19002. Add([
  19003. 'type',
  19004. ' TObject = class',
  19005. ' function GetSpeed(Index: boolean): word;',
  19006. ' procedure SetSpeed(Index: boolean; Value: word);',
  19007. ' end;',
  19008. ' TObjHelper = class helper for TObject',
  19009. ' function GetSize(Index: boolean): word;',
  19010. ' procedure SetSize(Index: boolean; Value: word);',
  19011. ' property Size[Index: boolean]: word read GetSize write SetSize;',
  19012. ' property Speed[Index: boolean]: word read GetSpeed write SetSpeed;',
  19013. ' end;',
  19014. ' TBird = class',
  19015. ' property Items[Index: boolean]: word read GetSize write SetSize;',
  19016. ' procedure DoIt;',
  19017. ' end;',
  19018. 'var',
  19019. ' b: TBird;',
  19020. 'function Tobject.GetSpeed(Index: boolean): word;',
  19021. 'begin',
  19022. ' Result:=Size[false];',
  19023. ' Size[true]:=Size[false]+11;',
  19024. ' Speed[true]:=Speed[false]+12;',
  19025. ' Self.Size[true]:=Self.Size[false]+21;',
  19026. ' Self.Speed[true]:=Self.Speed[false]+22;',
  19027. ' with Self do begin',
  19028. ' Size[true]:=Size[false]+31;',
  19029. ' Speed[true]:=Speed[false]+32;',
  19030. ' end;',
  19031. 'end;',
  19032. 'procedure Tobject.SetSpeed(Index: boolean; Value: word);',
  19033. 'begin',
  19034. 'end;',
  19035. 'function TObjHelper.GetSize(Index: boolean): word;',
  19036. 'begin',
  19037. ' Size[true]:=Size[false]+11;',
  19038. ' Speed[true]:=Speed[false]+12;',
  19039. ' Self.Size[true]:=Self.Size[false]+21;',
  19040. ' Self.Speed[true]:=Self.Speed[false]+22;',
  19041. ' with Self do begin',
  19042. ' Size[true]:=Size[false]+31;',
  19043. ' Speed[true]:=Speed[false]+32;',
  19044. ' end;',
  19045. 'end;',
  19046. 'procedure TObjHelper.SetSize(Index: boolean; Value: word);',
  19047. 'begin',
  19048. 'end;',
  19049. 'procedure TBird.DoIt;',
  19050. 'begin',
  19051. ' Items[true]:=Items[false]+11;',
  19052. ' Self.Items[true]:=Self.Items[false]+21;',
  19053. ' with Self do Items[true]:=Items[false]+31;',
  19054. 'end;',
  19055. 'begin',
  19056. ' b.Size[true]:=b.Size[false]+11;',
  19057. ' b.Speed[true]:=b.Speed[false]+12;',
  19058. ' b.Items[true]:=b.Items[false]+13;',
  19059. ' with b do begin',
  19060. ' Size[true]:=Size[false]+21;',
  19061. ' Speed[true]:=Speed[false]+22;',
  19062. ' Items[true]:=Items[false]+23;',
  19063. ' end;',
  19064. '']);
  19065. ConvertProgram;
  19066. CheckSource('TestClassHelper_Property_Array',
  19067. LinesToStr([ // statements
  19068. 'rtl.createClass($mod, "TObject", null, function () {',
  19069. ' this.$init = function () {',
  19070. ' };',
  19071. ' this.$final = function () {',
  19072. ' };',
  19073. ' this.GetSpeed = function (Index) {',
  19074. ' var Result = 0;',
  19075. ' Result = $mod.TObjHelper.GetSize.apply(this, false);',
  19076. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 11);',
  19077. ' this.SetSpeed(true, this.GetSpeed(false) + 12);',
  19078. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 21);',
  19079. ' this.SetSpeed(true, this.GetSpeed(false) + 22);',
  19080. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 31);',
  19081. ' this.SetSpeed(true, this.GetSpeed(false) + 32);',
  19082. ' return Result;',
  19083. ' };',
  19084. ' this.SetSpeed = function (Index, Value) {',
  19085. ' };',
  19086. '});',
  19087. 'rtl.createHelper($mod, "TObjHelper", null, function () {',
  19088. ' this.GetSize = function (Index) {',
  19089. ' var Result = 0;',
  19090. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 11);',
  19091. ' this.SetSpeed(true, this.GetSpeed(false) + 12);',
  19092. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 21);',
  19093. ' this.SetSpeed(true, this.GetSpeed(false) + 22);',
  19094. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 31);',
  19095. ' this.SetSpeed(true, this.GetSpeed(false) + 32);',
  19096. ' return Result;',
  19097. ' };',
  19098. ' this.SetSize = function (Index, Value) {',
  19099. ' };',
  19100. '});',
  19101. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  19102. ' this.DoIt = function () {',
  19103. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 11);',
  19104. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 21);',
  19105. ' $mod.TObjHelper.SetSize.apply(this, true, $mod.TObjHelper.GetSize.apply(this, false) + 31);',
  19106. ' };',
  19107. '});',
  19108. 'this.b = null;',
  19109. '']),
  19110. LinesToStr([ // $mod.$main
  19111. '$mod.TObjHelper.SetSize.apply($mod.b, true, $mod.TObjHelper.GetSize.apply($mod.b, false) + 11);',
  19112. '$mod.b.SetSpeed(true, $mod.b.GetSpeed(false) + 12);',
  19113. '$mod.TObjHelper.SetSize.apply($mod.b, true, $mod.TObjHelper.GetSize.apply($mod.b, false) + 13);',
  19114. 'var $with1 = $mod.b;',
  19115. '$mod.TObjHelper.SetSize.apply($with1, true, $mod.TObjHelper.GetSize.apply($with1, false) + 21);',
  19116. '$with1.SetSpeed(true, $with1.GetSpeed(false) + 22);',
  19117. '$mod.TObjHelper.SetSize.apply($with1, true, $mod.TObjHelper.GetSize.apply($with1, false) + 23);',
  19118. '']));
  19119. end;
  19120. procedure TTestModule.TestProcType;
  19121. begin
  19122. StartProgram(false);
  19123. Add([
  19124. 'type',
  19125. ' TProcInt = procedure(vI: longint = 1);',
  19126. 'procedure DoIt(vJ: longint);',
  19127. 'begin end;',
  19128. 'var',
  19129. ' b: boolean;',
  19130. ' vP, vQ: tprocint;',
  19131. 'begin',
  19132. ' vp:=nil;',
  19133. ' vp:=vp;',
  19134. ' vp:=@doit;',
  19135. ' vp;',
  19136. ' vp();',
  19137. ' vp(2);',
  19138. ' b:=vp=nil;',
  19139. ' b:=nil=vp;',
  19140. ' b:=vp=vq;',
  19141. ' b:=vp=@doit;',
  19142. ' b:=@doit=vp;',
  19143. ' b:=vp<>nil;',
  19144. ' b:=nil<>vp;',
  19145. ' b:=vp<>vq;',
  19146. ' b:=vp<>@doit;',
  19147. ' b:=@doit<>vp;',
  19148. ' b:=Assigned(vp);',
  19149. ' if Assigned(vp) then ;']);
  19150. ConvertProgram;
  19151. CheckSource('TestProcType',
  19152. LinesToStr([ // statements
  19153. 'this.DoIt = function(vJ) {',
  19154. '};',
  19155. 'this.b = false;',
  19156. 'this.vP = null;',
  19157. 'this.vQ = null;'
  19158. ]),
  19159. LinesToStr([ // $mod.$main
  19160. '$mod.vP = null;',
  19161. '$mod.vP = $mod.vP;',
  19162. '$mod.vP = $mod.DoIt;',
  19163. '$mod.vP(1);',
  19164. '$mod.vP(1);',
  19165. '$mod.vP(2);',
  19166. '$mod.b = $mod.vP === null;',
  19167. '$mod.b = null === $mod.vP;',
  19168. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  19169. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  19170. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  19171. '$mod.b = $mod.vP !== null;',
  19172. '$mod.b = null !== $mod.vP;',
  19173. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  19174. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  19175. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  19176. '$mod.b = $mod.vP != null;',
  19177. 'if ($mod.vP != null) ;',
  19178. '']));
  19179. end;
  19180. procedure TTestModule.TestProcType_Arg;
  19181. begin
  19182. StartProgram(false);
  19183. Add([
  19184. 'type',
  19185. ' TProcInt = procedure(vI: longint = 1);',
  19186. 'procedure DoIt(vJ: longint); begin end;',
  19187. 'procedure DoSome(vP, vQ: TProcInt);',
  19188. 'var',
  19189. ' b: boolean;',
  19190. 'begin',
  19191. ' vp:=nil;',
  19192. ' vp:=vp;',
  19193. ' vp:=@doit;',
  19194. ' vp;',
  19195. ' vp();',
  19196. ' vp(2);',
  19197. ' b:=vp=nil;',
  19198. ' b:=nil=vp;',
  19199. ' b:=vp=vq;',
  19200. ' b:=vp=@doit;',
  19201. ' b:=@doit=vp;',
  19202. ' b:=vp<>nil;',
  19203. ' b:=nil<>vp;',
  19204. ' b:=vp<>vq;',
  19205. ' b:=vp<>@doit;',
  19206. ' b:=@doit<>vp;',
  19207. ' b:=Assigned(vp);',
  19208. ' if Assigned(vp) then ;',
  19209. 'end;',
  19210. 'begin',
  19211. ' DoSome(@DoIt,nil);']);
  19212. ConvertProgram;
  19213. CheckSource('TestProcType_Arg',
  19214. LinesToStr([ // statements
  19215. 'this.DoIt = function(vJ) {',
  19216. '};',
  19217. 'this.DoSome = function(vP, vQ) {',
  19218. ' var b = false;',
  19219. ' vP = null;',
  19220. ' vP = vP;',
  19221. ' vP = $mod.DoIt;',
  19222. ' vP(1);',
  19223. ' vP(1);',
  19224. ' vP(2);',
  19225. ' b = vP === null;',
  19226. ' b = null === vP;',
  19227. ' b = rtl.eqCallback(vP,vQ);',
  19228. ' b = rtl.eqCallback(vP, $mod.DoIt);',
  19229. ' b = rtl.eqCallback($mod.DoIt, vP);',
  19230. ' b = vP !== null;',
  19231. ' b = null !== vP;',
  19232. ' b = !rtl.eqCallback(vP, vQ);',
  19233. ' b = !rtl.eqCallback(vP, $mod.DoIt);',
  19234. ' b = !rtl.eqCallback($mod.DoIt, vP);',
  19235. ' b = vP != null;',
  19236. ' if (vP != null) ;',
  19237. '};',
  19238. '']),
  19239. LinesToStr([ // $mod.$main
  19240. '$mod.DoSome($mod.DoIt,null);',
  19241. '']));
  19242. end;
  19243. procedure TTestModule.TestProcType_FunctionFPC;
  19244. begin
  19245. StartProgram(false);
  19246. Add('type');
  19247. Add(' TFuncInt = function(vA: longint = 1): longint;');
  19248. Add('function DoIt(vI: longint): longint;');
  19249. Add('begin end;');
  19250. Add('var');
  19251. Add(' b: boolean;');
  19252. Add(' vP, vQ: tfuncint;');
  19253. Add('begin');
  19254. Add(' vp:=nil;');
  19255. Add(' vp:=vp;');
  19256. Add(' vp:=@doit;'); // ok in fpc and delphi
  19257. //Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  19258. Add(' vp;'); // ok in fpc and delphi
  19259. Add(' vp();');
  19260. Add(' vp(2);');
  19261. Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  19262. Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  19263. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  19264. Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  19265. Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  19266. //Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  19267. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  19268. Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  19269. Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  19270. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  19271. Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  19272. Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  19273. //Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  19274. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  19275. Add(' b:=Assigned(vp);');
  19276. //Add(' doit(vp);'); // illegal in fpc, ok in delphi
  19277. Add(' doit(vp());'); // ok in fpc and delphi
  19278. Add(' doit(vp(2));'); // ok in fpc and delphi
  19279. ConvertProgram;
  19280. CheckSource('TestProcType_FunctionFPC',
  19281. LinesToStr([ // statements
  19282. 'this.DoIt = function(vI) {',
  19283. ' var Result = 0;',
  19284. ' return Result;',
  19285. '};',
  19286. 'this.b = false;',
  19287. 'this.vP = null;',
  19288. 'this.vQ = null;'
  19289. ]),
  19290. LinesToStr([ // $mod.$main
  19291. '$mod.vP = null;',
  19292. '$mod.vP = $mod.vP;',
  19293. '$mod.vP = $mod.DoIt;',
  19294. '$mod.vP(1);',
  19295. '$mod.vP(1);',
  19296. '$mod.vP(2);',
  19297. '$mod.b = $mod.vP === null;',
  19298. '$mod.b = null === $mod.vP;',
  19299. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  19300. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  19301. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  19302. '$mod.b = 4 === $mod.vP(1);',
  19303. '$mod.b = $mod.vP !== null;',
  19304. '$mod.b = null !== $mod.vP;',
  19305. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  19306. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  19307. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  19308. '$mod.b = 6 !== $mod.vP(1);',
  19309. '$mod.b = $mod.vP != null;',
  19310. '$mod.DoIt($mod.vP(1));',
  19311. '$mod.DoIt($mod.vP(2));',
  19312. '']));
  19313. end;
  19314. procedure TTestModule.TestProcType_FunctionDelphi;
  19315. begin
  19316. StartProgram(false);
  19317. Add('{$mode Delphi}');
  19318. Add('type');
  19319. Add(' TFuncInt = function(vA: longint = 1): longint;');
  19320. Add('function DoIt(vI: longint): longint;');
  19321. Add('begin end;');
  19322. Add('var');
  19323. Add(' b: boolean;');
  19324. Add(' vP, vQ: tfuncint;');
  19325. Add('begin');
  19326. Add(' vp:=nil;');
  19327. Add(' vp:=vp;');
  19328. Add(' vp:=@doit;'); // ok in fpc and delphi
  19329. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  19330. Add(' vp;'); // ok in fpc and delphi
  19331. Add(' vp();');
  19332. Add(' vp(2);');
  19333. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  19334. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  19335. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  19336. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  19337. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  19338. Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  19339. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  19340. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  19341. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  19342. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  19343. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  19344. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  19345. Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  19346. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  19347. Add(' b:=Assigned(vp);');
  19348. Add(' doit(vp);'); // illegal in fpc, ok in delphi
  19349. Add(' doit(vp());'); // ok in fpc and delphi
  19350. Add(' doit(vp(2));'); // ok in fpc and delphi *)
  19351. ConvertProgram;
  19352. CheckSource('TestProcType_FunctionDelphi',
  19353. LinesToStr([ // statements
  19354. 'this.DoIt = function(vI) {',
  19355. ' var Result = 0;',
  19356. ' return Result;',
  19357. '};',
  19358. 'this.b = false;',
  19359. 'this.vP = null;',
  19360. 'this.vQ = null;'
  19361. ]),
  19362. LinesToStr([ // $mod.$main
  19363. '$mod.vP = null;',
  19364. '$mod.vP = $mod.vP;',
  19365. '$mod.vP = $mod.DoIt;',
  19366. '$mod.vP = $mod.DoIt;',
  19367. '$mod.vP(1);',
  19368. '$mod.vP(1);',
  19369. '$mod.vP(2);',
  19370. '$mod.b = $mod.vP(1) === $mod.vQ(1);',
  19371. '$mod.b = $mod.vP(1) === 3;',
  19372. '$mod.b = 4 === $mod.vP(1);',
  19373. '$mod.b = $mod.vP(1) !== $mod.vQ(1);',
  19374. '$mod.b = $mod.vP(1) !== 5;',
  19375. '$mod.b = 6 !== $mod.vP(1);',
  19376. '$mod.b = $mod.vP != null;',
  19377. '$mod.DoIt($mod.vP(1));',
  19378. '$mod.DoIt($mod.vP(1));',
  19379. '$mod.DoIt($mod.vP(2));',
  19380. '']));
  19381. end;
  19382. procedure TTestModule.TestProcType_ProcedureDelphi;
  19383. begin
  19384. StartProgram(false);
  19385. Add('{$mode Delphi}');
  19386. Add('type');
  19387. Add(' TProc = procedure;');
  19388. Add('procedure DoIt;');
  19389. Add('begin end;');
  19390. Add('var');
  19391. Add(' b: boolean;');
  19392. Add(' vP, vQ: tproc;');
  19393. Add('begin');
  19394. Add(' vp:=nil;');
  19395. Add(' vp:=vp;');
  19396. Add(' vp:=vq;');
  19397. 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
  19398. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  19399. //Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
  19400. Add(' vp;'); // ok in fpc and delphi
  19401. Add(' vp();');
  19402. // equal
  19403. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  19404. Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
  19405. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  19406. Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
  19407. Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
  19408. //Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  19409. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  19410. Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
  19411. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  19412. Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
  19413. // unequal
  19414. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  19415. Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
  19416. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  19417. Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
  19418. //Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  19419. Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
  19420. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  19421. Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
  19422. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  19423. Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
  19424. Add(' b:=Assigned(vp);');
  19425. ConvertProgram;
  19426. CheckSource('TestProcType_ProcedureDelphi',
  19427. LinesToStr([ // statements
  19428. 'this.DoIt = function() {',
  19429. '};',
  19430. 'this.b = false;',
  19431. 'this.vP = null;',
  19432. 'this.vQ = null;'
  19433. ]),
  19434. LinesToStr([ // $mod.$main
  19435. '$mod.vP = null;',
  19436. '$mod.vP = $mod.vP;',
  19437. '$mod.vP = $mod.vQ;',
  19438. '$mod.vP = $mod.DoIt;',
  19439. '$mod.vP = $mod.DoIt;',
  19440. '$mod.vP();',
  19441. '$mod.vP();',
  19442. '$mod.b = $mod.vP === null;',
  19443. '$mod.b = null === $mod.vP;',
  19444. '$mod.b = rtl.eqCallback($mod.vP, $mod.vQ);',
  19445. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  19446. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  19447. '$mod.b = $mod.vP !== null;',
  19448. '$mod.b = null !== $mod.vP;',
  19449. '$mod.b = !rtl.eqCallback($mod.vP, $mod.vQ);',
  19450. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  19451. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  19452. '$mod.b = $mod.vP != null;',
  19453. '']));
  19454. end;
  19455. procedure TTestModule.TestProcType_AsParam;
  19456. begin
  19457. StartProgram(false);
  19458. Add('type');
  19459. Add(' TFuncInt = function(vA: longint = 1): longint;');
  19460. Add('procedure DoIt(vG: tfuncint; const vH: tfuncint; var vI: tfuncint);');
  19461. Add('var vJ: tfuncint;');
  19462. Add('begin');
  19463. Add(' vg:=vg;');
  19464. Add(' vj:=vh;');
  19465. Add(' vi:=vi;');
  19466. Add(' doit(vg,vg,vg);');
  19467. Add(' doit(vh,vh,vj);');
  19468. Add(' doit(vi,vi,vi);');
  19469. Add(' doit(vj,vj,vj);');
  19470. Add('end;');
  19471. Add('var i: tfuncint;');
  19472. Add('begin');
  19473. Add(' doit(i,i,i);');
  19474. ConvertProgram;
  19475. CheckSource('TestProcType_AsParam',
  19476. LinesToStr([ // statements
  19477. 'this.DoIt = function (vG,vH,vI) {',
  19478. ' var vJ = null;',
  19479. ' vG = vG;',
  19480. ' vJ = vH;',
  19481. ' vI.set(vI.get());',
  19482. ' $mod.DoIt(vG, vG, {',
  19483. ' get: function () {',
  19484. ' return vG;',
  19485. ' },',
  19486. ' set: function (v) {',
  19487. ' vG = v;',
  19488. ' }',
  19489. ' });',
  19490. ' $mod.DoIt(vH, vH, {',
  19491. ' get: function () {',
  19492. ' return vJ;',
  19493. ' },',
  19494. ' set: function (v) {',
  19495. ' vJ = v;',
  19496. ' }',
  19497. ' });',
  19498. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  19499. ' $mod.DoIt(vJ, vJ, {',
  19500. ' get: function () {',
  19501. ' return vJ;',
  19502. ' },',
  19503. ' set: function (v) {',
  19504. ' vJ = v;',
  19505. ' }',
  19506. ' });',
  19507. '};',
  19508. 'this.i = null;'
  19509. ]),
  19510. LinesToStr([
  19511. '$mod.DoIt($mod.i,$mod.i,{',
  19512. ' p: $mod,',
  19513. ' get: function () {',
  19514. ' return this.p.i;',
  19515. ' },',
  19516. ' set: function (v) {',
  19517. ' this.p.i = v;',
  19518. ' }',
  19519. '});'
  19520. ]));
  19521. end;
  19522. procedure TTestModule.TestProcType_MethodFPC;
  19523. begin
  19524. StartProgram(false);
  19525. Add('type');
  19526. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19527. Add(' TObject = class');
  19528. Add(' function DoIt(vA: longint = 1): longint;');
  19529. Add(' end;');
  19530. Add('function TObject.DoIt(vA: longint = 1): longint;');
  19531. Add('begin');
  19532. Add('end;');
  19533. Add('var');
  19534. Add(' Obj: TObject;');
  19535. Add(' vP: tfuncint;');
  19536. Add(' b: boolean;');
  19537. Add('begin');
  19538. Add(' vp:[email protected];'); // ok in fpc and delphi
  19539. //Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  19540. Add(' vp;'); // ok in fpc and delphi
  19541. Add(' vp();');
  19542. Add(' vp(2);');
  19543. Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  19544. Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  19545. Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  19546. Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  19547. ConvertProgram;
  19548. CheckSource('TestProcType_MethodFPC',
  19549. LinesToStr([ // statements
  19550. 'rtl.createClass($mod, "TObject", null, function () {',
  19551. ' this.$init = function () {',
  19552. ' };',
  19553. ' this.$final = function () {',
  19554. ' };',
  19555. ' this.DoIt = function (vA) {',
  19556. ' var Result = 0;',
  19557. ' return Result;',
  19558. ' };',
  19559. '});',
  19560. 'this.Obj = null;',
  19561. 'this.vP = null;',
  19562. 'this.b = false;'
  19563. ]),
  19564. LinesToStr([
  19565. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  19566. '$mod.vP(1);',
  19567. '$mod.vP(1);',
  19568. '$mod.vP(2);',
  19569. '$mod.b = rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  19570. '$mod.b = rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  19571. '$mod.b = !rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  19572. '$mod.b = !rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  19573. '']));
  19574. end;
  19575. procedure TTestModule.TestProcType_MethodDelphi;
  19576. begin
  19577. StartProgram(false);
  19578. Add('{$mode delphi}');
  19579. Add('type');
  19580. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19581. Add(' TObject = class');
  19582. Add(' function DoIt(vA: longint = 1): longint;');
  19583. Add(' end;');
  19584. Add('function TObject.DoIt(vA: longint = 1): longint;');
  19585. Add('begin');
  19586. Add('end;');
  19587. Add('var');
  19588. Add(' Obj: TObject;');
  19589. Add(' vP: tfuncint;');
  19590. Add(' b: boolean;');
  19591. Add('begin');
  19592. Add(' vp:[email protected];'); // ok in fpc and delphi
  19593. Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  19594. Add(' vp;'); // ok in fpc and delphi
  19595. Add(' vp();');
  19596. Add(' vp(2);');
  19597. //Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  19598. //Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  19599. //Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  19600. //Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  19601. ConvertProgram;
  19602. CheckSource('TestProcType_MethodDelphi',
  19603. LinesToStr([ // statements
  19604. 'rtl.createClass($mod, "TObject", null, function () {',
  19605. ' this.$init = function () {',
  19606. ' };',
  19607. ' this.$final = function () {',
  19608. ' };',
  19609. ' this.DoIt = function (vA) {',
  19610. ' var Result = 0;',
  19611. ' return Result;',
  19612. ' };',
  19613. '});',
  19614. 'this.Obj = null;',
  19615. 'this.vP = null;',
  19616. 'this.b = false;'
  19617. ]),
  19618. LinesToStr([
  19619. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  19620. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  19621. '$mod.vP(1);',
  19622. '$mod.vP(1);',
  19623. '$mod.vP(2);',
  19624. '']));
  19625. end;
  19626. procedure TTestModule.TestProcType_PropertyFPC;
  19627. begin
  19628. StartProgram(false);
  19629. Add('type');
  19630. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19631. Add(' TObject = class');
  19632. Add(' FOnFoo: TFuncInt;');
  19633. Add(' function DoIt(vA: longint = 1): longint;');
  19634. Add(' function GetFoo: TFuncInt;');
  19635. Add(' procedure SetFoo(const Value: TFuncInt);');
  19636. Add(' function GetEvents(Index: longint): TFuncInt;');
  19637. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  19638. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  19639. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  19640. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  19641. Add(' end;');
  19642. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  19643. Add('function tobject.getfoo: tfuncint; begin end;');
  19644. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  19645. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  19646. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  19647. Add('var');
  19648. Add(' Obj: TObject;');
  19649. Add(' vP: tfuncint;');
  19650. Add(' b: boolean;');
  19651. Add('begin');
  19652. Add(' obj.onfoo:=nil;');
  19653. Add(' obj.onbar:=nil;');
  19654. Add(' obj.events[1]:=nil;');
  19655. Add(' obj.onfoo:=obj.onfoo;');
  19656. Add(' obj.onbar:=obj.onbar;');
  19657. Add(' obj.events[2]:=obj.events[3];');
  19658. Add(' obj.onfoo:[email protected];');
  19659. Add(' obj.onbar:[email protected];');
  19660. Add(' obj.events[4]:[email protected];');
  19661. //Add(' obj.onfoo:=obj.doit;'); // delphi
  19662. //Add(' obj.onbar:=obj.doit;'); // delphi
  19663. //Add(' obj.events[4]:=obj.doit;'); // delphi
  19664. Add(' obj.onfoo;');
  19665. Add(' obj.onbar;');
  19666. //Add(' obj.events[5];'); ToDo in pasresolver
  19667. Add(' obj.onfoo();');
  19668. Add(' obj.onbar();');
  19669. Add(' obj.events[6]();');
  19670. Add(' b:=obj.onfoo=nil;');
  19671. Add(' b:=obj.onbar=nil;');
  19672. Add(' b:=obj.events[7]=nil;');
  19673. Add(' b:=obj.onfoo<>nil;');
  19674. Add(' b:=obj.onbar<>nil;');
  19675. Add(' b:=obj.events[8]<>nil;');
  19676. Add(' b:=obj.onfoo=vp;');
  19677. Add(' b:=obj.onbar=vp;');
  19678. Add(' b:=obj.events[9]=vp;');
  19679. Add(' b:=obj.onfoo=obj.onfoo;');
  19680. Add(' b:=obj.onbar=obj.onfoo;');
  19681. Add(' b:=obj.events[10]=obj.onfoo;');
  19682. Add(' b:=obj.onfoo<>obj.onfoo;');
  19683. Add(' b:=obj.onbar<>obj.onfoo;');
  19684. Add(' b:=obj.events[11]<>obj.onfoo;');
  19685. Add(' b:[email protected];');
  19686. Add(' b:[email protected];');
  19687. Add(' b:=obj.events[12][email protected];');
  19688. Add(' b:=obj.onfoo<>@obj.doit;');
  19689. Add(' b:=obj.onbar<>@obj.doit;');
  19690. Add(' b:=obj.events[12]<>@obj.doit;');
  19691. Add(' b:=Assigned(obj.onfoo);');
  19692. Add(' b:=Assigned(obj.onbar);');
  19693. Add(' b:=Assigned(obj.events[13]);');
  19694. ConvertProgram;
  19695. CheckSource('TestProcType_PropertyFPC',
  19696. LinesToStr([ // statements
  19697. 'rtl.createClass($mod, "TObject", null, function () {',
  19698. ' this.$init = function () {',
  19699. ' this.FOnFoo = null;',
  19700. ' };',
  19701. ' this.$final = function () {',
  19702. ' this.FOnFoo = undefined;',
  19703. ' };',
  19704. ' this.DoIt = function (vA) {',
  19705. ' var Result = 0;',
  19706. ' return Result;',
  19707. ' };',
  19708. 'this.GetFoo = function () {',
  19709. ' var Result = null;',
  19710. ' return Result;',
  19711. '};',
  19712. 'this.SetFoo = function (Value) {',
  19713. '};',
  19714. 'this.GetEvents = function (Index) {',
  19715. ' var Result = null;',
  19716. ' return Result;',
  19717. '};',
  19718. 'this.SetEvents = function (Index, Value) {',
  19719. '};',
  19720. '});',
  19721. 'this.Obj = null;',
  19722. 'this.vP = null;',
  19723. 'this.b = false;'
  19724. ]),
  19725. LinesToStr([
  19726. '$mod.Obj.FOnFoo = null;',
  19727. '$mod.Obj.SetFoo(null);',
  19728. '$mod.Obj.SetEvents(1, null);',
  19729. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  19730. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  19731. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  19732. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  19733. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  19734. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  19735. '$mod.Obj.FOnFoo(1);',
  19736. '$mod.Obj.GetFoo();',
  19737. '$mod.Obj.FOnFoo(1);',
  19738. '$mod.Obj.GetFoo()(1);',
  19739. '$mod.Obj.GetEvents(6)(1);',
  19740. '$mod.b = $mod.Obj.FOnFoo === null;',
  19741. '$mod.b = $mod.Obj.GetFoo() === null;',
  19742. '$mod.b = $mod.Obj.GetEvents(7) === null;',
  19743. '$mod.b = $mod.Obj.FOnFoo !== null;',
  19744. '$mod.b = $mod.Obj.GetFoo() !== null;',
  19745. '$mod.b = $mod.Obj.GetEvents(8) !== null;',
  19746. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.vP);',
  19747. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.vP);',
  19748. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(9), $mod.vP);',
  19749. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  19750. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  19751. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(10), $mod.Obj.FOnFoo);',
  19752. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  19753. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  19754. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(11), $mod.Obj.FOnFoo);',
  19755. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  19756. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  19757. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  19758. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  19759. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  19760. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  19761. '$mod.b = $mod.Obj.FOnFoo != null;',
  19762. '$mod.b = $mod.Obj.GetFoo() != null;',
  19763. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  19764. '']));
  19765. end;
  19766. procedure TTestModule.TestProcType_PropertyDelphi;
  19767. begin
  19768. StartProgram(false);
  19769. Add('{$mode delphi}');
  19770. Add('type');
  19771. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19772. Add(' TObject = class');
  19773. Add(' FOnFoo: TFuncInt;');
  19774. Add(' function DoIt(vA: longint = 1): longint;');
  19775. Add(' function GetFoo: TFuncInt;');
  19776. Add(' procedure SetFoo(const Value: TFuncInt);');
  19777. Add(' function GetEvents(Index: longint): TFuncInt;');
  19778. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  19779. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  19780. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  19781. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  19782. Add(' end;');
  19783. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  19784. Add('function tobject.getfoo: tfuncint; begin end;');
  19785. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  19786. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  19787. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  19788. Add('var');
  19789. Add(' Obj: TObject;');
  19790. Add(' vP: tfuncint;');
  19791. Add(' b: boolean;');
  19792. Add('begin');
  19793. Add(' obj.onfoo:=nil;');
  19794. Add(' obj.onbar:=nil;');
  19795. Add(' obj.events[1]:=nil;');
  19796. Add(' obj.onfoo:=obj.onfoo;');
  19797. Add(' obj.onbar:=obj.onbar;');
  19798. Add(' obj.events[2]:=obj.events[3];');
  19799. Add(' obj.onfoo:[email protected];');
  19800. Add(' obj.onbar:[email protected];');
  19801. Add(' obj.events[4]:[email protected];');
  19802. Add(' obj.onfoo:=obj.doit;'); // delphi
  19803. Add(' obj.onbar:=obj.doit;'); // delphi
  19804. Add(' obj.events[4]:=obj.doit;'); // delphi
  19805. Add(' obj.onfoo;');
  19806. Add(' obj.onbar;');
  19807. //Add(' obj.events[5];'); ToDo in pasresolver
  19808. Add(' obj.onfoo();');
  19809. Add(' obj.onbar();');
  19810. Add(' obj.events[6]();');
  19811. //Add(' b:=obj.onfoo=nil;'); // fpc
  19812. //Add(' b:=obj.onbar=nil;'); // fpc
  19813. //Add(' b:=obj.events[7]=nil;'); // fpc
  19814. //Add(' b:=obj.onfoo<>nil;'); // fpc
  19815. //Add(' b:=obj.onbar<>nil;'); // fpc
  19816. //Add(' b:=obj.events[8]<>nil;'); // fpc
  19817. Add(' b:=obj.onfoo=vp;');
  19818. Add(' b:=obj.onbar=vp;');
  19819. //Add(' b:=obj.events[9]=vp;'); ToDo in pasresolver
  19820. Add(' b:=obj.onfoo=obj.onfoo;');
  19821. Add(' b:=obj.onbar=obj.onfoo;');
  19822. //Add(' b:=obj.events[10]=obj.onfoo;'); // ToDo in pasresolver
  19823. Add(' b:=obj.onfoo<>obj.onfoo;');
  19824. Add(' b:=obj.onbar<>obj.onfoo;');
  19825. //Add(' b:=obj.events[11]<>obj.onfoo;'); // ToDo in pasresolver
  19826. //Add(' b:[email protected];'); // fpc
  19827. //Add(' b:[email protected];'); // fpc
  19828. //Add(' b:=obj.events[12][email protected];'); // fpc
  19829. //Add(' b:=obj.onfoo<>@obj.doit;'); // fpc
  19830. //Add(' b:=obj.onbar<>@obj.doit;'); // fpc
  19831. //Add(' b:=obj.events[12]<>@obj.doit;'); // fpc
  19832. Add(' b:=Assigned(obj.onfoo);');
  19833. Add(' b:=Assigned(obj.onbar);');
  19834. Add(' b:=Assigned(obj.events[13]);');
  19835. ConvertProgram;
  19836. CheckSource('TestProcType_PropertyDelphi',
  19837. LinesToStr([ // statements
  19838. 'rtl.createClass($mod, "TObject", null, function () {',
  19839. ' this.$init = function () {',
  19840. ' this.FOnFoo = null;',
  19841. ' };',
  19842. ' this.$final = function () {',
  19843. ' this.FOnFoo = undefined;',
  19844. ' };',
  19845. ' this.DoIt = function (vA) {',
  19846. ' var Result = 0;',
  19847. ' return Result;',
  19848. ' };',
  19849. 'this.GetFoo = function () {',
  19850. ' var Result = null;',
  19851. ' return Result;',
  19852. '};',
  19853. 'this.SetFoo = function (Value) {',
  19854. '};',
  19855. 'this.GetEvents = function (Index) {',
  19856. ' var Result = null;',
  19857. ' return Result;',
  19858. '};',
  19859. 'this.SetEvents = function (Index, Value) {',
  19860. '};',
  19861. '});',
  19862. 'this.Obj = null;',
  19863. 'this.vP = null;',
  19864. 'this.b = false;'
  19865. ]),
  19866. LinesToStr([
  19867. '$mod.Obj.FOnFoo = null;',
  19868. '$mod.Obj.SetFoo(null);',
  19869. '$mod.Obj.SetEvents(1, null);',
  19870. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  19871. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  19872. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  19873. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  19874. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  19875. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  19876. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  19877. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  19878. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  19879. '$mod.Obj.FOnFoo(1);',
  19880. '$mod.Obj.GetFoo();',
  19881. '$mod.Obj.FOnFoo(1);',
  19882. '$mod.Obj.GetFoo()(1);',
  19883. '$mod.Obj.GetEvents(6)(1);',
  19884. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.vP(1);',
  19885. '$mod.b = $mod.Obj.GetFoo() === $mod.vP(1);',
  19886. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.Obj.FOnFoo(1);',
  19887. '$mod.b = $mod.Obj.GetFoo() === $mod.Obj.FOnFoo(1);',
  19888. '$mod.b = $mod.Obj.FOnFoo(1) !== $mod.Obj.FOnFoo(1);',
  19889. '$mod.b = $mod.Obj.GetFoo() !== $mod.Obj.FOnFoo(1);',
  19890. '$mod.b = $mod.Obj.FOnFoo != null;',
  19891. '$mod.b = $mod.Obj.GetFoo() != null;',
  19892. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  19893. '']));
  19894. end;
  19895. procedure TTestModule.TestProcType_WithClassInstDoPropertyFPC;
  19896. begin
  19897. StartProgram(false);
  19898. Add('type');
  19899. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  19900. Add(' TObject = class');
  19901. Add(' FOnFoo: TFuncInt;');
  19902. Add(' function DoIt(vA: longint = 1): longint;');
  19903. Add(' function GetFoo: TFuncInt;');
  19904. Add(' procedure SetFoo(const Value: TFuncInt);');
  19905. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  19906. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  19907. Add(' end;');
  19908. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  19909. Add('function tobject.getfoo: tfuncint; begin end;');
  19910. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  19911. Add('var');
  19912. Add(' Obj: TObject;');
  19913. Add(' vP: tfuncint;');
  19914. Add(' b: boolean;');
  19915. Add('begin');
  19916. Add('with obj do begin');
  19917. Add(' fonfoo:=nil;');
  19918. Add(' onfoo:=nil;');
  19919. Add(' onbar:=nil;');
  19920. Add(' fonfoo:=fonfoo;');
  19921. Add(' onfoo:=onfoo;');
  19922. Add(' onbar:=onbar;');
  19923. Add(' fonfoo:=@doit;');
  19924. Add(' onfoo:=@doit;');
  19925. Add(' onbar:=@doit;');
  19926. //Add(' fonfoo:=doit;'); // delphi
  19927. //Add(' onfoo:=doit;'); // delphi
  19928. //Add(' onbar:=doit;'); // delphi
  19929. Add(' fonfoo;');
  19930. Add(' onfoo;');
  19931. Add(' onbar;');
  19932. Add(' fonfoo();');
  19933. Add(' onfoo();');
  19934. Add(' onbar();');
  19935. Add(' b:=fonfoo=nil;');
  19936. Add(' b:=onfoo=nil;');
  19937. Add(' b:=onbar=nil;');
  19938. Add(' b:=fonfoo<>nil;');
  19939. Add(' b:=onfoo<>nil;');
  19940. Add(' b:=onbar<>nil;');
  19941. Add(' b:=fonfoo=vp;');
  19942. Add(' b:=onfoo=vp;');
  19943. Add(' b:=onbar=vp;');
  19944. Add(' b:=fonfoo=fonfoo;');
  19945. Add(' b:=onfoo=onfoo;');
  19946. Add(' b:=onbar=onfoo;');
  19947. Add(' b:=fonfoo<>fonfoo;');
  19948. Add(' b:=onfoo<>onfoo;');
  19949. Add(' b:=onbar<>onfoo;');
  19950. Add(' b:=fonfoo=@doit;');
  19951. Add(' b:=onfoo=@doit;');
  19952. Add(' b:=onbar=@doit;');
  19953. Add(' b:=fonfoo<>@doit;');
  19954. Add(' b:=onfoo<>@doit;');
  19955. Add(' b:=onbar<>@doit;');
  19956. Add(' b:=Assigned(fonfoo);');
  19957. Add(' b:=Assigned(onfoo);');
  19958. Add(' b:=Assigned(onbar);');
  19959. Add('end;');
  19960. ConvertProgram;
  19961. CheckSource('TestProcType_WithClassInstDoPropertyFPC',
  19962. LinesToStr([ // statements
  19963. 'rtl.createClass($mod, "TObject", null, function () {',
  19964. ' this.$init = function () {',
  19965. ' this.FOnFoo = null;',
  19966. ' };',
  19967. ' this.$final = function () {',
  19968. ' this.FOnFoo = undefined;',
  19969. ' };',
  19970. ' this.DoIt = function (vA) {',
  19971. ' var Result = 0;',
  19972. ' return Result;',
  19973. ' };',
  19974. ' this.GetFoo = function () {',
  19975. ' var Result = null;',
  19976. ' return Result;',
  19977. ' };',
  19978. ' this.SetFoo = function (Value) {',
  19979. ' };',
  19980. '});',
  19981. 'this.Obj = null;',
  19982. 'this.vP = null;',
  19983. 'this.b = false;'
  19984. ]),
  19985. LinesToStr([
  19986. 'var $with1 = $mod.Obj;',
  19987. '$with1.FOnFoo = null;',
  19988. '$with1.FOnFoo = null;',
  19989. '$with1.SetFoo(null);',
  19990. '$with1.FOnFoo = $with1.FOnFoo;',
  19991. '$with1.FOnFoo = $with1.FOnFoo;',
  19992. '$with1.SetFoo($with1.GetFoo());',
  19993. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  19994. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  19995. '$with1.SetFoo(rtl.createCallback($with1, "DoIt"));',
  19996. '$with1.FOnFoo(1);',
  19997. '$with1.FOnFoo(1);',
  19998. '$with1.GetFoo();',
  19999. '$with1.FOnFoo(1);',
  20000. '$with1.FOnFoo(1);',
  20001. '$with1.GetFoo()(1);',
  20002. '$mod.b = $with1.FOnFoo === null;',
  20003. '$mod.b = $with1.FOnFoo === null;',
  20004. '$mod.b = $with1.GetFoo() === null;',
  20005. '$mod.b = $with1.FOnFoo !== null;',
  20006. '$mod.b = $with1.FOnFoo !== null;',
  20007. '$mod.b = $with1.GetFoo() !== null;',
  20008. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  20009. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  20010. '$mod.b = rtl.eqCallback($with1.GetFoo(), $mod.vP);',
  20011. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  20012. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  20013. '$mod.b = rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  20014. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  20015. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  20016. '$mod.b = !rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  20017. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  20018. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  20019. '$mod.b = rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  20020. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  20021. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  20022. '$mod.b = !rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  20023. '$mod.b = $with1.FOnFoo != null;',
  20024. '$mod.b = $with1.FOnFoo != null;',
  20025. '$mod.b = $with1.GetFoo() != null;',
  20026. '']));
  20027. end;
  20028. procedure TTestModule.TestProcType_Nested;
  20029. begin
  20030. StartProgram(false);
  20031. Add([
  20032. 'type',
  20033. ' TProcInt = procedure(vI: longint = 1);',
  20034. 'procedure DoIt(vJ: longint);',
  20035. 'var aProc: TProcInt;',
  20036. ' b: boolean;',
  20037. ' procedure Sub(vK: longint);',
  20038. ' var aSub: TProcInt;',
  20039. ' procedure SubSub(vK: longint);',
  20040. ' var aSubSub: TProcInt;',
  20041. ' begin;',
  20042. ' aProc:=@DoIt;',
  20043. ' aSub:=@DoIt;',
  20044. ' aSubSub:=@DoIt;',
  20045. ' aProc:=@Sub;',
  20046. ' aSub:=@Sub;',
  20047. ' aSubSub:=@Sub;',
  20048. ' aProc:=@SubSub;',
  20049. ' aSub:=@SubSub;',
  20050. ' aSubSub:=@SubSub;',
  20051. ' end;',
  20052. ' begin;',
  20053. ' end;',
  20054. 'begin;',
  20055. ' aProc:=@Sub;',
  20056. ' b:=aProc=@Sub;',
  20057. ' b:=@Sub=aProc;',
  20058. 'end;',
  20059. 'begin',
  20060. '']);
  20061. ConvertProgram;
  20062. CheckSource('TestProcType_Nested',
  20063. LinesToStr([ // statements
  20064. 'this.DoIt = function (vJ) {',
  20065. ' var aProc = null;',
  20066. ' var b = false;',
  20067. ' function Sub(vK) {',
  20068. ' var aSub = null;',
  20069. ' function SubSub(vK) {',
  20070. ' var aSubSub = null;',
  20071. ' aProc = $mod.DoIt;',
  20072. ' aSub = $mod.DoIt;',
  20073. ' aSubSub = $mod.DoIt;',
  20074. ' aProc = Sub;',
  20075. ' aSub = Sub;',
  20076. ' aSubSub = Sub;',
  20077. ' aProc = SubSub;',
  20078. ' aSub = SubSub;',
  20079. ' aSubSub = SubSub;',
  20080. ' };',
  20081. ' };',
  20082. ' aProc = Sub;',
  20083. ' b = rtl.eqCallback(aProc, Sub);',
  20084. ' b = rtl.eqCallback(Sub, aProc);',
  20085. '};',
  20086. '']),
  20087. LinesToStr([ // $mod.$main
  20088. '']));
  20089. end;
  20090. procedure TTestModule.TestProcType_NestedOfObject;
  20091. begin
  20092. StartProgram(false);
  20093. Add([
  20094. 'type',
  20095. ' TProcInt = procedure(vI: longint = 1) of object;',
  20096. ' TObject = class',
  20097. ' procedure DoIt(vJ: longint);',
  20098. ' end;',
  20099. 'procedure TObject.DoIt(vJ: longint);',
  20100. 'var aProc: TProcInt;',
  20101. ' b: boolean;',
  20102. ' procedure Sub(vK: longint);',
  20103. ' var aSub: TProcInt;',
  20104. ' procedure SubSub(vK: longint);',
  20105. ' var aSubSub: TProcInt;',
  20106. ' begin;',
  20107. ' aProc:=@DoIt;',
  20108. ' aSub:=@DoIt;',
  20109. ' aSubSub:=@DoIt;',
  20110. ' aProc:=@Sub;',
  20111. ' aSub:=@Sub;',
  20112. ' aSubSub:=@Sub;',
  20113. ' aProc:=@SubSub;',
  20114. ' aSub:=@SubSub;',
  20115. ' aSubSub:=@SubSub;',
  20116. ' end;',
  20117. ' begin;',
  20118. ' end;',
  20119. 'begin;',
  20120. ' aProc:=@Sub;',
  20121. ' b:=aProc=@Sub;',
  20122. ' b:=@Sub=aProc;',
  20123. 'end;',
  20124. 'begin',
  20125. '']);
  20126. ConvertProgram;
  20127. CheckSource('TestProcType_Nested',
  20128. LinesToStr([ // statements
  20129. 'rtl.createClass($mod, "TObject", null, function () {',
  20130. ' this.$init = function () {',
  20131. ' };',
  20132. ' this.$final = function () {',
  20133. ' };',
  20134. ' this.DoIt = function (vJ) {',
  20135. ' var $Self = this;',
  20136. ' var aProc = null;',
  20137. ' var b = false;',
  20138. ' function Sub(vK) {',
  20139. ' var aSub = null;',
  20140. ' function SubSub(vK) {',
  20141. ' var aSubSub = null;',
  20142. ' aProc = rtl.createCallback($Self, "DoIt");',
  20143. ' aSub = rtl.createCallback($Self, "DoIt");',
  20144. ' aSubSub = rtl.createCallback($Self, "DoIt");',
  20145. ' aProc = Sub;',
  20146. ' aSub = Sub;',
  20147. ' aSubSub = Sub;',
  20148. ' aProc = SubSub;',
  20149. ' aSub = SubSub;',
  20150. ' aSubSub = SubSub;',
  20151. ' };',
  20152. ' };',
  20153. ' aProc = Sub;',
  20154. ' b = rtl.eqCallback(aProc, Sub);',
  20155. ' b = rtl.eqCallback(Sub, aProc);',
  20156. ' };',
  20157. '});',
  20158. '']),
  20159. LinesToStr([ // $mod.$main
  20160. '']));
  20161. end;
  20162. procedure TTestModule.TestProcType_ReferenceToProc;
  20163. begin
  20164. StartProgram(false);
  20165. Add([
  20166. 'type',
  20167. ' TProcRef = reference to procedure(i: longint = 0);',
  20168. ' TFuncRef = reference to function(i: longint = 0): longint;',
  20169. 'var',
  20170. ' p: TProcRef;',
  20171. ' f: TFuncRef;',
  20172. 'procedure DoIt(i: longint);',
  20173. 'begin',
  20174. 'end;',
  20175. 'function GetIt(i: longint): longint;',
  20176. 'begin',
  20177. ' p:=@DoIt;',
  20178. ' f:=@GetIt;',
  20179. ' f;',
  20180. ' f();',
  20181. ' f(1);',
  20182. 'end;',
  20183. 'begin',
  20184. ' p:=@DoIt;',
  20185. ' f:=@GetIt;',
  20186. ' f;',
  20187. ' f();',
  20188. ' f(1);',
  20189. ' p:=TProcRef(f);',
  20190. '']);
  20191. ConvertProgram;
  20192. CheckSource('TestProcType_ReferenceToProc',
  20193. LinesToStr([ // statements
  20194. 'this.p = null;',
  20195. 'this.f = null;',
  20196. 'this.DoIt = function (i) {',
  20197. '};',
  20198. 'this.GetIt = function (i) {',
  20199. ' var Result = 0;',
  20200. ' $mod.p = $mod.DoIt;',
  20201. ' $mod.f = $mod.GetIt;',
  20202. ' $mod.f(0);',
  20203. ' $mod.f(0);',
  20204. ' $mod.f(1);',
  20205. ' return Result;',
  20206. '};',
  20207. '']),
  20208. LinesToStr([ // $mod.$main
  20209. '$mod.p = $mod.DoIt;',
  20210. '$mod.f = $mod.GetIt;',
  20211. '$mod.f(0);',
  20212. '$mod.f(0);',
  20213. '$mod.f(1);',
  20214. '$mod.p = $mod.f;',
  20215. '']));
  20216. end;
  20217. procedure TTestModule.TestProcType_ReferenceToMethod;
  20218. begin
  20219. StartProgram(false);
  20220. Add([
  20221. 'type',
  20222. ' TFuncRef = reference to function(i: longint = 5): longint;',
  20223. ' TObject = class',
  20224. ' function Grow(s: longint): longint;',
  20225. ' end;',
  20226. 'var',
  20227. ' f: tfuncref;',
  20228. 'function tobject.grow(s: longint): longint;',
  20229. ' function GrowSub(i: longint): longint;',
  20230. ' begin',
  20231. ' f:=@grow;',
  20232. ' f:=@growsub;',
  20233. ' end;',
  20234. 'begin',
  20235. ' f:=@grow;',
  20236. ' f:=@growsub;',
  20237. 'end;',
  20238. 'begin',
  20239. '']);
  20240. ConvertProgram;
  20241. CheckSource('TestProcType_ReferenceToMethod',
  20242. LinesToStr([ // statements
  20243. 'rtl.createClass($mod, "TObject", null, function () {',
  20244. ' this.$init = function () {',
  20245. ' };',
  20246. ' this.$final = function () {',
  20247. ' };',
  20248. ' this.Grow = function (s) {',
  20249. ' var $Self = this;',
  20250. ' var Result = 0;',
  20251. ' function GrowSub(i) {',
  20252. ' var Result = 0;',
  20253. ' $mod.f = rtl.createCallback($Self, "Grow");',
  20254. ' $mod.f = GrowSub;',
  20255. ' return Result;',
  20256. ' };',
  20257. ' $mod.f = rtl.createCallback($Self, "Grow");',
  20258. ' $mod.f = GrowSub;',
  20259. ' return Result;',
  20260. ' };',
  20261. '});',
  20262. 'this.f = null;',
  20263. '']),
  20264. LinesToStr([ // $mod.$main
  20265. '']));
  20266. end;
  20267. procedure TTestModule.TestProcType_Typecast;
  20268. begin
  20269. StartProgram(false);
  20270. Add([
  20271. 'type',
  20272. ' TNotifyEvent = procedure(Sender: Pointer) of object;',
  20273. ' TEvent = procedure of object;',
  20274. ' TGetter = function:longint of object;',
  20275. ' TProcA = procedure(i: longint);',
  20276. ' TFuncB = function(i, j: longint): longint;',
  20277. 'procedure DoIt(); varargs; begin end;',
  20278. 'var',
  20279. ' Notify: tnotifyevent;',
  20280. ' Event: tevent;',
  20281. ' Getter: tgetter;',
  20282. ' ProcA: tproca;',
  20283. ' FuncB: tfuncb;',
  20284. ' p: pointer;',
  20285. 'begin',
  20286. ' notify:=tnotifyevent(event);',
  20287. ' event:=tevent(event);',
  20288. ' event:=tevent(notify);',
  20289. ' event:=tevent(getter);',
  20290. ' event:=tevent(proca);',
  20291. ' proca:=tproca(funcb);',
  20292. ' funcb:=tfuncb(funcb);',
  20293. ' funcb:=tfuncb(proca);',
  20294. ' funcb:=tfuncb(getter);',
  20295. ' proca:=tproca(p);',
  20296. ' funcb:=tfuncb(p);',
  20297. ' getter:=tgetter(p);',
  20298. ' p:=pointer(notify);',
  20299. ' p:=notify;',
  20300. ' p:=pointer(proca);',
  20301. ' p:=proca;',
  20302. ' p:=pointer(funcb);',
  20303. ' p:=funcb;',
  20304. ' doit(Pointer(notify),pointer(event),pointer(proca));',
  20305. '']);
  20306. ConvertProgram;
  20307. CheckSource('TestProcType_Typecast',
  20308. LinesToStr([ // statements
  20309. 'this.DoIt = function () {',
  20310. '};',
  20311. 'this.Notify = null;',
  20312. 'this.Event = null;',
  20313. 'this.Getter = null;',
  20314. 'this.ProcA = null;',
  20315. 'this.FuncB = null;',
  20316. 'this.p = null;',
  20317. '']),
  20318. LinesToStr([ // $mod.$main
  20319. '$mod.Notify = $mod.Event;',
  20320. '$mod.Event = $mod.Event;',
  20321. '$mod.Event = $mod.Notify;',
  20322. '$mod.Event = $mod.Getter;',
  20323. '$mod.Event = $mod.ProcA;',
  20324. '$mod.ProcA = $mod.FuncB;',
  20325. '$mod.FuncB = $mod.FuncB;',
  20326. '$mod.FuncB = $mod.ProcA;',
  20327. '$mod.FuncB = $mod.Getter;',
  20328. '$mod.ProcA = $mod.p;',
  20329. '$mod.FuncB = $mod.p;',
  20330. '$mod.Getter = $mod.p;',
  20331. '$mod.p = $mod.Notify;',
  20332. '$mod.p = $mod.Notify;',
  20333. '$mod.p = $mod.ProcA;',
  20334. '$mod.p = $mod.ProcA;',
  20335. '$mod.p = $mod.FuncB;',
  20336. '$mod.p = $mod.FuncB;',
  20337. '$mod.DoIt($mod.Notify, $mod.Event, $mod.ProcA);',
  20338. '']));
  20339. end;
  20340. procedure TTestModule.TestProcType_PassProcToUntyped;
  20341. begin
  20342. StartProgram(false);
  20343. Add([
  20344. 'type',
  20345. ' TEvent = procedure of object;',
  20346. ' TFunc = function: longint;',
  20347. 'procedure DoIt(); varargs; begin end;',
  20348. 'procedure DoSome(const a; var b; p: pointer); begin end;',
  20349. 'var',
  20350. ' Event: tevent;',
  20351. ' Func: TFunc;',
  20352. 'begin',
  20353. ' doit(event,func);',
  20354. ' dosome(event,event,event);',
  20355. ' dosome(func,func,func);',
  20356. '']);
  20357. ConvertProgram;
  20358. CheckSource('TestProcType_PassProcToUntyped',
  20359. LinesToStr([ // statements
  20360. 'this.DoIt = function () {',
  20361. '};',
  20362. 'this.DoSome = function (a, b, p) {',
  20363. '};',
  20364. 'this.Event = null;',
  20365. 'this.Func = null;',
  20366. '']),
  20367. LinesToStr([ // $mod.$main
  20368. '$mod.DoIt($mod.Event, $mod.Func);',
  20369. '$mod.DoSome($mod.Event, {',
  20370. ' p: $mod,',
  20371. ' get: function () {',
  20372. ' return this.p.Event;',
  20373. ' },',
  20374. ' set: function (v) {',
  20375. ' this.p.Event = v;',
  20376. ' }',
  20377. '}, $mod.Event);',
  20378. '$mod.DoSome($mod.Func, {',
  20379. ' p: $mod,',
  20380. ' get: function () {',
  20381. ' return this.p.Func;',
  20382. ' },',
  20383. ' set: function (v) {',
  20384. ' this.p.Func = v;',
  20385. ' }',
  20386. '}, $mod.Func);',
  20387. '']));
  20388. end;
  20389. procedure TTestModule.TestProcType_PassProcToArray;
  20390. begin
  20391. StartProgram(false);
  20392. Add([
  20393. 'type',
  20394. ' TFunc = function: longint;',
  20395. ' TArrFunc = array of TFunc;',
  20396. 'procedure DoIt(Arr: TArrFunc); begin end;',
  20397. 'function GetIt: longint; begin end;',
  20398. 'var',
  20399. ' Func: tfunc;',
  20400. 'begin',
  20401. ' doit([]);',
  20402. ' doit([@GetIt]);',
  20403. ' doit([Func]);',
  20404. '']);
  20405. ConvertProgram;
  20406. CheckSource('TestProcType_PassProcToArray',
  20407. LinesToStr([ // statements
  20408. 'this.DoIt = function (Arr) {',
  20409. '};',
  20410. 'this.GetIt = function () {',
  20411. ' var Result = 0;',
  20412. ' return Result;',
  20413. '};',
  20414. 'this.Func = null;',
  20415. '']),
  20416. LinesToStr([ // $mod.$main
  20417. '$mod.DoIt([]);',
  20418. '$mod.DoIt([$mod.GetIt]);',
  20419. '$mod.DoIt([$mod.Func]);',
  20420. '']));
  20421. end;
  20422. procedure TTestModule.TestPointer;
  20423. begin
  20424. StartProgram(false);
  20425. Add(['type',
  20426. ' TObject = class end;',
  20427. ' TClass = class of TObject;',
  20428. ' TArrInt = array of longint;',
  20429. 'const',
  20430. ' n = nil;',
  20431. 'var',
  20432. ' v: jsvalue;',
  20433. ' Obj: tobject;',
  20434. ' C: tclass;',
  20435. ' a: tarrint;',
  20436. ' p: Pointer = nil;',
  20437. ' s: string;',
  20438. 'begin',
  20439. ' p:=p;',
  20440. ' p:=nil;',
  20441. ' if p=nil then;',
  20442. ' if nil=p then;',
  20443. ' if Assigned(p) then;',
  20444. ' p:=Pointer(v);',
  20445. ' p:=obj;',
  20446. ' p:=c;',
  20447. ' p:=a;',
  20448. ' p:=tobject;',
  20449. ' obj:=TObject(p);',
  20450. ' c:=TClass(p);',
  20451. ' a:=TArrInt(p);',
  20452. ' p:=n;',
  20453. ' p:=Pointer(a);',
  20454. ' p:=pointer(s);',
  20455. ' s:=string(p);',
  20456. '']);
  20457. ConvertProgram;
  20458. CheckSource('TestPointer',
  20459. LinesToStr([ // statements
  20460. 'rtl.createClass($mod, "TObject", null, function () {',
  20461. ' this.$init = function () {',
  20462. ' };',
  20463. ' this.$final = function () {',
  20464. ' };',
  20465. '});',
  20466. 'this.n = null;',
  20467. 'this.v = undefined;',
  20468. 'this.Obj = null;',
  20469. 'this.C = null;',
  20470. 'this.a = [];',
  20471. 'this.p = null;',
  20472. 'this.s = "";',
  20473. '']),
  20474. LinesToStr([ // $mod.$main
  20475. '$mod.p = $mod.p;',
  20476. '$mod.p = null;',
  20477. 'if ($mod.p === null) ;',
  20478. 'if (null === $mod.p) ;',
  20479. 'if ($mod.p != null) ;',
  20480. '$mod.p = $mod.v;',
  20481. '$mod.p = $mod.Obj;',
  20482. '$mod.p = $mod.C;',
  20483. '$mod.p = $mod.a;',
  20484. '$mod.p = $mod.TObject;',
  20485. '$mod.Obj = $mod.p;',
  20486. '$mod.C = $mod.p;',
  20487. '$mod.a = $mod.p;',
  20488. '$mod.p = null;',
  20489. '$mod.p = $mod.a;',
  20490. '$mod.p = $mod.s;',
  20491. '$mod.s = $mod.p;',
  20492. '']));
  20493. end;
  20494. procedure TTestModule.TestPointer_Proc;
  20495. begin
  20496. StartProgram(false);
  20497. Add('type');
  20498. Add(' TObject = class');
  20499. Add(' procedure DoIt; virtual; abstract;');
  20500. Add(' end;');
  20501. Add('procedure DoSome; begin end;');
  20502. Add('var');
  20503. Add(' o: TObject;');
  20504. Add(' p: Pointer;');
  20505. Add('begin');
  20506. Add(' p:=@DoSome;');
  20507. Add(' p:[email protected];');
  20508. ConvertProgram;
  20509. CheckSource('TestPointer_Proc',
  20510. LinesToStr([ // statements
  20511. 'rtl.createClass($mod, "TObject", null, function () {',
  20512. ' this.$init = function () {',
  20513. ' };',
  20514. ' this.$final = function () {',
  20515. ' };',
  20516. '});',
  20517. 'this.DoSome = function () {',
  20518. '};',
  20519. 'this.o = null;',
  20520. 'this.p = null;',
  20521. '']),
  20522. LinesToStr([ // $mod.$main
  20523. '$mod.p = $mod.DoSome;',
  20524. '$mod.p = rtl.createCallback($mod.o, "DoIt");',
  20525. '']));
  20526. end;
  20527. procedure TTestModule.TestPointer_AssignRecordFail;
  20528. begin
  20529. StartProgram(false);
  20530. Add('type');
  20531. Add(' TRec = record end;');
  20532. Add('var');
  20533. Add(' p: Pointer;');
  20534. Add(' r: TRec;');
  20535. Add('begin');
  20536. Add(' p:=r;');
  20537. SetExpectedPasResolverError('Incompatible types: got "TRec" expected "Pointer"',
  20538. nIncompatibleTypesGotExpected);
  20539. ConvertProgram;
  20540. end;
  20541. procedure TTestModule.TestPointer_AssignStaticArrayFail;
  20542. begin
  20543. StartProgram(false);
  20544. Add('type');
  20545. Add(' TArr = array[boolean] of longint;');
  20546. Add('var');
  20547. Add(' p: Pointer;');
  20548. Add(' a: TArr;');
  20549. Add('begin');
  20550. Add(' p:=a;');
  20551. SetExpectedPasResolverError('Incompatible types: got "TArr" expected "Pointer"',
  20552. nIncompatibleTypesGotExpected);
  20553. ConvertProgram;
  20554. end;
  20555. procedure TTestModule.TestPointer_TypeCastJSValueToPointer;
  20556. begin
  20557. StartProgram(false);
  20558. Add([
  20559. 'procedure DoIt(args: array of jsvalue); begin end;',
  20560. 'procedure DoAll; varargs; begin end;',
  20561. 'var',
  20562. ' v: jsvalue;',
  20563. 'begin',
  20564. ' DoIt([pointer(v)]);',
  20565. ' DoAll(pointer(v));',
  20566. '']);
  20567. ConvertProgram;
  20568. CheckSource('TestPointer_TypeCastJSValueToPointer',
  20569. LinesToStr([ // statements
  20570. 'this.DoIt = function (args) {',
  20571. '};',
  20572. 'this.DoAll = function () {',
  20573. '};',
  20574. 'this.v = undefined;',
  20575. '']),
  20576. LinesToStr([ // $mod.$main
  20577. '$mod.DoIt([$mod.v]);',
  20578. '$mod.DoAll($mod.v);',
  20579. '']));
  20580. end;
  20581. procedure TTestModule.TestPointer_NonRecordFail;
  20582. begin
  20583. StartProgram(false);
  20584. Add([
  20585. 'type',
  20586. ' p = ^longint;',
  20587. 'begin',
  20588. '']);
  20589. SetExpectedPasResolverError('Not supported: pointer of Longint',nNotSupportedX);
  20590. ConvertProgram;
  20591. end;
  20592. procedure TTestModule.TestPointer_AnonymousArgTypeFail;
  20593. begin
  20594. StartProgram(false);
  20595. Add([
  20596. 'procedure DoIt(p: ^longint); begin end;',
  20597. 'begin',
  20598. '']);
  20599. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  20600. ConvertProgram;
  20601. end;
  20602. procedure TTestModule.TestPointer_AnonymousVarTypeFail;
  20603. begin
  20604. StartProgram(false);
  20605. Add([
  20606. 'var p: ^longint;',
  20607. 'begin',
  20608. '']);
  20609. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  20610. ConvertProgram;
  20611. end;
  20612. procedure TTestModule.TestPointer_AnonymousResultTypeFail;
  20613. begin
  20614. StartProgram(false);
  20615. Add([
  20616. 'function DoIt: ^longint; begin end;',
  20617. 'begin',
  20618. '']);
  20619. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  20620. ConvertProgram;
  20621. end;
  20622. procedure TTestModule.TestPointer_AddrOperatorFail;
  20623. begin
  20624. StartProgram(false);
  20625. Add([
  20626. 'var i: longint;',
  20627. 'begin',
  20628. ' if @i=nil then ;',
  20629. '']);
  20630. SetExpectedConverterError('illegal qualifier "@" in front of "i:Longint"',nIllegalQualifierInFrontOf);
  20631. ConvertProgram;
  20632. end;
  20633. procedure TTestModule.TestPointer_ArrayParamsFail;
  20634. begin
  20635. StartProgram(false);
  20636. Add([
  20637. 'var',
  20638. ' p: Pointer;',
  20639. 'begin',
  20640. ' p:=p[1];',
  20641. '']);
  20642. SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter);
  20643. ConvertProgram;
  20644. end;
  20645. procedure TTestModule.TestPointer_PointerAddFail;
  20646. begin
  20647. StartProgram(false);
  20648. Add([
  20649. 'var',
  20650. ' p: Pointer;',
  20651. 'begin',
  20652. ' p:=p+1;',
  20653. '']);
  20654. SetExpectedPasResolverError('Operator is not overloaded: "Pointer" + "Longint"',nOperatorIsNotOverloadedAOpB);
  20655. ConvertProgram;
  20656. end;
  20657. procedure TTestModule.TestPointer_IncPointerFail;
  20658. begin
  20659. StartProgram(false);
  20660. Add([
  20661. 'var',
  20662. ' p: Pointer;',
  20663. 'begin',
  20664. ' inc(p,1);',
  20665. '']);
  20666. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Pointer", expected "integer"',
  20667. nIncompatibleTypeArgNo);
  20668. ConvertProgram;
  20669. end;
  20670. procedure TTestModule.TestPointer_Record;
  20671. begin
  20672. StartProgram(false);
  20673. Add([
  20674. 'type',
  20675. ' TRec = record x: longint; end;',
  20676. ' PRec = ^TRec;',
  20677. 'var',
  20678. ' r: TRec;',
  20679. ' p: PRec;',
  20680. ' q: ^TRec;',
  20681. ' Ptr: pointer;',
  20682. 'begin',
  20683. ' new(p);',
  20684. ' p:=@r;',
  20685. ' r:=p^;',
  20686. ' r.x:=p^.x;',
  20687. ' p^.x:=r.x;',
  20688. ' if p^.x=3 then ;',
  20689. ' if 4=p^.x then ;',
  20690. ' dispose(p);',
  20691. ' new(q);',
  20692. ' dispose(q);',
  20693. ' Ptr:=p;',
  20694. ' p:=PRec(ptr);',
  20695. '']);
  20696. ConvertProgram;
  20697. CheckSource('TestPointer_Record',
  20698. LinesToStr([ // statements
  20699. 'rtl.recNewT($mod, "TRec", function () {',
  20700. ' this.x = 0;',
  20701. ' this.$eq = function (b) {',
  20702. ' return this.x === b.x;',
  20703. ' };',
  20704. ' this.$assign = function (s) {',
  20705. ' this.x = s.x;',
  20706. ' return this;',
  20707. ' };',
  20708. '});',
  20709. 'this.r = $mod.TRec.$new();',
  20710. 'this.p = null;',
  20711. 'this.q = null;',
  20712. 'this.Ptr = null;',
  20713. '']),
  20714. LinesToStr([ // $mod.$main
  20715. '$mod.p = $mod.TRec.$new();',
  20716. '$mod.p = $mod.r;',
  20717. '$mod.r.$assign($mod.p);',
  20718. '$mod.r.x = $mod.p.x;',
  20719. '$mod.p.x = $mod.r.x;',
  20720. 'if ($mod.p.x === 3) ;',
  20721. 'if (4 === $mod.p.x) ;',
  20722. '$mod.p = null;',
  20723. '$mod.q = $mod.TRec.$new();',
  20724. '$mod.q = null;',
  20725. '$mod.Ptr = $mod.p;',
  20726. '$mod.p = $mod.Ptr;',
  20727. '']));
  20728. end;
  20729. procedure TTestModule.TestPointer_RecordArg;
  20730. begin
  20731. StartProgram(false);
  20732. Add([
  20733. '{$modeswitch autoderef}',
  20734. 'type',
  20735. ' TRec = record x: longint; end;',
  20736. ' PRec = ^TRec;',
  20737. 'function DoIt(const a: PRec; var b: PRec; out c: PRec): TRec;',
  20738. 'begin',
  20739. ' a.x:=a.x;',
  20740. ' a^.x:=a^.x;',
  20741. ' with a^ do',
  20742. ' x:=x;',
  20743. 'end;',
  20744. 'function GetIt(p: PRec): PRec;',
  20745. 'begin',
  20746. ' p.x:=p.x;',
  20747. ' p^.x:=p^.x;',
  20748. ' with p^ do',
  20749. ' x:=x;',
  20750. 'end;',
  20751. 'var',
  20752. ' r: TRec;',
  20753. ' p: PRec;',
  20754. 'begin',
  20755. ' p:=GetIt(p);',
  20756. ' p^:=GetIt(@r)^;',
  20757. ' DoIt(p,p,p);',
  20758. ' DoIt(@r,p,p);',
  20759. '']);
  20760. ConvertProgram;
  20761. CheckSource('TestPointer_Record',
  20762. LinesToStr([ // statements
  20763. 'rtl.recNewT($mod, "TRec", function () {',
  20764. ' this.x = 0;',
  20765. ' this.$eq = function (b) {',
  20766. ' return this.x === b.x;',
  20767. ' };',
  20768. ' this.$assign = function (s) {',
  20769. ' this.x = s.x;',
  20770. ' return this;',
  20771. ' };',
  20772. '});',
  20773. 'this.DoIt = function (a, b, c) {',
  20774. ' var Result = $mod.TRec.$new();',
  20775. ' a.x = a.x;',
  20776. ' a.x = a.x;',
  20777. ' a.x = a.x;',
  20778. ' return Result;',
  20779. '};',
  20780. 'this.GetIt = function (p) {',
  20781. ' var Result = null;',
  20782. ' p.x = p.x;',
  20783. ' p.x = p.x;',
  20784. ' p.x = p.x;',
  20785. ' return Result;',
  20786. '};',
  20787. 'this.r = $mod.TRec.$new();',
  20788. 'this.p = null;',
  20789. '']),
  20790. LinesToStr([ // $mod.$main
  20791. '$mod.p = $mod.GetIt($mod.p);',
  20792. '$mod.p.$assign($mod.GetIt($mod.r));',
  20793. '$mod.DoIt($mod.p, {',
  20794. ' p: $mod,',
  20795. ' get: function () {',
  20796. ' return this.p.p;',
  20797. ' },',
  20798. ' set: function (v) {',
  20799. ' this.p.p = v;',
  20800. ' }',
  20801. '}, {',
  20802. ' p: $mod,',
  20803. ' get: function () {',
  20804. ' return this.p.p;',
  20805. ' },',
  20806. ' set: function (v) {',
  20807. ' this.p.p = v;',
  20808. ' }',
  20809. '});',
  20810. '$mod.DoIt($mod.r, {',
  20811. ' p: $mod,',
  20812. ' get: function () {',
  20813. ' return this.p.p;',
  20814. ' },',
  20815. ' set: function (v) {',
  20816. ' this.p.p = v;',
  20817. ' }',
  20818. '}, {',
  20819. ' p: $mod,',
  20820. ' get: function () {',
  20821. ' return this.p.p;',
  20822. ' },',
  20823. ' set: function (v) {',
  20824. ' this.p.p = v;',
  20825. ' }',
  20826. '});',
  20827. '']));
  20828. end;
  20829. procedure TTestModule.TestJSValue_AssignToJSValue;
  20830. begin
  20831. StartProgram(false);
  20832. Add('var');
  20833. Add(' v: jsvalue;');
  20834. Add(' i: longint;');
  20835. Add(' s: string;');
  20836. Add(' b: boolean;');
  20837. Add(' d: double;');
  20838. Add(' p: pointer;');
  20839. Add('begin');
  20840. Add(' v:=v;');
  20841. Add(' v:=1;');
  20842. Add(' v:=i;');
  20843. Add(' v:='''';');
  20844. Add(' v:=''c'';');
  20845. Add(' v:=''foo'';');
  20846. Add(' v:=s;');
  20847. Add(' v:=false;');
  20848. Add(' v:=true;');
  20849. Add(' v:=b;');
  20850. Add(' v:=0.1;');
  20851. Add(' v:=d;');
  20852. Add(' v:=nil;');
  20853. Add(' v:=p;');
  20854. ConvertProgram;
  20855. CheckSource('TestJSValue_AssignToJSValue',
  20856. LinesToStr([ // statements
  20857. 'this.v = undefined;',
  20858. 'this.i = 0;',
  20859. 'this.s = "";',
  20860. 'this.b = false;',
  20861. 'this.d = 0.0;',
  20862. 'this.p = null;',
  20863. '']),
  20864. LinesToStr([ // $mod.$main
  20865. '$mod.v = $mod.v;',
  20866. '$mod.v = 1;',
  20867. '$mod.v = $mod.i;',
  20868. '$mod.v = "";',
  20869. '$mod.v = "c";',
  20870. '$mod.v = "foo";',
  20871. '$mod.v = $mod.s;',
  20872. '$mod.v = false;',
  20873. '$mod.v = true;',
  20874. '$mod.v = $mod.b;',
  20875. '$mod.v = 0.1;',
  20876. '$mod.v = $mod.d;',
  20877. '$mod.v = null;',
  20878. '$mod.v = $mod.p;',
  20879. '']));
  20880. end;
  20881. procedure TTestModule.TestJSValue_TypeCastToBaseType;
  20882. begin
  20883. StartProgram(false);
  20884. Add('type');
  20885. Add(' integer = longint;');
  20886. Add(' TYesNo = boolean;');
  20887. Add(' TFloat = double;');
  20888. Add(' TCaption = string;');
  20889. Add(' TChar = char;');
  20890. Add('var');
  20891. Add(' v: jsvalue;');
  20892. Add(' i: integer;');
  20893. Add(' s: TCaption;');
  20894. Add(' b: TYesNo;');
  20895. Add(' d: TFloat;');
  20896. Add(' c: char;');
  20897. Add('begin');
  20898. Add(' i:=longint(v);');
  20899. Add(' i:=integer(v);');
  20900. Add(' s:=string(v);');
  20901. Add(' s:=TCaption(v);');
  20902. Add(' b:=boolean(v);');
  20903. Add(' b:=TYesNo(v);');
  20904. Add(' d:=double(v);');
  20905. Add(' d:=TFloat(v);');
  20906. Add(' c:=char(v);');
  20907. Add(' c:=TChar(v);');
  20908. ConvertProgram;
  20909. CheckSource('TestJSValue_TypeCastToBaseType',
  20910. LinesToStr([ // statements
  20911. 'this.v = undefined;',
  20912. 'this.i = 0;',
  20913. 'this.s = "";',
  20914. 'this.b = false;',
  20915. 'this.d = 0.0;',
  20916. 'this.c = "";',
  20917. '']),
  20918. LinesToStr([ // $mod.$main
  20919. '$mod.i = Math.floor($mod.v);',
  20920. '$mod.i = Math.floor($mod.v);',
  20921. '$mod.s = "" + $mod.v;',
  20922. '$mod.s = "" + $mod.v;',
  20923. '$mod.b = !($mod.v == false);',
  20924. '$mod.b = !($mod.v == false);',
  20925. '$mod.d = rtl.getNumber($mod.v);',
  20926. '$mod.d = rtl.getNumber($mod.v);',
  20927. '$mod.c = rtl.getChar($mod.v);',
  20928. '$mod.c = rtl.getChar($mod.v);',
  20929. '']));
  20930. end;
  20931. procedure TTestModule.TestJSValue_Equal;
  20932. begin
  20933. StartProgram(false);
  20934. Add('type');
  20935. Add(' integer = longint;');
  20936. Add(' TYesNo = boolean;');
  20937. Add(' TFloat = double;');
  20938. Add(' TCaption = string;');
  20939. Add(' TChar = char;');
  20940. Add(' TMulti = JSValue;');
  20941. Add('var');
  20942. Add(' v: jsvalue;');
  20943. Add(' i: integer;');
  20944. Add(' s: TCaption;');
  20945. Add(' b: TYesNo;');
  20946. Add(' d: TFloat;');
  20947. Add(' c: char;');
  20948. Add(' m: TMulti;');
  20949. Add('begin');
  20950. Add(' b:=v=v;');
  20951. Add(' b:=v<>v;');
  20952. Add(' b:=v=1;');
  20953. Add(' b:=v<>1;');
  20954. Add(' b:=2=v;');
  20955. Add(' b:=2<>v;');
  20956. Add(' b:=v=i;');
  20957. Add(' b:=i=v;');
  20958. Add(' b:=v=nil;');
  20959. Add(' b:=nil=v;');
  20960. Add(' b:=v=false;');
  20961. Add(' b:=true=v;');
  20962. Add(' b:=v=b;');
  20963. Add(' b:=b=v;');
  20964. Add(' b:=v=s;');
  20965. Add(' b:=s=v;');
  20966. Add(' b:=v=''foo'';');
  20967. Add(' b:=''''=v;');
  20968. Add(' b:=v=d;');
  20969. Add(' b:=d=v;');
  20970. Add(' b:=v=3.4;');
  20971. Add(' b:=5.6=v;');
  20972. Add(' b:=v=c;');
  20973. Add(' b:=c=v;');
  20974. Add(' b:=m=m;');
  20975. Add(' b:=v=m;');
  20976. Add(' b:=m=v;');
  20977. ConvertProgram;
  20978. CheckSource('TestJSValue_Equal',
  20979. LinesToStr([ // statements
  20980. 'this.v = undefined;',
  20981. 'this.i = 0;',
  20982. 'this.s = "";',
  20983. 'this.b = false;',
  20984. 'this.d = 0.0;',
  20985. 'this.c = "";',
  20986. 'this.m = undefined;',
  20987. '']),
  20988. LinesToStr([ // $mod.$main
  20989. '$mod.b = $mod.v == $mod.v;',
  20990. '$mod.b = $mod.v != $mod.v;',
  20991. '$mod.b = $mod.v == 1;',
  20992. '$mod.b = $mod.v != 1;',
  20993. '$mod.b = 2 == $mod.v;',
  20994. '$mod.b = 2 != $mod.v;',
  20995. '$mod.b = $mod.v == $mod.i;',
  20996. '$mod.b = $mod.i == $mod.v;',
  20997. '$mod.b = $mod.v == null;',
  20998. '$mod.b = null == $mod.v;',
  20999. '$mod.b = $mod.v == false;',
  21000. '$mod.b = true == $mod.v;',
  21001. '$mod.b = $mod.v == $mod.b;',
  21002. '$mod.b = $mod.b == $mod.v;',
  21003. '$mod.b = $mod.v == $mod.s;',
  21004. '$mod.b = $mod.s == $mod.v;',
  21005. '$mod.b = $mod.v == "foo";',
  21006. '$mod.b = "" == $mod.v;',
  21007. '$mod.b = $mod.v == $mod.d;',
  21008. '$mod.b = $mod.d == $mod.v;',
  21009. '$mod.b = $mod.v == 3.4;',
  21010. '$mod.b = 5.6 == $mod.v;',
  21011. '$mod.b = $mod.v == $mod.c;',
  21012. '$mod.b = $mod.c == $mod.v;',
  21013. '$mod.b = $mod.m == $mod.m;',
  21014. '$mod.b = $mod.v == $mod.m;',
  21015. '$mod.b = $mod.m == $mod.v;',
  21016. '']));
  21017. end;
  21018. procedure TTestModule.TestJSValue_If;
  21019. begin
  21020. StartProgram(false);
  21021. Add([
  21022. 'var',
  21023. ' v: jsvalue;',
  21024. 'begin',
  21025. ' if v then ;',
  21026. ' while v do ;',
  21027. ' repeat until v;',
  21028. '']);
  21029. ConvertProgram;
  21030. CheckSource('TestJSValue_If',
  21031. LinesToStr([ // statements
  21032. 'this.v = undefined;',
  21033. '']),
  21034. LinesToStr([ // $mod.$main
  21035. 'if ($mod.v) ;',
  21036. 'while($mod.v){',
  21037. '};',
  21038. 'do{',
  21039. '} while(!$mod.v);',
  21040. '']));
  21041. end;
  21042. procedure TTestModule.TestJSValue_Not;
  21043. begin
  21044. StartProgram(false);
  21045. Add([
  21046. 'var',
  21047. ' v: jsvalue;',
  21048. ' b: boolean;',
  21049. 'begin',
  21050. ' b:=not v;',
  21051. ' if not v then ;',
  21052. ' while not v do ;',
  21053. ' repeat until not v;',
  21054. '']);
  21055. ConvertProgram;
  21056. CheckSource('TestJSValue_If',
  21057. LinesToStr([ // statements
  21058. 'this.v = undefined;',
  21059. 'this.b = false;',
  21060. '']),
  21061. LinesToStr([ // $mod.$main
  21062. '$mod.b=!$mod.v;',
  21063. 'if (!$mod.v) ;',
  21064. 'while(!$mod.v){',
  21065. '};',
  21066. 'do{',
  21067. '} while($mod.v);',
  21068. '']));
  21069. end;
  21070. procedure TTestModule.TestJSValue_Enum;
  21071. begin
  21072. StartProgram(false);
  21073. Add('type');
  21074. Add(' TColor = (red, blue);');
  21075. Add(' TRedBlue = TColor;');
  21076. Add('var');
  21077. Add(' v: jsvalue;');
  21078. Add(' e: TColor;');
  21079. Add('begin');
  21080. Add(' v:=e;');
  21081. Add(' v:=TColor(e);');
  21082. Add(' v:=TRedBlue(e);');
  21083. Add(' e:=TColor(v);');
  21084. Add(' e:=TRedBlue(v);');
  21085. ConvertProgram;
  21086. CheckSource('TestJSValue_Enum',
  21087. LinesToStr([ // statements
  21088. 'this.TColor = {',
  21089. ' "0": "red",',
  21090. ' red: 0,',
  21091. ' "1": "blue",',
  21092. ' blue: 1',
  21093. '};',
  21094. 'this.v = undefined;',
  21095. 'this.e = 0;',
  21096. '']),
  21097. LinesToStr([ // $mod.$main
  21098. '$mod.v = $mod.e;',
  21099. '$mod.v = $mod.e;',
  21100. '$mod.v = $mod.e;',
  21101. '$mod.e = $mod.v;',
  21102. '$mod.e = $mod.v;',
  21103. '']));
  21104. end;
  21105. procedure TTestModule.TestJSValue_ClassInstance;
  21106. begin
  21107. StartProgram(false);
  21108. Add([
  21109. 'type',
  21110. ' TObject = class',
  21111. ' end;',
  21112. ' TBirdObject = TObject;',
  21113. 'var',
  21114. ' v: jsvalue;',
  21115. ' o: TObject;',
  21116. 'begin',
  21117. ' v:=o;',
  21118. ' v:=TObject(o);',
  21119. ' v:=TBirdObject(o);',
  21120. ' o:=TObject(v);',
  21121. ' o:=TBirdObject(v);',
  21122. ' if v is TObject then ;',
  21123. '']);
  21124. ConvertProgram;
  21125. CheckSource('TestJSValue_ClassInstance',
  21126. LinesToStr([ // statements
  21127. 'rtl.createClass($mod, "TObject", null, function () {',
  21128. ' this.$init = function () {',
  21129. ' };',
  21130. ' this.$final = function () {',
  21131. ' };',
  21132. '});',
  21133. 'this.v = undefined;',
  21134. 'this.o = null;',
  21135. '']),
  21136. LinesToStr([ // $mod.$main
  21137. '$mod.v = $mod.o;',
  21138. '$mod.v = $mod.o;',
  21139. '$mod.v = $mod.o;',
  21140. '$mod.o = rtl.getObject($mod.v);',
  21141. '$mod.o = rtl.getObject($mod.v);',
  21142. 'if (rtl.isExt($mod.v, $mod.TObject, 1)) ;',
  21143. '']));
  21144. end;
  21145. procedure TTestModule.TestJSValue_ClassOf;
  21146. begin
  21147. StartProgram(false);
  21148. Add([
  21149. 'type',
  21150. ' TClass = class of TObject;',
  21151. ' TObject = class',
  21152. ' end;',
  21153. ' TBirds = class of TBird;',
  21154. ' TBird = class(TObject) end;',
  21155. 'var',
  21156. ' v: jsvalue;',
  21157. ' c: TClass;',
  21158. 'begin',
  21159. ' v:=c;',
  21160. ' v:=TObject;',
  21161. ' v:=TClass(c);',
  21162. ' v:=TBirds(c);',
  21163. ' c:=TClass(v);',
  21164. ' c:=TBirds(v);',
  21165. ' if v is TClass then ;',
  21166. '']);
  21167. ConvertProgram;
  21168. CheckSource('TestJSValue_ClassOf',
  21169. LinesToStr([ // statements
  21170. 'rtl.createClass($mod, "TObject", null, function () {',
  21171. ' this.$init = function () {',
  21172. ' };',
  21173. ' this.$final = function () {',
  21174. ' };',
  21175. '});',
  21176. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  21177. '});',
  21178. 'this.v = undefined;',
  21179. 'this.c = null;',
  21180. '']),
  21181. LinesToStr([ // $mod.$main
  21182. '$mod.v = $mod.c;',
  21183. '$mod.v = $mod.TObject;',
  21184. '$mod.v = $mod.c;',
  21185. '$mod.v = $mod.c;',
  21186. '$mod.c = rtl.getObject($mod.v);',
  21187. '$mod.c = rtl.getObject($mod.v);',
  21188. 'if (rtl.isExt($mod.v, $mod.TObject, 2)) ;',
  21189. '']));
  21190. end;
  21191. procedure TTestModule.TestJSValue_ArrayOfJSValue;
  21192. begin
  21193. StartProgram(false);
  21194. Add([
  21195. 'type',
  21196. ' integer = longint;',
  21197. ' TArray = array of JSValue;',
  21198. ' TArrgh = tarray;',
  21199. ' TArrInt = array of integer;',
  21200. 'var',
  21201. ' v: jsvalue;',
  21202. ' TheArray: tarray = (1,''2'');',
  21203. ' Arr: tarrgh;',
  21204. ' i: integer;',
  21205. ' ArrInt: tarrint;',
  21206. 'begin',
  21207. ' arr:=thearray;',
  21208. ' thearray:=arr;',
  21209. ' setlength(arr,2);',
  21210. ' setlength(thearray,3);',
  21211. ' arr[4]:=v;',
  21212. ' arr[5]:=length(thearray);',
  21213. ' arr[6]:=nil;',
  21214. ' arr[7]:=thearray[8];',
  21215. ' arr[low(arr)]:=high(thearray);',
  21216. ' arr:=arrint;',
  21217. ' arrInt:=tarrint(arr);',
  21218. ' if TheArray = nil then ;',
  21219. ' if nil = TheArray then ;',
  21220. ' if TheArray <> nil then ;',
  21221. ' if nil <> TheArray then ;',
  21222. '']);
  21223. ConvertProgram;
  21224. CheckSource('TestJSValue_ArrayOfJSValue',
  21225. LinesToStr([ // statements
  21226. 'this.v = undefined;',
  21227. 'this.TheArray = [1, "2"];',
  21228. 'this.Arr = [];',
  21229. 'this.i = 0;',
  21230. 'this.ArrInt = [];',
  21231. '']),
  21232. LinesToStr([ // $mod.$main
  21233. '$mod.Arr = $mod.TheArray;',
  21234. '$mod.TheArray = $mod.Arr;',
  21235. '$mod.Arr = rtl.arraySetLength($mod.Arr,undefined,2);',
  21236. '$mod.TheArray = rtl.arraySetLength($mod.TheArray,undefined,3);',
  21237. '$mod.Arr[4] = $mod.v;',
  21238. '$mod.Arr[5] = rtl.length($mod.TheArray);',
  21239. '$mod.Arr[6] = null;',
  21240. '$mod.Arr[7] = $mod.TheArray[8];',
  21241. '$mod.Arr[0] = rtl.length($mod.TheArray) - 1;',
  21242. '$mod.Arr = $mod.ArrInt;',
  21243. '$mod.ArrInt = $mod.Arr;',
  21244. 'if (rtl.length($mod.TheArray) === 0) ;',
  21245. 'if (rtl.length($mod.TheArray) === 0) ;',
  21246. 'if (rtl.length($mod.TheArray) > 0) ;',
  21247. 'if (rtl.length($mod.TheArray) > 0) ;',
  21248. '']));
  21249. end;
  21250. procedure TTestModule.TestJSValue_ArrayLit;
  21251. begin
  21252. StartProgram(false);
  21253. Add([
  21254. 'type',
  21255. ' TFlag = (big,small);',
  21256. ' TArray = array of JSValue;',
  21257. ' TObject = class end;',
  21258. ' TClass = class of TObject;',
  21259. 'var',
  21260. ' v: jsvalue;',
  21261. ' a: TArray;',
  21262. ' o: TObject;',
  21263. 'begin',
  21264. ' a:=[];',
  21265. ' a:=[1];',
  21266. ' a:=[1,2];',
  21267. ' a:=[big];',
  21268. ' a:=[1,big];',
  21269. ' a:=[o,nil];',
  21270. '']);
  21271. ConvertProgram;
  21272. CheckSource('TestJSValue_ArrayLit',
  21273. LinesToStr([ // statements
  21274. 'this.TFlag = {',
  21275. ' "0": "big",',
  21276. ' big: 0,',
  21277. ' "1": "small",',
  21278. ' small: 1',
  21279. '};',
  21280. 'rtl.createClass($mod, "TObject", null, function () {',
  21281. ' this.$init = function () {',
  21282. ' };',
  21283. ' this.$final = function () {',
  21284. ' };',
  21285. '});',
  21286. 'this.v = undefined;',
  21287. 'this.a = [];',
  21288. 'this.o = null;',
  21289. '']),
  21290. LinesToStr([ // $mod.$main
  21291. '$mod.a = [];',
  21292. '$mod.a = [1];',
  21293. '$mod.a = [1, 2];',
  21294. '$mod.a = [$mod.TFlag.big];',
  21295. '$mod.a = [1, $mod.TFlag.big];',
  21296. '$mod.a = [$mod.o, null];',
  21297. '']));
  21298. end;
  21299. procedure TTestModule.TestJSValue_Params;
  21300. begin
  21301. StartProgram(false);
  21302. Add('type');
  21303. Add(' integer = longint;');
  21304. Add(' TYesNo = boolean;');
  21305. Add(' TFloat = double;');
  21306. Add(' TCaption = string;');
  21307. Add(' TChar = char;');
  21308. Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
  21309. Add('var');
  21310. Add(' l: jsvalue;');
  21311. Add('begin');
  21312. Add(' a:=a;');
  21313. Add(' l:=b;');
  21314. Add(' c:=c;');
  21315. Add(' d:=d;');
  21316. Add(' Result:=l;');
  21317. Add('end;');
  21318. Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
  21319. Add('var');
  21320. Add(' v: jsvalue;');
  21321. Add(' i: integer;');
  21322. Add(' b: TYesNo;');
  21323. Add(' d: TFloat;');
  21324. Add(' s: TCaption;');
  21325. Add(' c: TChar;');
  21326. Add('begin');
  21327. Add(' v:=doit(v,v,v,v);');
  21328. Add(' i:=integer(dosome(i,i));');
  21329. Add(' b:=TYesNo(dosome(b,b));');
  21330. Add(' d:=TFloat(dosome(d,d));');
  21331. Add(' s:=TCaption(dosome(s,s));');
  21332. Add(' c:=TChar(dosome(c,c));');
  21333. ConvertProgram;
  21334. CheckSource('TestJSValue_Params',
  21335. LinesToStr([ // statements
  21336. 'this.DoIt = function (a, b, c, d) {',
  21337. ' var Result = undefined;',
  21338. ' var l = undefined;',
  21339. ' a = a;',
  21340. ' l = b;',
  21341. ' c.set(c.get());',
  21342. ' d.set(d.get());',
  21343. ' Result = l;',
  21344. ' return Result;',
  21345. '};',
  21346. 'this.DoSome = function (a, b) {',
  21347. ' var Result = undefined;',
  21348. ' return Result;',
  21349. '};',
  21350. 'this.v = undefined;',
  21351. 'this.i = 0;',
  21352. 'this.b = false;',
  21353. 'this.d = 0.0;',
  21354. 'this.s = "";',
  21355. 'this.c = "";',
  21356. '']),
  21357. LinesToStr([ // $mod.$main
  21358. '$mod.v = $mod.DoIt($mod.v, $mod.v, {',
  21359. ' p: $mod,',
  21360. ' get: function () {',
  21361. ' return this.p.v;',
  21362. ' },',
  21363. ' set: function (v) {',
  21364. ' this.p.v = v;',
  21365. ' }',
  21366. '}, {',
  21367. ' p: $mod,',
  21368. ' get: function () {',
  21369. ' return this.p.v;',
  21370. ' },',
  21371. ' set: function (v) {',
  21372. ' this.p.v = v;',
  21373. ' }',
  21374. '});',
  21375. '$mod.i = Math.floor($mod.DoSome($mod.i, $mod.i));',
  21376. '$mod.b = !($mod.DoSome($mod.b, $mod.b) == false);',
  21377. '$mod.d = rtl.getNumber($mod.DoSome($mod.d, $mod.d));',
  21378. '$mod.s = "" + $mod.DoSome($mod.s, $mod.s);',
  21379. '$mod.c = rtl.getChar($mod.DoSome($mod.c, $mod.c));',
  21380. '']));
  21381. end;
  21382. procedure TTestModule.TestJSValue_UntypedParam;
  21383. begin
  21384. StartProgram(false);
  21385. Add('function DoIt(const a; var b; out c): jsvalue;');
  21386. Add('begin');
  21387. Add(' Result:=a;');
  21388. Add(' Result:=b;');
  21389. Add(' Result:=c;');
  21390. Add(' b:=Result;');
  21391. Add(' c:=Result;');
  21392. Add('end;');
  21393. Add('var i: longint;');
  21394. Add('begin');
  21395. Add(' doit(i,i,i);');
  21396. ConvertProgram;
  21397. CheckSource('TestJSValue_UntypedParam',
  21398. LinesToStr([ // statements
  21399. 'this.DoIt = function (a, b, c) {',
  21400. ' var Result = undefined;',
  21401. ' Result = a;',
  21402. ' Result = b.get();',
  21403. ' Result = c.get();',
  21404. ' b.set(Result);',
  21405. ' c.set(Result);',
  21406. ' return Result;',
  21407. '};',
  21408. 'this.i = 0;',
  21409. '']),
  21410. LinesToStr([ // $mod.$main
  21411. '$mod.DoIt($mod.i, {',
  21412. ' p: $mod,',
  21413. ' get: function () {',
  21414. ' return this.p.i;',
  21415. ' },',
  21416. ' set: function (v) {',
  21417. ' this.p.i = v;',
  21418. ' }',
  21419. '}, {',
  21420. ' p: $mod,',
  21421. ' get: function () {',
  21422. ' return this.p.i;',
  21423. ' },',
  21424. ' set: function (v) {',
  21425. ' this.p.i = v;',
  21426. ' }',
  21427. '});',
  21428. '']));
  21429. end;
  21430. procedure TTestModule.TestJSValue_FuncResultType;
  21431. begin
  21432. StartProgram(false);
  21433. Add('type');
  21434. Add(' integer = longint;');
  21435. Add(' TJSValueArray = array of JSValue;');
  21436. Add(' TListSortCompare = function(Item1, Item2: JSValue): Integer;');
  21437. Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
  21438. Add('begin');
  21439. Add(' while Compare(P,aList[0])>0 do ;');
  21440. Add('end;');
  21441. Add('var');
  21442. Add(' Compare: TListSortCompare;');
  21443. Add(' V: JSValue;');
  21444. Add(' i: integer;');
  21445. Add('begin');
  21446. Add(' if Compare(V,V)>0 then ;');
  21447. Add(' if Compare(i,i)>1 then ;');
  21448. Add(' if Compare(nil,false)>2 then ;');
  21449. Add(' if Compare(1,true)>3 then ;');
  21450. ConvertProgram;
  21451. CheckSource('TestJSValue_UntypedParam',
  21452. LinesToStr([ // statements
  21453. 'this.Sort = function (P, aList, Compare) {',
  21454. ' while (Compare(P, aList[0]) > 0) {',
  21455. ' };',
  21456. '};',
  21457. 'this.Compare = null;',
  21458. 'this.V = undefined;',
  21459. 'this.i = 0;',
  21460. '']),
  21461. LinesToStr([ // $mod.$main
  21462. 'if ($mod.Compare($mod.V, $mod.V) > 0) ;',
  21463. 'if ($mod.Compare($mod.i, $mod.i) > 1) ;',
  21464. 'if ($mod.Compare(null, false) > 2) ;',
  21465. 'if ($mod.Compare(1, true) > 3) ;',
  21466. '']));
  21467. end;
  21468. procedure TTestModule.TestJSValue_ProcType_Assign;
  21469. begin
  21470. StartProgram(false);
  21471. Add('type');
  21472. Add(' integer = longint;');
  21473. Add(' TObject = class');
  21474. Add(' class function GetGlob: integer;');
  21475. Add(' function Getter: integer;');
  21476. Add(' end;');
  21477. Add('class function TObject.GetGlob: integer;');
  21478. Add('var v1: jsvalue;');
  21479. Add('begin');
  21480. Add(' v1:=@GetGlob;');
  21481. Add(' v1:[email protected];');
  21482. Add('end;');
  21483. Add('function TObject.Getter: integer;');
  21484. Add('var v2: jsvalue;');
  21485. Add('begin');
  21486. Add(' v2:=@Getter;');
  21487. Add(' v2:[email protected];');
  21488. Add(' v2:=@GetGlob;');
  21489. Add(' v2:[email protected];');
  21490. Add('end;');
  21491. Add('function GetIt(i: integer): integer;');
  21492. Add('var v3: jsvalue;');
  21493. Add('begin');
  21494. Add(' v3:=@GetIt;');
  21495. Add('end;');
  21496. Add('var');
  21497. Add(' V: JSValue;');
  21498. Add(' o: TObject;');
  21499. Add('begin');
  21500. Add(' v:=@GetIt;');
  21501. Add(' v:[email protected];');
  21502. Add(' v:[email protected];');
  21503. ConvertProgram;
  21504. CheckSource('TestJSValue_ProcType_Assign',
  21505. LinesToStr([ // statements
  21506. 'rtl.createClass($mod, "TObject", null, function () {',
  21507. ' this.$init = function () {',
  21508. ' };',
  21509. ' this.$final = function () {',
  21510. ' };',
  21511. ' this.GetGlob = function () {',
  21512. ' var Result = 0;',
  21513. ' var v1 = undefined;',
  21514. ' v1 = rtl.createCallback(this, "GetGlob");',
  21515. ' v1 = rtl.createCallback(this, "GetGlob");',
  21516. ' return Result;',
  21517. ' };',
  21518. ' this.Getter = function () {',
  21519. ' var Result = 0;',
  21520. ' var v2 = undefined;',
  21521. ' v2 = rtl.createCallback(this, "Getter");',
  21522. ' v2 = rtl.createCallback(this, "Getter");',
  21523. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  21524. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  21525. ' return Result;',
  21526. ' };',
  21527. '});',
  21528. 'this.GetIt = function (i) {',
  21529. ' var Result = 0;',
  21530. ' var v3 = undefined;',
  21531. ' v3 = $mod.GetIt;',
  21532. ' return Result;',
  21533. '};',
  21534. 'this.V = undefined;',
  21535. 'this.o = null;',
  21536. '']),
  21537. LinesToStr([ // $mod.$main
  21538. '$mod.V = $mod.GetIt;',
  21539. '$mod.V = rtl.createCallback($mod.o, "Getter");',
  21540. '$mod.V = rtl.createCallback($mod.o.$class, "GetGlob");',
  21541. '']));
  21542. end;
  21543. procedure TTestModule.TestJSValue_ProcType_Equal;
  21544. begin
  21545. StartProgram(false);
  21546. Add('type');
  21547. Add(' integer = longint;');
  21548. Add(' TObject = class');
  21549. Add(' class function GetGlob: integer;');
  21550. Add(' function Getter: integer;');
  21551. Add(' end;');
  21552. Add('class function TObject.GetGlob: integer;');
  21553. Add('var v1: jsvalue;');
  21554. Add('begin');
  21555. Add(' if v1=@GetGlob then;');
  21556. Add(' if [email protected] then ;');
  21557. Add('end;');
  21558. Add('function TObject.Getter: integer;');
  21559. Add('var v2: jsvalue;');
  21560. Add('begin');
  21561. Add(' if v2=@Getter then;');
  21562. Add(' if [email protected] then ;');
  21563. Add(' if v2=@GetGlob then;');
  21564. Add(' if [email protected] then;');
  21565. Add('end;');
  21566. Add('function GetIt(i: integer): integer;');
  21567. Add('var v3: jsvalue;');
  21568. Add('begin');
  21569. Add(' if v3=@GetIt then;');
  21570. Add('end;');
  21571. Add('var');
  21572. Add(' V: JSValue;');
  21573. Add(' o: TObject;');
  21574. Add('begin');
  21575. Add(' if v=@GetIt then;');
  21576. Add(' if [email protected] then;');
  21577. Add(' if [email protected] then;');
  21578. Add(' if @GetIt=v then;');
  21579. Add(' if @o.Getter=v then;');
  21580. Add(' if @o.GetGlob=v then;');
  21581. ConvertProgram;
  21582. CheckSource('TestJSValue_ProcType_Equal',
  21583. LinesToStr([ // statements
  21584. 'rtl.createClass($mod, "TObject", null, function () {',
  21585. ' this.$init = function () {',
  21586. ' };',
  21587. ' this.$final = function () {',
  21588. ' };',
  21589. ' this.GetGlob = function () {',
  21590. ' var Result = 0;',
  21591. ' var v1 = undefined;',
  21592. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  21593. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  21594. ' return Result;',
  21595. ' };',
  21596. ' this.Getter = function () {',
  21597. ' var Result = 0;',
  21598. ' var v2 = undefined;',
  21599. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  21600. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  21601. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  21602. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  21603. ' return Result;',
  21604. ' };',
  21605. '});',
  21606. 'this.GetIt = function (i) {',
  21607. ' var Result = 0;',
  21608. ' var v3 = undefined;',
  21609. ' if (rtl.eqCallback(v3, $mod.GetIt)) ;',
  21610. ' return Result;',
  21611. '};',
  21612. 'this.V = undefined;',
  21613. 'this.o = null;',
  21614. '']),
  21615. LinesToStr([ // $mod.$main
  21616. 'if (rtl.eqCallback($mod.V, $mod.GetIt)) ;',
  21617. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o, "Getter"))) ;',
  21618. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o.$class, "GetGlob"))) ;',
  21619. 'if (rtl.eqCallback($mod.GetIt, $mod.V)) ;',
  21620. 'if (rtl.eqCallback(rtl.createCallback($mod.o, "Getter"), $mod.V)) ;',
  21621. 'if (rtl.eqCallback(rtl.createCallback($mod.o.$class, "GetGlob"), $mod.V)) ;',
  21622. '']));
  21623. end;
  21624. procedure TTestModule.TestJSValue_ProcType_Param;
  21625. begin
  21626. StartProgram(false);
  21627. Add([
  21628. 'type',
  21629. ' variant = jsvalue;',
  21630. ' TArrVariant = array of variant;',
  21631. ' TArrVar2 = TArrVariant;',
  21632. ' TFuncInt = function: longint;',
  21633. 'function GetIt: longint;',
  21634. 'begin',
  21635. 'end;',
  21636. 'procedure DoIt(p: jsvalue; Arr: TArrVar2);',
  21637. 'var v: variant;',
  21638. 'begin',
  21639. ' v:=arr[1];',
  21640. 'end;',
  21641. 'var s: string;',
  21642. 'begin',
  21643. ' DoIt(GetIt,[]);',
  21644. ' DoIt(@GetIt,[]);',
  21645. ' DoIt(1,[s,GetIt]);',
  21646. ' DoIt(1,[s,@GetIt]);',
  21647. '']);
  21648. ConvertProgram;
  21649. CheckSource('TestJSValue_ProcType_Param',
  21650. LinesToStr([ // statements
  21651. 'this.GetIt = function () {',
  21652. ' var Result = 0;',
  21653. ' return Result;',
  21654. '};',
  21655. 'this.DoIt = function (p, Arr) {',
  21656. ' var v = undefined;',
  21657. ' v = Arr[1];',
  21658. '};',
  21659. 'this.s = "";',
  21660. '']),
  21661. LinesToStr([ // $mod.$main
  21662. '$mod.DoIt($mod.GetIt(), []);',
  21663. '$mod.DoIt($mod.GetIt, []);',
  21664. '$mod.DoIt(1, [$mod.s, $mod.GetIt()]);',
  21665. '$mod.DoIt(1, [$mod.s, $mod.GetIt]);',
  21666. '']));
  21667. end;
  21668. procedure TTestModule.TestJSValue_AssignToPointerFail;
  21669. begin
  21670. StartProgram(false);
  21671. Add([
  21672. 'var',
  21673. ' v: JSValue;',
  21674. ' p: Pointer;',
  21675. 'begin',
  21676. ' p:=v;',
  21677. '']);
  21678. SetExpectedPasResolverError('Incompatible types: got "JSValue" expected "Pointer"',
  21679. nIncompatibleTypesGotExpected);
  21680. ConvertProgram;
  21681. end;
  21682. procedure TTestModule.TestJSValue_OverloadDouble;
  21683. begin
  21684. StartProgram(false);
  21685. Add([
  21686. 'type',
  21687. ' integer = longint;',
  21688. ' tdatetime = double;',
  21689. 'procedure DoIt(d: double); begin end;',
  21690. 'procedure DoIt(v: jsvalue); begin end;',
  21691. 'var',
  21692. ' d: double;',
  21693. ' dt: tdatetime;',
  21694. ' i: integer;',
  21695. ' b: byte;',
  21696. ' shi: shortint;',
  21697. ' w: word;',
  21698. ' smi: smallint;',
  21699. ' lw: longword;',
  21700. ' li: longint;',
  21701. ' ni: nativeint;',
  21702. ' nu: nativeuint;',
  21703. 'begin',
  21704. ' DoIt(d);',
  21705. ' DoIt(dt);',
  21706. ' DoIt(i);',
  21707. ' DoIt(b);',
  21708. ' DoIt(shi);',
  21709. ' DoIt(w);',
  21710. ' DoIt(smi);',
  21711. ' DoIt(lw);',
  21712. ' DoIt(li);',
  21713. ' DoIt(ni);',
  21714. ' DoIt(nu);',
  21715. '']);
  21716. ConvertProgram;
  21717. CheckSource('TestJSValue_OverloadDouble',
  21718. LinesToStr([ // statements
  21719. 'this.DoIt = function (d) {',
  21720. '};',
  21721. 'this.DoIt$1 = function (v) {',
  21722. '};',
  21723. 'this.d = 0.0;',
  21724. 'this.dt = 0.0;',
  21725. 'this.i = 0;',
  21726. 'this.b = 0;',
  21727. 'this.shi = 0;',
  21728. 'this.w = 0;',
  21729. 'this.smi = 0;',
  21730. 'this.lw = 0;',
  21731. 'this.li = 0;',
  21732. 'this.ni = 0;',
  21733. 'this.nu = 0;',
  21734. '']),
  21735. LinesToStr([ // $mod.$main
  21736. '$mod.DoIt($mod.d);',
  21737. '$mod.DoIt($mod.dt);',
  21738. '$mod.DoIt$1($mod.i);',
  21739. '$mod.DoIt$1($mod.b);',
  21740. '$mod.DoIt$1($mod.shi);',
  21741. '$mod.DoIt$1($mod.w);',
  21742. '$mod.DoIt$1($mod.smi);',
  21743. '$mod.DoIt$1($mod.lw);',
  21744. '$mod.DoIt$1($mod.li);',
  21745. '$mod.DoIt$1($mod.ni);',
  21746. '$mod.DoIt$1($mod.nu);',
  21747. '']));
  21748. end;
  21749. procedure TTestModule.TestJSValue_OverloadNativeInt;
  21750. begin
  21751. StartProgram(false);
  21752. Add([
  21753. 'type',
  21754. ' integer = longint;',
  21755. ' int53 = nativeint;',
  21756. ' tdatetime = double;',
  21757. 'procedure DoIt(n: nativeint); begin end;',
  21758. 'procedure DoIt(v: jsvalue); begin end;',
  21759. 'var',
  21760. ' d: double;',
  21761. ' dt: tdatetime;',
  21762. ' i: integer;',
  21763. ' b: byte;',
  21764. ' shi: shortint;',
  21765. ' w: word;',
  21766. ' smi: smallint;',
  21767. ' lw: longword;',
  21768. ' li: longint;',
  21769. ' ni: nativeint;',
  21770. ' nu: nativeuint;',
  21771. 'begin',
  21772. ' DoIt(d);',
  21773. ' DoIt(dt);',
  21774. ' DoIt(i);',
  21775. ' DoIt(b);',
  21776. ' DoIt(shi);',
  21777. ' DoIt(w);',
  21778. ' DoIt(smi);',
  21779. ' DoIt(lw);',
  21780. ' DoIt(li);',
  21781. ' DoIt(ni);',
  21782. ' DoIt(nu);',
  21783. '']);
  21784. ConvertProgram;
  21785. CheckSource('TestJSValue_OverloadNativeInt',
  21786. LinesToStr([ // statements
  21787. 'this.DoIt = function (n) {',
  21788. '};',
  21789. 'this.DoIt$1 = function (v) {',
  21790. '};',
  21791. 'this.d = 0.0;',
  21792. 'this.dt = 0.0;',
  21793. 'this.i = 0;',
  21794. 'this.b = 0;',
  21795. 'this.shi = 0;',
  21796. 'this.w = 0;',
  21797. 'this.smi = 0;',
  21798. 'this.lw = 0;',
  21799. 'this.li = 0;',
  21800. 'this.ni = 0;',
  21801. 'this.nu = 0;',
  21802. '']),
  21803. LinesToStr([ // $mod.$main
  21804. '$mod.DoIt$1($mod.d);',
  21805. '$mod.DoIt$1($mod.dt);',
  21806. '$mod.DoIt($mod.i);',
  21807. '$mod.DoIt($mod.b);',
  21808. '$mod.DoIt($mod.shi);',
  21809. '$mod.DoIt($mod.w);',
  21810. '$mod.DoIt($mod.smi);',
  21811. '$mod.DoIt($mod.lw);',
  21812. '$mod.DoIt($mod.li);',
  21813. '$mod.DoIt($mod.ni);',
  21814. '$mod.DoIt($mod.nu);',
  21815. '']));
  21816. end;
  21817. procedure TTestModule.TestJSValue_OverloadWord;
  21818. begin
  21819. StartProgram(false);
  21820. Add([
  21821. 'type',
  21822. ' integer = longint;',
  21823. ' int53 = nativeint;',
  21824. ' tdatetime = double;',
  21825. 'procedure DoIt(w: word); begin end;',
  21826. 'procedure DoIt(v: jsvalue); begin end;',
  21827. 'var',
  21828. ' d: double;',
  21829. ' dt: tdatetime;',
  21830. ' i: integer;',
  21831. ' b: byte;',
  21832. ' shi: shortint;',
  21833. ' w: word;',
  21834. ' smi: smallint;',
  21835. ' lw: longword;',
  21836. ' li: longint;',
  21837. ' ni: nativeint;',
  21838. ' nu: nativeuint;',
  21839. 'begin',
  21840. ' DoIt(d);',
  21841. ' DoIt(dt);',
  21842. ' DoIt(i);',
  21843. ' DoIt(b);',
  21844. ' DoIt(shi);',
  21845. ' DoIt(w);',
  21846. ' DoIt(smi);',
  21847. ' DoIt(lw);',
  21848. ' DoIt(li);',
  21849. ' DoIt(ni);',
  21850. ' DoIt(nu);',
  21851. '']);
  21852. ConvertProgram;
  21853. CheckSource('TestJSValue_OverloadWord',
  21854. LinesToStr([ // statements
  21855. 'this.DoIt = function (w) {',
  21856. '};',
  21857. 'this.DoIt$1 = function (v) {',
  21858. '};',
  21859. 'this.d = 0.0;',
  21860. 'this.dt = 0.0;',
  21861. 'this.i = 0;',
  21862. 'this.b = 0;',
  21863. 'this.shi = 0;',
  21864. 'this.w = 0;',
  21865. 'this.smi = 0;',
  21866. 'this.lw = 0;',
  21867. 'this.li = 0;',
  21868. 'this.ni = 0;',
  21869. 'this.nu = 0;',
  21870. '']),
  21871. LinesToStr([ // $mod.$main
  21872. '$mod.DoIt$1($mod.d);',
  21873. '$mod.DoIt$1($mod.dt);',
  21874. '$mod.DoIt$1($mod.i);',
  21875. '$mod.DoIt($mod.b);',
  21876. '$mod.DoIt($mod.shi);',
  21877. '$mod.DoIt($mod.w);',
  21878. '$mod.DoIt$1($mod.smi);',
  21879. '$mod.DoIt$1($mod.lw);',
  21880. '$mod.DoIt$1($mod.li);',
  21881. '$mod.DoIt$1($mod.ni);',
  21882. '$mod.DoIt$1($mod.nu);',
  21883. '']));
  21884. end;
  21885. procedure TTestModule.TestJSValue_OverloadString;
  21886. begin
  21887. StartProgram(false);
  21888. Add([
  21889. 'type',
  21890. ' uni = string;',
  21891. ' WChar = char;',
  21892. 'procedure DoIt(s: string); begin end;',
  21893. 'procedure DoIt(v: jsvalue); begin end;',
  21894. 'var',
  21895. ' s: string;',
  21896. ' c: char;',
  21897. ' u: uni;',
  21898. 'begin',
  21899. ' DoIt(s);',
  21900. ' DoIt(c);',
  21901. ' DoIt(u);',
  21902. '']);
  21903. ConvertProgram;
  21904. CheckSource('TestJSValue_OverloadString',
  21905. LinesToStr([ // statements
  21906. 'this.DoIt = function (s) {',
  21907. '};',
  21908. 'this.DoIt$1 = function (v) {',
  21909. '};',
  21910. 'this.s = "";',
  21911. 'this.c = "";',
  21912. 'this.u = "";',
  21913. '']),
  21914. LinesToStr([ // $mod.$main
  21915. '$mod.DoIt($mod.s);',
  21916. '$mod.DoIt($mod.c);',
  21917. '$mod.DoIt($mod.u);',
  21918. '']));
  21919. end;
  21920. procedure TTestModule.TestJSValue_OverloadChar;
  21921. begin
  21922. StartProgram(false);
  21923. Add([
  21924. 'type',
  21925. ' uni = string;',
  21926. ' WChar = char;',
  21927. 'procedure DoIt(c: char); begin end;',
  21928. 'procedure DoIt(v: jsvalue); begin end;',
  21929. 'var',
  21930. ' s: string;',
  21931. ' c: char;',
  21932. ' u: uni;',
  21933. 'begin',
  21934. ' DoIt(s);',
  21935. ' DoIt(c);',
  21936. ' DoIt(u);',
  21937. '']);
  21938. ConvertProgram;
  21939. CheckSource('TestJSValue_OverloadChar',
  21940. LinesToStr([ // statements
  21941. 'this.DoIt = function (c) {',
  21942. '};',
  21943. 'this.DoIt$1 = function (v) {',
  21944. '};',
  21945. 'this.s = "";',
  21946. 'this.c = "";',
  21947. 'this.u = "";',
  21948. '']),
  21949. LinesToStr([ // $mod.$main
  21950. '$mod.DoIt$1($mod.s);',
  21951. '$mod.DoIt($mod.c);',
  21952. '$mod.DoIt$1($mod.u);',
  21953. '']));
  21954. end;
  21955. procedure TTestModule.TestJSValue_OverloadPointer;
  21956. begin
  21957. StartProgram(false);
  21958. Add([
  21959. 'type',
  21960. ' TObject = class end;',
  21961. 'procedure DoIt(p: pointer); begin end;',
  21962. 'procedure DoIt(v: jsvalue); begin end;',
  21963. 'var',
  21964. ' o: TObject;',
  21965. 'begin',
  21966. ' DoIt(o);',
  21967. '']);
  21968. ConvertProgram;
  21969. CheckSource('TestJSValue_OverloadPointer',
  21970. LinesToStr([ // statements
  21971. 'rtl.createClass($mod, "TObject", null, function () {',
  21972. ' this.$init = function () {',
  21973. ' };',
  21974. ' this.$final = function () {',
  21975. ' };',
  21976. '});',
  21977. 'this.DoIt = function (p) {',
  21978. '};',
  21979. 'this.DoIt$1 = function (v) {',
  21980. '};',
  21981. 'this.o = null;',
  21982. '']),
  21983. LinesToStr([ // $mod.$main
  21984. '$mod.DoIt($mod.o);',
  21985. '']));
  21986. end;
  21987. procedure TTestModule.TestJSValue_ForIn;
  21988. begin
  21989. StartProgram(false);
  21990. Add([
  21991. 'var',
  21992. ' v: JSValue;',
  21993. ' key: string;',
  21994. 'begin',
  21995. ' for key in v do begin',
  21996. ' if key=''abc'' then ;',
  21997. ' end;',
  21998. '']);
  21999. ConvertProgram;
  22000. CheckSource('TestJSValue_ForIn',
  22001. LinesToStr([ // statements
  22002. 'this.v = undefined;',
  22003. 'this.key = "";',
  22004. '']),
  22005. LinesToStr([ // $mod.$main
  22006. 'for ($mod.key in $mod.v) {',
  22007. ' if ($mod.key === "abc") ;',
  22008. '};',
  22009. '']));
  22010. end;
  22011. procedure TTestModule.TestRTTI_IntRange;
  22012. begin
  22013. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22014. StartProgram(false);
  22015. Add([
  22016. '{$modeswitch externalclass}',
  22017. 'type',
  22018. ' TTypeInfo = class external name ''rtl.tTypeInfo''',
  22019. ' end;',
  22020. ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo)',
  22021. ' end;',
  22022. ' TGraphicsColor = -$7FFFFFFF-1..$7FFFFFFF;',
  22023. ' TColor = type TGraphicsColor;',
  22024. 'var',
  22025. ' p: TTypeInfo;',
  22026. 'begin',
  22027. ' p:=typeinfo(TGraphicsColor);',
  22028. ' p:=typeinfo(TColor);',
  22029. '']);
  22030. ConvertProgram;
  22031. CheckSource('TestRTTI_IntRange',
  22032. LinesToStr([ // statements
  22033. '$mod.$rtti.$Int("TGraphicsColor", {',
  22034. ' minvalue: -2147483648,',
  22035. ' maxvalue: 2147483647,',
  22036. ' ordtype: 4',
  22037. '});',
  22038. '$mod.$rtti.$inherited("TColor", $mod.$rtti["TGraphicsColor"], {});',
  22039. 'this.p = null;',
  22040. '']),
  22041. LinesToStr([ // $mod.$main
  22042. '$mod.p = $mod.$rtti["TGraphicsColor"];',
  22043. '$mod.p = $mod.$rtti["TColor"];',
  22044. '']));
  22045. end;
  22046. procedure TTestModule.TestRTTI_Double;
  22047. begin
  22048. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22049. StartProgram(false);
  22050. Add([
  22051. '{$modeswitch externalclass}',
  22052. 'type',
  22053. ' TTypeInfo = class external name ''rtl.tTypeInfo''',
  22054. ' end;',
  22055. ' TFloat = type double;',
  22056. 'var',
  22057. ' p: TTypeInfo;',
  22058. 'begin',
  22059. ' p:=typeinfo(double);',
  22060. ' p:=typeinfo(TFloat);',
  22061. '']);
  22062. ConvertProgram;
  22063. CheckSource('TestRTTI_Double',
  22064. LinesToStr([ // statements
  22065. '$mod.$rtti.$inherited("TFloat", rtl.double, {});',
  22066. 'this.p = null;',
  22067. '']),
  22068. LinesToStr([ // $mod.$main
  22069. '$mod.p = rtl.double;',
  22070. '$mod.p = $mod.$rtti["TFloat"];',
  22071. '']));
  22072. end;
  22073. procedure TTestModule.TestRTTI_ProcType;
  22074. begin
  22075. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22076. StartProgram(false);
  22077. Add('type');
  22078. Add(' TProcA = procedure;');
  22079. Add(' TMethodB = procedure of object;');
  22080. Add(' TProcC = procedure; varargs;');
  22081. Add(' TProcD = procedure(i: longint; const j: string; var c: char; out d: double);');
  22082. Add(' TProcE = function: nativeint;');
  22083. Add(' TProcF = function(const p: TProcA): nativeuint;');
  22084. Add('var p: pointer;');
  22085. Add('begin');
  22086. Add(' p:=typeinfo(tproca);');
  22087. ConvertProgram;
  22088. CheckSource('TestRTTI_ProcType',
  22089. LinesToStr([ // statements
  22090. '$mod.$rtti.$ProcVar("TProcA", {',
  22091. ' procsig: rtl.newTIProcSig(null)',
  22092. '});',
  22093. '$mod.$rtti.$MethodVar("TMethodB", {',
  22094. ' procsig: rtl.newTIProcSig(null),',
  22095. ' methodkind: 0',
  22096. '});',
  22097. '$mod.$rtti.$ProcVar("TProcC", {',
  22098. ' procsig: rtl.newTIProcSig(null, 2)',
  22099. '});',
  22100. '$mod.$rtti.$ProcVar("TProcD", {',
  22101. ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
  22102. '});',
  22103. '$mod.$rtti.$ProcVar("TProcE", {',
  22104. ' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
  22105. '});',
  22106. '$mod.$rtti.$ProcVar("TProcF", {',
  22107. ' procsig: rtl.newTIProcSig([["p", $mod.$rtti["TProcA"], 2]], rtl.nativeuint)',
  22108. '});',
  22109. 'this.p = null;',
  22110. '']),
  22111. LinesToStr([ // $mod.$main
  22112. '$mod.p = $mod.$rtti["TProcA"];',
  22113. '']));
  22114. end;
  22115. procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
  22116. begin
  22117. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22118. AddModuleWithIntfImplSrc('unit2.pas',
  22119. LinesToStr([
  22120. 'type',
  22121. ' TObject = class end;'
  22122. ]),
  22123. '');
  22124. StartUnit(true);
  22125. Add('interface');
  22126. Add('uses unit2;');
  22127. Add('type');
  22128. Add(' TProcA = function(o: tobject): tobject;');
  22129. Add('implementation');
  22130. Add('type');
  22131. Add(' TProcB = function(o: tobject): tobject;');
  22132. Add('var p: Pointer;');
  22133. Add('initialization');
  22134. Add(' p:=typeinfo(tproca);');
  22135. Add(' p:=typeinfo(tprocb);');
  22136. ConvertUnit;
  22137. CheckSource('TestRTTI_ProcType_ArgFromOtherUnit',
  22138. LinesToStr([ // statements
  22139. 'var $impl = $mod.$impl;',
  22140. '$mod.$rtti.$ProcVar("TProcA", {',
  22141. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  22142. '});',
  22143. '']),
  22144. LinesToStr([ // this.$init
  22145. '$impl.p = $mod.$rtti["TProcA"];',
  22146. '$impl.p = $mod.$rtti["TProcB"];',
  22147. '']),
  22148. LinesToStr([ // implementation
  22149. '$mod.$rtti.$ProcVar("TProcB", {',
  22150. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  22151. '});',
  22152. '$impl.p = null;',
  22153. '']) );
  22154. end;
  22155. procedure TTestModule.TestRTTI_EnumAndSetType;
  22156. begin
  22157. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22158. StartProgram(false);
  22159. Add('type');
  22160. Add(' TFlag = (light,dark);');
  22161. Add(' TFlags = set of TFlag;');
  22162. Add(' TProc = function(f: TFlags): TFlag;');
  22163. Add('var p: pointer;');
  22164. Add('begin');
  22165. Add(' p:=typeinfo(tflag);');
  22166. Add(' p:=typeinfo(tflags);');
  22167. ConvertProgram;
  22168. CheckSource('TestRTTI_EnumAndType',
  22169. LinesToStr([ // statements
  22170. 'this.TFlag = {',
  22171. ' "0": "light",',
  22172. ' light: 0,',
  22173. ' "1": "dark",',
  22174. ' dark: 1',
  22175. '};',
  22176. '$mod.$rtti.$Enum("TFlag", {',
  22177. ' minvalue: 0,',
  22178. ' maxvalue: 1,',
  22179. ' ordtype: 1,',
  22180. ' enumtype: this.TFlag',
  22181. '});',
  22182. '$mod.$rtti.$Set("TFlags", {',
  22183. ' comptype: $mod.$rtti["TFlag"]',
  22184. '});',
  22185. '$mod.$rtti.$ProcVar("TProc", {',
  22186. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TFlags"]]], $mod.$rtti["TFlag"])',
  22187. '});',
  22188. 'this.p = null;',
  22189. '']),
  22190. LinesToStr([ // $mod.$main
  22191. '$mod.p = $mod.$rtti["TFlag"];',
  22192. '$mod.p = $mod.$rtti["TFlags"];',
  22193. '']));
  22194. end;
  22195. procedure TTestModule.TestRTTI_EnumRange;
  22196. begin
  22197. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22198. StartProgram(false);
  22199. Add([
  22200. 'type',
  22201. ' TCol = (red,green,blue);',
  22202. ' TColRg = green..blue;',
  22203. ' TSetOfColRg = set of TColRg;',
  22204. 'var p: pointer;',
  22205. 'begin',
  22206. ' p:=typeinfo(tcolrg);',
  22207. ' p:=typeinfo(tsetofcolrg);',
  22208. '']);
  22209. ConvertProgram;
  22210. end;
  22211. procedure TTestModule.TestRTTI_AnonymousEnumType;
  22212. begin
  22213. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22214. StartProgram(false);
  22215. Add('type');
  22216. Add(' TFlags = set of (red, green);');
  22217. Add('var');
  22218. Add(' f: TFlags;');
  22219. Add('begin');
  22220. Add(' Include(f,red);');
  22221. ConvertProgram;
  22222. CheckSource('TestRTTI_AnonymousEnumType',
  22223. LinesToStr([ // statements
  22224. 'this.TFlags$a = {',
  22225. ' "0": "red",',
  22226. ' red: 0,',
  22227. ' "1": "green",',
  22228. ' green: 1',
  22229. '};',
  22230. '$mod.$rtti.$Enum("TFlags$a", {',
  22231. ' minvalue: 0,',
  22232. ' maxvalue: 1,',
  22233. ' ordtype: 1,',
  22234. ' enumtype: this.TFlags$a',
  22235. '});',
  22236. '$mod.$rtti.$Set("TFlags", {',
  22237. ' comptype: $mod.$rtti["TFlags$a"]',
  22238. '});',
  22239. 'this.f = {};',
  22240. '']),
  22241. LinesToStr([
  22242. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  22243. '']));
  22244. end;
  22245. procedure TTestModule.TestRTTI_StaticArray;
  22246. begin
  22247. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22248. StartProgram(false);
  22249. Add('type');
  22250. Add(' TFlag = (light,dark);');
  22251. Add(' TFlagNames = array[TFlag] of string;');
  22252. Add(' TBoolNames = array[boolean] of string;');
  22253. Add(' TByteArray = array[1..32768] of byte;');
  22254. Add(' TProc = function(f: TBoolNames): TFlagNames;');
  22255. Add('var p: pointer;');
  22256. Add('begin');
  22257. Add(' p:=typeinfo(TFlagNames);');
  22258. Add(' p:=typeinfo(TBoolNames);');
  22259. ConvertProgram;
  22260. CheckSource('TestRTTI_StaticArray',
  22261. LinesToStr([ // statements
  22262. 'this.TFlag = {',
  22263. ' "0": "light",',
  22264. ' light: 0,',
  22265. ' "1": "dark",',
  22266. ' dark: 1',
  22267. '};',
  22268. '$mod.$rtti.$Enum("TFlag", {',
  22269. ' minvalue: 0,',
  22270. ' maxvalue: 1,',
  22271. ' ordtype: 1,',
  22272. ' enumtype: this.TFlag',
  22273. '});',
  22274. '$mod.$rtti.$StaticArray("TFlagNames", {',
  22275. ' dims: [2],',
  22276. ' eltype: rtl.string',
  22277. '});',
  22278. '$mod.$rtti.$StaticArray("TBoolNames", {',
  22279. ' dims: [2],',
  22280. ' eltype: rtl.string',
  22281. '});',
  22282. '$mod.$rtti.$StaticArray("TByteArray", {',
  22283. ' dims: [32768],',
  22284. ' eltype: rtl.byte',
  22285. '});',
  22286. '$mod.$rtti.$ProcVar("TProc", {',
  22287. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TBoolNames"]]], $mod.$rtti["TFlagNames"])',
  22288. '});',
  22289. 'this.p = null;',
  22290. '']),
  22291. LinesToStr([ // $mod.$main
  22292. '$mod.p = $mod.$rtti["TFlagNames"];',
  22293. '$mod.p = $mod.$rtti["TBoolNames"];',
  22294. '']));
  22295. end;
  22296. procedure TTestModule.TestRTTI_DynArray;
  22297. begin
  22298. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22299. StartProgram(false);
  22300. Add('type');
  22301. Add(' TArrStr = array of string;');
  22302. Add(' TArr2Dim = array of tarrstr;');
  22303. Add(' TProc = function(f: TArrStr): TArr2Dim;');
  22304. Add('var p: pointer;');
  22305. Add('begin');
  22306. Add(' p:=typeinfo(tarrstr);');
  22307. Add(' p:=typeinfo(tarr2dim);');
  22308. ConvertProgram;
  22309. CheckSource('TestRTTI_DynArray',
  22310. LinesToStr([ // statements
  22311. '$mod.$rtti.$DynArray("TArrStr", {',
  22312. ' eltype: rtl.string',
  22313. '});',
  22314. '$mod.$rtti.$DynArray("TArr2Dim", {',
  22315. ' eltype: $mod.$rtti["TArrStr"]',
  22316. '});',
  22317. '$mod.$rtti.$ProcVar("TProc", {',
  22318. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TArrStr"]]], $mod.$rtti["TArr2Dim"])',
  22319. '});',
  22320. 'this.p = null;',
  22321. '']),
  22322. LinesToStr([ // $mod.$main
  22323. '$mod.p = $mod.$rtti["TArrStr"];',
  22324. '$mod.p = $mod.$rtti["TArr2Dim"];',
  22325. '']));
  22326. end;
  22327. procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
  22328. begin
  22329. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22330. StartProgram(false);
  22331. Add('type');
  22332. Add(' TArr = array of array of longint;');
  22333. Add('var a: TArr;');
  22334. Add('begin');
  22335. ConvertProgram;
  22336. CheckSource('TestRTTI_ArrayNestedAnonymous',
  22337. LinesToStr([ // statements
  22338. '$mod.$rtti.$DynArray("TArr$a", {',
  22339. ' eltype: rtl.longint',
  22340. '});',
  22341. '$mod.$rtti.$DynArray("TArr", {',
  22342. ' eltype: $mod.$rtti["TArr$a"]',
  22343. '});',
  22344. 'this.a = [];',
  22345. '']),
  22346. LinesToStr([ // $mod.$main
  22347. ]));
  22348. end;
  22349. procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
  22350. begin
  22351. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22352. StartProgram(false);
  22353. Add('type');
  22354. Add(' TObject = class');
  22355. Add(' published');
  22356. Add(' procedure Proc; virtual; abstract;');
  22357. Add(' procedure Proc(Sender: tobject); virtual; abstract;');
  22358. Add(' end;');
  22359. Add('begin');
  22360. SetExpectedPasResolverError('Duplicate identifier "Proc" at test1.pp(6,19)',
  22361. nDuplicateIdentifier);
  22362. ConvertProgram;
  22363. end;
  22364. procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
  22365. begin
  22366. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22367. StartProgram(false);
  22368. Add('type');
  22369. Add(' TObject = class');
  22370. Add(' published');
  22371. Add(' procedure Proc; external name ''foo'';');
  22372. Add(' end;');
  22373. Add('begin');
  22374. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  22375. nPublishedNameMustMatchExternal);
  22376. ConvertProgram;
  22377. end;
  22378. procedure TTestModule.TestRTTI_PublishedClassPropertyFail;
  22379. begin
  22380. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22381. StartProgram(false);
  22382. Add('type');
  22383. Add(' TObject = class');
  22384. Add(' class var FA: longint;');
  22385. Add(' published');
  22386. Add(' class property A: longint read FA;');
  22387. Add(' end;');
  22388. Add('begin');
  22389. SetExpectedPasResolverError('Invalid published property modifier "class"',
  22390. nInvalidXModifierY);
  22391. ConvertProgram;
  22392. end;
  22393. procedure TTestModule.TestRTTI_PublishedClassFieldFail;
  22394. begin
  22395. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22396. StartProgram(false);
  22397. Add('type');
  22398. Add(' TObject = class');
  22399. Add(' published');
  22400. Add(' class var FA: longint;');
  22401. Add(' end;');
  22402. Add('begin');
  22403. SetExpectedPasResolverError(sSymbolCannotBePublished,
  22404. nSymbolCannotBePublished);
  22405. ConvertProgram;
  22406. end;
  22407. procedure TTestModule.TestRTTI_PublishedFieldExternalFail;
  22408. begin
  22409. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22410. StartProgram(false);
  22411. Add('{$modeswitch externalclass}');
  22412. Add('type');
  22413. Add(' TObject = class');
  22414. Add(' published');
  22415. Add(' V: longint; external name ''foo'';');
  22416. Add(' end;');
  22417. Add('begin');
  22418. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  22419. nPublishedNameMustMatchExternal);
  22420. ConvertProgram;
  22421. end;
  22422. procedure TTestModule.TestRTTI_Class_Field;
  22423. begin
  22424. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22425. StartProgram(false);
  22426. Add('{$modeswitch externalclass}');
  22427. Add('type');
  22428. Add(' TObject = class');
  22429. Add(' private');
  22430. Add(' FPropA: string;');
  22431. Add(' published');
  22432. Add(' VarLI: longint;');
  22433. Add(' VarC: char;');
  22434. Add(' VarS: string;');
  22435. Add(' VarD: double;');
  22436. Add(' VarB: boolean;');
  22437. Add(' VarLW: longword;');
  22438. Add(' VarSmI: smallint;');
  22439. Add(' VarW: word;');
  22440. Add(' VarShI: shortint;');
  22441. Add(' VarBy: byte;');
  22442. Add(' VarExt: longint external name ''VarExt'';');
  22443. Add(' end;');
  22444. Add('var p: pointer;');
  22445. Add(' Obj: tobject;');
  22446. Add('begin');
  22447. Add(' p:=typeinfo(tobject);');
  22448. Add(' p:=typeinfo(p);');
  22449. Add(' p:=typeinfo(obj);');
  22450. ConvertProgram;
  22451. CheckSource('TestRTTI_Class_Field',
  22452. LinesToStr([ // statements
  22453. 'rtl.createClass($mod, "TObject", null, function () {',
  22454. ' this.$init = function () {',
  22455. ' this.FPropA = "";',
  22456. ' this.VarLI = 0;',
  22457. ' this.VarC = "";',
  22458. ' this.VarS = "";',
  22459. ' this.VarD = 0.0;',
  22460. ' this.VarB = false;',
  22461. ' this.VarLW = 0;',
  22462. ' this.VarSmI = 0;',
  22463. ' this.VarW = 0;',
  22464. ' this.VarShI = 0;',
  22465. ' this.VarBy = 0;',
  22466. ' };',
  22467. ' this.$final = function () {',
  22468. ' };',
  22469. ' var $r = this.$rtti;',
  22470. ' $r.addField("VarLI", rtl.longint);',
  22471. ' $r.addField("VarC", rtl.char);',
  22472. ' $r.addField("VarS", rtl.string);',
  22473. ' $r.addField("VarD", rtl.double);',
  22474. ' $r.addField("VarB", rtl.boolean);',
  22475. ' $r.addField("VarLW", rtl.longword);',
  22476. ' $r.addField("VarSmI", rtl.smallint);',
  22477. ' $r.addField("VarW", rtl.word);',
  22478. ' $r.addField("VarShI", rtl.shortint);',
  22479. ' $r.addField("VarBy", rtl.byte);',
  22480. ' $r.addField("VarExt", rtl.longint);',
  22481. '});',
  22482. 'this.p = null;',
  22483. 'this.Obj = null;',
  22484. '']),
  22485. LinesToStr([ // $mod.$main
  22486. '$mod.p = $mod.$rtti["TObject"];',
  22487. '$mod.p = rtl.pointer;',
  22488. '$mod.p = $mod.Obj.$rtti;',
  22489. '']));
  22490. end;
  22491. procedure TTestModule.TestRTTI_Class_Method;
  22492. begin
  22493. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22494. StartProgram(false);
  22495. Add('type');
  22496. Add(' TObject = class');
  22497. Add(' private');
  22498. Add(' procedure Internal; external name ''$intern'';');
  22499. Add(' published');
  22500. Add(' procedure Click; virtual; abstract;');
  22501. Add(' procedure Notify(Sender: TObject); virtual; abstract;');
  22502. Add(' function GetNotify: boolean; external name ''GetNotify'';');
  22503. Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
  22504. Add(' end;');
  22505. Add('begin');
  22506. ConvertProgram;
  22507. CheckSource('TestRTTI_Class_Method',
  22508. LinesToStr([ // statements
  22509. 'rtl.createClass($mod, "TObject", null, function () {',
  22510. ' this.$init = function () {',
  22511. ' };',
  22512. ' this.$final = function () {',
  22513. ' };',
  22514. ' var $r = this.$rtti;',
  22515. ' $r.addMethod("Click", 0, null);',
  22516. ' $r.addMethod("Notify", 0, [["Sender", $r]]);',
  22517. ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
  22518. ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
  22519. ' flags: 2',
  22520. ' });',
  22521. '});',
  22522. '']),
  22523. LinesToStr([ // $mod.$main
  22524. '']));
  22525. end;
  22526. procedure TTestModule.TestRTTI_Class_MethodArgFlags;
  22527. begin
  22528. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22529. StartProgram(false);
  22530. Add('type');
  22531. Add(' TObject = class');
  22532. Add(' published');
  22533. Add(' procedure OpenArray(const Args: array of string); virtual; abstract;');
  22534. Add(' procedure ByRef(var Value: longint; out Item: longint); virtual; abstract;');
  22535. Add(' procedure Untyped(var Value; out Item); virtual; abstract;');
  22536. Add(' end;');
  22537. Add('begin');
  22538. ConvertProgram;
  22539. CheckSource('TestRTTI_Class_MethodOpenArray',
  22540. LinesToStr([ // statements
  22541. 'rtl.createClass($mod, "TObject", null, function () {',
  22542. ' this.$init = function () {',
  22543. ' };',
  22544. ' this.$final = function () {',
  22545. ' };',
  22546. ' var $r = this.$rtti;',
  22547. '$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
  22548. '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
  22549. '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
  22550. '});',
  22551. '']),
  22552. LinesToStr([ // $mod.$main
  22553. '']));
  22554. end;
  22555. procedure TTestModule.TestRTTI_Class_Property;
  22556. begin
  22557. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22558. StartProgram(false);
  22559. Add('{$modeswitch externalclass}');
  22560. Add('type');
  22561. Add(' TObject = class');
  22562. Add(' private');
  22563. Add(' FColor: longint;');
  22564. Add(' FColorStored: boolean;');
  22565. Add(' procedure SetColor(Value: longint); virtual; abstract;');
  22566. Add(' function GetColor: longint; virtual; abstract;');
  22567. Add(' function GetColorStored: boolean; virtual; abstract;');
  22568. Add(' FExtSize: longint external name ''$extSize'';');
  22569. Add(' FExtSizeStored: boolean external name ''$extSizeStored'';');
  22570. Add(' procedure SetExtSize(Value: longint); external name ''$setSize'';');
  22571. Add(' function GetExtSize: longint; external name ''$getSize'';');
  22572. Add(' function GetExtSizeStored: boolean; external name ''$getExtSizeStored'';');
  22573. Add(' published');
  22574. Add(' property ColorA: longint read FColor;');
  22575. Add(' property ColorB: longint write FColor;');
  22576. Add(' property ColorC: longint read GetColor write SetColor;');
  22577. Add(' property ColorD: longint read FColor write FColor stored FColorStored;');
  22578. Add(' property ExtSizeA: longint read FExtSize write FExtSize;');
  22579. Add(' property ExtSizeB: longint read GetExtSize write SetExtSize stored FExtSizeStored;');
  22580. Add(' property ExtSizeC: longint read FExtSize write FExtSize stored GetExtSizeStored;');
  22581. Add(' end;');
  22582. Add('begin');
  22583. ConvertProgram;
  22584. CheckSource('TestRTTI_Class_Property',
  22585. LinesToStr([ // statements
  22586. 'rtl.createClass($mod, "TObject", null, function () {',
  22587. ' this.$init = function () {',
  22588. ' this.FColor = 0;',
  22589. ' this.FColorStored = false;',
  22590. ' };',
  22591. ' this.$final = function () {',
  22592. ' };',
  22593. ' var $r = this.$rtti;',
  22594. ' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
  22595. ' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
  22596. ' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
  22597. ' $r.addProperty(',
  22598. ' "ColorD",',
  22599. ' 8,',
  22600. ' rtl.longint,',
  22601. ' "FColor",',
  22602. ' "FColor",',
  22603. ' {',
  22604. ' stored: "FColorStored"',
  22605. ' }',
  22606. ' );',
  22607. ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
  22608. ' $r.addProperty(',
  22609. ' "ExtSizeB",',
  22610. ' 11,',
  22611. ' rtl.longint,',
  22612. ' "$getSize",',
  22613. ' "$setSize",',
  22614. ' {',
  22615. ' stored: "$extSizeStored"',
  22616. ' }',
  22617. ' );',
  22618. ' $r.addProperty(',
  22619. ' "ExtSizeC",',
  22620. ' 12,',
  22621. ' rtl.longint,',
  22622. ' "$extSize",',
  22623. ' "$extSize",',
  22624. ' {',
  22625. ' stored: "$getExtSizeStored"',
  22626. ' }',
  22627. ' );',
  22628. '});',
  22629. '']),
  22630. LinesToStr([ // $mod.$main
  22631. '']));
  22632. end;
  22633. procedure TTestModule.TestRTTI_Class_PropertyParams;
  22634. begin
  22635. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22636. StartProgram(false);
  22637. Add('{$modeswitch externalclass}');
  22638. Add('type');
  22639. Add(' integer = longint;');
  22640. Add(' TObject = class');
  22641. Add(' private');
  22642. Add(' function GetItems(i: integer): tobject; virtual; abstract;');
  22643. Add(' procedure SetItems(i: integer; value: tobject); virtual; abstract;');
  22644. Add(' function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
  22645. Add(' procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
  22646. Add(' published');
  22647. Add(' property Items[Index: integer]: tobject read getitems write setitems;');
  22648. Add(' property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
  22649. Add(' end;');
  22650. Add('begin');
  22651. ConvertProgram;
  22652. CheckSource('TestRTTI_Class_PropertyParams',
  22653. LinesToStr([ // statements
  22654. 'rtl.createClass($mod, "TObject", null, function () {',
  22655. ' this.$init = function () {',
  22656. ' };',
  22657. ' this.$final = function () {',
  22658. ' };',
  22659. ' var $r = this.$rtti;',
  22660. ' $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
  22661. ' $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
  22662. '});',
  22663. '']),
  22664. LinesToStr([ // $mod.$main
  22665. '']));
  22666. end;
  22667. procedure TTestModule.TestRTTI_Class_OtherUnit_TypeAlias;
  22668. begin
  22669. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22670. AddModuleWithIntfImplSrc('unit1.pas',
  22671. 'type TColor = -5..5;',
  22672. '');
  22673. StartProgram(true);
  22674. Add([
  22675. 'uses unit1;',
  22676. 'type',
  22677. ' TColorAlias = TColor;',
  22678. ' TColorTypeAlias = type TColor;',
  22679. ' TObject = class',
  22680. ' private',
  22681. ' fColor: TColor;',
  22682. ' fAlias: TColorAlias;',
  22683. ' fTypeAlias: TColorTypeAlias;',
  22684. ' published',
  22685. ' property Color: TColor read fcolor;',
  22686. ' property Alias: TColorAlias read falias;',
  22687. ' property TypeAlias: TColorTypeAlias read ftypealias;',
  22688. ' end;',
  22689. 'begin',
  22690. '']);
  22691. ConvertProgram;
  22692. CheckSource('TestRTTI_Class_OtherUnit_TypeAlias',
  22693. LinesToStr([ // statements
  22694. '$mod.$rtti.$inherited("TColorTypeAlias", pas.unit1.$rtti["TColor"], {});',
  22695. 'rtl.createClass($mod, "TObject", null, function () {',
  22696. ' this.$init = function () {',
  22697. ' this.fColor = 0;',
  22698. ' this.fAlias = 0;',
  22699. ' this.fTypeAlias = 0;',
  22700. ' };',
  22701. ' this.$final = function () {',
  22702. ' };',
  22703. ' var $r = this.$rtti;',
  22704. ' $r.addProperty("Color", 0, pas.unit1.$rtti["TColor"], "fColor", "");',
  22705. ' $r.addProperty("Alias", 0, pas.unit1.$rtti["TColor"], "fAlias", "");',
  22706. ' $r.addProperty("TypeAlias", 0, $mod.$rtti["TColorTypeAlias"], "fTypeAlias", "");',
  22707. '});',
  22708. '']),
  22709. LinesToStr([ // $mod.$main
  22710. '']));
  22711. end;
  22712. procedure TTestModule.TestRTTI_Class_OmitRTTI;
  22713. begin
  22714. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22715. StartProgram(false);
  22716. Add([
  22717. '{$modeswitch omitrtti}',
  22718. 'type',
  22719. ' TObject = class',
  22720. ' private',
  22721. ' FA: byte;',
  22722. ' published',
  22723. ' property A: byte read FA write FA;',
  22724. ' end;',
  22725. 'begin']);
  22726. ConvertProgram;
  22727. CheckSource('TestRTTI_Class_OmitRTTI',
  22728. LinesToStr([ // statements
  22729. 'rtl.createClass($mod, "TObject", null, function () {',
  22730. ' this.$init = function () {',
  22731. ' this.FA = 0;',
  22732. ' };',
  22733. ' this.$final = function () {',
  22734. ' };',
  22735. '});',
  22736. '']),
  22737. LinesToStr([ // $mod.$main
  22738. '']));
  22739. end;
  22740. procedure TTestModule.TestRTTI_IndexModifier;
  22741. begin
  22742. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22743. StartProgram(false);
  22744. Add([
  22745. 'type',
  22746. ' TEnum = (red, blue);',
  22747. ' TObject = class',
  22748. ' FB: boolean;',
  22749. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  22750. ' function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
  22751. ' procedure SetBoolBool(Index: boolean; b: boolean); virtual; abstract;',
  22752. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  22753. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  22754. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  22755. ' published',
  22756. ' property B1: boolean index 1 read FB write SetIntBool;',
  22757. ' property B2: boolean index TEnum.blue read GetEnumBool write FB;',
  22758. ' property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
  22759. ' end;',
  22760. 'begin']);
  22761. ConvertProgram;
  22762. CheckSource('TestRTTI_IndexModifier',
  22763. LinesToStr([ // statements
  22764. 'this.TEnum = {',
  22765. ' "0": "red",',
  22766. ' red: 0,',
  22767. ' "1": "blue",',
  22768. ' blue: 1',
  22769. '};',
  22770. '$mod.$rtti.$Enum("TEnum", {',
  22771. ' minvalue: 0,',
  22772. ' maxvalue: 1,',
  22773. ' ordtype: 1,',
  22774. ' enumtype: this.TEnum',
  22775. '});',
  22776. 'rtl.createClass($mod, "TObject", null, function () {',
  22777. ' this.$init = function () {',
  22778. ' this.FB = false;',
  22779. ' };',
  22780. ' this.$final = function () {',
  22781. ' };',
  22782. ' var $r = this.$rtti;',
  22783. ' $r.addProperty(',
  22784. ' "B1",',
  22785. ' 18,',
  22786. ' rtl.boolean,',
  22787. ' "FB",',
  22788. ' "SetIntBool",',
  22789. ' {',
  22790. ' index: 1',
  22791. ' }',
  22792. ' );',
  22793. ' $r.addProperty(',
  22794. ' "B2",',
  22795. ' 17,',
  22796. ' rtl.boolean,',
  22797. ' "GetEnumBool",',
  22798. ' "FB",',
  22799. ' {',
  22800. ' index: $mod.TEnum.blue',
  22801. ' }',
  22802. ' );',
  22803. ' $r.addProperty(',
  22804. ' "I1",',
  22805. ' 19,',
  22806. ' rtl.boolean,',
  22807. ' "GetStrIntBool",',
  22808. ' "SetStrIntBool",',
  22809. ' {',
  22810. ' index: 2',
  22811. ' }',
  22812. ' );',
  22813. '});',
  22814. '']),
  22815. LinesToStr([ // $mod.$main
  22816. '']));
  22817. end;
  22818. procedure TTestModule.TestRTTI_StoredModifier;
  22819. begin
  22820. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22821. StartProgram(false);
  22822. Add([
  22823. 'const',
  22824. ' ConstB = true;',
  22825. 'type',
  22826. ' TObject = class',
  22827. ' private',
  22828. ' FB: boolean;',
  22829. ' function IsBStored: boolean; virtual; abstract;',
  22830. ' published',
  22831. ' property BoolA: boolean read FB stored true;',
  22832. ' property BoolB: boolean read FB stored false;',
  22833. ' property BoolC: boolean read FB stored FB;',
  22834. ' property BoolD: boolean read FB stored ConstB;',
  22835. ' property BoolE: boolean read FB stored IsBStored;',
  22836. ' end;',
  22837. 'begin']);
  22838. ConvertProgram;
  22839. CheckSource('TestRTTI_StoredModifier',
  22840. LinesToStr([ // statements
  22841. 'this.ConstB = true;',
  22842. 'rtl.createClass($mod, "TObject", null, function () {',
  22843. ' this.$init = function () {',
  22844. ' this.FB = false;',
  22845. ' };',
  22846. ' this.$final = function () {',
  22847. ' };',
  22848. ' var $r = this.$rtti;',
  22849. ' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
  22850. ' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
  22851. ' $r.addProperty(',
  22852. ' "BoolC",',
  22853. ' 8,',
  22854. ' rtl.boolean,',
  22855. ' "FB",',
  22856. ' "",',
  22857. ' {',
  22858. ' stored: "FB"',
  22859. ' }',
  22860. ' );',
  22861. ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
  22862. ' $r.addProperty(',
  22863. ' "BoolE",',
  22864. ' 12,',
  22865. ' rtl.boolean,',
  22866. ' "FB",',
  22867. ' "",',
  22868. ' {',
  22869. ' stored: "IsBStored"',
  22870. ' }',
  22871. ' );',
  22872. '});',
  22873. '']),
  22874. LinesToStr([ // $mod.$main
  22875. '']));
  22876. end;
  22877. procedure TTestModule.TestRTTI_DefaultValue;
  22878. begin
  22879. Converter.Options:=Converter.Options-[coNoTypeInfo];
  22880. StartProgram(false);
  22881. Add([
  22882. 'type',
  22883. ' TEnum = (red, blue);',
  22884. 'const',
  22885. ' CB = true or false;',
  22886. ' CI = 1+2;',
  22887. 'type',
  22888. ' TObject = class',
  22889. ' FB: boolean;',
  22890. ' FI: longint;',
  22891. ' FE: TEnum;',
  22892. ' published',
  22893. ' property B1: boolean read FB default true;',
  22894. ' property B2: boolean read FB default CB;',
  22895. ' property B3: boolean read FB default test1.cb;',
  22896. ' property I1: longint read FI default 2;',
  22897. ' property I2: longint read FI default CI;',
  22898. ' property E1: TEnum read FE default red;',
  22899. ' property E2: TEnum read FE default TEnum.blue;',
  22900. ' end;',
  22901. 'begin']);
  22902. ConvertProgram;
  22903. CheckSource('TestRTTI_DefaultValue',
  22904. LinesToStr([ // statements
  22905. 'this.TEnum = {',
  22906. ' "0": "red",',
  22907. ' red: 0,',
  22908. ' "1": "blue",',
  22909. ' blue: 1',
  22910. '};',
  22911. '$mod.$rtti.$Enum("TEnum", {',
  22912. ' minvalue: 0,',
  22913. ' maxvalue: 1,',
  22914. ' ordtype: 1,',
  22915. ' enumtype: this.TEnum',
  22916. '});',
  22917. 'this.CB = true || false;',
  22918. 'this.CI = 1 + 2;',
  22919. 'rtl.createClass($mod, "TObject", null, function () {',
  22920. ' this.$init = function () {',
  22921. ' this.FB = false;',
  22922. ' this.FI = 0;',
  22923. ' this.FE = 0;',
  22924. ' };',
  22925. ' this.$final = function () {',
  22926. ' };',
  22927. ' var $r = this.$rtti;',
  22928. ' $r.addProperty(',
  22929. ' "B1",',
  22930. ' 0,',
  22931. ' rtl.boolean,',
  22932. ' "FB",',
  22933. ' "",',
  22934. ' {',
  22935. ' Default: true',
  22936. ' }',
  22937. ' );',
  22938. ' $r.addProperty(',
  22939. ' "B2",',
  22940. ' 0,',
  22941. ' rtl.boolean,',
  22942. ' "FB",',
  22943. ' "",',
  22944. ' {',
  22945. ' Default: true',
  22946. ' }',
  22947. ' );',
  22948. ' $r.addProperty(',
  22949. ' "B3",',
  22950. ' 0,',
  22951. ' rtl.boolean,',
  22952. ' "FB",',
  22953. ' "",',
  22954. ' {',
  22955. ' Default: true',
  22956. ' }',
  22957. ' );',
  22958. ' $r.addProperty(',
  22959. ' "I1",',
  22960. ' 0,',
  22961. ' rtl.longint,',
  22962. ' "FI",',
  22963. ' "",',
  22964. ' {',
  22965. ' Default: 2',
  22966. ' }',
  22967. ' );',
  22968. ' $r.addProperty(',
  22969. ' "I2",',
  22970. ' 0,',
  22971. ' rtl.longint,',
  22972. ' "FI",',
  22973. ' "",',
  22974. ' {',
  22975. ' Default: 3',
  22976. ' }',
  22977. ' );',
  22978. ' $r.addProperty(',
  22979. ' "E1",',
  22980. ' 0,',
  22981. ' $mod.$rtti["TEnum"],',
  22982. ' "FE",',
  22983. ' "",',
  22984. ' {',
  22985. ' Default: $mod.TEnum.red',
  22986. ' }',
  22987. ' );',
  22988. ' $r.addProperty(',
  22989. ' "E2",',
  22990. ' 0,',
  22991. ' $mod.$rtti["TEnum"],',
  22992. ' "FE",',
  22993. ' "",',
  22994. ' {',
  22995. ' Default: $mod.TEnum.blue',
  22996. ' }',
  22997. ' );',
  22998. '});',
  22999. '']),
  23000. LinesToStr([ // $mod.$main
  23001. '']));
  23002. end;
  23003. procedure TTestModule.TestRTTI_DefaultValueSet;
  23004. begin
  23005. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23006. StartProgram(false);
  23007. Add([
  23008. 'type',
  23009. ' TEnum = (red, blue);',
  23010. ' TSet = set of TEnum;',
  23011. 'const',
  23012. ' CSet = [red,blue];',
  23013. 'type',
  23014. ' TObject = class',
  23015. ' FSet: TSet;',
  23016. ' published',
  23017. ' property Set1: TSet read FSet default [];',
  23018. ' property Set2: TSet read FSet default [red];',
  23019. ' property Set3: TSet read FSet default [red,blue];',
  23020. ' property Set4: TSet read FSet default CSet;',
  23021. ' end;',
  23022. 'begin']);
  23023. ConvertProgram;
  23024. CheckSource('TestRTTI_DefaultValueSet',
  23025. LinesToStr([ // statements
  23026. 'this.TEnum = {',
  23027. ' "0": "red",',
  23028. ' red: 0,',
  23029. ' "1": "blue",',
  23030. ' blue: 1',
  23031. '};',
  23032. '$mod.$rtti.$Enum("TEnum", {',
  23033. ' minvalue: 0,',
  23034. ' maxvalue: 1,',
  23035. ' ordtype: 1,',
  23036. ' enumtype: this.TEnum',
  23037. '});',
  23038. '$mod.$rtti.$Set("TSet", {',
  23039. ' comptype: $mod.$rtti["TEnum"]',
  23040. '});',
  23041. 'this.CSet = rtl.createSet($mod.TEnum.red, $mod.TEnum.blue);',
  23042. 'rtl.createClass($mod, "TObject", null, function () {',
  23043. ' this.$init = function () {',
  23044. ' this.FSet = {};',
  23045. ' };',
  23046. ' this.$final = function () {',
  23047. ' this.FSet = undefined;',
  23048. ' };',
  23049. ' var $r = this.$rtti;',
  23050. ' $r.addProperty(',
  23051. ' "Set1",',
  23052. ' 0,',
  23053. ' $mod.$rtti["TSet"],',
  23054. ' "FSet",',
  23055. ' "",',
  23056. ' {',
  23057. ' Default: {}',
  23058. ' }',
  23059. ' );',
  23060. ' $r.addProperty(',
  23061. ' "Set2",',
  23062. ' 0,',
  23063. ' $mod.$rtti["TSet"],',
  23064. ' "FSet",',
  23065. ' "",',
  23066. ' {',
  23067. ' Default: rtl.createSet($mod.TEnum.red)',
  23068. ' }',
  23069. ' );',
  23070. ' $r.addProperty(',
  23071. ' "Set3",',
  23072. ' 0,',
  23073. ' $mod.$rtti["TSet"],',
  23074. ' "FSet",',
  23075. ' "",',
  23076. ' {',
  23077. ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
  23078. ' }',
  23079. ' );',
  23080. ' $r.addProperty(',
  23081. ' "Set4",',
  23082. ' 0,',
  23083. ' $mod.$rtti["TSet"],',
  23084. ' "FSet",',
  23085. ' "",',
  23086. ' {',
  23087. ' Default: $mod.CSet',
  23088. ' }',
  23089. ' );',
  23090. '});',
  23091. '']),
  23092. LinesToStr([ // $mod.$main
  23093. '']));
  23094. end;
  23095. procedure TTestModule.TestRTTI_DefaultValueRangeType;
  23096. begin
  23097. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23098. StartProgram(false);
  23099. Add([
  23100. 'type',
  23101. ' TRg = -1..1;',
  23102. 'const',
  23103. ' l = low(TRg);',
  23104. ' h = high(TRg);',
  23105. 'type',
  23106. ' TObject = class',
  23107. ' FV: TRg;',
  23108. ' published',
  23109. ' property V1: TRg read FV default -1;',
  23110. ' end;',
  23111. 'begin']);
  23112. ConvertProgram;
  23113. CheckSource('TestRTTI_DefaultValueRangeType',
  23114. LinesToStr([ // statements
  23115. '$mod.$rtti.$Int("TRg", {',
  23116. ' minvalue: -1,',
  23117. ' maxvalue: 1,',
  23118. ' ordtype: 0',
  23119. '});',
  23120. 'this.l = -1;',
  23121. 'this.h = 1;',
  23122. 'rtl.createClass($mod, "TObject", null, function () {',
  23123. ' this.$init = function () {',
  23124. ' this.FV = 0;',
  23125. ' };',
  23126. ' this.$final = function () {',
  23127. ' };',
  23128. ' var $r = this.$rtti;',
  23129. ' $r.addProperty(',
  23130. ' "V1",',
  23131. ' 0,',
  23132. ' $mod.$rtti["TRg"],',
  23133. ' "FV",',
  23134. ' "",',
  23135. ' {',
  23136. ' Default: -1',
  23137. ' }',
  23138. ' );',
  23139. '});',
  23140. '']),
  23141. LinesToStr([ // $mod.$main
  23142. '']));
  23143. end;
  23144. procedure TTestModule.TestRTTI_DefaultValueInherit;
  23145. begin
  23146. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23147. StartProgram(false);
  23148. Add([
  23149. 'type',
  23150. ' TObject = class',
  23151. ' FA, FB: byte;',
  23152. ' property A: byte read FA default 1;',
  23153. ' property B: byte read FB default 2;',
  23154. ' end;',
  23155. ' TBird = class',
  23156. ' published',
  23157. ' property A;',
  23158. ' property B nodefault;',
  23159. ' end;',
  23160. 'begin']);
  23161. ConvertProgram;
  23162. CheckSource('TestRTTI_DefaultValueInherit',
  23163. LinesToStr([ // statements
  23164. 'rtl.createClass($mod, "TObject", null, function () {',
  23165. ' this.$init = function () {',
  23166. ' this.FA = 0;',
  23167. ' this.FB = 0;',
  23168. ' };',
  23169. ' this.$final = function () {',
  23170. ' };',
  23171. '});',
  23172. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  23173. ' var $r = this.$rtti;',
  23174. ' $r.addProperty(',
  23175. ' "A",',
  23176. ' 0,',
  23177. ' rtl.byte,',
  23178. ' "FA",',
  23179. ' "",',
  23180. ' {',
  23181. ' Default: 1',
  23182. ' }',
  23183. ' );',
  23184. ' $r.addProperty("B", 0, rtl.byte, "FB", "");',
  23185. '});',
  23186. '']),
  23187. LinesToStr([ // $mod.$main
  23188. '']));
  23189. end;
  23190. procedure TTestModule.TestRTTI_OverrideMethod;
  23191. begin
  23192. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23193. StartProgram(false);
  23194. Add('type');
  23195. Add(' TObject = class');
  23196. Add(' published');
  23197. Add(' procedure DoIt; virtual; abstract;');
  23198. Add(' end;');
  23199. Add(' TSky = class');
  23200. Add(' published');
  23201. Add(' procedure DoIt; override;');
  23202. Add(' end;');
  23203. Add('procedure TSky.DoIt; begin end;');
  23204. Add('begin');
  23205. ConvertProgram;
  23206. CheckSource('TestRTTI_OverrideMethod',
  23207. LinesToStr([ // statements
  23208. 'rtl.createClass($mod, "TObject", null, function () {',
  23209. ' this.$init = function () {',
  23210. ' };',
  23211. ' this.$final = function () {',
  23212. ' };',
  23213. ' var $r = this.$rtti;',
  23214. ' $r.addMethod("DoIt", 0, null);',
  23215. '});',
  23216. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  23217. ' this.DoIt = function () {',
  23218. ' };',
  23219. '});',
  23220. '']),
  23221. LinesToStr([ // $mod.$main
  23222. '']));
  23223. end;
  23224. procedure TTestModule.TestRTTI_OverloadProperty;
  23225. begin
  23226. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23227. StartProgram(false);
  23228. Add('type');
  23229. Add(' TObject = class');
  23230. Add(' protected');
  23231. Add(' FFlag: longint;');
  23232. Add(' published');
  23233. Add(' property Flag: longint read fflag;');
  23234. Add(' end;');
  23235. Add(' TSky = class');
  23236. Add(' published');
  23237. Add(' property FLAG: longint write fflag;');
  23238. Add(' end;');
  23239. Add('begin');
  23240. ConvertProgram;
  23241. CheckSource('TestRTTI_OverrideMethod',
  23242. LinesToStr([ // statements
  23243. 'rtl.createClass($mod, "TObject", null, function () {',
  23244. ' this.$init = function () {',
  23245. ' this.FFlag = 0;',
  23246. ' };',
  23247. ' this.$final = function () {',
  23248. ' };',
  23249. ' var $r = this.$rtti;',
  23250. ' $r.addProperty("Flag", 0, rtl.longint, "FFlag", "");',
  23251. '});',
  23252. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  23253. ' var $r = this.$rtti;',
  23254. ' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
  23255. '});',
  23256. '']),
  23257. LinesToStr([ // $mod.$main
  23258. '']));
  23259. end;
  23260. procedure TTestModule.TestRTTI_ClassForward;
  23261. begin
  23262. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23263. StartProgram(false);
  23264. Add('type');
  23265. Add(' TObject = class end;');
  23266. Add(' tbridge = class;');
  23267. Add(' TProc = function: tbridge;');
  23268. Add(' TOger = class');
  23269. Add(' published');
  23270. Add(' FBridge: tbridge;');
  23271. Add(' procedure SetBridge(Value: tbridge); virtual; abstract;');
  23272. Add(' property Bridge: tbridge read fbridge write setbridge;');
  23273. Add(' end;');
  23274. Add(' TBridge = class');
  23275. Add(' FOger: toger;');
  23276. Add(' end;');
  23277. Add('var p: Pointer;');
  23278. Add(' b: tbridge;');
  23279. Add('begin');
  23280. Add(' p:=typeinfo(tbridge);');
  23281. Add(' p:=typeinfo(b);');
  23282. ConvertProgram;
  23283. CheckSource('TestRTTI_ClassForward',
  23284. LinesToStr([ // statements
  23285. 'rtl.createClass($mod, "TObject", null, function () {',
  23286. ' this.$init = function () {',
  23287. ' };',
  23288. ' this.$final = function () {',
  23289. ' };',
  23290. '});',
  23291. '$mod.$rtti.$Class("TBridge");',
  23292. '$mod.$rtti.$ProcVar("TProc", {',
  23293. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TBridge"])',
  23294. '});',
  23295. 'rtl.createClass($mod, "TOger", $mod.TObject, function () {',
  23296. ' this.$init = function () {',
  23297. ' $mod.TObject.$init.call(this);',
  23298. ' this.FBridge = null;',
  23299. ' };',
  23300. ' this.$final = function () {',
  23301. ' this.FBridge = undefined;',
  23302. ' $mod.TObject.$final.call(this);',
  23303. ' };',
  23304. ' var $r = this.$rtti;',
  23305. ' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
  23306. ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
  23307. ' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
  23308. '});',
  23309. 'rtl.createClass($mod, "TBridge", $mod.TObject, function () {',
  23310. ' this.$init = function () {',
  23311. ' $mod.TObject.$init.call(this);',
  23312. ' this.FOger = null;',
  23313. ' };',
  23314. ' this.$final = function () {',
  23315. ' this.FOger = undefined;',
  23316. ' $mod.TObject.$final.call(this);',
  23317. ' };',
  23318. '});',
  23319. 'this.p = null;',
  23320. 'this.b = null;',
  23321. '']),
  23322. LinesToStr([ // $mod.$main
  23323. '$mod.p = $mod.$rtti["TBridge"];',
  23324. '$mod.p = $mod.b.$rtti;',
  23325. '']));
  23326. end;
  23327. procedure TTestModule.TestRTTI_ClassOf;
  23328. begin
  23329. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23330. StartProgram(false);
  23331. Add('type');
  23332. Add(' TClass = class of tobject;');
  23333. Add(' TProcA = function: TClass;');
  23334. Add(' TObject = class');
  23335. Add(' published');
  23336. Add(' C: tclass;');
  23337. Add(' end;');
  23338. Add(' tfox = class;');
  23339. Add(' TBird = class end;');
  23340. Add(' TBirds = class of tbird;');
  23341. Add(' TFox = class end;');
  23342. Add(' TFoxes = class of tfox;');
  23343. Add(' TCows = class of TCow;');
  23344. Add(' TCow = class;');
  23345. Add(' TCow = class end;');
  23346. Add('begin');
  23347. ConvertProgram;
  23348. CheckSource('TestRTTI_ClassOf',
  23349. LinesToStr([ // statements
  23350. '$mod.$rtti.$Class("TObject");',
  23351. '$mod.$rtti.$ClassRef("TClass", {',
  23352. ' instancetype: $mod.$rtti["TObject"]',
  23353. '});',
  23354. '$mod.$rtti.$ProcVar("TProcA", {',
  23355. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TClass"])',
  23356. '});',
  23357. 'rtl.createClass($mod, "TObject", null, function () {',
  23358. ' this.$init = function () {',
  23359. ' this.C = null;',
  23360. ' };',
  23361. ' this.$final = function () {',
  23362. ' this.C = undefined;',
  23363. ' };',
  23364. ' var $r = this.$rtti;',
  23365. ' $r.addField("C", $mod.$rtti["TClass"]);',
  23366. '});',
  23367. '$mod.$rtti.$Class("TFox");',
  23368. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  23369. '});',
  23370. '$mod.$rtti.$ClassRef("TBirds", {',
  23371. ' instancetype: $mod.$rtti["TBird"]',
  23372. '});',
  23373. 'rtl.createClass($mod, "TFox", $mod.TObject, function () {',
  23374. '});',
  23375. '$mod.$rtti.$ClassRef("TFoxes", {',
  23376. ' instancetype: $mod.$rtti["TFox"]',
  23377. '});',
  23378. '$mod.$rtti.$Class("TCow");',
  23379. '$mod.$rtti.$ClassRef("TCows", {',
  23380. ' instancetype: $mod.$rtti["TCow"]',
  23381. '});',
  23382. 'rtl.createClass($mod, "TCow", $mod.TObject, function () {',
  23383. '});',
  23384. '']),
  23385. LinesToStr([ // $mod.$main
  23386. '']));
  23387. end;
  23388. procedure TTestModule.TestRTTI_Record;
  23389. begin
  23390. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23391. StartProgram(false);
  23392. Add('type');
  23393. Add(' integer = longint;');
  23394. Add(' TPoint = record');
  23395. Add(' x,y: integer;');
  23396. Add(' end;');
  23397. Add('var p: pointer;');
  23398. Add(' r: tpoint;');
  23399. Add('begin');
  23400. Add(' p:=typeinfo(tpoint);');
  23401. Add(' p:=typeinfo(r);');
  23402. Add(' p:=typeinfo(r.x);');
  23403. ConvertProgram;
  23404. CheckSource('TestRTTI_Record',
  23405. LinesToStr([ // statements
  23406. 'rtl.recNewT($mod, "TPoint", function () {',
  23407. ' this.x = 0;',
  23408. ' this.y = 0;',
  23409. ' this.$eq = function (b) {',
  23410. ' return (this.x === b.x) && (this.y === b.y);',
  23411. ' };',
  23412. ' this.$assign = function (s) {',
  23413. ' this.x = s.x;',
  23414. ' this.y = s.y;',
  23415. ' return this;',
  23416. ' };',
  23417. ' var $r = $mod.$rtti.$Record("TPoint", {});',
  23418. ' $r.addField("x", rtl.longint);',
  23419. ' $r.addField("y", rtl.longint);',
  23420. '});',
  23421. 'this.p = null;',
  23422. 'this.r = $mod.TPoint.$new();',
  23423. '']),
  23424. LinesToStr([ // $mod.$main
  23425. '$mod.p = $mod.$rtti["TPoint"];',
  23426. '$mod.p = $mod.$rtti["TPoint"];',
  23427. '$mod.p = rtl.longint;',
  23428. '']));
  23429. end;
  23430. procedure TTestModule.TestRTTI_RecordAnonymousArray;
  23431. begin
  23432. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23433. StartProgram(false);
  23434. Add('type');
  23435. Add(' TFloatRec = record');
  23436. Add(' d: array of char;');
  23437. // Add(' i: array of array of longint;');
  23438. Add(' end;');
  23439. Add('var p: pointer;');
  23440. Add(' r: tfloatrec;');
  23441. Add('begin');
  23442. Add(' p:=typeinfo(tfloatrec);');
  23443. Add(' p:=typeinfo(r);');
  23444. Add(' p:=typeinfo(r.d);');
  23445. ConvertProgram;
  23446. CheckSource('TestRTTI_Record',
  23447. LinesToStr([ // statements
  23448. 'rtl.recNewT($mod, "TFloatRec", function () {',
  23449. ' this.d = [];',
  23450. ' this.$eq = function (b) {',
  23451. ' return this.d === b.d;',
  23452. ' };',
  23453. ' this.$assign = function (s) {',
  23454. ' this.d = s.d;',
  23455. ' return this;',
  23456. ' };',
  23457. ' $mod.$rtti.$DynArray("TFloatRec.d$a", {',
  23458. ' eltype: rtl.char',
  23459. ' });',
  23460. ' var $r = $mod.$rtti.$Record("TFloatRec", {});',
  23461. ' $r.addField("d", $mod.$rtti["TFloatRec.d$a"]);',
  23462. '});',
  23463. 'this.p = null;',
  23464. 'this.r = $mod.TFloatRec.$new();',
  23465. '']),
  23466. LinesToStr([ // $mod.$main
  23467. '$mod.p = $mod.$rtti["TFloatRec"];',
  23468. '$mod.p = $mod.$rtti["TFloatRec"];',
  23469. '$mod.p = $mod.$rtti["TFloatRec.d$a"];',
  23470. '']));
  23471. end;
  23472. procedure TTestModule.TestRTTI_LocalTypes;
  23473. begin
  23474. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23475. StartProgram(false);
  23476. Add([
  23477. 'procedure DoIt;',
  23478. 'type',
  23479. ' integer = longint;',
  23480. ' TPoint = record',
  23481. ' x,y: integer;',
  23482. ' end;',
  23483. 'var p: TPoint;',
  23484. 'begin',
  23485. 'end;',
  23486. 'begin']);
  23487. ConvertProgram;
  23488. CheckSource('TestRTTI_LocalTypes',
  23489. LinesToStr([ // statements
  23490. 'var TPoint = rtl.recNewT(null, "", function () {',
  23491. ' this.x = 0;',
  23492. ' this.y = 0;',
  23493. ' this.$eq = function (b) {',
  23494. ' return (this.x === b.x) && (this.y === b.y);',
  23495. ' };',
  23496. ' this.$assign = function (s) {',
  23497. ' this.x = s.x;',
  23498. ' this.y = s.y;',
  23499. ' return this;',
  23500. ' };',
  23501. '});',
  23502. 'this.DoIt = function () {',
  23503. ' var p = TPoint.$new();',
  23504. '};',
  23505. '']),
  23506. LinesToStr([ // $mod.$main
  23507. '']));
  23508. end;
  23509. procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
  23510. begin
  23511. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23512. StartProgram(false);
  23513. Add([
  23514. 'type',
  23515. ' TCaption = string;',
  23516. ' TYesNo = boolean;',
  23517. ' TLetter = char;',
  23518. ' TFloat = double;',
  23519. ' TPtr = pointer;',
  23520. ' TShortInt = shortint;',
  23521. ' TByte = byte;',
  23522. ' TSmallInt = smallint;',
  23523. ' TWord = word;',
  23524. ' TInt32 = longint;',
  23525. ' TDWord = longword;',
  23526. ' TValue = jsvalue;',
  23527. 'var p: TPtr;',
  23528. 'begin',
  23529. ' p:=typeinfo(string);',
  23530. ' p:=typeinfo(tcaption);',
  23531. ' p:=typeinfo(boolean);',
  23532. ' p:=typeinfo(tyesno);',
  23533. ' p:=typeinfo(char);',
  23534. ' p:=typeinfo(tletter);',
  23535. ' p:=typeinfo(double);',
  23536. ' p:=typeinfo(tfloat);',
  23537. ' p:=typeinfo(pointer);',
  23538. ' p:=typeinfo(tptr);',
  23539. ' p:=typeinfo(shortint);',
  23540. ' p:=typeinfo(tshortint);',
  23541. ' p:=typeinfo(byte);',
  23542. ' p:=typeinfo(tbyte);',
  23543. ' p:=typeinfo(smallint);',
  23544. ' p:=typeinfo(tsmallint);',
  23545. ' p:=typeinfo(word);',
  23546. ' p:=typeinfo(tword);',
  23547. ' p:=typeinfo(longword);',
  23548. ' p:=typeinfo(tdword);',
  23549. ' p:=typeinfo(jsvalue);',
  23550. ' p:=typeinfo(tvalue);',
  23551. '']);
  23552. ConvertProgram;
  23553. CheckSource('TestRTTI_TypeInfo_BaseTypes',
  23554. LinesToStr([ // statements
  23555. 'this.p = null;',
  23556. '']),
  23557. LinesToStr([ // $mod.$main
  23558. '$mod.p = rtl.string;',
  23559. '$mod.p = rtl.string;',
  23560. '$mod.p = rtl.boolean;',
  23561. '$mod.p = rtl.boolean;',
  23562. '$mod.p = rtl.char;',
  23563. '$mod.p = rtl.char;',
  23564. '$mod.p = rtl.double;',
  23565. '$mod.p = rtl.double;',
  23566. '$mod.p = rtl.pointer;',
  23567. '$mod.p = rtl.pointer;',
  23568. '$mod.p = rtl.shortint;',
  23569. '$mod.p = rtl.shortint;',
  23570. '$mod.p = rtl.byte;',
  23571. '$mod.p = rtl.byte;',
  23572. '$mod.p = rtl.smallint;',
  23573. '$mod.p = rtl.smallint;',
  23574. '$mod.p = rtl.word;',
  23575. '$mod.p = rtl.word;',
  23576. '$mod.p = rtl.longword;',
  23577. '$mod.p = rtl.longword;',
  23578. '$mod.p = rtl.jsvalue;',
  23579. '$mod.p = rtl.jsvalue;',
  23580. '']));
  23581. end;
  23582. procedure TTestModule.TestRTTI_TypeInfo_Type_BaseTypes;
  23583. begin
  23584. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23585. StartProgram(false);
  23586. Add([
  23587. 'type',
  23588. ' TCaption = type string;',
  23589. ' TYesNo = type boolean;',
  23590. ' TLetter = type char;',
  23591. ' TFloat = type double;',
  23592. ' TPtr = type pointer;',
  23593. ' TShortInt = type shortint;',
  23594. ' TByte = type byte;',
  23595. ' TSmallInt = type smallint;',
  23596. ' TWord = type word;',
  23597. ' TInt32 = type longint;',
  23598. ' TDWord = type longword;',
  23599. ' TValue = type jsvalue;',
  23600. ' TAliasValue = type TValue;',
  23601. 'var',
  23602. ' p: TPtr;',
  23603. ' a: TAliasValue;',
  23604. 'begin',
  23605. ' p:=typeinfo(tcaption);',
  23606. ' p:=typeinfo(tyesno);',
  23607. ' p:=typeinfo(tletter);',
  23608. ' p:=typeinfo(tfloat);',
  23609. ' p:=typeinfo(tptr);',
  23610. ' p:=typeinfo(tshortint);',
  23611. ' p:=typeinfo(tbyte);',
  23612. ' p:=typeinfo(tsmallint);',
  23613. ' p:=typeinfo(tword);',
  23614. ' p:=typeinfo(tdword);',
  23615. ' p:=typeinfo(tvalue);',
  23616. ' p:=typeinfo(taliasvalue);',
  23617. ' p:=typeinfo(a);',
  23618. '']);
  23619. ConvertProgram;
  23620. CheckSource('TestRTTI_TypeInfo_Type_BaseTypes',
  23621. LinesToStr([ // statements
  23622. '$mod.$rtti.$inherited("TCaption", rtl.string, {});',
  23623. '$mod.$rtti.$inherited("TYesNo", rtl.boolean, {});',
  23624. '$mod.$rtti.$inherited("TLetter", rtl.char, {});',
  23625. '$mod.$rtti.$inherited("TFloat", rtl.double, {});',
  23626. '$mod.$rtti.$inherited("TPtr", rtl.pointer, {});',
  23627. '$mod.$rtti.$inherited("TShortInt", rtl.shortint, {});',
  23628. '$mod.$rtti.$inherited("TByte", rtl.byte, {});',
  23629. '$mod.$rtti.$inherited("TSmallInt", rtl.smallint, {});',
  23630. '$mod.$rtti.$inherited("TWord", rtl.word, {});',
  23631. '$mod.$rtti.$inherited("TInt32", rtl.longint, {});',
  23632. '$mod.$rtti.$inherited("TDWord", rtl.longword, {});',
  23633. '$mod.$rtti.$inherited("TValue", rtl.jsvalue, {});',
  23634. '$mod.$rtti.$inherited("TAliasValue", $mod.$rtti["TValue"], {});',
  23635. 'this.p = null;',
  23636. 'this.a = undefined;',
  23637. '']),
  23638. LinesToStr([ // $mod.$main
  23639. '$mod.p = $mod.$rtti["TCaption"];',
  23640. '$mod.p = $mod.$rtti["TYesNo"];',
  23641. '$mod.p = $mod.$rtti["TLetter"];',
  23642. '$mod.p = $mod.$rtti["TFloat"];',
  23643. '$mod.p = $mod.$rtti["TPtr"];',
  23644. '$mod.p = $mod.$rtti["TShortInt"];',
  23645. '$mod.p = $mod.$rtti["TByte"];',
  23646. '$mod.p = $mod.$rtti["TSmallInt"];',
  23647. '$mod.p = $mod.$rtti["TWord"];',
  23648. '$mod.p = $mod.$rtti["TDWord"];',
  23649. '$mod.p = $mod.$rtti["TValue"];',
  23650. '$mod.p = $mod.$rtti["TAliasValue"];',
  23651. '$mod.p = $mod.$rtti["TAliasValue"];',
  23652. '']));
  23653. end;
  23654. procedure TTestModule.TestRTTI_TypeInfo_LocalFail;
  23655. begin
  23656. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23657. StartProgram(false);
  23658. Add('procedure DoIt;');
  23659. Add('type');
  23660. Add(' integer = longint;');
  23661. Add(' TPoint = record');
  23662. Add(' x,y: integer;');
  23663. Add(' end;');
  23664. Add('var p: pointer;');
  23665. Add('begin');
  23666. Add(' p:=typeinfo(tpoint);');
  23667. Add('end;');
  23668. Add('begin');
  23669. SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
  23670. ConvertProgram;
  23671. end;
  23672. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  23673. begin
  23674. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23675. StartProgram(false);
  23676. Add([
  23677. '{$modeswitch externalclass}',
  23678. 'type',
  23679. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23680. ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
  23681. ' TFlag = (up,down);',
  23682. ' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;',
  23683. ' TFlags = set of TFlag;',
  23684. ' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;',
  23685. 'var',
  23686. ' ti: TTypeInfo;',
  23687. ' tiInt: TTypeInfoInteger;',
  23688. ' tiEnum: TTypeInfoEnum;',
  23689. ' tiSet: TTypeInfoSet;',
  23690. 'begin',
  23691. ' ti:=typeinfo(string);',
  23692. ' ti:=typeinfo(boolean);',
  23693. ' ti:=typeinfo(char);',
  23694. ' ti:=typeinfo(double);',
  23695. ' tiInt:=typeinfo(shortint);',
  23696. ' tiInt:=typeinfo(byte);',
  23697. ' tiInt:=typeinfo(smallint);',
  23698. ' tiInt:=typeinfo(word);',
  23699. ' tiInt:=typeinfo(longint);',
  23700. ' tiInt:=typeinfo(longword);',
  23701. ' ti:=typeinfo(jsvalue);',
  23702. ' tiEnum:=typeinfo(tflag);',
  23703. ' tiSet:=typeinfo(tflags);']);
  23704. ConvertProgram;
  23705. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
  23706. LinesToStr([ // statements
  23707. 'this.TFlag = {',
  23708. ' "0": "up",',
  23709. ' up: 0,',
  23710. ' "1": "down",',
  23711. ' down: 1',
  23712. '};',
  23713. '$mod.$rtti.$Enum("TFlag", {',
  23714. ' minvalue: 0,',
  23715. ' maxvalue: 1,',
  23716. ' ordtype: 1,',
  23717. ' enumtype: this.TFlag',
  23718. '});',
  23719. '$mod.$rtti.$Set("TFlags", {',
  23720. ' comptype: $mod.$rtti["TFlag"]',
  23721. '});',
  23722. 'this.ti = null;',
  23723. 'this.tiInt = null;',
  23724. 'this.tiEnum = null;',
  23725. 'this.tiSet = null;',
  23726. '']),
  23727. LinesToStr([ // $mod.$main
  23728. '$mod.ti = rtl.string;',
  23729. '$mod.ti = rtl.boolean;',
  23730. '$mod.ti = rtl.char;',
  23731. '$mod.ti = rtl.double;',
  23732. '$mod.tiInt = rtl.shortint;',
  23733. '$mod.tiInt = rtl.byte;',
  23734. '$mod.tiInt = rtl.smallint;',
  23735. '$mod.tiInt = rtl.word;',
  23736. '$mod.tiInt = rtl.longint;',
  23737. '$mod.tiInt = rtl.longword;',
  23738. '$mod.ti = rtl.jsvalue;',
  23739. '$mod.tiEnum = $mod.$rtti["TFlag"];',
  23740. '$mod.tiSet = $mod.$rtti["TFlags"];',
  23741. '']));
  23742. end;
  23743. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  23744. begin
  23745. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23746. StartProgram(false);
  23747. Add('{$modeswitch externalclass}');
  23748. Add('type');
  23749. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  23750. Add(' TStaticArr = array[boolean] of string;');
  23751. Add(' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
  23752. Add(' TDynArr = array of string;');
  23753. Add(' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
  23754. Add(' TProc = procedure;');
  23755. Add(' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
  23756. Add(' TMethod = procedure of object;');
  23757. Add(' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
  23758. Add('var');
  23759. Add(' StaticArray: TStaticArr;');
  23760. Add(' tiStaticArray: TTypeInfoStaticArray;');
  23761. Add(' DynArray: TDynArr;');
  23762. Add(' tiDynArray: TTypeInfoDynArray;');
  23763. Add(' ProcVar: TProc;');
  23764. Add(' tiProcVar: TTypeInfoProcVar;');
  23765. Add(' MethodVar: TMethod;');
  23766. Add(' tiMethodVar: TTypeInfoMethodVar;');
  23767. Add('begin');
  23768. Add(' tiStaticArray:=typeinfo(StaticArray);');
  23769. Add(' tiStaticArray:=typeinfo(TStaticArr);');
  23770. Add(' tiDynArray:=typeinfo(DynArray);');
  23771. Add(' tiDynArray:=typeinfo(TDynArr);');
  23772. Add(' tiProcVar:=typeinfo(ProcVar);');
  23773. Add(' tiProcVar:=typeinfo(TProc);');
  23774. Add(' tiMethodVar:=typeinfo(MethodVar);');
  23775. Add(' tiMethodVar:=typeinfo(TMethod);');
  23776. ConvertProgram;
  23777. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
  23778. LinesToStr([ // statements
  23779. ' $mod.$rtti.$StaticArray("TStaticArr", {',
  23780. ' dims: [2],',
  23781. ' eltype: rtl.string',
  23782. '});',
  23783. '$mod.$rtti.$DynArray("TDynArr", {',
  23784. ' eltype: rtl.string',
  23785. '});',
  23786. '$mod.$rtti.$ProcVar("TProc", {',
  23787. ' procsig: rtl.newTIProcSig(null)',
  23788. '});',
  23789. '$mod.$rtti.$MethodVar("TMethod", {',
  23790. ' procsig: rtl.newTIProcSig(null),',
  23791. ' methodkind: 0',
  23792. '});',
  23793. 'this.StaticArray = rtl.arraySetLength(null,"",2);',
  23794. 'this.tiStaticArray = null;',
  23795. 'this.DynArray = [];',
  23796. 'this.tiDynArray = null;',
  23797. 'this.ProcVar = null;',
  23798. 'this.tiProcVar = null;',
  23799. 'this.MethodVar = null;',
  23800. 'this.tiMethodVar = null;',
  23801. '']),
  23802. LinesToStr([ // $mod.$main
  23803. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  23804. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  23805. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  23806. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  23807. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  23808. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  23809. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  23810. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  23811. '']));
  23812. end;
  23813. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  23814. begin
  23815. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23816. StartProgram(false);
  23817. Add('{$modeswitch externalclass}');
  23818. Add('type');
  23819. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  23820. Add(' TRec = record end;');
  23821. Add(' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
  23822. // ToDo: ^PRec
  23823. Add(' TObject = class end;');
  23824. Add(' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
  23825. Add(' TClass = class of tobject;');
  23826. Add(' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
  23827. Add(' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
  23828. Add('var');
  23829. Add(' Rec: trec;');
  23830. Add(' tiRecord: ttypeinforecord;');
  23831. Add(' Obj: tobject;');
  23832. Add(' tiClass: ttypeinfoclass;');
  23833. Add(' aClass: tclass;');
  23834. Add(' tiClassRef: ttypeinfoclassref;');
  23835. // ToDo: ^PRec
  23836. Add(' tiPointer: ttypeinfopointer;');
  23837. Add('begin');
  23838. Add(' tirecord:=typeinfo(trec);');
  23839. Add(' tirecord:=typeinfo(trec);');
  23840. Add(' ticlass:=typeinfo(obj);');
  23841. Add(' ticlass:=typeinfo(tobject);');
  23842. Add(' ticlass:=typeinfo(aclass);');
  23843. Add(' ticlassref:=typeinfo(tclass);');
  23844. ConvertProgram;
  23845. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
  23846. LinesToStr([ // statements
  23847. 'rtl.recNewT($mod, "TRec", function () {',
  23848. ' this.$eq = function (b) {',
  23849. ' return true;',
  23850. ' };',
  23851. ' this.$assign = function (s) {',
  23852. ' return this;',
  23853. ' };',
  23854. ' $mod.$rtti.$Record("TRec", {});',
  23855. '});',
  23856. 'rtl.createClass($mod, "TObject", null, function () {',
  23857. ' this.$init = function () {',
  23858. ' };',
  23859. ' this.$final = function () {',
  23860. ' };',
  23861. '});',
  23862. '$mod.$rtti.$ClassRef("TClass", {',
  23863. ' instancetype: $mod.$rtti["TObject"]',
  23864. '});',
  23865. 'this.Rec = $mod.TRec.$new();',
  23866. 'this.tiRecord = null;',
  23867. 'this.Obj = null;',
  23868. 'this.tiClass = null;',
  23869. 'this.aClass = null;',
  23870. 'this.tiClassRef = null;',
  23871. 'this.tiPointer = null;',
  23872. '']),
  23873. LinesToStr([ // $mod.$main
  23874. '$mod.tiRecord = $mod.$rtti["TRec"];',
  23875. '$mod.tiRecord = $mod.$rtti["TRec"];',
  23876. '$mod.tiClass = $mod.Obj.$rtti;',
  23877. '$mod.tiClass = $mod.$rtti["TObject"];',
  23878. '$mod.tiClass = $mod.aClass.$rtti;',
  23879. '$mod.tiClassRef = $mod.$rtti["TClass"];',
  23880. '']));
  23881. end;
  23882. procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
  23883. begin
  23884. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23885. StartProgram(false);
  23886. Add([
  23887. '{$modeswitch externalclass}',
  23888. 'type',
  23889. ' TClass = class of tobject;',
  23890. ' TObject = class',
  23891. ' function MyClass: TClass;',
  23892. ' class function ClassType: TClass;',
  23893. ' end;',
  23894. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23895. ' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
  23896. 'function TObject.MyClass: TClass;',
  23897. 'var t: TTypeInfoClass;',
  23898. 'begin',
  23899. ' t:=TypeInfo(Self);',
  23900. ' t:=TypeInfo(Result);',
  23901. ' t:=TypeInfo(TObject);',
  23902. 'end;',
  23903. 'class function TObject.ClassType: TClass;',
  23904. 'var t: TTypeInfoClass;',
  23905. 'begin',
  23906. ' t:=TypeInfo(Self);',
  23907. ' t:=TypeInfo(Result);',
  23908. 'end;',
  23909. 'var',
  23910. ' Obj: TObject;',
  23911. ' t: TTypeInfoClass;',
  23912. 'begin',
  23913. ' t:=TypeInfo(TObject.ClassType);',
  23914. ' t:=TypeInfo(Obj.ClassType);',
  23915. ' t:=TypeInfo(Obj.MyClass);',
  23916. '']);
  23917. ConvertProgram;
  23918. CheckSource('TestRTTI_TypeInfo_FunctionClassType',
  23919. LinesToStr([ // statements
  23920. '$mod.$rtti.$Class("TObject");',
  23921. '$mod.$rtti.$ClassRef("TClass", {',
  23922. ' instancetype: $mod.$rtti["TObject"]',
  23923. '});',
  23924. 'rtl.createClass($mod, "TObject", null, function () {',
  23925. ' this.$init = function () {',
  23926. ' };',
  23927. ' this.$final = function () {',
  23928. ' };',
  23929. ' this.MyClass = function () {',
  23930. ' var Result = null;',
  23931. ' var t = null;',
  23932. ' t = this.$rtti;',
  23933. ' t = Result.$rtti;',
  23934. ' t = $mod.$rtti["TObject"];',
  23935. ' return Result;',
  23936. ' };',
  23937. ' this.ClassType = function () {',
  23938. ' var Result = null;',
  23939. ' var t = null;',
  23940. ' t = this.$rtti;',
  23941. ' t = Result.$rtti;',
  23942. ' return Result;',
  23943. ' };',
  23944. '});',
  23945. 'this.Obj = null;',
  23946. 'this.t = null;',
  23947. '']),
  23948. LinesToStr([ // $mod.$main
  23949. '$mod.t = $mod.TObject.ClassType().$rtti;',
  23950. '$mod.t = $mod.Obj.$class.ClassType().$rtti;',
  23951. '$mod.t = $mod.Obj.MyClass().$rtti;',
  23952. '']));
  23953. end;
  23954. procedure TTestModule.TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
  23955. begin
  23956. Converter.Options:=Converter.Options-[coNoTypeInfo];
  23957. AddModuleWithIntfImplSrc('typinfo.pas',
  23958. LinesToStr([
  23959. '{$modeswitch externalclass}',
  23960. 'type',
  23961. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  23962. ' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
  23963. '']),
  23964. '');
  23965. AddModuleWithIntfImplSrc('unit2.pas',
  23966. LinesToStr([
  23967. 'uses typinfo;',
  23968. 'type PTypeInfo = TTypeInfo;', // delphi compatibility code
  23969. 'procedure DoPtr(p: PTypeInfo);',
  23970. 'procedure DoInfo(t: TTypeInfo);',
  23971. 'procedure DoInt(t: TTypeInfoInteger);',
  23972. '']),
  23973. LinesToStr([
  23974. 'procedure DoPtr(p: PTypeInfo);',
  23975. 'begin end;',
  23976. 'procedure DoInfo(t: TTypeInfo);',
  23977. 'begin end;',
  23978. 'procedure DoInt(t: TTypeInfoInteger);',
  23979. 'begin end;',
  23980. '']));
  23981. StartUnit(true);
  23982. Add([
  23983. 'interface',
  23984. 'uses unit2;', // does not use unit typinfo
  23985. 'implementation',
  23986. 'var',
  23987. ' i: byte;',
  23988. ' p: pointer;',
  23989. ' t: PTypeInfo;',
  23990. 'initialization',
  23991. ' p:=typeinfo(i);',
  23992. ' t:=typeinfo(i);',
  23993. ' if p=t then ;',
  23994. ' if p=typeinfo(i) then ;',
  23995. ' if typeinfo(i)=p then ;',
  23996. ' if t=typeinfo(i) then ;',
  23997. ' if typeinfo(i)=t then ;',
  23998. ' DoPtr(p);',
  23999. ' DoPtr(t);',
  24000. ' DoPtr(typeinfo(i));',
  24001. ' DoInfo(p);',
  24002. ' DoInfo(t);',
  24003. ' DoInfo(typeinfo(i));',
  24004. ' DoInt(typeinfo(i));',
  24005. '']);
  24006. ConvertUnit;
  24007. CheckSource('TestRTTI_TypeInfo_MixedUnits_PointerAndClass',
  24008. LinesToStr([ // statements
  24009. 'var $impl = $mod.$impl;',
  24010. '']),
  24011. LinesToStr([ // this.$init
  24012. '$impl.p = rtl.byte;',
  24013. '$impl.t = rtl.byte;',
  24014. 'if ($impl.p === $impl.t) ;',
  24015. 'if ($impl.p === rtl.byte) ;',
  24016. 'if (rtl.byte === $impl.p) ;',
  24017. 'if ($impl.t === rtl.byte) ;',
  24018. 'if (rtl.byte === $impl.t) ;',
  24019. 'pas.unit2.DoPtr($impl.p);',
  24020. 'pas.unit2.DoPtr($impl.t);',
  24021. 'pas.unit2.DoPtr(rtl.byte);',
  24022. 'pas.unit2.DoInfo($impl.p);',
  24023. 'pas.unit2.DoInfo($impl.t);',
  24024. 'pas.unit2.DoInfo(rtl.byte);',
  24025. 'pas.unit2.DoInt(rtl.byte);',
  24026. '']),
  24027. LinesToStr([ // implementation
  24028. '$impl.i = 0;',
  24029. '$impl.p = null;',
  24030. '$impl.t = null;',
  24031. '']) );
  24032. end;
  24033. procedure TTestModule.TestRTTI_Interface_Corba;
  24034. begin
  24035. Converter.Options:=Converter.Options-[coNoTypeInfo];
  24036. StartProgram(false);
  24037. Add([
  24038. '{$interfaces corba}',
  24039. '{$modeswitch externalclass}',
  24040. 'type',
  24041. ' IUnknown = interface',
  24042. ' end;',
  24043. ' IBird = interface',
  24044. ' function GetItem: longint;',
  24045. ' procedure SetItem(Value: longint);',
  24046. ' property Item: longint read GetItem write SetItem;',
  24047. ' end;',
  24048. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  24049. ' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
  24050. 'procedure DoIt(t: TTypeInfoInterface); begin end;',
  24051. 'var',
  24052. ' i: IBird;',
  24053. ' t: TTypeInfoInterface;',
  24054. 'begin',
  24055. ' t:=TypeInfo(IBird);',
  24056. ' t:=TypeInfo(i);',
  24057. ' DoIt(t);',
  24058. ' DoIt(TypeInfo(IBird));',
  24059. '']);
  24060. ConvertProgram;
  24061. CheckSource('TestRTTI_Interface_Corba',
  24062. LinesToStr([ // statements
  24063. 'rtl.createInterface(',
  24064. ' $mod,',
  24065. ' "IUnknown",',
  24066. ' "{B92D5841-758A-322B-B800-000000000000}",',
  24067. ' [],',
  24068. ' null,',
  24069. ' function () {',
  24070. ' }',
  24071. ');',
  24072. 'rtl.createInterface(',
  24073. ' $mod,',
  24074. ' "IBird",',
  24075. ' "{D32D5841-6264-3AE3-A2C9-B91CE922C9B9}",',
  24076. ' ["GetItem", "SetItem"],',
  24077. ' null,',
  24078. ' function () {',
  24079. ' var $r = this.$rtti;',
  24080. ' $r.addMethod("GetItem", 1, null, rtl.longint);',
  24081. ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
  24082. ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
  24083. ' }',
  24084. ');',
  24085. 'this.DoIt = function (t) {',
  24086. '}; ',
  24087. 'this.i = null;',
  24088. 'this.t = null;',
  24089. '']),
  24090. LinesToStr([ // $mod.$main
  24091. '$mod.t = $mod.$rtti["IBird"];',
  24092. '$mod.t = $mod.i.$rtti;',
  24093. '$mod.DoIt($mod.t);',
  24094. '$mod.DoIt($mod.$rtti["IBird"]);',
  24095. '']));
  24096. end;
  24097. procedure TTestModule.TestRTTI_Interface_COM;
  24098. begin
  24099. Converter.Options:=Converter.Options-[coNoTypeInfo];
  24100. StartProgram(false);
  24101. Add([
  24102. '{$interfaces com}',
  24103. '{$modeswitch externalclass}',
  24104. 'type',
  24105. ' TGuid = record end;',
  24106. ' integer = longint;',
  24107. ' IUnknown = interface',
  24108. ' function QueryInterface(const iid: TGuid; out obj): Integer;',
  24109. ' function _AddRef: Integer;',
  24110. ' function _Release: Integer;',
  24111. ' end;',
  24112. ' IBird = interface',
  24113. ' function GetItem: longint;',
  24114. ' procedure SetItem(Value: longint);',
  24115. ' property Item: longint read GetItem write SetItem;',
  24116. ' end;',
  24117. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  24118. ' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
  24119. 'var',
  24120. ' i: IBird;',
  24121. ' t: TTypeInfoInterface;',
  24122. 'begin',
  24123. ' t:=TypeInfo(IBird);',
  24124. ' t:=TypeInfo(i);',
  24125. '']);
  24126. ConvertProgram;
  24127. CheckSource('TestRTTI_Interface_COM',
  24128. LinesToStr([ // statements
  24129. 'rtl.recNewT($mod, "TGuid", function () {',
  24130. ' this.$eq = function (b) {',
  24131. ' return true;',
  24132. ' };',
  24133. ' this.$assign = function (s) {',
  24134. ' return this;',
  24135. ' };',
  24136. ' $mod.$rtti.$Record("TGuid", {});',
  24137. '});',
  24138. 'rtl.createInterface(',
  24139. ' $mod,',
  24140. ' "IUnknown",',
  24141. ' "{D7ADB00D-1A9B-3EDC-B123-730E661DDFA9}",',
  24142. ' ["QueryInterface", "_AddRef", "_Release"],',
  24143. ' null,',
  24144. ' function () {',
  24145. ' this.$kind = "com";',
  24146. ' var $r = this.$rtti;',
  24147. ' $r.addMethod("QueryInterface", 1, [["iid", $mod.$rtti["TGuid"], 2], ["obj", null, 4]], rtl.longint);',
  24148. ' $r.addMethod("_AddRef", 1, null, rtl.longint);',
  24149. ' $r.addMethod("_Release", 1, null, rtl.longint);',
  24150. ' }',
  24151. ');',
  24152. 'rtl.createInterface(',
  24153. ' $mod,',
  24154. ' "IBird",',
  24155. ' "{9CC77572-0E45-3594-9A88-9E8D865C9E0A}",',
  24156. ' ["GetItem", "SetItem"],',
  24157. ' $mod.IUnknown,',
  24158. ' function () {',
  24159. ' var $r = this.$rtti;',
  24160. ' $r.addMethod("GetItem", 1, null, rtl.longint);',
  24161. ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
  24162. ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
  24163. ' }',
  24164. ');',
  24165. 'this.i = null;',
  24166. 'this.t = null;',
  24167. '']),
  24168. LinesToStr([ // $mod.$main
  24169. '$mod.t = $mod.$rtti["IBird"];',
  24170. '$mod.t = $mod.i.$rtti;',
  24171. '']));
  24172. end;
  24173. procedure TTestModule.TestResourcestringProgram;
  24174. begin
  24175. StartProgram(false);
  24176. Add([
  24177. 'const Bar = ''bar'';',
  24178. 'resourcestring',
  24179. ' Red = ''red'';',
  24180. ' Foobar = ''fOo''+bar;',
  24181. 'var s: string;',
  24182. ' c: char;',
  24183. 'begin',
  24184. ' s:=red;',
  24185. ' s:=test1.red;',
  24186. ' c:=red[1];',
  24187. ' c:=test1.red[2];',
  24188. ' if red=foobar then ;',
  24189. ' if red[3]=red[4] then ;']);
  24190. ConvertProgram;
  24191. CheckSource('TestResourcestringProgram',
  24192. LinesToStr([ // statements
  24193. 'this.Bar = "bar";',
  24194. 'this.s = "";',
  24195. 'this.c = "";',
  24196. '$mod.$resourcestrings = {',
  24197. ' Red: {',
  24198. ' org: "red"',
  24199. ' },',
  24200. ' Foobar: {',
  24201. ' org: "fOobar"',
  24202. ' }',
  24203. '};',
  24204. '']),
  24205. LinesToStr([ // $mod.$main
  24206. '$mod.s = rtl.getResStr(pas.program, "Red");',
  24207. '$mod.s = rtl.getResStr(pas.program, "Red");',
  24208. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(0);',
  24209. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(1);',
  24210. 'if (rtl.getResStr(pas.program, "Red") === rtl.getResStr(pas.program, "Foobar")) ;',
  24211. 'if (rtl.getResStr(pas.program, "Red").charAt(2) === rtl.getResStr(pas.program, "Red").charAt(3)) ;',
  24212. '']));
  24213. end;
  24214. procedure TTestModule.TestResourcestringUnit;
  24215. begin
  24216. StartUnit(false);
  24217. Add([
  24218. 'interface',
  24219. 'const Red = ''rEd'';',
  24220. 'resourcestring',
  24221. ' Blue = ''blue'';',
  24222. ' NotRed = ''not''+Red;',
  24223. 'var s: string;',
  24224. 'implementation',
  24225. 'resourcestring',
  24226. ' ImplGreen = ''green'';',
  24227. 'initialization',
  24228. ' s:=blue+ImplGreen;',
  24229. ' s:=test1.blue+test1.implgreen;',
  24230. ' s:=blue[1]+implgreen[2];']);
  24231. ConvertUnit;
  24232. CheckSource('TestResourcestringUnit',
  24233. LinesToStr([ // statements
  24234. 'this.Red = "rEd";',
  24235. 'this.s = "";',
  24236. '$mod.$resourcestrings = {',
  24237. ' Blue: {',
  24238. ' org: "blue"',
  24239. ' },',
  24240. ' NotRed: {',
  24241. ' org: "notrEd"',
  24242. ' },',
  24243. ' ImplGreen: {',
  24244. ' org: "green"',
  24245. ' }',
  24246. '};',
  24247. '']),
  24248. LinesToStr([ // $mod.$main
  24249. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  24250. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  24251. '$mod.s = rtl.getResStr(pas.Test1, "Blue").charAt(0) + rtl.getResStr(pas.Test1, "ImplGreen").charAt(1);',
  24252. '']));
  24253. end;
  24254. procedure TTestModule.TestResourcestringImplementation;
  24255. begin
  24256. StartUnit(false);
  24257. Add([
  24258. 'interface',
  24259. 'implementation',
  24260. 'resourcestring',
  24261. ' ImplRed = ''red'';']);
  24262. ConvertUnit;
  24263. CheckSource('TestResourcestringImplementation',
  24264. LinesToStr([ // intf statements
  24265. 'var $impl = $mod.$impl;']),
  24266. LinesToStr([ // $mod.$init
  24267. '']),
  24268. LinesToStr([ // impl statements
  24269. '$mod.$resourcestrings = {',
  24270. ' ImplRed: {',
  24271. ' org: "red"',
  24272. ' }',
  24273. '};',
  24274. '']));
  24275. end;
  24276. procedure TTestModule.TestAtributes_Ignore;
  24277. begin
  24278. StartProgram(false);
  24279. Add([
  24280. '{$modeswitch ignoreattributes}',
  24281. 'type',
  24282. ' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
  24283. ' TObject = class',
  24284. ' [custom5()] FS: string;',
  24285. ' [customProp] property S: string read FS;',
  24286. ' end;',
  24287. 'var',
  24288. ' [custom6]',
  24289. ' o: TObject;',
  24290. 'begin',
  24291. '']);
  24292. ConvertProgram;
  24293. CheckSource('TestAtributes_Ignore',
  24294. LinesToStr([ // statements
  24295. 'rtl.createClass($mod, "TObject", null, function () {',
  24296. ' this.$init = function () {',
  24297. ' this.FS = "";',
  24298. ' };',
  24299. ' this.$final = function () {',
  24300. ' };',
  24301. '});',
  24302. 'this.o = null;',
  24303. '']),
  24304. LinesToStr([ // $mod.$main
  24305. '']));
  24306. end;
  24307. procedure TTestModule.TestAssert;
  24308. begin
  24309. StartProgram(false);
  24310. Add([
  24311. 'procedure DoIt;',
  24312. 'var',
  24313. ' b: boolean;',
  24314. ' s: string;',
  24315. 'begin',
  24316. ' {$Assertions on}',
  24317. ' Assert(b);',
  24318. 'end;',
  24319. 'begin',
  24320. ' DoIt;',
  24321. '']);
  24322. ConvertProgram;
  24323. CheckSource('TestAssert',
  24324. LinesToStr([ // statements
  24325. 'this.DoIt = function () {',
  24326. ' var b = false;',
  24327. ' var s = "";',
  24328. ' if (!b) throw "assert failed";',
  24329. '};',
  24330. '']),
  24331. LinesToStr([ // $mod.$main
  24332. '$mod.DoIt();',
  24333. '']));
  24334. end;
  24335. procedure TTestModule.TestAssert_SysUtils;
  24336. begin
  24337. AddModuleWithIntfImplSrc('SysUtils.pas',
  24338. LinesToStr([
  24339. 'type',
  24340. ' TObject = class',
  24341. ' constructor Create;',
  24342. ' end;',
  24343. ' EAssertionFailed = class',
  24344. ' constructor Create(s: string);',
  24345. ' end;',
  24346. '']),
  24347. LinesToStr([
  24348. 'constructor TObject.Create;',
  24349. 'begin end;',
  24350. 'constructor EAssertionFailed.Create(s: string);',
  24351. 'begin end;',
  24352. '']) );
  24353. StartProgram(true);
  24354. Add([
  24355. 'uses sysutils;',
  24356. 'procedure DoIt;',
  24357. 'var',
  24358. ' b: boolean;',
  24359. ' s: string;',
  24360. 'begin',
  24361. ' {$Assertions on}',
  24362. ' Assert(b);',
  24363. ' Assert(b,''msg'');',
  24364. 'end;',
  24365. 'begin',
  24366. ' DoIt;',
  24367. '']);
  24368. ConvertProgram;
  24369. CheckSource('TestAssert_SysUtils',
  24370. LinesToStr([ // statements
  24371. 'this.DoIt = function () {',
  24372. ' var b = false;',
  24373. ' var s = "";',
  24374. ' if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
  24375. ' if (!b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
  24376. '};',
  24377. '']),
  24378. LinesToStr([ // $mod.$main
  24379. '$mod.DoIt();',
  24380. '']));
  24381. end;
  24382. procedure TTestModule.TestObjectChecks;
  24383. begin
  24384. Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsObjectChecks];
  24385. StartProgram(false);
  24386. Add([
  24387. 'type',
  24388. ' TObject = class',
  24389. ' procedure DoIt;',
  24390. ' end;',
  24391. ' TClass = class of tobject;',
  24392. ' TBird = class',
  24393. ' end;',
  24394. ' TBirdClass = class of TBird;',
  24395. 'var',
  24396. ' o : TObject;',
  24397. ' c: TClass;',
  24398. ' b: TBird;',
  24399. ' bc: TBirdClass;',
  24400. 'procedure TObject.DoIt;',
  24401. 'begin',
  24402. ' b:=TBird(o);',
  24403. 'end;',
  24404. 'begin',
  24405. ' o.DoIt;',
  24406. ' b:=TBird(o);',
  24407. ' bc:=TBirdClass(c);',
  24408. '']);
  24409. ConvertProgram;
  24410. CheckSource('TestCheckMethodCall',
  24411. LinesToStr([ // statements
  24412. 'rtl.createClass($mod, "TObject", null, function () {',
  24413. ' this.$init = function () {',
  24414. ' };',
  24415. ' this.$final = function () {',
  24416. ' };',
  24417. ' this.DoIt = function () {',
  24418. ' rtl.checkMethodCall(this,$mod.TObject);',
  24419. ' $mod.b = rtl.asExt($mod.o, $mod.TBird, 1);',
  24420. ' };',
  24421. '});',
  24422. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  24423. '});',
  24424. 'this.o = null;',
  24425. 'this.c = null;',
  24426. 'this.b = null;',
  24427. 'this.bc = null;',
  24428. '']),
  24429. LinesToStr([ // $mod.$main
  24430. '$mod.o.DoIt();',
  24431. '$mod.b = rtl.asExt($mod.o,$mod.TBird, 1);',
  24432. '$mod.bc = rtl.asExt($mod.c, $mod.TBird, 2);',
  24433. '']));
  24434. end;
  24435. procedure TTestModule.TestRangeChecks_AssignInt;
  24436. begin
  24437. Scanner.Options:=Scanner.Options+[po_CAssignments];
  24438. StartProgram(false);
  24439. Add([
  24440. '{$R+}',
  24441. 'var',
  24442. ' b: byte = 2;',
  24443. ' w: word = 3;',
  24444. 'procedure DoIt(p: byte);',
  24445. 'begin',
  24446. ' b:=w;',
  24447. ' b+=w;',
  24448. ' b:=1;',
  24449. 'end;',
  24450. '{$R-}',
  24451. 'procedure DoSome;',
  24452. 'begin',
  24453. ' DoIt(w);',
  24454. ' b:=w;',
  24455. ' b:=2;',
  24456. 'end;',
  24457. 'begin',
  24458. '{$R+}',
  24459. '']);
  24460. ConvertProgram;
  24461. CheckSource('TestRangeChecks_AssignInt',
  24462. LinesToStr([ // statements
  24463. 'this.b = 2;',
  24464. 'this.w = 3;',
  24465. 'this.DoIt = function (p) {',
  24466. ' rtl.rc(p, 0, 255);',
  24467. ' $mod.b = rtl.rc($mod.w,0,255);',
  24468. ' rtl.rc($mod.b += $mod.w, 0, 255);',
  24469. ' $mod.b = 1;',
  24470. '};',
  24471. 'this.DoSome = function () {',
  24472. ' $mod.DoIt($mod.w);',
  24473. ' $mod.b = $mod.w;',
  24474. ' $mod.b = 2;',
  24475. '};',
  24476. '']),
  24477. LinesToStr([ // $mod.$main
  24478. '']));
  24479. end;
  24480. procedure TTestModule.TestRangeChecks_AssignIntRange;
  24481. begin
  24482. Scanner.Options:=Scanner.Options+[po_CAssignments];
  24483. StartProgram(false);
  24484. Add([
  24485. '{$R+}',
  24486. 'type Ten = 1..10;',
  24487. 'var',
  24488. ' b: Ten = 2;',
  24489. ' w: Ten = 3;',
  24490. 'procedure DoIt(p: Ten);',
  24491. 'begin',
  24492. ' b:=w;',
  24493. ' b+=w;',
  24494. ' b:=1;',
  24495. 'end;',
  24496. '{$R-}',
  24497. 'procedure DoSome;',
  24498. 'begin',
  24499. ' DoIt(w);',
  24500. ' b:=w;',
  24501. ' b:=2;',
  24502. 'end;',
  24503. 'begin',
  24504. '{$R+}',
  24505. '']);
  24506. ConvertProgram;
  24507. CheckSource('TestRangeChecks_AssignIntRange',
  24508. LinesToStr([ // statements
  24509. 'this.b = 2;',
  24510. 'this.w = 3;',
  24511. 'this.DoIt = function (p) {',
  24512. ' rtl.rc(p, 1, 10);',
  24513. ' $mod.b = rtl.rc($mod.w, 1, 10);',
  24514. ' rtl.rc($mod.b += $mod.w, 1, 10);',
  24515. ' $mod.b = 1;',
  24516. '};',
  24517. 'this.DoSome = function () {',
  24518. ' $mod.DoIt($mod.w);',
  24519. ' $mod.b = $mod.w;',
  24520. ' $mod.b = 2;',
  24521. '};',
  24522. '']),
  24523. LinesToStr([ // $mod.$main
  24524. '']));
  24525. end;
  24526. procedure TTestModule.TestRangeChecks_AssignEnum;
  24527. begin
  24528. StartProgram(false);
  24529. Add([
  24530. '{$R+}',
  24531. 'type TEnum = (red,green);',
  24532. 'var',
  24533. ' e: TEnum = red;',
  24534. 'procedure DoIt(p: TEnum);',
  24535. 'begin',
  24536. ' e:=p;',
  24537. ' p:=TEnum(0);',
  24538. ' p:=succ(e);',
  24539. 'end;',
  24540. '{$R-}',
  24541. 'procedure DoSome;',
  24542. 'begin',
  24543. ' DoIt(e);',
  24544. ' e:=TEnum(1);',
  24545. ' e:=pred(e);',
  24546. 'end;',
  24547. 'begin',
  24548. '{$R+}',
  24549. '']);
  24550. ConvertProgram;
  24551. CheckSource('TestRangeChecks_AssignEnum',
  24552. LinesToStr([ // statements
  24553. 'this.TEnum = {',
  24554. ' "0": "red",',
  24555. ' red: 0,',
  24556. ' "1": "green",',
  24557. ' green: 1',
  24558. '};',
  24559. 'this.e = $mod.TEnum.red;',
  24560. 'this.DoIt = function (p) {',
  24561. ' rtl.rc(p, 0, 1);',
  24562. ' $mod.e = rtl.rc(p, 0, 1);',
  24563. ' p = 0;',
  24564. ' p = rtl.rc($mod.e + 1, 0, 1);',
  24565. '};',
  24566. 'this.DoSome = function () {',
  24567. ' $mod.DoIt($mod.e);',
  24568. ' $mod.e = 1;',
  24569. ' $mod.e = $mod.e - 1;',
  24570. '};',
  24571. '']),
  24572. LinesToStr([ // $mod.$main
  24573. '']));
  24574. end;
  24575. procedure TTestModule.TestRangeChecks_AssignEnumRange;
  24576. begin
  24577. StartProgram(false);
  24578. Add([
  24579. '{$R+}',
  24580. 'type',
  24581. ' TEnum = (red,green);',
  24582. ' TEnumRg = red..green;',
  24583. 'var',
  24584. ' e: TEnumRg = red;',
  24585. 'procedure DoIt(p: TEnumRg);',
  24586. 'begin',
  24587. ' e:=p;',
  24588. ' p:=TEnumRg(0);',
  24589. ' p:=succ(e);',
  24590. 'end;',
  24591. '{$R-}',
  24592. 'procedure DoSome;',
  24593. 'begin',
  24594. ' DoIt(e);',
  24595. ' e:=TEnum(1);',
  24596. ' e:=pred(e);',
  24597. 'end;',
  24598. 'begin',
  24599. '{$R+}',
  24600. '']);
  24601. ConvertProgram;
  24602. CheckSource('TestRangeChecks_AssignEnumRange',
  24603. LinesToStr([ // statements
  24604. 'this.TEnum = {',
  24605. ' "0": "red",',
  24606. ' red: 0,',
  24607. ' "1": "green",',
  24608. ' green: 1',
  24609. '};',
  24610. 'this.e = $mod.TEnum.red;',
  24611. 'this.DoIt = function (p) {',
  24612. ' rtl.rc(p, 0, 1);',
  24613. ' $mod.e = rtl.rc(p, 0, 1);',
  24614. ' p = 0;',
  24615. ' p = rtl.rc($mod.e + 1, 0, 1);',
  24616. '};',
  24617. 'this.DoSome = function () {',
  24618. ' $mod.DoIt($mod.e);',
  24619. ' $mod.e = 1;',
  24620. ' $mod.e = $mod.e - 1;',
  24621. '};',
  24622. '']),
  24623. LinesToStr([ // $mod.$main
  24624. '']));
  24625. end;
  24626. procedure TTestModule.TestRangeChecks_AssignChar;
  24627. begin
  24628. StartProgram(false);
  24629. Add([
  24630. '{$R+}',
  24631. 'type',
  24632. ' TLetter = char;',
  24633. 'var',
  24634. ' b: TLetter = ''2'';',
  24635. ' w: TLetter = ''3'';',
  24636. 'procedure DoIt(p: TLetter);',
  24637. 'begin',
  24638. ' b:=w;',
  24639. ' b:=''1'';',
  24640. 'end;',
  24641. '{$R-}',
  24642. 'procedure DoSome;',
  24643. 'begin',
  24644. ' DoIt(w);',
  24645. ' b:=w;',
  24646. ' b:=''2'';',
  24647. 'end;',
  24648. 'begin',
  24649. '{$R+}',
  24650. '']);
  24651. ConvertProgram;
  24652. CheckSource('TestRangeChecks_AssignChar',
  24653. LinesToStr([ // statements
  24654. 'this.b = "2";',
  24655. 'this.w = "3";',
  24656. 'this.DoIt = function (p) {',
  24657. ' rtl.rcc(p, 0, 65535);',
  24658. ' $mod.b = rtl.rcc($mod.w, 0, 65535);',
  24659. ' $mod.b = "1";',
  24660. '};',
  24661. 'this.DoSome = function () {',
  24662. ' $mod.DoIt($mod.w);',
  24663. ' $mod.b = $mod.w;',
  24664. ' $mod.b = "2";',
  24665. '};',
  24666. '']),
  24667. LinesToStr([ // $mod.$main
  24668. '']));
  24669. end;
  24670. procedure TTestModule.TestRangeChecks_AssignCharRange;
  24671. begin
  24672. StartProgram(false);
  24673. Add([
  24674. '{$R+}',
  24675. 'type TDigit = ''0''..''9'';',
  24676. 'var',
  24677. ' b: TDigit = ''2'';',
  24678. ' w: TDigit = ''3'';',
  24679. 'procedure DoIt(p: TDigit);',
  24680. 'begin',
  24681. ' b:=w;',
  24682. ' b:=''1'';',
  24683. 'end;',
  24684. '{$R-}',
  24685. 'procedure DoSome;',
  24686. 'begin',
  24687. ' DoIt(w);',
  24688. ' b:=w;',
  24689. ' b:=''2'';',
  24690. 'end;',
  24691. 'begin',
  24692. '{$R+}',
  24693. '']);
  24694. ConvertProgram;
  24695. CheckSource('TestRangeChecks_AssignCharRange',
  24696. LinesToStr([ // statements
  24697. 'this.b = "2";',
  24698. 'this.w = "3";',
  24699. 'this.DoIt = function (p) {',
  24700. ' rtl.rcc(p, 48, 57);',
  24701. ' $mod.b = rtl.rcc($mod.w, 48, 57);',
  24702. ' $mod.b = "1";',
  24703. '};',
  24704. 'this.DoSome = function () {',
  24705. ' $mod.DoIt($mod.w);',
  24706. ' $mod.b = $mod.w;',
  24707. ' $mod.b = "2";',
  24708. '};',
  24709. '']),
  24710. LinesToStr([ // $mod.$main
  24711. '']));
  24712. end;
  24713. procedure TTestModule.TestRangeChecks_ArrayIndex;
  24714. begin
  24715. StartProgram(false);
  24716. Add([
  24717. '{$R+}',
  24718. 'type',
  24719. ' Ten = 1..10;',
  24720. ' TArr = array of Ten;',
  24721. ' TArrArr = array of TArr;',
  24722. ' TArrByte = array[byte] of Ten;',
  24723. ' TArrChar = array[''0''..''9''] of Ten;',
  24724. ' TArrByteChar = array[byte,''0''..''9''] of Ten;',
  24725. ' TObject = class',
  24726. ' A: TArr;',
  24727. ' end;',
  24728. 'procedure DoIt;',
  24729. 'var',
  24730. ' Arr: TArr;',
  24731. ' ArrArr: TArrArr;',
  24732. ' ArrByte: TArrByte;',
  24733. ' ArrChar: TArrChar;',
  24734. ' ArrByteChar: TArrByteChar;',
  24735. ' i: Ten;',
  24736. ' c: char;',
  24737. ' o: tobject;',
  24738. 'begin',
  24739. ' i:=Arr[1];',
  24740. ' i:=ArrByteChar[1,''2''];',
  24741. ' Arr[1]:=Arr[1];',
  24742. ' Arr[i]:=Arr[i];',
  24743. ' ArrByte[3]:=ArrByte[3];',
  24744. ' ArrByte[i]:=ArrByte[i];',
  24745. ' ArrChar[''5'']:=ArrChar[''5''];',
  24746. ' ArrChar[c]:=ArrChar[c];',
  24747. ' ArrByteChar[7,''7'']:=ArrByteChar[7,''7''];',
  24748. ' ArrByteChar[i,c]:=ArrByteChar[i,c];',
  24749. ' o.a[i]:=o.a[i];',
  24750. 'end;',
  24751. 'begin',
  24752. '']);
  24753. ConvertProgram;
  24754. CheckSource('TestRangeChecks_ArrayIndex',
  24755. LinesToStr([ // statements
  24756. 'rtl.createClass($mod, "TObject", null, function () {',
  24757. ' this.$init = function () {',
  24758. ' this.A = [];',
  24759. ' };',
  24760. ' this.$final = function () {',
  24761. ' this.A = undefined;',
  24762. ' };',
  24763. '});',
  24764. 'this.DoIt = function () {',
  24765. ' var Arr = [];',
  24766. ' var ArrArr = [];',
  24767. ' var ArrByte = rtl.arraySetLength(null, 0, 256);',
  24768. ' var ArrChar = rtl.arraySetLength(null, 0, 10);',
  24769. ' var ArrByteChar = rtl.arraySetLength(null, 0, 256, 10);',
  24770. ' var i = 0;',
  24771. ' var c = "";',
  24772. ' var o = null;',
  24773. ' i = rtl.rc(Arr[1], 1, 10);',
  24774. ' i = rtl.rc(ArrByteChar[1][2], 1, 10);',
  24775. ' Arr[1] = rtl.rc(Arr[1], 1, 10);',
  24776. ' rtl.rcArrW(Arr, i, rtl.rcArrR(Arr, i));',
  24777. ' ArrByte[3] = rtl.rc(ArrByte[3], 1, 10);',
  24778. ' rtl.rcArrW(ArrByte, i, rtl.rcArrR(ArrByte, i));',
  24779. ' ArrChar[5] = rtl.rc(ArrChar[5], 1, 10);',
  24780. ' rtl.rcArrW(ArrChar, c.charCodeAt() - 48, rtl.rcArrR(ArrChar, c.charCodeAt() - 48));',
  24781. ' ArrByteChar[7][7] = rtl.rc(ArrByteChar[7][7], 1, 10);',
  24782. ' rtl.rcArrW(ArrByteChar, i, c.charCodeAt() - 48, rtl.rcArrR(ArrByteChar, i, c.charCodeAt() - 48));',
  24783. ' rtl.rcArrW(o.A, i, rtl.rcArrR(o.A, i));',
  24784. '};',
  24785. '']),
  24786. LinesToStr([ // $mod.$main
  24787. '']));
  24788. end;
  24789. procedure TTestModule.TestRangeChecks_ArrayOfRecIndex;
  24790. begin
  24791. StartProgram(false);
  24792. Add([
  24793. '{$R+}',
  24794. 'type',
  24795. ' Ten = 1..10;',
  24796. ' TRec = record x: Ten end;',
  24797. ' TArr = array of TRec;',
  24798. ' TArrArr = array of TArr;',
  24799. ' TObject = class',
  24800. ' A: TArr;',
  24801. ' end;',
  24802. 'procedure DoIt;',
  24803. 'var',
  24804. ' Arr: TArr;',
  24805. ' ArrArr: TArrArr;',
  24806. ' i: Ten;',
  24807. ' o: tobject;',
  24808. 'begin',
  24809. ' Arr[1]:=Arr[1];',
  24810. ' Arr[i]:=Arr[i+1];',
  24811. ' o.a[i]:=o.a[i+2];',
  24812. 'end;',
  24813. 'begin',
  24814. '']);
  24815. ConvertProgram;
  24816. CheckSource('TestRangeChecks_ArrayOfRecIndex',
  24817. LinesToStr([ // statements
  24818. 'rtl.recNewT($mod, "TRec", function () {',
  24819. ' this.x = 0;',
  24820. ' this.$eq = function (b) {',
  24821. ' return this.x === b.x;',
  24822. ' };',
  24823. ' this.$assign = function (s) {',
  24824. ' this.x = s.x;',
  24825. ' return this;',
  24826. ' };',
  24827. '});',
  24828. 'rtl.createClass($mod, "TObject", null, function () {',
  24829. ' this.$init = function () {',
  24830. ' this.A = [];',
  24831. ' };',
  24832. ' this.$final = function () {',
  24833. ' this.A = undefined;',
  24834. ' };',
  24835. '});',
  24836. 'this.DoIt = function () {',
  24837. ' var Arr = [];',
  24838. ' var ArrArr = [];',
  24839. ' var i = 0;',
  24840. ' var o = null;',
  24841. ' Arr[1].$assign(Arr[1]);',
  24842. ' rtl.rcArrR(Arr, i).$assign(rtl.rcArrR(Arr, i + 1));',
  24843. ' rtl.rcArrR(o.A, i).$assign(rtl.rcArrR(o.A, i + 2));',
  24844. '};',
  24845. '']),
  24846. LinesToStr([ // $mod.$main
  24847. '']));
  24848. end;
  24849. procedure TTestModule.TestRangeChecks_StringIndex;
  24850. begin
  24851. StartProgram(false);
  24852. Add([
  24853. 'type',
  24854. ' TObject = class',
  24855. ' S: string;',
  24856. ' end;',
  24857. '{$R+}',
  24858. 'procedure DoIt(var h: string);',
  24859. 'var',
  24860. ' s: string;',
  24861. ' i: longint;',
  24862. ' c: char;',
  24863. ' o: tobject;',
  24864. 'begin',
  24865. ' c:=s[1];',
  24866. ' s[i]:=s[i];',
  24867. ' h[i]:=h[i];',
  24868. ' c:=o.s[i];',
  24869. ' o.s[i]:=c;',
  24870. 'end;',
  24871. 'begin',
  24872. '']);
  24873. ConvertProgram;
  24874. CheckSource('TestRangeChecks_StringIndex',
  24875. LinesToStr([ // statements
  24876. 'rtl.createClass($mod, "TObject", null, function () {',
  24877. ' this.$init = function () {',
  24878. ' this.S = "";',
  24879. ' };',
  24880. ' this.$final = function () {',
  24881. ' };',
  24882. '});',
  24883. 'this.DoIt = function (h) {',
  24884. ' var s = "";',
  24885. ' var i = 0;',
  24886. ' var c = "";',
  24887. ' var o = null;',
  24888. ' c = rtl.rcc(rtl.rcCharAt(s, 0), 0, 65535);',
  24889. ' s = rtl.rcSetCharAt(s, i - 1, rtl.rcCharAt(s, i - 1));',
  24890. ' h.set(rtl.rcSetCharAt(h.get(), i - 1, rtl.rcCharAt(h.get(), i - 1)));',
  24891. ' c = rtl.rcc(rtl.rcCharAt(o.S, i - 1), 0, 65535);',
  24892. ' o.S = rtl.rcSetCharAt(o.S, i - 1, c);',
  24893. '};',
  24894. '']),
  24895. LinesToStr([ // $mod.$main
  24896. '']));
  24897. end;
  24898. procedure TTestModule.TestRangeChecks_TypecastInt;
  24899. begin
  24900. StartProgram(false);
  24901. Add([
  24902. '{$R+}',
  24903. 'var',
  24904. ' i: nativeint;',
  24905. ' b: byte;',
  24906. ' sh: shortint;',
  24907. ' w: word;',
  24908. ' sm: smallint;',
  24909. ' lw: longword;',
  24910. ' li: longint;',
  24911. 'begin',
  24912. ' b:=12+byte(i);',
  24913. ' sh:=12+shortint(i);',
  24914. ' w:=12+word(i);',
  24915. ' sm:=12+smallint(i);',
  24916. ' lw:=12+longword(i);',
  24917. ' li:=12+longint(i);',
  24918. '']);
  24919. ConvertProgram;
  24920. CheckSource('TestRangeChecks_TypecastInt',
  24921. LinesToStr([
  24922. 'this.i = 0;',
  24923. 'this.b = 0;',
  24924. 'this.sh = 0;',
  24925. 'this.w = 0;',
  24926. 'this.sm = 0;',
  24927. 'this.lw = 0;',
  24928. 'this.li = 0;',
  24929. '']),
  24930. LinesToStr([
  24931. '$mod.b = rtl.rc(12 + rtl.rc($mod.i, 0, 255), 0, 255);',
  24932. '$mod.sh = rtl.rc(12 + rtl.rc($mod.i, -128, 127), -128, 127);',
  24933. '$mod.w = rtl.rc(12 + rtl.rc($mod.i, 0, 65535), 0, 65535);',
  24934. '$mod.sm = rtl.rc(12 + rtl.rc($mod.i, -32768, 32767), -32768, 32767);',
  24935. '$mod.lw = rtl.rc(12 + rtl.rc($mod.i, 0, 4294967295), 0, 4294967295);',
  24936. '$mod.li = rtl.rc(12 + rtl.rc($mod.i, -2147483648, 2147483647), -2147483648, 2147483647);',
  24937. '']));
  24938. end;
  24939. Initialization
  24940. RegisterTests([TTestModule]);
  24941. end.