tcmodules.pas 414 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 2014 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_pas2js = [po_asmwhole,po_resolvestandardtypes];
  26. co_tcmodules = [coNoTypeInfo];
  27. type
  28. { TTestPasParser }
  29. TTestPasParser = Class(TPasParser)
  30. end;
  31. TOnFindUnit = function(const aUnitName: String): TPasModule of object;
  32. { TTestEnginePasResolver }
  33. TTestEnginePasResolver = class(TPas2JsResolver)
  34. private
  35. FFilename: string;
  36. FModule: TPasModule;
  37. FOnFindUnit: TOnFindUnit;
  38. FParser: TTestPasParser;
  39. FResolver: TStreamResolver;
  40. FScanner: TPascalScanner;
  41. FSource: string;
  42. procedure SetModule(AValue: TPasModule);
  43. public
  44. destructor Destroy; override;
  45. function FindModule(const AName: String): TPasModule; override;
  46. property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
  47. property Filename: string read FFilename write FFilename;
  48. property Resolver: TStreamResolver read FResolver write FResolver;
  49. property Scanner: TPascalScanner read FScanner write FScanner;
  50. property Parser: TTestPasParser read FParser write FParser;
  51. property Source: string read FSource write FSource;
  52. property Module: TPasModule read FModule write SetModule;
  53. end;
  54. { TCustomTestModule }
  55. TCustomTestModule = Class(TTestCase)
  56. private
  57. FConverter: TPasToJSConverter;
  58. FEngine: TTestEnginePasResolver;
  59. FExpectedErrorClass: ExceptClass;
  60. FExpectedErrorMsg: string;
  61. FExpectedErrorNumber: integer;
  62. FFilename: string;
  63. FFileResolver: TStreamResolver;
  64. FJSImplementationSrc: TJSSourceElements;
  65. FJSImplementationUses: TJSArrayLiteral;
  66. FJSInitBody: TJSFunctionBody;
  67. FJSImplentationUses: TJSArrayLiteral;
  68. FJSInterfaceUses: TJSArrayLiteral;
  69. FJSModule: TJSSourceElements;
  70. FJSModuleSrc: TJSSourceElements;
  71. FJSSource: TStringList;
  72. FModule: TPasModule;
  73. FJSModuleCallArgs: TJSArguments;
  74. FModules: TObjectList;// list of TTestEnginePasResolver
  75. FParser: TTestPasParser;
  76. FPasProgram: TPasProgram;
  77. FJSRegModuleCall: TJSCallExpression;
  78. FScanner: TPascalScanner;
  79. FSkipTests: boolean;
  80. FSource: TStringList;
  81. FFirstPasStatement: TPasImplBlock;
  82. function GetResolverCount: integer;
  83. function GetResolvers(Index: integer): TTestEnginePasResolver;
  84. function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
  85. function FindUnit(const aUnitName: String): TPasModule;
  86. protected
  87. procedure SetUp; override;
  88. function CreateConverter: TPasToJSConverter; virtual;
  89. procedure TearDown; override;
  90. Procedure Add(Line: string); virtual;
  91. Procedure Add(const Lines: array of string);
  92. Procedure StartParsing; virtual;
  93. procedure ParseModule; virtual;
  94. procedure ParseProgram; virtual;
  95. procedure ParseUnit; virtual;
  96. protected
  97. function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
  98. function AddModule(aFilename: string): TTestEnginePasResolver; virtual;
  99. function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
  100. function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  101. ImplementationSrc: string): TTestEnginePasResolver; virtual;
  102. procedure AddSystemUnit; virtual;
  103. procedure StartProgram(NeedSystemUnit: boolean); virtual;
  104. procedure StartUnit(NeedSystemUnit: boolean); virtual;
  105. procedure ConvertModule; virtual;
  106. procedure ConvertProgram; virtual;
  107. procedure ConvertUnit; virtual;
  108. function ConvertJSModuleToString(El: TJSElement): string; virtual;
  109. procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
  110. function GetDottedIdentifier(El: TJSElement): string;
  111. procedure CheckSource(Msg,Statements: String; InitStatements: string = '';
  112. ImplStatements: string = ''); virtual;
  113. procedure CheckDiff(Msg, Expected, Actual: string); virtual;
  114. procedure CheckUnit(Filename, ExpectedSrc: string); virtual;
  115. procedure SetExpectedScannerError(Msg: string; MsgNumber: integer);
  116. procedure SetExpectedParserError(Msg: string; MsgNumber: integer);
  117. procedure SetExpectedPasResolverError(Msg: string; MsgNumber: integer);
  118. procedure SetExpectedConverterError(Msg: string; MsgNumber: integer);
  119. function IsErrorExpected(E: Exception): boolean;
  120. procedure HandleScannerError(E: EScannerError);
  121. procedure HandleParserError(E: EParserError);
  122. procedure HandlePasResolveError(E: EPasResolve);
  123. procedure HandlePas2JSError(E: EPas2JS);
  124. procedure HandleException(E: Exception);
  125. procedure RaiseException(E: Exception);
  126. procedure WriteSources(const aFilename: string; aRow, aCol: integer);
  127. function IndexOfResolver(const Filename: string): integer;
  128. function GetResolver(const Filename: string): TTestEnginePasResolver;
  129. function GetDefaultNamespace: string;
  130. property PasProgram: TPasProgram Read FPasProgram;
  131. property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
  132. property ResolverCount: integer read GetResolverCount;
  133. property Engine: TTestEnginePasResolver read FEngine;
  134. property Filename: string read FFilename;
  135. Property Module: TPasModule Read FModule;
  136. property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
  137. property Converter: TPasToJSConverter read FConverter;
  138. property JSSource: TStringList read FJSSource;
  139. property JSModule: TJSSourceElements read FJSModule;
  140. property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
  141. property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
  142. property JSImplementationUses: TJSArrayLiteral read FJSImplementationUses;
  143. property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
  144. property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
  145. property JSInitBody: TJSFunctionBody read FJSInitBody;
  146. property JSImplementationSrc: TJSSourceElements read FJSImplementationSrc;
  147. property ExpectedErrorClass: ExceptClass read FExpectedErrorClass write FExpectedErrorClass;
  148. property ExpectedErrorMsg: string read FExpectedErrorMsg write FExpectedErrorMsg;
  149. property ExpectedErrorNumber: integer read FExpectedErrorNumber write FExpectedErrorNumber;
  150. property SkipTests: boolean read FSkipTests write FSkipTests;
  151. public
  152. property Source: TStringList read FSource;
  153. property FileResolver: TStreamResolver read FFileResolver;
  154. property Scanner: TPascalScanner read FScanner;
  155. property Parser: TTestPasParser read FParser;
  156. end;
  157. { TTestModule }
  158. TTestModule = class(TCustomTestModule)
  159. Published
  160. // Resolvers
  161. Procedure TestEmptyProgram;
  162. Procedure TestEmptyProgramUseStrict;
  163. Procedure TestEmptyUnit;
  164. Procedure TestEmptyUnitUseStrict;
  165. Procedure TestDottedUnitNames;
  166. Procedure TestDottedUnitNameImpl;
  167. Procedure TestDottedUnitExpr;
  168. Procedure Test_ModeFPCFail;
  169. Procedure Test_ModeSwitchCBlocksFail;
  170. // vars/const
  171. Procedure TestVarInt;
  172. Procedure TestVarBaseTypes;
  173. Procedure TestBaseTypeSingleFail;
  174. Procedure TestBaseTypeExtendedFail;
  175. Procedure TestConstBaseTypes;
  176. Procedure TestUnitImplVars;
  177. Procedure TestUnitImplConsts;
  178. Procedure TestUnitImplRecord;
  179. Procedure TestRenameJSNameConflict;
  180. Procedure TestLocalConst;
  181. Procedure TestVarExternal;
  182. Procedure TestVarExternalOtherUnit;
  183. Procedure TestVarAbsoluteFail;
  184. // numbers
  185. Procedure TestDouble;
  186. Procedure TestIntegerRange;
  187. Procedure TestForBoolDo;
  188. // strings
  189. Procedure TestCharConst;
  190. Procedure TestChar_Compare;
  191. Procedure TestChar_Ord;
  192. Procedure TestChar_Chr;
  193. Procedure TestStringConst;
  194. Procedure TestString_Length;
  195. Procedure TestString_Compare;
  196. Procedure TestString_SetLength;
  197. Procedure TestString_CharAt;
  198. Procedure TestStr;
  199. Procedure TestBaseType_AnsiStringFail;
  200. Procedure TestBaseType_WideStringFail;
  201. Procedure TestBaseType_ShortStringFail;
  202. Procedure TestBaseType_RawByteStringFail;
  203. Procedure TestTypeShortstring_Fail;
  204. Procedure TestCharSet_Custom;
  205. Procedure TestForCharDo;
  206. Procedure TestForCharInDo;
  207. // alias types
  208. Procedure TestAliasTypeRef;
  209. Procedure TestTypeCast_BaseTypes;
  210. Procedure TestTypeCast_AliasBaseTypes;
  211. // functions
  212. Procedure TestEmptyProc;
  213. Procedure TestProcOneParam;
  214. Procedure TestFunctionWithoutParams;
  215. Procedure TestProcedureWithoutParams;
  216. Procedure TestPrgProcVar;
  217. Procedure TestProcTwoArgs;
  218. Procedure TestProc_DefaultValue;
  219. Procedure TestUnitProcVar;
  220. Procedure TestImplProc;
  221. Procedure TestFunctionResult;
  222. Procedure TestNestedProc;
  223. Procedure TestForwardProc;
  224. Procedure TestNestedForwardProc;
  225. Procedure TestAssignFunctionResult;
  226. Procedure TestFunctionResultInCondition;
  227. Procedure TestExit;
  228. Procedure TestBreak;
  229. Procedure TestContinue;
  230. Procedure TestProc_External;
  231. Procedure TestProc_ExternalOtherUnit;
  232. Procedure TestProc_Asm;
  233. Procedure TestProc_Assembler;
  234. Procedure TestProc_VarParam;
  235. Procedure TestProc_Overload;
  236. Procedure TestProc_OverloadForward;
  237. Procedure TestProc_OverloadUnit;
  238. Procedure TestProc_OverloadNested;
  239. Procedure TestProc_Varargs;
  240. Procedure TestProc_ConstOrder;
  241. // enums, sets
  242. Procedure TestEnum_Name;
  243. Procedure TestEnum_Number;
  244. Procedure TestEnum_Functions;
  245. Procedure TestEnum_AsParams;
  246. Procedure TestEnumRange_Array;
  247. Procedure TestSet;
  248. Procedure TestSet_Operators;
  249. Procedure TestSet_Operator_In;
  250. Procedure TestSet_Functions;
  251. Procedure TestSet_PassAsArgClone;
  252. Procedure TestSet_AsParams;
  253. Procedure TestSet_Property;
  254. Procedure TestSet_EnumConst;
  255. Procedure TestSet_AnonymousEnumType;
  256. Procedure TestSet_ConstEnum;
  257. Procedure TestSet_ConstChar;
  258. Procedure TestSet_ConstInt;
  259. // statements
  260. Procedure TestNestBegin;
  261. Procedure TestIncDec;
  262. Procedure TestAssignments;
  263. Procedure TestArithmeticOperators1;
  264. Procedure TestLogicalOperators;
  265. Procedure TestBitwiseOperators;
  266. Procedure TestFunctionInt;
  267. Procedure TestFunctionString;
  268. Procedure TestForLoop;
  269. Procedure TestForLoopInFunction;
  270. Procedure TestForLoop_ReadVarAfter;
  271. Procedure TestForLoop_Nested;
  272. Procedure TestRepeatUntil;
  273. Procedure TestAsmBlock;
  274. Procedure TestAsmPas_Impl; // ToDo
  275. Procedure TestTryFinally;
  276. Procedure TestTryExcept;
  277. Procedure TestCaseOf;
  278. Procedure TestCaseOf_UseSwitch;
  279. Procedure TestCaseOfNoElse;
  280. Procedure TestCaseOfNoElse_UseSwitch;
  281. Procedure TestCaseOfRange;
  282. // arrays
  283. Procedure TestArray_Dynamic;
  284. Procedure TestArray_Dynamic_Nil;
  285. Procedure TestArray_DynMultiDimensional;
  286. Procedure TestArray_StaticInt;
  287. Procedure TestArray_StaticBool;
  288. Procedure TestArray_StaticChar;
  289. Procedure TestArray_StaticMultiDim; // ToDo
  290. Procedure TestArrayOfRecord;
  291. // ToDo: Procedure TestArrayOfSet;
  292. Procedure TestArray_AsParams;
  293. Procedure TestArrayElement_AsParams;
  294. Procedure TestArrayElementFromFuncResult_AsParams;
  295. Procedure TestArrayEnumTypeRange;
  296. Procedure TestArray_SetLengthOutArg;
  297. Procedure TestArray_SetLengthProperty;
  298. Procedure TestArray_SetLengthMultiDim;
  299. Procedure TestArray_OpenArrayOfString;
  300. Procedure TestArray_Concat;
  301. Procedure TestArray_Copy;
  302. Procedure TestArray_InsertDelete;
  303. Procedure TestArray_DynArrayConst;
  304. Procedure TestExternalClass_TypeCastArrayToExternalArray;
  305. Procedure TestExternalClass_TypeCastArrayFromExternalArray;
  306. // record
  307. Procedure TestRecord_Var;
  308. Procedure TestWithRecordDo;
  309. Procedure TestRecord_Assign;
  310. Procedure TestRecord_PassAsArgClone;
  311. Procedure TestRecord_AsParams;
  312. Procedure TestRecordElement_AsParams;
  313. Procedure TestRecordElementFromFuncResult_AsParams;
  314. Procedure TestRecordElementFromWith_AsParams;
  315. Procedure TestRecord_Equal;
  316. Procedure TestRecord_TypeCastJSValueToRecord;
  317. // ToDo: const record
  318. // classes
  319. Procedure TestClass_TObjectDefaultConstructor;
  320. Procedure TestClass_TObjectConstructorWithParams;
  321. Procedure TestClass_TObjectConstructorWithDefaultParam;
  322. Procedure TestClass_Var;
  323. Procedure TestClass_Method;
  324. Procedure TestClass_Implementation;
  325. Procedure TestClass_Inheritance;
  326. Procedure TestClass_AbstractMethod;
  327. Procedure TestClass_CallInherited_NoParams;
  328. Procedure TestClass_CallInherited_WithParams;
  329. Procedure TestClasS_CallInheritedConstructor;
  330. Procedure TestClass_ClassVar;
  331. Procedure TestClass_CallClassMethod;
  332. Procedure TestClass_Property;
  333. Procedure TestClass_Property_ClassMethod;
  334. Procedure TestClass_Property_Indexed;
  335. Procedure TestClass_Property_IndexSpec;
  336. Procedure TestClass_PropertyOfTypeArray;
  337. Procedure TestClass_PropertyDefault;
  338. Procedure TestClass_PropertyOverride;
  339. Procedure TestClass_Assigned;
  340. Procedure TestClass_WithClassDoCreate;
  341. Procedure TestClass_WithClassInstDoProperty;
  342. Procedure TestClass_WithClassInstDoPropertyWithParams;
  343. Procedure TestClass_WithClassInstDoFunc;
  344. Procedure TestClass_TypeCast;
  345. Procedure TestClass_TypeCastUntypedParam;
  346. Procedure TestClass_Overloads;
  347. Procedure TestClass_OverloadsAncestor;
  348. Procedure TestClass_OverloadConstructor;
  349. Procedure TestClass_OverloadDelphiOverride;
  350. Procedure TestClass_ReintroducedVar;
  351. Procedure TestClass_RaiseDescendant;
  352. Procedure TestClass_ExternalMethod;
  353. Procedure TestClass_ExternalVirtualNameMismatchFail;
  354. Procedure TestClass_ExternalOverrideFail;
  355. Procedure TestClass_ExternalVar;
  356. Procedure TestClass_Const;
  357. Procedure TestClass_LocalVarSelfFail;
  358. Procedure TestClass_ArgSelfFail;
  359. Procedure TestClass_NestedSelf;
  360. Procedure TestClass_NestedClassSelf;
  361. Procedure TestClass_NestedCallInherited;
  362. Procedure TestClass_TObjectFree;
  363. Procedure TestClass_TObjectFreeNewInstance;
  364. Procedure TestClass_TObjectFreeLowerCase;
  365. Procedure TestClass_TObjectFreeFunctionFail;
  366. Procedure TestClass_TObjectFreePropertyFail;
  367. // class of
  368. Procedure TestClassOf_Create;
  369. Procedure TestClassOf_Call;
  370. Procedure TestClassOf_Assign;
  371. Procedure TestClassOf_Is;
  372. Procedure TestClassOf_Compare;
  373. Procedure TestClassOf_ClassVar;
  374. Procedure TestClassOf_ClassMethod;
  375. Procedure TestClassOf_ClassProperty;
  376. Procedure TestClassOf_ClassMethodSelf;
  377. Procedure TestClassOf_TypeCast;
  378. Procedure TestClassOf_ImplicitFunctionCall;
  379. Procedure TestClassOf_Const;
  380. // nested class
  381. Procedure TestNestedClass_Fail;
  382. // external class
  383. Procedure TestExternalClass_Var;
  384. //ToDo Procedure TestExternalClass_Const;
  385. Procedure TestExternalClass_Dollar;
  386. Procedure TestExternalClass_DuplicateVarFail;
  387. Procedure TestExternalClass_Method;
  388. Procedure TestExternalClass_NonExternalOverride;
  389. Procedure TestExternalClass_Property;
  390. Procedure TestExternalClass_ClassProperty;
  391. Procedure TestExternalClass_ClassOf;
  392. Procedure TestExternalClass_ClassOtherUnit;
  393. Procedure TestExternalClass_Is;
  394. Procedure TestExternalClass_As;
  395. Procedure TestExternalClass_DestructorFail;
  396. Procedure TestExternalClass_New;
  397. Procedure TestExternalClass_ClassOf_New;
  398. Procedure TestExternalClass_FuncClassOf_New;
  399. Procedure TestExternalClass_LocalConstSameName;
  400. Procedure TestExternalClass_ReintroduceOverload;
  401. Procedure TestExternalClass_Inherited;
  402. Procedure TestExternalClass_PascalAncestorFail;
  403. Procedure TestExternalClass_NewInstance;
  404. Procedure TestExternalClass_NewInstance_NonVirtualFail;
  405. Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
  406. Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail;
  407. Procedure TestExternalClass_PascalProperty;
  408. Procedure TestExternalClass_TypeCastToRootClass;
  409. Procedure TestExternalClass_TypeCastStringToExternalString;
  410. Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
  411. Procedure TestExternalClass_BracketAccessor;
  412. Procedure TestExternalClass_BracketAccessor_2ParamsFail;
  413. Procedure TestExternalClass_BracketAccessor_ReadOnly;
  414. Procedure TestExternalClass_BracketAccessor_WriteOnly;
  415. Procedure TestExternalClass_BracketAccessor_MultiType;
  416. Procedure TestExternalClass_BracketAccessor_Index;
  417. // class interfaces
  418. Procedure TestClassInterface_Ignore;
  419. // proc types
  420. Procedure TestProcType;
  421. Procedure TestProcType_FunctionFPC;
  422. Procedure TestProcType_FunctionDelphi;
  423. Procedure TestProcType_ProcedureDelphi;
  424. Procedure TestProcType_AsParam;
  425. Procedure TestProcType_MethodFPC;
  426. Procedure TestProcType_MethodDelphi;
  427. Procedure TestProcType_PropertyFPC;
  428. Procedure TestProcType_PropertyDelphi;
  429. Procedure TestProcType_WithClassInstDoPropertyFPC;
  430. Procedure TestProcType_Nested;
  431. Procedure TestProcType_NestedOfObject;
  432. Procedure TestProcType_ReferenceToProc;
  433. Procedure TestProcType_ReferenceToMethod;
  434. Procedure TestProcType_Typecast;
  435. Procedure TestProcType_PassProcToUntyped;
  436. // pointer
  437. Procedure TestPointer;
  438. Procedure TestPointer_Proc;
  439. Procedure TestPointer_AssignRecordFail;
  440. Procedure TestPointer_AssignStaticArrayFail;
  441. Procedure TestPointer_ArrayParamsFail;
  442. Procedure TestPointer_TypeCastJSValueToPointer;
  443. // jsvalue
  444. Procedure TestJSValue_AssignToJSValue;
  445. Procedure TestJSValue_TypeCastToBaseType;
  446. Procedure TestJSValue_Equal;
  447. Procedure TestJSValue_If;
  448. Procedure TestJSValue_Enum;
  449. Procedure TestJSValue_ClassInstance;
  450. Procedure TestJSValue_ClassOf;
  451. Procedure TestJSValue_ArrayOfJSValue;
  452. Procedure TestJSValue_Params;
  453. Procedure TestJSValue_UntypedParam;
  454. Procedure TestJSValue_FuncResultType;
  455. Procedure TestJSValue_ProcType_Assign;
  456. Procedure TestJSValue_ProcType_Equal;
  457. Procedure TestJSValue_AssignToPointerFail;
  458. Procedure TestJSValue_OverloadDouble;
  459. Procedure TestJSValue_OverloadNativeInt;
  460. Procedure TestJSValue_OverloadWord;
  461. Procedure TestJSValue_OverloadString;
  462. Procedure TestJSValue_OverloadChar;
  463. Procedure TestJSValue_OverloadPointer;
  464. // RTTI
  465. Procedure TestRTTI_ProcType;
  466. Procedure TestRTTI_ProcType_ArgFromOtherUnit;
  467. Procedure TestRTTI_EnumAndSetType;
  468. Procedure TestRTTI_EnumRange;
  469. Procedure TestRTTI_AnonymousEnumType;
  470. Procedure TestRTTI_StaticArray;
  471. Procedure TestRTTI_DynArray;
  472. Procedure TestRTTI_ArrayNestedAnonymous;
  473. // ToDo: Procedure TestRTTI_Pointer;
  474. Procedure TestRTTI_PublishedMethodOverloadFail;
  475. Procedure TestRTTI_PublishedMethodExternalFail;
  476. Procedure TestRTTI_PublishedClassPropertyFail;
  477. Procedure TestRTTI_PublishedClassFieldFail;
  478. Procedure TestRTTI_PublishedFieldExternalFail;
  479. Procedure TestRTTI_IndexModifier;
  480. Procedure TestRTTI_StoredModifier;
  481. Procedure TestRTTI_DefaultValue;
  482. Procedure TestRTTI_DefaultValueSet;
  483. Procedure TestRTTI_DefaultValueRangeType;
  484. Procedure TestRTTI_Class_Field;
  485. Procedure TestRTTI_Class_Method;
  486. Procedure TestRTTI_Class_MethodArgFlags;
  487. Procedure TestRTTI_Class_Property;
  488. Procedure TestRTTI_Class_PropertyParams;
  489. Procedure TestRTTI_OverrideMethod;
  490. Procedure TestRTTI_OverloadProperty;
  491. // ToDo: array argument
  492. Procedure TestRTTI_ClassForward;
  493. Procedure TestRTTI_ClassOf;
  494. Procedure TestRTTI_Record;
  495. Procedure TestRTTI_RecordAnonymousArray;
  496. Procedure TestRTTI_LocalTypes;
  497. Procedure TestRTTI_TypeInfo_BaseTypes;
  498. Procedure TestRTTI_TypeInfo_LocalFail;
  499. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  500. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  501. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  502. Procedure TestRTTI_TypeInfo_FunctionClassType;
  503. // Resourcestring
  504. Procedure TestResourcestringProgram;
  505. Procedure TestResourcestringUnit;
  506. Procedure TestResourcestringImplementation;
  507. // ToDo: in unit interface and implementation
  508. // Attributes
  509. Procedure TestAtributes_Ignore;
  510. end;
  511. function LinesToStr(Args: array of const): string;
  512. function ExtractFileUnitName(aFilename: string): string;
  513. function JSToStr(El: TJSElement): string;
  514. implementation
  515. function LinesToStr(Args: array of const): string;
  516. var
  517. s: String;
  518. i: Integer;
  519. begin
  520. s:='';
  521. for i:=Low(Args) to High(Args) do
  522. case Args[i].VType of
  523. vtChar: s += Args[i].VChar+LineEnding;
  524. vtString: s += Args[i].VString^+LineEnding;
  525. vtPChar: s += Args[i].VPChar+LineEnding;
  526. vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
  527. vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
  528. vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
  529. vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
  530. vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
  531. end;
  532. Result:=s;
  533. end;
  534. function ExtractFileUnitName(aFilename: string): string;
  535. var
  536. p: Integer;
  537. begin
  538. Result:=ExtractFileName(aFilename);
  539. if Result='' then exit;
  540. for p:=length(Result) downto 1 do
  541. case Result[p] of
  542. '/','\': exit;
  543. '.':
  544. begin
  545. Delete(Result,p,length(Result));
  546. exit;
  547. end;
  548. end;
  549. end;
  550. function JSToStr(El: TJSElement): string;
  551. var
  552. aWriter: TBufferWriter;
  553. aJSWriter: TJSWriter;
  554. begin
  555. aJSWriter:=nil;
  556. aWriter:=TBufferWriter.Create(1000);
  557. try
  558. aJSWriter:=TJSWriter.Create(aWriter);
  559. aJSWriter.IndentSize:=2;
  560. aJSWriter.WriteJS(El);
  561. Result:=aWriter.AsAnsistring;
  562. finally
  563. aJSWriter.Free;
  564. aWriter.Free;
  565. end;
  566. end;
  567. { TTestEnginePasResolver }
  568. procedure TTestEnginePasResolver.SetModule(AValue: TPasModule);
  569. begin
  570. if FModule=AValue then Exit;
  571. if Module<>nil then
  572. Module.Release;
  573. FModule:=AValue;
  574. if Module<>nil then
  575. Module.AddRef;
  576. end;
  577. destructor TTestEnginePasResolver.Destroy;
  578. begin
  579. FreeAndNil(FResolver);
  580. Module:=nil;
  581. FreeAndNil(FParser);
  582. FreeAndNil(FScanner);
  583. FreeAndNil(FResolver);
  584. inherited Destroy;
  585. end;
  586. function TTestEnginePasResolver.FindModule(const AName: String): TPasModule;
  587. begin
  588. Result:=nil;
  589. if Assigned(OnFindUnit) then
  590. Result:=OnFindUnit(AName);
  591. end;
  592. { TCustomTestModule }
  593. function TCustomTestModule.GetResolverCount: integer;
  594. begin
  595. Result:=FModules.Count;
  596. end;
  597. function TCustomTestModule.GetResolvers(Index: integer
  598. ): TTestEnginePasResolver;
  599. begin
  600. Result:=TTestEnginePasResolver(FModules[Index]);
  601. end;
  602. function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
  603. ): TPasModule;
  604. var
  605. DefNamespace: String;
  606. begin
  607. //writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
  608. if (Pos('.',aUnitName)<1) then
  609. begin
  610. DefNamespace:=GetDefaultNamespace;
  611. if DefNamespace<>'' then
  612. begin
  613. Result:=FindUnit(DefNamespace+'.'+aUnitName);
  614. if Result<>nil then exit;
  615. end;
  616. end;
  617. Result:=FindUnit(aUnitName);
  618. if Result<>nil then exit;
  619. writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
  620. Fail('can''t find unit "'+aUnitName+'"');
  621. end;
  622. function TCustomTestModule.FindUnit(const aUnitName: String): TPasModule;
  623. var
  624. i: Integer;
  625. CurEngine: TTestEnginePasResolver;
  626. CurUnitName: String;
  627. begin
  628. //writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
  629. Result:=nil;
  630. for i:=0 to ResolverCount-1 do
  631. begin
  632. CurEngine:=Resolvers[i];
  633. CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
  634. //writeln('TTestModule.FindUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
  635. if CompareText(aUnitName,CurUnitName)=0 then
  636. begin
  637. Result:=CurEngine.Module;
  638. if Result<>nil then exit;
  639. //writeln('TTestModule.FindUnit PARSING unit "',CurEngine.Filename,'"');
  640. FileResolver.FindSourceFile(aUnitName);
  641. CurEngine.Resolver:=TStreamResolver.Create;
  642. CurEngine.Resolver.OwnsStreams:=True;
  643. //writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
  644. CurEngine.Resolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
  645. CurEngine.Scanner:=TPascalScanner.Create(CurEngine.Resolver);
  646. CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.Resolver,CurEngine);
  647. CurEngine.Parser.Options:=CurEngine.Parser.Options+po_pas2js+[po_KeepScannerError];
  648. if CompareText(CurUnitName,'System')=0 then
  649. CurEngine.Parser.ImplicitUses.Clear;
  650. CurEngine.Scanner.OpenFile(CurEngine.Filename);
  651. try
  652. CurEngine.Parser.NextToken;
  653. CurEngine.Parser.ParseUnit(CurEngine.FModule);
  654. except
  655. on E: Exception do
  656. HandleException(E);
  657. end;
  658. //writeln('TTestModule.FindUnit END ',CurUnitName);
  659. Result:=CurEngine.Module;
  660. exit;
  661. end;
  662. end;
  663. end;
  664. procedure TCustomTestModule.SetUp;
  665. begin
  666. inherited SetUp;
  667. FSkipTests:=false;
  668. FSource:=TStringList.Create;
  669. FModules:=TObjectList.Create(true);
  670. FFilename:='test1.pp';
  671. FFileResolver:=TStreamResolver.Create;
  672. FFileResolver.OwnsStreams:=True;
  673. FScanner:=TPascalScanner.Create(FFileResolver);
  674. FScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
  675. FScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
  676. FScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
  677. FEngine:=AddModule(Filename);
  678. FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
  679. Parser.Options:=Parser.Options+po_pas2js+[po_KeepScannerError];
  680. FModule:=Nil;
  681. FConverter:=CreateConverter;
  682. FExpectedErrorClass:=nil;
  683. end;
  684. function TCustomTestModule.CreateConverter: TPasToJSConverter;
  685. begin
  686. Result:=TPasToJSConverter.Create;
  687. Result.Options:=co_tcmodules;
  688. end;
  689. procedure TCustomTestModule.TearDown;
  690. begin
  691. FSkipTests:=false;
  692. FJSModule:=nil;
  693. FJSRegModuleCall:=nil;
  694. FJSModuleCallArgs:=nil;
  695. FJSImplentationUses:=nil;
  696. FJSInterfaceUses:=nil;
  697. FJSModuleSrc:=nil;
  698. FJSInitBody:=nil;
  699. FreeAndNil(FJSSource);
  700. FreeAndNil(FJSModule);
  701. FreeAndNil(FConverter);
  702. Engine.Clear;
  703. if Assigned(FModule) then
  704. begin
  705. FModule.Release;
  706. FModule:=nil;
  707. end;
  708. FreeAndNil(FSource);
  709. FreeAndNil(FParser);
  710. FreeAndNil(FScanner);
  711. FreeAndNil(FFileResolver);
  712. if FModules<>nil then
  713. begin
  714. FreeAndNil(FModules);
  715. FEngine:=nil;
  716. end;
  717. inherited TearDown;
  718. end;
  719. procedure TCustomTestModule.Add(Line: string);
  720. begin
  721. Source.Add(Line);
  722. end;
  723. procedure TCustomTestModule.Add(const Lines: array of string);
  724. var
  725. i: Integer;
  726. begin
  727. for i:=low(Lines) to high(Lines) do
  728. Add(Lines[i]);
  729. end;
  730. procedure TCustomTestModule.StartParsing;
  731. var
  732. Src: String;
  733. begin
  734. Src:=Source.Text;
  735. FEngine.Source:=Src;
  736. FileResolver.AddStream(FileName,TStringStream.Create(Src));
  737. Scanner.OpenFile(FileName);
  738. Writeln('// Test : ',Self.TestName);
  739. Writeln(Src);
  740. end;
  741. procedure TCustomTestModule.ParseModule;
  742. begin
  743. if SkipTests then exit;
  744. FFirstPasStatement:=nil;
  745. try
  746. StartParsing;
  747. Parser.ParseMain(FModule);
  748. except
  749. on E: Exception do
  750. HandleException(E);
  751. end;
  752. if SkipTests then exit;
  753. AssertNotNull('Module resulted in Module',FModule);
  754. AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
  755. TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
  756. end;
  757. procedure TCustomTestModule.ParseProgram;
  758. begin
  759. if SkipTests then exit;
  760. ParseModule;
  761. if SkipTests then exit;
  762. AssertEquals('Has program',TPasProgram,Module.ClassType);
  763. FPasProgram:=TPasProgram(Module);
  764. AssertNotNull('Has program section',PasProgram.ProgramSection);
  765. AssertNotNull('Has initialization section',PasProgram.InitializationSection);
  766. if (PasProgram.InitializationSection.Elements.Count>0) then
  767. if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
  768. FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
  769. end;
  770. procedure TCustomTestModule.ParseUnit;
  771. begin
  772. if SkipTests then exit;
  773. ParseModule;
  774. if SkipTests then exit;
  775. AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
  776. AssertNotNull('Has interface section',Module.InterfaceSection);
  777. AssertNotNull('Has implementation section',Module.ImplementationSection);
  778. if (Module.InitializationSection<>nil)
  779. and (Module.InitializationSection.Elements.Count>0)
  780. and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
  781. FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
  782. end;
  783. function TCustomTestModule.FindModuleWithFilename(aFilename: string
  784. ): TTestEnginePasResolver;
  785. var
  786. i: Integer;
  787. begin
  788. for i:=0 to ResolverCount-1 do
  789. if CompareText(Resolvers[i].Filename,aFilename)=0 then
  790. exit(Resolvers[i]);
  791. Result:=nil;
  792. end;
  793. function TCustomTestModule.AddModule(aFilename: string
  794. ): TTestEnginePasResolver;
  795. begin
  796. //writeln('TTestModuleConverter.AddModule ',aFilename);
  797. if FindModuleWithFilename(aFilename)<>nil then
  798. Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
  799. Result:=TTestEnginePasResolver.Create;
  800. Result.Filename:=aFilename;
  801. Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
  802. Result.OnFindUnit:=@OnPasResolverFindUnit;
  803. FModules.Add(Result);
  804. end;
  805. function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
  806. ): TTestEnginePasResolver;
  807. begin
  808. Result:=AddModule(aFilename);
  809. Result.Source:=Src;
  810. end;
  811. function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  812. ImplementationSrc: string): TTestEnginePasResolver;
  813. var
  814. Src: String;
  815. begin
  816. Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
  817. Src+=LineEnding;
  818. Src+='interface'+LineEnding;
  819. Src+=LineEnding;
  820. Src+=InterfaceSrc;
  821. Src+='implementation'+LineEnding;
  822. Src+=LineEnding;
  823. Src+=ImplementationSrc;
  824. Src+='end.'+LineEnding;
  825. Result:=AddModuleWithSrc(aFilename,Src);
  826. end;
  827. procedure TCustomTestModule.AddSystemUnit;
  828. begin
  829. AddModuleWithIntfImplSrc('system.pp',
  830. // interface
  831. LinesToStr([
  832. 'type',
  833. ' integer=longint;',
  834. 'var',
  835. ' ExitCode: Longint;',
  836. ''
  837. // implementation
  838. ]),LinesToStr([
  839. ''
  840. ]));
  841. end;
  842. procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean);
  843. begin
  844. if NeedSystemUnit then
  845. AddSystemUnit
  846. else
  847. Parser.ImplicitUses.Clear;
  848. Add('program '+ExtractFileUnitName(Filename)+';');
  849. Add('');
  850. end;
  851. procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean);
  852. begin
  853. if NeedSystemUnit then
  854. AddSystemUnit
  855. else
  856. Parser.ImplicitUses.Clear;
  857. Add('unit Test1;');
  858. Add('');
  859. end;
  860. procedure TCustomTestModule.ConvertModule;
  861. procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
  862. out UsesLit: TJSArrayLiteral);
  863. var
  864. i: Integer;
  865. Item: TJSElement;
  866. Lit: TJSLiteral;
  867. begin
  868. UsesLit:=nil;
  869. AssertNotNull(UsesName+' uses section',Arg.Expr);
  870. if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
  871. exit; // null is ok
  872. AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
  873. FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
  874. for i:=0 to FJSInterfaceUses.Elements.Count-1 do
  875. begin
  876. Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
  877. AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
  878. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
  879. Lit:=TJSLiteral(Item);
  880. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
  881. ord(jsbase.jstString),ord(Lit.Value.ValueType));
  882. end;
  883. end;
  884. procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
  885. out Src: TJSSourceElements);
  886. var
  887. FunDecl: TJSFunctionDeclarationStatement;
  888. FunDef: TJSFuncDef;
  889. FunBody: TJSFunctionBody;
  890. begin
  891. Src:=nil;
  892. AssertNotNull(ParamName,Arg.Expr);
  893. AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
  894. FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
  895. AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
  896. AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
  897. FunDef:=FunDecl.AFunction as TJSFuncDef;
  898. AssertEquals(ParamName+' name empty','',String(FunDef.Name));
  899. AssertNotNull(ParamName+' body',FunDef.Body);
  900. AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
  901. FunBody:=FunDef.Body as TJSFunctionBody;
  902. AssertNotNull(ParamName+' body.A',FunBody.A);
  903. AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
  904. Src:=FunBody.A as TJSSourceElements;
  905. end;
  906. var
  907. ModuleNameExpr: TJSLiteral;
  908. InitFunction: TJSFunctionDeclarationStatement;
  909. InitAssign: TJSSimpleAssignStatement;
  910. InitName: String;
  911. LastNode: TJSElement;
  912. Arg: TJSArrayLiteralElement;
  913. begin
  914. if SkipTests then exit;
  915. try
  916. FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
  917. except
  918. on E: Exception do
  919. HandleException(E);
  920. end;
  921. if SkipTests then exit;
  922. if ExpectedErrorClass<>nil then
  923. Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
  924. FJSSource:=TStringList.Create;
  925. FJSSource.Text:=ConvertJSModuleToString(JSModule);
  926. {$IFDEF VerbosePas2JS}
  927. writeln('TTestModule.ConvertModule JS:');
  928. write(FJSSource.Text);
  929. {$ENDIF}
  930. // rtl.module(...
  931. AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
  932. AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
  933. AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
  934. FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
  935. AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
  936. AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
  937. AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
  938. FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
  939. // parameter 'unitname'
  940. if JSModuleCallArgs.Elements.Count<1 then
  941. Fail('rtl.module first param unit missing');
  942. Arg:=JSModuleCallArgs.Elements.Elements[0];
  943. AssertNotNull('module name param',Arg.Expr);
  944. ModuleNameExpr:=Arg.Expr as TJSLiteral;
  945. AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
  946. if Module is TPasProgram then
  947. AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
  948. else
  949. AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
  950. // main uses section
  951. if JSModuleCallArgs.Elements.Count<2 then
  952. Fail('rtl.module second param main uses missing');
  953. Arg:=JSModuleCallArgs.Elements.Elements[1];
  954. CheckUsesList('interface',Arg,FJSInterfaceUses);
  955. // program/library/interface function()
  956. if JSModuleCallArgs.Elements.Count<3 then
  957. Fail('rtl.module third param intf-function missing');
  958. Arg:=JSModuleCallArgs.Elements.Elements[2];
  959. CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
  960. // search for $mod.$init or $mod.$main - the last statement
  961. if Module is TPasProgram then
  962. begin
  963. InitName:='$main';
  964. AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
  965. end
  966. else
  967. InitName:='$init';
  968. FJSInitBody:=nil;
  969. if JSModuleSrc.Statements.Count>0 then
  970. begin
  971. LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
  972. if LastNode is TJSSimpleAssignStatement then
  973. begin
  974. InitAssign:=LastNode as TJSSimpleAssignStatement;
  975. if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
  976. begin
  977. InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
  978. FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
  979. end
  980. else if Module is TPasProgram then
  981. CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
  982. end;
  983. end;
  984. // optional: implementation uses section
  985. if JSModuleCallArgs.Elements.Count<4 then
  986. exit;
  987. Arg:=JSModuleCallArgs.Elements.Elements[3];
  988. CheckUsesList('implementation',Arg,FJSImplentationUses);
  989. // optional: implementation function()
  990. if JSModuleCallArgs.Elements.Count<5 then
  991. exit;
  992. Arg:=JSModuleCallArgs.Elements.Elements[4];
  993. CheckFunctionParam('module impl-function',Arg,FJSImplementationSrc);
  994. end;
  995. procedure TCustomTestModule.ConvertProgram;
  996. begin
  997. Add('end.');
  998. ParseProgram;
  999. ConvertModule;
  1000. end;
  1001. procedure TCustomTestModule.ConvertUnit;
  1002. begin
  1003. Add('end.');
  1004. ParseUnit;
  1005. ConvertModule;
  1006. end;
  1007. function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
  1008. begin
  1009. Result:=tcmodules.JSToStr(El);
  1010. end;
  1011. procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
  1012. DottedName: string);
  1013. begin
  1014. if DottedName='' then
  1015. begin
  1016. AssertNull(Msg,El);
  1017. end
  1018. else
  1019. begin
  1020. AssertNotNull(Msg,El);
  1021. AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
  1022. end;
  1023. end;
  1024. function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
  1025. begin
  1026. if El=nil then
  1027. Result:=''
  1028. else if El is TJSPrimaryExpressionIdent then
  1029. Result:=String(TJSPrimaryExpressionIdent(El).Name)
  1030. else if El is TJSDotMemberExpression then
  1031. Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
  1032. else
  1033. AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
  1034. end;
  1035. procedure TCustomTestModule.CheckSource(Msg, Statements: String;
  1036. InitStatements: string; ImplStatements: string);
  1037. var
  1038. ActualSrc, ExpectedSrc, InitName: String;
  1039. begin
  1040. ActualSrc:=JSToStr(JSModuleSrc);
  1041. ExpectedSrc:=
  1042. 'var $mod = this;'+LineEnding
  1043. +Statements;
  1044. if coUseStrict in Converter.Options then
  1045. ExpectedSrc:='"use strict";'+LineEnding+ExpectedSrc;
  1046. if Module is TPasProgram then
  1047. InitName:='$main'
  1048. else
  1049. InitName:='$init';
  1050. if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
  1051. ExpectedSrc:=ExpectedSrc+LineEnding
  1052. +'$mod.'+InitName+' = function () {'+LineEnding
  1053. +InitStatements
  1054. +'};'+LineEnding;
  1055. //writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
  1056. //writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
  1057. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1058. if (JSImplementationSrc<>nil) then
  1059. begin
  1060. ActualSrc:=JSToStr(JSImplementationSrc);
  1061. ExpectedSrc:=
  1062. 'var $mod = this;'+LineEnding
  1063. +'var $impl = $mod.$impl;'+LineEnding
  1064. +ImplStatements;
  1065. end
  1066. else
  1067. begin
  1068. ActualSrc:='';
  1069. ExpectedSrc:=ImplStatements;
  1070. end;
  1071. //writeln('TTestModule.CheckSource InitStatements="',InitStatements,'"');
  1072. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1073. end;
  1074. procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
  1075. // search diff, ignore changes in spaces
  1076. const
  1077. SpaceChars = [#9,#10,#13,' '];
  1078. var
  1079. ExpectedP, ActualP: PChar;
  1080. function FindLineEnd(p: PChar): PChar;
  1081. begin
  1082. Result:=p;
  1083. while not (Result^ in [#0,#10,#13]) do inc(Result);
  1084. end;
  1085. function FindLineStart(p, MinP: PChar): PChar;
  1086. begin
  1087. while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
  1088. Result:=p;
  1089. end;
  1090. procedure DiffFound;
  1091. var
  1092. ActLineStartP, ActLineEndP, p, StartPos: PChar;
  1093. ExpLine, ActLine: String;
  1094. i: Integer;
  1095. begin
  1096. writeln('Diff found "',Msg,'". Lines:');
  1097. // write correct lines
  1098. p:=PChar(Expected);
  1099. repeat
  1100. StartPos:=p;
  1101. while not (p^ in [#0,#10,#13]) do inc(p);
  1102. ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
  1103. if p^ in [#10,#13] then begin
  1104. if (p[1] in [#10,#13]) and (p^<>p[1]) then
  1105. inc(p,2)
  1106. else
  1107. inc(p);
  1108. end;
  1109. if (p<=ExpectedP) and (p^<>#0) then begin
  1110. writeln('= ',ExpLine);
  1111. end else begin
  1112. // diff line
  1113. // write actual line
  1114. ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
  1115. ActLineEndP:=FindLineEnd(ActualP);
  1116. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  1117. writeln('- ',ActLine);
  1118. // write expected line
  1119. writeln('+ ',ExpLine);
  1120. // write empty line with pointer ^
  1121. for i:=1 to 2+ExpectedP-StartPos do write(' ');
  1122. writeln('^');
  1123. AssertEquals(Msg,ExpLine,ActLine);
  1124. break;
  1125. end;
  1126. until p^=#0;
  1127. writeln('DiffFound Actual:-----------------------');
  1128. writeln(Actual);
  1129. writeln('DiffFound Expected:---------------------');
  1130. writeln(Expected);
  1131. writeln('DiffFound ------------------------------');
  1132. Fail('diff found, but lines are the same, internal error');
  1133. end;
  1134. var
  1135. IsSpaceNeeded: Boolean;
  1136. LastChar: Char;
  1137. begin
  1138. if Expected='' then Expected:=' ';
  1139. if Actual='' then Actual:=' ';
  1140. ExpectedP:=PChar(Expected);
  1141. ActualP:=PChar(Actual);
  1142. repeat
  1143. //writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
  1144. case ExpectedP^ of
  1145. #0:
  1146. begin
  1147. // check that rest of Actual has only spaces
  1148. while ActualP^ in SpaceChars do inc(ActualP);
  1149. if ActualP^<>#0 then
  1150. DiffFound;
  1151. exit;
  1152. end;
  1153. ' ',#9,#10,#13:
  1154. begin
  1155. // skip space in Expected
  1156. IsSpaceNeeded:=false;
  1157. if ExpectedP>PChar(Expected) then
  1158. LastChar:=ExpectedP[-1]
  1159. else
  1160. LastChar:=#0;
  1161. while ExpectedP^ in SpaceChars do inc(ExpectedP);
  1162. if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
  1163. and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
  1164. IsSpaceNeeded:=true;
  1165. if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
  1166. DiffFound;
  1167. while ActualP^ in SpaceChars do inc(ActualP);
  1168. end;
  1169. else
  1170. while ActualP^ in SpaceChars do inc(ActualP);
  1171. if ExpectedP^<>ActualP^ then
  1172. DiffFound;
  1173. inc(ExpectedP);
  1174. inc(ActualP);
  1175. end;
  1176. until false;
  1177. end;
  1178. procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
  1179. var
  1180. aResolver: TTestEnginePasResolver;
  1181. aConverter: TPasToJSConverter;
  1182. aJSModule: TJSSourceElements;
  1183. ActualSrc: String;
  1184. begin
  1185. aResolver:=GetResolver(Filename);
  1186. AssertNotNull('missing resolver of unit '+Filename,aResolver);
  1187. {$IFDEF VerbosePas2JS}
  1188. writeln('CheckUnit '+Filename+' converting ...');
  1189. {$ENDIF}
  1190. aConverter:=CreateConverter;
  1191. try
  1192. try
  1193. aJSModule:=aConverter.ConvertPasElement(aResolver.Module,aResolver) as TJSSourceElements;
  1194. except
  1195. on E: Exception do
  1196. HandleException(E);
  1197. end;
  1198. ActualSrc:=ConvertJSModuleToString(aJSModule);
  1199. {$IFDEF VerbosePas2JS}
  1200. writeln('TTestModule.CheckUnit ',Filename,' Pas:');
  1201. write(aResolver.Source);
  1202. writeln('TTestModule.CheckUnit ',Filename,' JS:');
  1203. write(ActualSrc);
  1204. {$ENDIF}
  1205. CheckDiff('Converted unit: "'+ChangeFileExt(Filename,'.js')+'"',ExpectedSrc,ActualSrc);
  1206. finally
  1207. aConverter.Free;
  1208. end;
  1209. end;
  1210. procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
  1211. MsgNumber: integer);
  1212. begin
  1213. ExpectedErrorClass:=EScannerError;
  1214. ExpectedErrorMsg:=Msg;
  1215. ExpectedErrorNumber:=MsgNumber;
  1216. end;
  1217. procedure TCustomTestModule.SetExpectedParserError(Msg: string;
  1218. MsgNumber: integer);
  1219. begin
  1220. ExpectedErrorClass:=EParserError;
  1221. ExpectedErrorMsg:=Msg;
  1222. ExpectedErrorNumber:=MsgNumber;
  1223. end;
  1224. procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
  1225. MsgNumber: integer);
  1226. begin
  1227. ExpectedErrorClass:=EPasResolve;
  1228. ExpectedErrorMsg:=Msg;
  1229. ExpectedErrorNumber:=MsgNumber;
  1230. end;
  1231. procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
  1232. MsgNumber: integer);
  1233. begin
  1234. ExpectedErrorClass:=EPas2JS;
  1235. ExpectedErrorMsg:=Msg;
  1236. ExpectedErrorNumber:=MsgNumber;
  1237. end;
  1238. function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
  1239. var
  1240. MsgNumber: Integer;
  1241. Msg: String;
  1242. begin
  1243. Result:=false;
  1244. if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
  1245. Msg:=E.Message;
  1246. if E is EPas2JS then
  1247. MsgNumber:=EPas2JS(E).MsgNumber
  1248. else if E is EPasResolve then
  1249. MsgNumber:=EPasResolve(E).MsgNumber
  1250. else if E is EParserError then
  1251. MsgNumber:=Parser.LastMsgNumber
  1252. else if E is EScannerError then
  1253. begin
  1254. MsgNumber:=Scanner.LastMsgNumber;
  1255. Msg:=Scanner.LastMsg;
  1256. end
  1257. else
  1258. MsgNumber:=0;
  1259. Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
  1260. if Result then
  1261. SkipTests:=true;
  1262. end;
  1263. procedure TCustomTestModule.HandleScannerError(E: EScannerError);
  1264. begin
  1265. if IsErrorExpected(E) then exit;
  1266. WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
  1267. writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
  1268. +' '+Scanner.CurFilename
  1269. +'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
  1270. RaiseException(E);
  1271. end;
  1272. procedure TCustomTestModule.HandleParserError(E: EParserError);
  1273. begin
  1274. if IsErrorExpected(E) then exit;
  1275. WriteSources(E.Filename,E.Row,E.Column);
  1276. writeln('ERROR: TCustomTestModule.HandleParserError '+E.ClassName+':'+E.Message
  1277. +' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')'
  1278. +' MainModuleScannerLine="'+Scanner.CurLine+'"'
  1279. );
  1280. RaiseException(E);
  1281. end;
  1282. procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
  1283. var
  1284. P: TPasSourcePos;
  1285. begin
  1286. if IsErrorExpected(E) then exit;
  1287. P:=E.SourcePos;
  1288. WriteSources(P.FileName,P.Row,P.Column);
  1289. writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
  1290. +' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
  1291. RaiseException(E);
  1292. end;
  1293. procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
  1294. var
  1295. Row, Col: integer;
  1296. begin
  1297. if IsErrorExpected(E) then exit;
  1298. Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
  1299. WriteSources(E.PasElement.SourceFilename,Row,Col);
  1300. writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
  1301. +' '+E.PasElement.SourceFilename
  1302. +'('+IntToStr(Row)+','+IntToStr(Col)+')');
  1303. RaiseException(E);
  1304. end;
  1305. procedure TCustomTestModule.HandleException(E: Exception);
  1306. begin
  1307. if E is EScannerError then
  1308. HandleScannerError(EScannerError(E))
  1309. else if E is EParserError then
  1310. HandleParserError(EParserError(E))
  1311. else if E is EPasResolve then
  1312. HandlePasResolveError(EPasResolve(E))
  1313. else if E is EPas2JS then
  1314. HandlePas2JSError(EPas2JS(E))
  1315. else
  1316. begin
  1317. if IsErrorExpected(E) then exit;
  1318. if not (E is EAssertionFailedError) then
  1319. begin
  1320. WriteSources('',0,0);
  1321. writeln('ERROR: TCustomTestModule.HandleException '+E.ClassName+':'+E.Message);
  1322. end;
  1323. RaiseException(E);
  1324. end;
  1325. end;
  1326. procedure TCustomTestModule.RaiseException(E: Exception);
  1327. var
  1328. MsgNumber: Integer;
  1329. begin
  1330. if ExpectedErrorClass<>nil then begin
  1331. if FExpectedErrorClass=E.ClassType then begin
  1332. if E is EPas2JS then
  1333. MsgNumber:=EPas2JS(E).MsgNumber
  1334. else if E is EPasResolve then
  1335. MsgNumber:=EPasResolve(E).MsgNumber
  1336. else if E is EParserError then
  1337. MsgNumber:=Parser.LastMsgNumber
  1338. else if E is EScannerError then
  1339. MsgNumber:=Scanner.LastMsgNumber
  1340. else
  1341. MsgNumber:=0;
  1342. AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
  1343. AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
  1344. ExpectedErrorNumber,MsgNumber);
  1345. end else begin
  1346. AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
  1347. end;
  1348. end;
  1349. Fail(E.Message);
  1350. end;
  1351. procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
  1352. aCol: integer);
  1353. var
  1354. IsSrc: Boolean;
  1355. i, j: Integer;
  1356. SrcLines: TStringList;
  1357. Line: string;
  1358. aModule: TTestEnginePasResolver;
  1359. begin
  1360. writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
  1361. for i:=0 to ResolverCount-1 do
  1362. begin
  1363. aModule:=Resolvers[i];
  1364. SrcLines:=TStringList.Create;
  1365. try
  1366. SrcLines.Text:=aModule.Source;
  1367. IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
  1368. writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
  1369. for j:=1 to SrcLines.Count do
  1370. begin
  1371. Line:=SrcLines[j-1];
  1372. if IsSrc and (j=aRow) then
  1373. begin
  1374. write('*');
  1375. Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
  1376. end;
  1377. writeln(Format('%:4d: ',[j]),Line);
  1378. end;
  1379. finally
  1380. SrcLines.Free;
  1381. end;
  1382. end;
  1383. end;
  1384. function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
  1385. var
  1386. i: Integer;
  1387. begin
  1388. for i:=0 to ResolverCount-1 do
  1389. if Filename=Resolvers[i].Filename then exit(i);
  1390. Result:=-1;
  1391. end;
  1392. function TCustomTestModule.GetResolver(const Filename: string
  1393. ): TTestEnginePasResolver;
  1394. var
  1395. i: Integer;
  1396. begin
  1397. i:=IndexOfResolver(Filename);
  1398. if i<0 then exit(nil);
  1399. Result:=Resolvers[i];
  1400. end;
  1401. function TCustomTestModule.GetDefaultNamespace: string;
  1402. var
  1403. C: TClass;
  1404. begin
  1405. Result:='';
  1406. if FModule=nil then exit;
  1407. C:=FModule.ClassType;
  1408. if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
  1409. Result:=Engine.DefaultNameSpace;
  1410. end;
  1411. { TTestModule }
  1412. procedure TTestModule.TestEmptyProgram;
  1413. begin
  1414. StartProgram(false);
  1415. Add('begin');
  1416. ConvertProgram;
  1417. CheckSource('TestEmptyProgram','','');
  1418. end;
  1419. procedure TTestModule.TestEmptyProgramUseStrict;
  1420. begin
  1421. Converter.Options:=Converter.Options+[coUseStrict];
  1422. StartProgram(false);
  1423. Add('begin');
  1424. ConvertProgram;
  1425. CheckSource('TestEmptyProgramUseStrict','','');
  1426. end;
  1427. procedure TTestModule.TestEmptyUnit;
  1428. begin
  1429. StartUnit(false);
  1430. Add('interface');
  1431. Add('implementation');
  1432. ConvertUnit;
  1433. CheckSource('TestEmptyUnit',
  1434. LinesToStr([
  1435. ]),
  1436. '');
  1437. end;
  1438. procedure TTestModule.TestEmptyUnitUseStrict;
  1439. begin
  1440. Converter.Options:=Converter.Options+[coUseStrict];
  1441. StartUnit(false);
  1442. Add('interface');
  1443. Add('implementation');
  1444. ConvertUnit;
  1445. CheckSource('TestEmptyUnitUseStrict',
  1446. LinesToStr([
  1447. ''
  1448. ]),
  1449. '');
  1450. end;
  1451. procedure TTestModule.TestDottedUnitNames;
  1452. begin
  1453. AddModuleWithIntfImplSrc('NS1.Unit2.pas',
  1454. LinesToStr([
  1455. 'var iV: longint;'
  1456. ]),
  1457. '');
  1458. FFilename:='ns1.test1.pp';
  1459. StartProgram(true);
  1460. Add('uses unIt2;');
  1461. Add('implementation');
  1462. Add('var');
  1463. Add(' i: longint;');
  1464. Add('begin');
  1465. Add(' i:=iv;');
  1466. Add(' i:=uNit2.iv;');
  1467. Add(' i:=Ns1.TEst1.i;');
  1468. ConvertProgram;
  1469. CheckSource('TestDottedUnitNames',
  1470. LinesToStr([
  1471. 'this.i = 0;',
  1472. '']),
  1473. LinesToStr([ // this.$init
  1474. '$mod.i = pas["NS1.Unit2"].iV;',
  1475. '$mod.i = pas["NS1.Unit2"].iV;',
  1476. '$mod.i = $mod.i;',
  1477. '']) );
  1478. end;
  1479. procedure TTestModule.TestDottedUnitNameImpl;
  1480. begin
  1481. AddModuleWithIntfImplSrc('TEST.UnitA.pas',
  1482. LinesToStr([
  1483. 'type',
  1484. ' TObject = class end;',
  1485. ' TTestA = class',
  1486. ' end;'
  1487. ]),
  1488. LinesToStr(['uses TEST.UnitB;'])
  1489. );
  1490. AddModuleWithIntfImplSrc('TEST.UnitB.pas',
  1491. LinesToStr([
  1492. 'uses TEST.UnitA;',
  1493. 'type TTestB = class(TTestA);'
  1494. ]),
  1495. ''
  1496. );
  1497. StartProgram(true);
  1498. Add('uses TEST.UnitA;');
  1499. Add('begin');
  1500. ConvertProgram;
  1501. CheckSource('TestDottedUnitNameImpl',
  1502. LinesToStr([
  1503. '']),
  1504. LinesToStr([ // this.$init
  1505. '']) );
  1506. CheckUnit('TEST.UnitA.pas',
  1507. LinesToStr([
  1508. 'rtl.module("TEST.UnitA", ["system"], function () {',
  1509. ' var $mod = this;',
  1510. ' rtl.createClass($mod, "TObject", null, function () {',
  1511. ' this.$init = function () {',
  1512. ' };',
  1513. ' this.$final = function () {',
  1514. ' };',
  1515. ' });',
  1516. ' rtl.createClass($mod, "TTestA", $mod.TObject, function () {',
  1517. ' });',
  1518. '}, ["TEST.UnitB"]);'
  1519. ]));
  1520. CheckUnit('TEST.UnitB.pas',
  1521. LinesToStr([
  1522. 'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
  1523. ' var $mod = this;',
  1524. ' rtl.createClass($mod, "TTestB", pas["TEST.UnitA"].TTestA, function () {',
  1525. ' });',
  1526. '});'
  1527. ]));
  1528. end;
  1529. procedure TTestModule.TestDottedUnitExpr;
  1530. begin
  1531. AddModuleWithIntfImplSrc('NS2.SubNs2.Unit2.pas',
  1532. LinesToStr([
  1533. 'procedure DoIt;'
  1534. ]),
  1535. 'procedure DoIt; begin end;');
  1536. FFilename:='Ns1.SubNs1.Test1.pp';
  1537. StartProgram(true);
  1538. Add('uses Ns2.sUbnS2.unIt2;');
  1539. Add('implementation');
  1540. Add('var');
  1541. Add(' i: longint;');
  1542. Add('begin');
  1543. Add(' ns2.subns2.unit2.doit;');
  1544. Add(' i:=Ns1.SubNS1.TEst1.i;');
  1545. ConvertProgram;
  1546. CheckSource('TestDottedUnitExpr',
  1547. LinesToStr([
  1548. 'this.i = 0;',
  1549. '']),
  1550. LinesToStr([ // this.$init
  1551. 'pas["NS2.SubNs2.Unit2"].DoIt();',
  1552. '$mod.i = $mod.i;',
  1553. '']) );
  1554. end;
  1555. procedure TTestModule.Test_ModeFPCFail;
  1556. begin
  1557. StartProgram(false);
  1558. Add('{$mode FPC}');
  1559. Add('begin');
  1560. SetExpectedScannerError('Invalid mode: "FPC"',nErrInvalidMode);
  1561. ConvertProgram;
  1562. end;
  1563. procedure TTestModule.Test_ModeSwitchCBlocksFail;
  1564. begin
  1565. StartProgram(false);
  1566. Add('{$modeswitch cblocks-}');
  1567. Add('begin');
  1568. SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
  1569. ConvertProgram;
  1570. end;
  1571. procedure TTestModule.TestVarInt;
  1572. begin
  1573. StartProgram(false);
  1574. Add('var MyI: longint;');
  1575. Add('begin');
  1576. ConvertProgram;
  1577. CheckSource('TestVarInt','this.MyI=0;','');
  1578. end;
  1579. procedure TTestModule.TestVarBaseTypes;
  1580. begin
  1581. StartProgram(false);
  1582. Add('var');
  1583. Add(' i: longint;');
  1584. Add(' s: string;');
  1585. Add(' c: char;');
  1586. Add(' b: boolean;');
  1587. Add(' d: double;');
  1588. Add(' i2: longint = 3;');
  1589. Add(' s2: string = ''foo'';');
  1590. Add(' c2: char = ''4'';');
  1591. Add(' b2: boolean = true;');
  1592. Add(' d2: double = 5.6;');
  1593. Add(' i3: longint = $707;');
  1594. Add(' i4: nativeint = 4503599627370495;');
  1595. Add(' i5: nativeint = -4503599627370496;');
  1596. Add(' i6: nativeint = $fffffffffffff;');
  1597. Add(' i7: nativeint = -$10000000000000;');
  1598. Add(' u8: nativeuint = $fffffffffffff;');
  1599. Add(' u9: nativeuint = $0000000000000;');
  1600. Add('begin');
  1601. ConvertProgram;
  1602. CheckSource('TestVarBaseTypes',
  1603. LinesToStr([
  1604. 'this.i=0;',
  1605. 'this.s="";',
  1606. 'this.c="";',
  1607. 'this.b=false;',
  1608. 'this.d=0.0;',
  1609. 'this.i2=3;',
  1610. 'this.s2="foo";',
  1611. 'this.c2="4";',
  1612. 'this.b2=true;',
  1613. 'this.d2=5.6;',
  1614. 'this.i3=0x707;',
  1615. 'this.i4= 4503599627370495;',
  1616. 'this.i5= -4503599627370496;',
  1617. 'this.i6= 0xfffffffffffff;',
  1618. 'this.i7=-0x10000000000000;',
  1619. 'this.u8= 0xfffffffffffff;',
  1620. 'this.u9= 0x0000000000000;'
  1621. ]),
  1622. '');
  1623. end;
  1624. procedure TTestModule.TestBaseTypeSingleFail;
  1625. begin
  1626. StartProgram(false);
  1627. Add('var s: single;');
  1628. SetExpectedPasResolverError('identifier not found "single"',PasResolveEval.nIdentifierNotFound);
  1629. ConvertProgram;
  1630. end;
  1631. procedure TTestModule.TestBaseTypeExtendedFail;
  1632. begin
  1633. StartProgram(false);
  1634. Add('var e: extended;');
  1635. SetExpectedPasResolverError('identifier not found "extended"',PasResolveEval.nIdentifierNotFound);
  1636. ConvertProgram;
  1637. end;
  1638. procedure TTestModule.TestConstBaseTypes;
  1639. begin
  1640. StartProgram(false);
  1641. Add('const');
  1642. Add(' i: longint = 3;');
  1643. Add(' s: string = ''foo'';');
  1644. Add(' c: char = ''4'';');
  1645. Add(' b: boolean = true;');
  1646. Add(' d: double = 5.6;');
  1647. Add(' e = low(word);');
  1648. Add(' f = high(word);');
  1649. Add('begin');
  1650. ConvertProgram;
  1651. CheckSource('TestVarBaseTypes',
  1652. LinesToStr([
  1653. 'this.i=3;',
  1654. 'this.s="foo";',
  1655. 'this.c="4";',
  1656. 'this.b=true;',
  1657. 'this.d=5.6;',
  1658. 'this.e = 0;',
  1659. 'this.f = 65535;'
  1660. ]),
  1661. '');
  1662. end;
  1663. procedure TTestModule.TestAliasTypeRef;
  1664. begin
  1665. StartProgram(false);
  1666. Add('type');
  1667. Add(' a=longint;');
  1668. Add(' b=a;');
  1669. Add('var');
  1670. Add(' c: A;');
  1671. Add(' d: B;');
  1672. Add('begin');
  1673. ConvertProgram;
  1674. CheckSource('TestAliasTypeRef',
  1675. LinesToStr([ // statements
  1676. 'this.c = 0;',
  1677. 'this.d = 0;'
  1678. ]),
  1679. LinesToStr([ // this.$main
  1680. ''
  1681. ]));
  1682. end;
  1683. procedure TTestModule.TestTypeCast_BaseTypes;
  1684. begin
  1685. StartProgram(false);
  1686. Add('var');
  1687. Add(' i: longint;');
  1688. Add(' b: boolean;');
  1689. Add(' d: double;');
  1690. Add(' s: string;');
  1691. Add(' c: char;');
  1692. Add('begin');
  1693. Add(' i:=longint(i);');
  1694. Add(' i:=longint(b);');
  1695. Add(' b:=boolean(b);');
  1696. Add(' b:=boolean(i);');
  1697. Add(' d:=double(d);');
  1698. Add(' d:=double(i);');
  1699. Add(' s:=string(s);');
  1700. Add(' s:=string(c);');
  1701. Add(' c:=char(c);');
  1702. ConvertProgram;
  1703. CheckSource('TestAliasTypeRef',
  1704. LinesToStr([ // statements
  1705. 'this.i = 0;',
  1706. 'this.b = false;',
  1707. 'this.d = 0.0;',
  1708. 'this.s = "";',
  1709. 'this.c = "";',
  1710. '']),
  1711. LinesToStr([ // this.$main
  1712. '$mod.i = $mod.i;',
  1713. '$mod.i = ($mod.b ? 1 : 0);',
  1714. '$mod.b = $mod.b;',
  1715. '$mod.b = $mod.i != 0;',
  1716. '$mod.d = $mod.d;',
  1717. '$mod.d = $mod.i;',
  1718. '$mod.s = $mod.s;',
  1719. '$mod.s = $mod.c;',
  1720. '$mod.c = $mod.c;',
  1721. '']));
  1722. end;
  1723. procedure TTestModule.TestTypeCast_AliasBaseTypes;
  1724. begin
  1725. StartProgram(false);
  1726. Add('type');
  1727. Add(' integer = longint;');
  1728. Add(' TYesNo = boolean;');
  1729. Add(' TFloat = double;');
  1730. Add(' TCaption = string;');
  1731. Add(' TChar = char;');
  1732. Add('var');
  1733. Add(' i: integer;');
  1734. Add(' b: TYesNo;');
  1735. Add(' d: TFloat;');
  1736. Add(' s: TCaption;');
  1737. Add(' c: TChar;');
  1738. Add('begin');
  1739. Add(' i:=integer(i);');
  1740. Add(' i:=integer(b);');
  1741. Add(' b:=TYesNo(b);');
  1742. Add(' b:=TYesNo(i);');
  1743. Add(' d:=TFloat(d);');
  1744. Add(' d:=TFloat(i);');
  1745. Add(' s:=TCaption(s);');
  1746. Add(' s:=TCaption(c);');
  1747. Add(' c:=TChar(c);');
  1748. ConvertProgram;
  1749. CheckSource('TestAliasTypeRef',
  1750. LinesToStr([ // statements
  1751. 'this.i = 0;',
  1752. 'this.b = false;',
  1753. 'this.d = 0.0;',
  1754. 'this.s = "";',
  1755. 'this.c = "";',
  1756. '']),
  1757. LinesToStr([ // this.$main
  1758. '$mod.i = $mod.i;',
  1759. '$mod.i = ($mod.b ? 1 : 0);',
  1760. '$mod.b = $mod.b;',
  1761. '$mod.b = $mod.i != 0;',
  1762. '$mod.d = $mod.d;',
  1763. '$mod.d = $mod.i;',
  1764. '$mod.s = $mod.s;',
  1765. '$mod.s = $mod.c;',
  1766. '$mod.c = $mod.c;',
  1767. '']));
  1768. end;
  1769. procedure TTestModule.TestEmptyProc;
  1770. begin
  1771. StartProgram(false);
  1772. Add('procedure Test;');
  1773. Add('begin');
  1774. Add('end;');
  1775. Add('begin');
  1776. ConvertProgram;
  1777. CheckSource('TestEmptyProc',
  1778. LinesToStr([ // statements
  1779. 'this.Test = function () {',
  1780. '};'
  1781. ]),
  1782. LinesToStr([ // this.$main
  1783. ''
  1784. ]));
  1785. end;
  1786. procedure TTestModule.TestProcOneParam;
  1787. begin
  1788. StartProgram(false);
  1789. Add('procedure ProcA(i: longint);');
  1790. Add('begin');
  1791. Add('end;');
  1792. Add('begin');
  1793. Add(' PROCA(3);');
  1794. ConvertProgram;
  1795. CheckSource('TestProcOneParam',
  1796. LinesToStr([ // statements
  1797. 'this.ProcA = function (i) {',
  1798. '};'
  1799. ]),
  1800. LinesToStr([ // this.$main
  1801. '$mod.ProcA(3);'
  1802. ]));
  1803. end;
  1804. procedure TTestModule.TestFunctionWithoutParams;
  1805. begin
  1806. StartProgram(false);
  1807. Add('function FuncA: longint;');
  1808. Add('begin');
  1809. Add('end;');
  1810. Add('var i: longint;');
  1811. Add('begin');
  1812. Add(' I:=FUNCA();');
  1813. Add(' I:=FUNCA;');
  1814. Add(' FUNCA();');
  1815. Add(' FUNCA;');
  1816. ConvertProgram;
  1817. CheckSource('TestProcWithoutParams',
  1818. LinesToStr([ // statements
  1819. 'this.FuncA = function () {',
  1820. ' var Result = 0;',
  1821. ' return Result;',
  1822. '};',
  1823. 'this.i=0;'
  1824. ]),
  1825. LinesToStr([ // this.$main
  1826. '$mod.i=$mod.FuncA();',
  1827. '$mod.i=$mod.FuncA();',
  1828. '$mod.FuncA();',
  1829. '$mod.FuncA();'
  1830. ]));
  1831. end;
  1832. procedure TTestModule.TestProcedureWithoutParams;
  1833. begin
  1834. StartProgram(false);
  1835. Add('procedure ProcA;');
  1836. Add('begin');
  1837. Add('end;');
  1838. Add('begin');
  1839. Add(' PROCA();');
  1840. Add(' PROCA;');
  1841. ConvertProgram;
  1842. CheckSource('TestProcWithoutParams',
  1843. LinesToStr([ // statements
  1844. 'this.ProcA = function () {',
  1845. '};'
  1846. ]),
  1847. LinesToStr([ // this.$main
  1848. '$mod.ProcA();',
  1849. '$mod.ProcA();'
  1850. ]));
  1851. end;
  1852. procedure TTestModule.TestIncDec;
  1853. begin
  1854. StartProgram(false);
  1855. Add([
  1856. 'procedure DoIt(var i: longint);',
  1857. 'begin',
  1858. ' inc(i);',
  1859. ' inc(i,2);',
  1860. 'end;',
  1861. 'var',
  1862. ' Bar: longint;',
  1863. 'begin',
  1864. ' inc(bar);',
  1865. ' inc(bar,2);',
  1866. ' dec(bar);',
  1867. ' dec(bar,3);',
  1868. '']);
  1869. ConvertProgram;
  1870. CheckSource('TestIncDec',
  1871. LinesToStr([ // statements
  1872. 'this.DoIt = function (i) {',
  1873. ' i.set(i.get()+1);',
  1874. ' i.set(i.get()+2);',
  1875. '};',
  1876. 'this.Bar = 0;'
  1877. ]),
  1878. LinesToStr([ // this.$main
  1879. '$mod.Bar+=1;',
  1880. '$mod.Bar+=2;',
  1881. '$mod.Bar-=1;',
  1882. '$mod.Bar-=3;'
  1883. ]));
  1884. end;
  1885. procedure TTestModule.TestAssignments;
  1886. begin
  1887. StartProgram(false);
  1888. Parser.Options:=Parser.Options+[po_cassignments];
  1889. Add('var');
  1890. Add(' Bar:longint;');
  1891. Add('begin');
  1892. Add(' bar:=3;');
  1893. Add(' bar+=4;');
  1894. Add(' bar-=5;');
  1895. Add(' bar*=6;');
  1896. ConvertProgram;
  1897. CheckSource('TestAssignments',
  1898. LinesToStr([ // statements
  1899. 'this.Bar = 0;'
  1900. ]),
  1901. LinesToStr([ // this.$main
  1902. '$mod.Bar=3;',
  1903. '$mod.Bar+=4;',
  1904. '$mod.Bar-=5;',
  1905. '$mod.Bar*=6;'
  1906. ]));
  1907. end;
  1908. procedure TTestModule.TestArithmeticOperators1;
  1909. begin
  1910. StartProgram(false);
  1911. Add('var');
  1912. Add(' vA,vB,vC:longint;');
  1913. Add('begin');
  1914. Add(' va:=1;');
  1915. Add(' vb:=va+va;');
  1916. Add(' vb:=va div vb;');
  1917. Add(' vb:=va mod vb;');
  1918. Add(' vb:=va+va*vb+va div vb;');
  1919. Add(' vc:=-va;');
  1920. Add(' va:=va-vb;');
  1921. Add(' vb:=va;');
  1922. Add(' if va<vb then vc:=va else vc:=vb;');
  1923. ConvertProgram;
  1924. CheckSource('TestArithmeticOperators1',
  1925. LinesToStr([ // statements
  1926. 'this.vA = 0;',
  1927. 'this.vB = 0;',
  1928. 'this.vC = 0;'
  1929. ]),
  1930. LinesToStr([ // this.$main
  1931. '$mod.vA = 1;',
  1932. '$mod.vB = $mod.vA + $mod.vA;',
  1933. '$mod.vB = Math.floor($mod.vA / $mod.vB);',
  1934. '$mod.vB = $mod.vA % $mod.vB;',
  1935. '$mod.vB = ($mod.vA + ($mod.vA * $mod.vB)) + Math.floor($mod.vA / $mod.vB);',
  1936. '$mod.vC = -$mod.vA;',
  1937. '$mod.vA = $mod.vA - $mod.vB;',
  1938. '$mod.vB = $mod.vA;',
  1939. 'if ($mod.vA < $mod.vB){ $mod.vC = $mod.vA } else $mod.vC = $mod.vB;'
  1940. ]));
  1941. end;
  1942. procedure TTestModule.TestLogicalOperators;
  1943. begin
  1944. StartProgram(false);
  1945. Add('var');
  1946. Add(' vA,vB,vC:boolean;');
  1947. Add('begin');
  1948. Add(' va:=vb and vc;');
  1949. Add(' va:=vb or vc;');
  1950. Add(' va:=vb xor vc;');
  1951. Add(' va:=true and vc;');
  1952. Add(' va:=(vb and vc) or (va and vb);');
  1953. Add(' va:=not vb;');
  1954. ConvertProgram;
  1955. CheckSource('TestLogicalOperators',
  1956. LinesToStr([ // statements
  1957. 'this.vA = false;',
  1958. 'this.vB = false;',
  1959. 'this.vC = false;'
  1960. ]),
  1961. LinesToStr([ // this.$main
  1962. '$mod.vA = $mod.vB && $mod.vC;',
  1963. '$mod.vA = $mod.vB || $mod.vC;',
  1964. '$mod.vA = $mod.vB ^ $mod.vC;',
  1965. '$mod.vA = true && $mod.vC;',
  1966. '$mod.vA = ($mod.vB && $mod.vC) || ($mod.vA && $mod.vB);',
  1967. '$mod.vA = !$mod.vB;'
  1968. ]));
  1969. end;
  1970. procedure TTestModule.TestBitwiseOperators;
  1971. begin
  1972. StartProgram(false);
  1973. Add('var');
  1974. Add(' vA,vB,vC:longint;');
  1975. Add('begin');
  1976. Add(' va:=vb and vc;');
  1977. Add(' va:=vb or vc;');
  1978. Add(' va:=vb xor vc;');
  1979. Add(' va:=vb shl vc;');
  1980. Add(' va:=vb shr vc;');
  1981. Add(' va:=3 and vc;');
  1982. Add(' va:=(vb and vc) or (va and vb);');
  1983. Add(' va:=not vb;');
  1984. ConvertProgram;
  1985. CheckSource('TestBitwiseOperators',
  1986. LinesToStr([ // statements
  1987. 'this.vA = 0;',
  1988. 'this.vB = 0;',
  1989. 'this.vC = 0;'
  1990. ]),
  1991. LinesToStr([ // this.$main
  1992. '$mod.vA = $mod.vB & $mod.vC;',
  1993. '$mod.vA = $mod.vB | $mod.vC;',
  1994. '$mod.vA = $mod.vB ^ $mod.vC;',
  1995. '$mod.vA = $mod.vB << $mod.vC;',
  1996. '$mod.vA = $mod.vB >>> $mod.vC;',
  1997. '$mod.vA = 3 & $mod.vC;',
  1998. '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
  1999. '$mod.vA = ~$mod.vB;'
  2000. ]));
  2001. end;
  2002. procedure TTestModule.TestPrgProcVar;
  2003. begin
  2004. StartProgram(false);
  2005. Add('procedure Proc1;');
  2006. Add('type');
  2007. Add(' t1=longint;');
  2008. Add('var');
  2009. Add(' vA:t1;');
  2010. Add('begin');
  2011. Add('end;');
  2012. Add('begin');
  2013. ConvertProgram;
  2014. CheckSource('TestPrgProcVar',
  2015. LinesToStr([ // statements
  2016. 'this.Proc1 = function () {',
  2017. ' var vA=0;',
  2018. '};'
  2019. ]),
  2020. LinesToStr([ // this.$main
  2021. ''
  2022. ]));
  2023. end;
  2024. procedure TTestModule.TestUnitProcVar;
  2025. begin
  2026. StartUnit(false);
  2027. Add('interface');
  2028. Add('');
  2029. Add('type tA=string; // unit scope');
  2030. Add('procedure Proc1;');
  2031. Add('');
  2032. Add('implementation');
  2033. Add('');
  2034. Add('procedure Proc1;');
  2035. Add('type tA=longint; // local proc scope');
  2036. Add('var v1:tA; // using local tA');
  2037. Add('begin');
  2038. Add('end;');
  2039. Add('var v2:tA; // using interface tA');
  2040. ConvertUnit;
  2041. CheckSource('TestUnitProcVar',
  2042. LinesToStr([ // statements
  2043. 'var $impl = $mod.$impl;',
  2044. 'this.Proc1 = function () {',
  2045. ' var v1 = 0;',
  2046. '};',
  2047. '']),
  2048. // this.$init
  2049. '',
  2050. // implementation
  2051. LinesToStr([
  2052. '$impl.v2 = "";',
  2053. '']));
  2054. end;
  2055. procedure TTestModule.TestImplProc;
  2056. begin
  2057. StartUnit(false);
  2058. Add('interface');
  2059. Add('');
  2060. Add('procedure Proc1;');
  2061. Add('');
  2062. Add('implementation');
  2063. Add('');
  2064. Add('procedure Proc1; begin end;');
  2065. Add('procedure Proc2; begin end;');
  2066. Add('initialization');
  2067. Add(' Proc1;');
  2068. Add(' Proc2;');
  2069. ConvertUnit;
  2070. CheckSource('TestImplProc',
  2071. LinesToStr([ // statements
  2072. 'var $impl = $mod.$impl;',
  2073. 'this.Proc1 = function () {',
  2074. '};',
  2075. '']),
  2076. LinesToStr([ // this.$init
  2077. '$mod.Proc1();',
  2078. '$impl.Proc2();',
  2079. '']),
  2080. LinesToStr([ // implementation
  2081. '$impl.Proc2 = function () {',
  2082. '};',
  2083. ''])
  2084. );
  2085. end;
  2086. procedure TTestModule.TestFunctionResult;
  2087. begin
  2088. StartProgram(false);
  2089. Add('function Func1: longint;');
  2090. Add('begin');
  2091. Add(' Result:=3;');
  2092. Add(' Func1:=4;');
  2093. Add('end;');
  2094. Add('begin');
  2095. ConvertProgram;
  2096. CheckSource('TestFunctionResult',
  2097. LinesToStr([ // statements
  2098. 'this.Func1 = function () {',
  2099. ' var Result = 0;',
  2100. ' Result = 3;',
  2101. ' Result = 4;',
  2102. ' return Result;',
  2103. '};'
  2104. ]),
  2105. '');
  2106. end;
  2107. procedure TTestModule.TestNestedProc;
  2108. begin
  2109. StartProgram(false);
  2110. Add([
  2111. 'var vInUnit: longint;',
  2112. 'function DoIt(pA,pD: longint): longint;',
  2113. 'var',
  2114. ' vB: longint;',
  2115. ' vC: longint;',
  2116. ' function Nesty(pA: longint): longint; ',
  2117. ' var vB: longint;',
  2118. ' begin',
  2119. ' Result:=pa+vb+vc+pd+vInUnit;',
  2120. ' nesty:=3;',
  2121. ' doit:=4;',
  2122. ' exit;',
  2123. ' end;',
  2124. 'begin',
  2125. ' Result:=pa+vb+vc;',
  2126. ' doit:=6;',
  2127. ' exit;',
  2128. 'end;',
  2129. 'begin']);
  2130. ConvertProgram;
  2131. CheckSource('TestNestedProc',
  2132. LinesToStr([ // statements
  2133. 'this.vInUnit = 0;',
  2134. 'this.DoIt = function (pA, pD) {',
  2135. ' var Result = 0;',
  2136. ' var vB = 0;',
  2137. ' var vC = 0;',
  2138. ' function Nesty(pA) {',
  2139. ' var Result$1 = 0;',
  2140. ' var vB = 0;',
  2141. ' Result$1 = (((pA + vB) + vC) + pD) + $mod.vInUnit;',
  2142. ' Result$1 = 3;',
  2143. ' Result = 4;',
  2144. ' return Result$1;',
  2145. ' return Result$1;',
  2146. ' };',
  2147. ' Result = (pA + vB) + vC;',
  2148. ' Result = 6;',
  2149. ' return Result;',
  2150. ' return Result;',
  2151. '};'
  2152. ]),
  2153. '');
  2154. end;
  2155. procedure TTestModule.TestForwardProc;
  2156. begin
  2157. StartProgram(false);
  2158. Add('procedure FuncA(Bar: longint); forward;');
  2159. Add('procedure FuncB(Bar: longint);');
  2160. Add('begin');
  2161. Add(' funca(bar);');
  2162. Add('end;');
  2163. Add('procedure funca(bar: longint);');
  2164. Add('begin');
  2165. Add(' if bar=3 then ;');
  2166. Add('end;');
  2167. Add('begin');
  2168. Add(' funca(4);');
  2169. Add(' funcb(5);');
  2170. ConvertProgram;
  2171. CheckSource('TestForwardProc',
  2172. LinesToStr([ // statements'
  2173. 'this.FuncB = function (Bar) {',
  2174. ' $mod.FuncA(Bar);',
  2175. '};',
  2176. 'this.FuncA = function (Bar) {',
  2177. ' if (Bar === 3);',
  2178. '};'
  2179. ]),
  2180. LinesToStr([
  2181. '$mod.FuncA(4);',
  2182. '$mod.FuncB(5);'
  2183. ])
  2184. );
  2185. end;
  2186. procedure TTestModule.TestNestedForwardProc;
  2187. begin
  2188. StartProgram(false);
  2189. Add('procedure FuncA;');
  2190. Add(' procedure FuncB(i: longint); forward;');
  2191. Add(' procedure FuncC(i: longint);');
  2192. Add(' begin');
  2193. Add(' funcb(i);');
  2194. Add(' end;');
  2195. Add(' procedure FuncB(i: longint);');
  2196. Add(' begin');
  2197. Add(' if i=3 then ;');
  2198. Add(' end;');
  2199. Add('begin');
  2200. Add(' funcc(4)');
  2201. Add('end;');
  2202. Add('begin');
  2203. Add(' funca;');
  2204. ConvertProgram;
  2205. CheckSource('TestNestedForwardProc',
  2206. LinesToStr([ // statements'
  2207. 'this.FuncA = function () {',
  2208. ' function FuncC(i) {',
  2209. ' FuncB(i);',
  2210. ' };',
  2211. ' function FuncB(i) {',
  2212. ' if (i === 3);',
  2213. ' };',
  2214. ' FuncC(4);',
  2215. '};'
  2216. ]),
  2217. LinesToStr([
  2218. '$mod.FuncA();'
  2219. ])
  2220. );
  2221. end;
  2222. procedure TTestModule.TestAssignFunctionResult;
  2223. begin
  2224. StartProgram(false);
  2225. Add('function Func1: longint;');
  2226. Add('begin');
  2227. Add('end;');
  2228. Add('var i: longint;');
  2229. Add('begin');
  2230. Add(' i:=func1();');
  2231. Add(' i:=func1()+func1();');
  2232. ConvertProgram;
  2233. CheckSource('TestAssignFunctionResult',
  2234. LinesToStr([ // statements
  2235. 'this.Func1 = function () {',
  2236. ' var Result = 0;',
  2237. ' return Result;',
  2238. '};',
  2239. 'this.i = 0;'
  2240. ]),
  2241. LinesToStr([
  2242. '$mod.i = $mod.Func1();',
  2243. '$mod.i = $mod.Func1() + $mod.Func1();'
  2244. ]));
  2245. end;
  2246. procedure TTestModule.TestFunctionResultInCondition;
  2247. begin
  2248. StartProgram(false);
  2249. Add('function Func1: longint;');
  2250. Add('begin');
  2251. Add('end;');
  2252. Add('function Func2: boolean;');
  2253. Add('begin');
  2254. Add('end;');
  2255. Add('var i: longint;');
  2256. Add('begin');
  2257. Add(' if func2 then ;');
  2258. Add(' if i=func1() then ;');
  2259. Add(' if i=func1 then ;');
  2260. ConvertProgram;
  2261. CheckSource('TestFunctionResultInCondition',
  2262. LinesToStr([ // statements
  2263. 'this.Func1 = function () {',
  2264. ' var Result = 0;',
  2265. ' return Result;',
  2266. '};',
  2267. 'this.Func2 = function () {',
  2268. ' var Result = false;',
  2269. ' return Result;',
  2270. '};',
  2271. 'this.i = 0;'
  2272. ]),
  2273. LinesToStr([
  2274. 'if ($mod.Func2());',
  2275. 'if ($mod.i === $mod.Func1());',
  2276. 'if ($mod.i === $mod.Func1());'
  2277. ]));
  2278. end;
  2279. procedure TTestModule.TestExit;
  2280. begin
  2281. StartProgram(false);
  2282. Add('procedure ProcA;');
  2283. Add('begin');
  2284. Add(' exit;');
  2285. Add('end;');
  2286. Add('function FuncB: longint;');
  2287. Add('begin');
  2288. Add(' exit;');
  2289. Add(' exit(3);');
  2290. Add('end;');
  2291. Add('function FuncC: string;');
  2292. Add('begin');
  2293. Add(' exit;');
  2294. Add(' exit(''a'');');
  2295. Add(' exit(''abc'');');
  2296. Add('end;');
  2297. Add('begin');
  2298. Add(' exit;');
  2299. Add(' exit(1);');
  2300. ConvertProgram;
  2301. CheckSource('TestExit',
  2302. LinesToStr([ // statements
  2303. 'this.ProcA = function () {',
  2304. ' return;',
  2305. '};',
  2306. 'this.FuncB = function () {',
  2307. ' var Result = 0;',
  2308. ' return Result;',
  2309. ' return 3;',
  2310. ' return Result;',
  2311. '};',
  2312. 'this.FuncC = function () {',
  2313. ' var Result = "";',
  2314. ' return Result;',
  2315. ' return "a";',
  2316. ' return "abc";',
  2317. ' return Result;',
  2318. '};'
  2319. ]),
  2320. LinesToStr([
  2321. 'return;',
  2322. 'return 1;',
  2323. '']));
  2324. end;
  2325. procedure TTestModule.TestBreak;
  2326. begin
  2327. StartProgram(false);
  2328. Add('var i: longint;');
  2329. Add('begin');
  2330. Add(' repeat');
  2331. Add(' break;');
  2332. Add(' until true;');
  2333. Add(' while true do');
  2334. Add(' break;');
  2335. Add(' for i:=1 to 2 do');
  2336. Add(' break;');
  2337. ConvertProgram;
  2338. CheckSource('TestBreak',
  2339. LinesToStr([ // statements
  2340. 'this.i = 0;'
  2341. ]),
  2342. LinesToStr([
  2343. 'do {',
  2344. ' break;',
  2345. '} while (!true);',
  2346. 'while (true) break;',
  2347. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) break;',
  2348. '']));
  2349. end;
  2350. procedure TTestModule.TestContinue;
  2351. begin
  2352. StartProgram(false);
  2353. Add('var i: longint;');
  2354. Add('begin');
  2355. Add(' repeat');
  2356. Add(' continue;');
  2357. Add(' until true;');
  2358. Add(' while true do');
  2359. Add(' continue;');
  2360. Add(' for i:=1 to 2 do');
  2361. Add(' continue;');
  2362. ConvertProgram;
  2363. CheckSource('TestContinue',
  2364. LinesToStr([ // statements
  2365. 'this.i = 0;'
  2366. ]),
  2367. LinesToStr([
  2368. 'do {',
  2369. ' continue;',
  2370. '} while (!true);',
  2371. 'while (true) continue;',
  2372. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) continue;',
  2373. '']));
  2374. end;
  2375. procedure TTestModule.TestProc_External;
  2376. begin
  2377. StartProgram(false);
  2378. Add('procedure Foo; external name ''console.log'';');
  2379. Add('function Bar: longint; external name ''get.item'';');
  2380. Add('function Bla(s: string): longint; external name ''apply.something'';');
  2381. Add('var');
  2382. Add(' i: longint;');
  2383. Add('begin');
  2384. Add(' Foo;');
  2385. Add(' i:=Bar;');
  2386. Add(' i:=Bla(''abc'');');
  2387. ConvertProgram;
  2388. CheckSource('TestProcedureExternal',
  2389. LinesToStr([ // statements
  2390. 'this.i = 0;'
  2391. ]),
  2392. LinesToStr([
  2393. 'console.log();',
  2394. '$mod.i = get.item();',
  2395. '$mod.i = apply.something("abc");'
  2396. ]));
  2397. end;
  2398. procedure TTestModule.TestProc_ExternalOtherUnit;
  2399. begin
  2400. AddModuleWithIntfImplSrc('unit2.pas',
  2401. LinesToStr([
  2402. 'procedure Now; external name ''Date.now'';',
  2403. 'procedure DoIt;'
  2404. ]),
  2405. 'procedure doit; begin end;');
  2406. StartUnit(true);
  2407. Add('interface');
  2408. Add('uses unit2;');
  2409. Add('implementation');
  2410. Add('begin');
  2411. Add(' now;');
  2412. Add(' now();');
  2413. Add(' uNit2.now;');
  2414. Add(' uNit2.now();');
  2415. Add(' doit;');
  2416. Add(' uNit2.doit;');
  2417. ConvertUnit;
  2418. CheckSource('TestProcedureExternalOtherUnit',
  2419. LinesToStr([
  2420. '']),
  2421. LinesToStr([
  2422. 'Date.now();',
  2423. 'Date.now();',
  2424. 'Date.now();',
  2425. 'Date.now();',
  2426. 'pas.unit2.DoIt();',
  2427. 'pas.unit2.DoIt();',
  2428. '']));
  2429. end;
  2430. procedure TTestModule.TestProc_Asm;
  2431. begin
  2432. StartProgram(false);
  2433. Add([
  2434. 'function DoIt: longint;',
  2435. 'begin;',
  2436. ' asm',
  2437. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2438. ' end;',
  2439. ' asm console.log(); end;',
  2440. 'end;',
  2441. 'begin']);
  2442. ConvertProgram;
  2443. CheckSource('TestProcedureAsm',
  2444. LinesToStr([ // statements
  2445. 'this.DoIt = function () {',
  2446. ' var Result = 0;',
  2447. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2448. ' console.log();',
  2449. ' return Result;',
  2450. '};'
  2451. ]),
  2452. LinesToStr([
  2453. ''
  2454. ]));
  2455. end;
  2456. procedure TTestModule.TestProc_Assembler;
  2457. begin
  2458. StartProgram(false);
  2459. Add('function DoIt: longint; assembler;');
  2460. Add('asm');
  2461. Add('{ a:{ b:{}, c:[]}, d:''1'' };');
  2462. Add('end;');
  2463. Add('begin');
  2464. ConvertProgram;
  2465. CheckSource('TestProcedureAssembler',
  2466. LinesToStr([ // statements
  2467. 'this.DoIt = function () {',
  2468. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2469. '};'
  2470. ]),
  2471. LinesToStr([
  2472. ''
  2473. ]));
  2474. end;
  2475. procedure TTestModule.TestProc_VarParam;
  2476. begin
  2477. StartProgram(false);
  2478. Add('type integer = longint;');
  2479. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  2480. Add('var vJ: integer;');
  2481. Add('begin');
  2482. Add(' vg:=vg+1;');
  2483. Add(' vj:=vh+2;');
  2484. Add(' vi:=vi+3;');
  2485. Add(' doit(vg,vg,vg);');
  2486. Add(' doit(vh,vh,vj);');
  2487. Add(' doit(vi,vi,vi);');
  2488. Add(' doit(vj,vj,vj);');
  2489. Add('end;');
  2490. Add('var i: integer;');
  2491. Add('begin');
  2492. Add(' doit(i,i,i);');
  2493. ConvertProgram;
  2494. CheckSource('TestProcedure_VarParam',
  2495. LinesToStr([ // statements
  2496. 'this.DoIt = function (vG,vH,vI) {',
  2497. ' var vJ = 0;',
  2498. ' vG = vG + 1;',
  2499. ' vJ = vH + 2;',
  2500. ' vI.set(vI.get()+3);',
  2501. ' $mod.DoIt(vG, vG, {',
  2502. ' get: function () {',
  2503. ' return vG;',
  2504. ' },',
  2505. ' set: function (v) {',
  2506. ' vG = v;',
  2507. ' }',
  2508. ' });',
  2509. ' $mod.DoIt(vH, vH, {',
  2510. ' get: function () {',
  2511. ' return vJ;',
  2512. ' },',
  2513. ' set: function (v) {',
  2514. ' vJ = v;',
  2515. ' }',
  2516. ' });',
  2517. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  2518. ' $mod.DoIt(vJ, vJ, {',
  2519. ' get: function () {',
  2520. ' return vJ;',
  2521. ' },',
  2522. ' set: function (v) {',
  2523. ' vJ = v;',
  2524. ' }',
  2525. ' });',
  2526. '};',
  2527. 'this.i = 0;'
  2528. ]),
  2529. LinesToStr([
  2530. '$mod.DoIt($mod.i,$mod.i,{',
  2531. ' p: $mod,',
  2532. ' get: function () {',
  2533. ' return this.p.i;',
  2534. ' },',
  2535. ' set: function (v) {',
  2536. ' this.p.i = v;',
  2537. ' }',
  2538. '});'
  2539. ]));
  2540. end;
  2541. procedure TTestModule.TestProc_Overload;
  2542. begin
  2543. StartProgram(false);
  2544. Add('procedure DoIt(vI: longint); begin end;');
  2545. Add('procedure DoIt(vI, vJ: longint); begin end;');
  2546. Add('procedure DoIt(vD: double); begin end;');
  2547. Add('begin');
  2548. Add(' DoIt(1);');
  2549. Add(' DoIt(2,3);');
  2550. Add(' DoIt(4.5);');
  2551. ConvertProgram;
  2552. CheckSource('TestProcedureOverload',
  2553. LinesToStr([ // statements
  2554. 'this.DoIt = function (vI) {',
  2555. '};',
  2556. 'this.DoIt$1 = function (vI, vJ) {',
  2557. '};',
  2558. 'this.DoIt$2 = function (vD) {',
  2559. '};',
  2560. '']),
  2561. LinesToStr([
  2562. '$mod.DoIt(1);',
  2563. '$mod.DoIt$1(2, 3);',
  2564. '$mod.DoIt$2(4.5);',
  2565. '']));
  2566. end;
  2567. procedure TTestModule.TestProc_OverloadForward;
  2568. begin
  2569. StartProgram(false);
  2570. Add('procedure DoIt(vI: longint); forward;');
  2571. Add('procedure DoIt(vI, vJ: longint); begin end;');
  2572. Add('procedure doit(vi: longint); begin end;');
  2573. Add('begin');
  2574. Add(' doit(1);');
  2575. Add(' doit(2,3);');
  2576. ConvertProgram;
  2577. CheckSource('TestProcedureOverloadForward',
  2578. LinesToStr([ // statements
  2579. 'this.DoIt$1 = function (vI, vJ) {',
  2580. '};',
  2581. 'this.DoIt = function (vI) {',
  2582. '};',
  2583. '']),
  2584. LinesToStr([
  2585. '$mod.DoIt(1);',
  2586. '$mod.DoIt$1(2, 3);',
  2587. '']));
  2588. end;
  2589. procedure TTestModule.TestProc_OverloadUnit;
  2590. begin
  2591. StartUnit(false);
  2592. Add('interface');
  2593. Add('procedure DoIt(vI: longint);');
  2594. Add('procedure DoIt(vI, vJ: longint);');
  2595. Add('implementation');
  2596. Add('procedure DoIt(vI, vJ, vK, vL, vM: longint); forward;');
  2597. Add('procedure DoIt(vI, vJ, vK: longint); begin end;');
  2598. Add('procedure DoIt(vi: longint); begin end;');
  2599. Add('procedure DoIt(vI, vJ, vK, vL: longint); begin end;');
  2600. Add('procedure DoIt(vi, vj: longint); begin end;');
  2601. Add('procedure DoIt(vi, vj, vk, vl, vm: longint); begin end;');
  2602. Add('begin');
  2603. Add(' doit(1);');
  2604. Add(' doit(2,3);');
  2605. Add(' doit(4,5,6);');
  2606. Add(' doit(7,8,9,10);');
  2607. Add(' doit(11,12,13,14,15);');
  2608. ConvertUnit;
  2609. CheckSource('TestProcedureOverloadUnit',
  2610. LinesToStr([ // statements
  2611. 'var $impl = $mod.$impl;',
  2612. 'this.DoIt = function (vI) {',
  2613. '};',
  2614. 'this.DoIt$1 = function (vI, vJ) {',
  2615. '};',
  2616. '']),
  2617. LinesToStr([ // this.$init
  2618. '$mod.DoIt(1);',
  2619. '$mod.DoIt$1(2, 3);',
  2620. '$impl.DoIt$3(4,5,6);',
  2621. '$impl.DoIt$4(7,8,9,10);',
  2622. '$impl.DoIt$2(11,12,13,14,15);',
  2623. '']),
  2624. LinesToStr([ // implementation
  2625. '$impl.DoIt$3 = function (vI, vJ, vK) {',
  2626. '};',
  2627. '$impl.DoIt$4 = function (vI, vJ, vK, vL) {',
  2628. '};',
  2629. '$impl.DoIt$2 = function (vI, vJ, vK, vL, vM) {',
  2630. '};',
  2631. '']));
  2632. end;
  2633. procedure TTestModule.TestProc_OverloadNested;
  2634. begin
  2635. StartProgram(false);
  2636. Add([
  2637. 'procedure DoIt(vA: longint); overload; forward;',
  2638. 'procedure DoIt(vB, vC: longint); overload;',
  2639. 'begin // 2 param overload',
  2640. ' doit(1);',
  2641. ' doit(1,2);',
  2642. 'end;',
  2643. 'procedure doit(vA: longint);',
  2644. ' procedure DoIt(vA, vB, vC: longint); overload; forward;',
  2645. ' procedure DoIt(vA, vB, vC, vD: longint); overload;',
  2646. ' begin // 4 param overload',
  2647. ' doit(1);',
  2648. ' doit(1,2);',
  2649. ' doit(1,2,3);',
  2650. ' doit(1,2,3,4);',
  2651. ' end;',
  2652. ' procedure doit(vA, vB, vC: longint);',
  2653. ' procedure DoIt(vA, vB, vC, vD, vE: longint); overload; forward;',
  2654. ' procedure DoIt(vA, vB, vC, vD, vE, vF: longint); overload;',
  2655. ' begin // 6 param overload',
  2656. ' doit(1);',
  2657. ' doit(1,2);',
  2658. ' doit(1,2,3);',
  2659. ' doit(1,2,3,4);',
  2660. ' doit(1,2,3,4,5);',
  2661. ' doit(1,2,3,4,5,6);',
  2662. ' end;',
  2663. ' procedure doit(vA, vB, vC, vD, vE: longint);',
  2664. ' begin // 5 param overload',
  2665. ' doit(1);',
  2666. ' doit(1,2);',
  2667. ' doit(1,2,3);',
  2668. ' doit(1,2,3,4);',
  2669. ' doit(1,2,3,4,5);',
  2670. ' doit(1,2,3,4,5,6);',
  2671. ' end;',
  2672. ' begin // 3 param overload',
  2673. ' doit(1);',
  2674. ' doit(1,2);',
  2675. ' doit(1,2,3);',
  2676. ' doit(1,2,3,4);',
  2677. ' doit(1,2,3,4,5);',
  2678. ' doit(1,2,3,4,5,6);',
  2679. ' end;',
  2680. 'begin // 1 param overload',
  2681. ' doit(1);',
  2682. ' doit(1,2);',
  2683. ' doit(1,2,3);',
  2684. ' doit(1,2,3,4);',
  2685. 'end;',
  2686. 'begin // main',
  2687. ' doit(1);',
  2688. ' doit(1,2);']);
  2689. ConvertProgram;
  2690. CheckSource('TestProcedureOverloadNested',
  2691. LinesToStr([ // statements
  2692. 'this.DoIt$1 = function (vB, vC) {',
  2693. ' $mod.DoIt(1);',
  2694. ' $mod.DoIt$1(1, 2);',
  2695. '};',
  2696. 'this.DoIt = function (vA) {',
  2697. ' function DoIt$3(vA, vB, vC, vD) {',
  2698. ' $mod.DoIt(1);',
  2699. ' $mod.DoIt$1(1, 2);',
  2700. ' DoIt$2(1, 2, 3);',
  2701. ' DoIt$3(1, 2, 3, 4);',
  2702. ' };',
  2703. ' function DoIt$2(vA, vB, vC) {',
  2704. ' function DoIt$5(vA, vB, vC, vD, vE, vF) {',
  2705. ' $mod.DoIt(1);',
  2706. ' $mod.DoIt$1(1, 2);',
  2707. ' DoIt$2(1, 2, 3);',
  2708. ' DoIt$3(1, 2, 3, 4);',
  2709. ' DoIt$4(1, 2, 3, 4, 5);',
  2710. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  2711. ' };',
  2712. ' function DoIt$4(vA, vB, vC, vD, vE) {',
  2713. ' $mod.DoIt(1);',
  2714. ' $mod.DoIt$1(1, 2);',
  2715. ' DoIt$2(1, 2, 3);',
  2716. ' DoIt$3(1, 2, 3, 4);',
  2717. ' DoIt$4(1, 2, 3, 4, 5);',
  2718. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  2719. ' };',
  2720. ' $mod.DoIt(1);',
  2721. ' $mod.DoIt$1(1, 2);',
  2722. ' DoIt$2(1, 2, 3);',
  2723. ' DoIt$3(1, 2, 3, 4);',
  2724. ' DoIt$4(1, 2, 3, 4, 5);',
  2725. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  2726. ' };',
  2727. ' $mod.DoIt(1);',
  2728. ' $mod.DoIt$1(1, 2);',
  2729. ' DoIt$2(1, 2, 3);',
  2730. ' DoIt$3(1, 2, 3, 4);',
  2731. '};',
  2732. '']),
  2733. LinesToStr([
  2734. '$mod.DoIt(1);',
  2735. '$mod.DoIt$1(1, 2);',
  2736. '']));
  2737. end;
  2738. procedure TTestModule.TestProc_Varargs;
  2739. begin
  2740. StartProgram(false);
  2741. Add('procedure ProcA(i:longint); varargs; external name ''ProcA'';');
  2742. Add('procedure ProcB; varargs; external name ''ProcB'';');
  2743. Add('procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';');
  2744. Add('function GetIt: longint; begin end;');
  2745. Add('begin');
  2746. Add(' ProcA(1);');
  2747. Add(' ProcA(1,2);');
  2748. Add(' ProcA(1,2.0);');
  2749. Add(' ProcA(1,2,3);');
  2750. Add(' ProcA(1,''2'');');
  2751. Add(' ProcA(2,'''');');
  2752. Add(' ProcA(3,false);');
  2753. Add(' ProcB;');
  2754. Add(' ProcB();');
  2755. Add(' ProcB(4);');
  2756. Add(' ProcB(''foo'');');
  2757. Add(' ProcC;');
  2758. Add(' ProcC();');
  2759. Add(' ProcC(4);');
  2760. Add(' ProcC(5,''foo'');');
  2761. Add(' ProcB(GetIt);');
  2762. Add(' ProcB(GetIt());');
  2763. Add(' ProcB(GetIt,GetIt());');
  2764. ConvertProgram;
  2765. CheckSource('TestProc_Varargs',
  2766. LinesToStr([ // statements
  2767. 'this.GetIt = function () {',
  2768. ' var Result = 0;',
  2769. ' return Result;',
  2770. '};',
  2771. '']),
  2772. LinesToStr([
  2773. 'ProcA(1);',
  2774. 'ProcA(1, 2);',
  2775. 'ProcA(1, 2.0);',
  2776. 'ProcA(1, 2, 3);',
  2777. 'ProcA(1, "2");',
  2778. 'ProcA(2, "");',
  2779. 'ProcA(3, false);',
  2780. 'ProcB();',
  2781. 'ProcB();',
  2782. 'ProcB(4);',
  2783. 'ProcB("foo");',
  2784. 'ProcC(17);',
  2785. 'ProcC(17);',
  2786. 'ProcC(4);',
  2787. 'ProcC(5, "foo");',
  2788. 'ProcB($mod.GetIt());',
  2789. 'ProcB($mod.GetIt());',
  2790. 'ProcB($mod.GetIt(), $mod.GetIt());',
  2791. '']));
  2792. end;
  2793. procedure TTestModule.TestProc_ConstOrder;
  2794. begin
  2795. StartProgram(false);
  2796. Add([
  2797. 'const A = 3;',
  2798. 'const B = A+1;',
  2799. 'procedure DoIt;',
  2800. 'const C = A+1;',
  2801. 'const D = B+1;',
  2802. 'const E = D+C+B+A;',
  2803. 'begin',
  2804. 'end;',
  2805. 'begin'
  2806. ]);
  2807. ConvertProgram;
  2808. CheckSource('TestProc_ConstOrder',
  2809. LinesToStr([ // statements
  2810. 'this.A = 3;',
  2811. 'this.B = $mod.A + 1;',
  2812. 'var C = $mod.A + 1;',
  2813. 'var D = $mod.B + 1;',
  2814. 'var E = ((D + C) + $mod.B) + $mod.A;',
  2815. 'this.DoIt = function () {',
  2816. '};',
  2817. '']),
  2818. LinesToStr([
  2819. ''
  2820. ]));
  2821. end;
  2822. procedure TTestModule.TestEnum_Name;
  2823. begin
  2824. StartProgram(false);
  2825. Add('type TMyEnum = (Red, Green, Blue);');
  2826. Add('var e: TMyEnum;');
  2827. Add('var f: TMyEnum = Blue;');
  2828. Add('begin');
  2829. Add(' e:=green;');
  2830. ConvertProgram;
  2831. CheckSource('TestEnumName',
  2832. LinesToStr([ // statements
  2833. 'this.TMyEnum = {',
  2834. ' "0":"Red",',
  2835. ' Red:0,',
  2836. ' "1":"Green",',
  2837. ' Green:1,',
  2838. ' "2":"Blue",',
  2839. ' Blue:2',
  2840. ' };',
  2841. 'this.e = 0;',
  2842. 'this.f = $mod.TMyEnum.Blue;'
  2843. ]),
  2844. LinesToStr([
  2845. '$mod.e=$mod.TMyEnum.Green;'
  2846. ]));
  2847. end;
  2848. procedure TTestModule.TestEnum_Number;
  2849. begin
  2850. Converter.Options:=Converter.Options+[coEnumNumbers];
  2851. StartProgram(false);
  2852. Add('type TMyEnum = (Red, Green);');
  2853. Add('var');
  2854. Add(' e: TMyEnum;');
  2855. Add(' f: TMyEnum = Green;');
  2856. Add(' i: longint;');
  2857. Add('begin');
  2858. Add(' e:=green;');
  2859. //Add(' i:=longint(e);');
  2860. ConvertProgram;
  2861. CheckSource('TestEnumNumber',
  2862. LinesToStr([ // statements
  2863. 'this.TMyEnum = {',
  2864. ' "0":"Red",',
  2865. ' Red:0,',
  2866. ' "1":"Green",',
  2867. ' Green:1',
  2868. ' };',
  2869. 'this.e = 0;',
  2870. 'this.f = 1;',
  2871. 'this.i = 0;'
  2872. ]),
  2873. LinesToStr([
  2874. '$mod.e=1;'
  2875. //'$mod.i=$mod.e;'
  2876. ]));
  2877. end;
  2878. procedure TTestModule.TestEnum_Functions;
  2879. begin
  2880. StartProgram(false);
  2881. Add('type TMyEnum = (Red, Green);');
  2882. Add('var');
  2883. Add(' e: TMyEnum;');
  2884. Add(' i: longint;');
  2885. Add(' s: string;');
  2886. Add(' b: boolean;');
  2887. Add('begin');
  2888. Add(' i:=ord(red);');
  2889. Add(' i:=ord(green);');
  2890. Add(' i:=ord(e);');
  2891. Add(' i:=ord(b);');
  2892. Add(' e:=low(tmyenum);');
  2893. Add(' e:=low(e);');
  2894. Add(' b:=low(boolean);');
  2895. Add(' e:=high(tmyenum);');
  2896. Add(' e:=high(e);');
  2897. Add(' b:=high(boolean);');
  2898. Add(' e:=pred(green);');
  2899. Add(' e:=pred(e);');
  2900. Add(' b:=pred(b);');
  2901. Add(' e:=succ(red);');
  2902. Add(' e:=succ(e);');
  2903. Add(' b:=succ(b);');
  2904. Add(' e:=tmyenum(1);');
  2905. Add(' e:=tmyenum(i);');
  2906. Add(' s:=str(e);');
  2907. Add(' str(e,s);');
  2908. Add(' s:=str(e:3);');
  2909. Add(' e:=TMyEnum(i);');
  2910. Add(' i:=longint(e);');
  2911. ConvertProgram;
  2912. CheckSource('TestEnum_Functions',
  2913. LinesToStr([ // statements
  2914. 'this.TMyEnum = {',
  2915. ' "0":"Red",',
  2916. ' Red:0,',
  2917. ' "1":"Green",',
  2918. ' Green:1',
  2919. ' };',
  2920. 'this.e = 0;',
  2921. 'this.i = 0;',
  2922. 'this.s = "";',
  2923. 'this.b = false;',
  2924. '']),
  2925. LinesToStr([
  2926. '$mod.i=$mod.TMyEnum.Red;',
  2927. '$mod.i=$mod.TMyEnum.Green;',
  2928. '$mod.i=$mod.e;',
  2929. '$mod.i=$mod.b+0;',
  2930. '$mod.e=$mod.TMyEnum.Red;',
  2931. '$mod.e=$mod.TMyEnum.Red;',
  2932. '$mod.b=false;',
  2933. '$mod.e=$mod.TMyEnum.Green;',
  2934. '$mod.e=$mod.TMyEnum.Green;',
  2935. '$mod.b=true;',
  2936. '$mod.e=$mod.TMyEnum.Green-1;',
  2937. '$mod.e=$mod.e-1;',
  2938. '$mod.b=false;',
  2939. '$mod.e=$mod.TMyEnum.Red+1;',
  2940. '$mod.e=$mod.e+1;',
  2941. '$mod.b=true;',
  2942. '$mod.e=1;',
  2943. '$mod.e=$mod.i;',
  2944. '$mod.s = $mod.TMyEnum[$mod.e];',
  2945. '$mod.s = $mod.TMyEnum[$mod.e];',
  2946. '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
  2947. '$mod.e=$mod.i;',
  2948. '$mod.i=$mod.e;',
  2949. '']));
  2950. end;
  2951. procedure TTestModule.TestEnum_AsParams;
  2952. begin
  2953. StartProgram(false);
  2954. Add('type TEnum = (Red,Blue);');
  2955. Add('procedure DoIt(vG: TEnum; const vH: TEnum; var vI: TEnum);');
  2956. Add('var vJ: TEnum;');
  2957. Add('begin');
  2958. Add(' vg:=vg;');
  2959. Add(' vj:=vh;');
  2960. Add(' vi:=vi;');
  2961. Add(' doit(vg,vg,vg);');
  2962. Add(' doit(vh,vh,vj);');
  2963. Add(' doit(vi,vi,vi);');
  2964. Add(' doit(vj,vj,vj);');
  2965. Add('end;');
  2966. Add('var i: TEnum;');
  2967. Add('begin');
  2968. Add(' doit(i,i,i);');
  2969. ConvertProgram;
  2970. CheckSource('TestEnum_AsParams',
  2971. LinesToStr([ // statements
  2972. 'this.TEnum = {',
  2973. ' "0": "Red",',
  2974. ' Red: 0,',
  2975. ' "1": "Blue",',
  2976. ' Blue: 1',
  2977. '};',
  2978. 'this.DoIt = function (vG,vH,vI) {',
  2979. ' var vJ = 0;',
  2980. ' vG = vG;',
  2981. ' vJ = vH;',
  2982. ' vI.set(vI.get());',
  2983. ' $mod.DoIt(vG, vG, {',
  2984. ' get: function () {',
  2985. ' return vG;',
  2986. ' },',
  2987. ' set: function (v) {',
  2988. ' vG = v;',
  2989. ' }',
  2990. ' });',
  2991. ' $mod.DoIt(vH, vH, {',
  2992. ' get: function () {',
  2993. ' return vJ;',
  2994. ' },',
  2995. ' set: function (v) {',
  2996. ' vJ = v;',
  2997. ' }',
  2998. ' });',
  2999. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  3000. ' $mod.DoIt(vJ, vJ, {',
  3001. ' get: function () {',
  3002. ' return vJ;',
  3003. ' },',
  3004. ' set: function (v) {',
  3005. ' vJ = v;',
  3006. ' }',
  3007. ' });',
  3008. '};',
  3009. 'this.i = 0;'
  3010. ]),
  3011. LinesToStr([
  3012. '$mod.DoIt($mod.i,$mod.i,{',
  3013. ' p: $mod,',
  3014. ' get: function () {',
  3015. ' return this.p.i;',
  3016. ' },',
  3017. ' set: function (v) {',
  3018. ' this.p.i = v;',
  3019. ' }',
  3020. '});'
  3021. ]));
  3022. end;
  3023. procedure TTestModule.TestEnumRange_Array;
  3024. begin
  3025. StartProgram(false);
  3026. Add([
  3027. 'type',
  3028. ' TEnum = (Red, Green, Blue);',
  3029. ' TEnumRg = green..blue;',
  3030. ' TArr = array[TEnumRg] of byte;',
  3031. 'var',
  3032. ' a: TArr;',
  3033. ' b: TArr = (3,4);',
  3034. 'begin',
  3035. ' a[green] := b[blue];']);
  3036. ConvertProgram;
  3037. CheckSource('TestEnumRange_Array',
  3038. LinesToStr([ // statements
  3039. 'this.TEnum = {',
  3040. ' "0": "Red",',
  3041. ' Red: 0,',
  3042. ' "1": "Green",',
  3043. ' Green: 1,',
  3044. ' "2": "Blue",',
  3045. ' Blue: 2',
  3046. '};',
  3047. 'this.a = rtl.arraySetLength(null, 0, 2);',
  3048. 'this.b = [3, 4];',
  3049. '']),
  3050. LinesToStr([
  3051. ' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
  3052. '']));
  3053. end;
  3054. procedure TTestModule.TestSet;
  3055. begin
  3056. StartProgram(false);
  3057. Add('type');
  3058. Add(' TColor = (Red, Green, Blue);');
  3059. Add(' TColors = set of TColor;');
  3060. Add('var');
  3061. Add(' c: TColor;');
  3062. Add(' s: TColors;');
  3063. Add(' t: TColors = [];');
  3064. Add(' u: TColors = [Red];');
  3065. Add('begin');
  3066. Add(' s:=[];');
  3067. Add(' s:=[Green];');
  3068. Add(' s:=[Green,Blue];');
  3069. Add(' s:=[Red..Blue];');
  3070. Add(' s:=[Red,Green..Blue];');
  3071. Add(' s:=[Red,c];');
  3072. Add(' s:=t;');
  3073. ConvertProgram;
  3074. CheckSource('TestEnumName',
  3075. LinesToStr([ // statements
  3076. 'this.TColor = {',
  3077. ' "0":"Red",',
  3078. ' Red:0,',
  3079. ' "1":"Green",',
  3080. ' Green:1,',
  3081. ' "2":"Blue",',
  3082. ' Blue:2',
  3083. ' };',
  3084. 'this.c = 0;',
  3085. 'this.s = {};',
  3086. 'this.t = {};',
  3087. 'this.u = rtl.createSet($mod.TColor.Red);'
  3088. ]),
  3089. LinesToStr([
  3090. '$mod.s={};',
  3091. '$mod.s=rtl.createSet($mod.TColor.Green);',
  3092. '$mod.s=rtl.createSet($mod.TColor.Green,$mod.TColor.Blue);',
  3093. '$mod.s=rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);',
  3094. '$mod.s=rtl.createSet($mod.TColor.Red,null,$mod.TColor.Green,$mod.TColor.Blue);',
  3095. '$mod.s=rtl.createSet($mod.TColor.Red,$mod.c);',
  3096. '$mod.s=rtl.refSet($mod.t);',
  3097. '']));
  3098. end;
  3099. procedure TTestModule.TestSet_Operators;
  3100. begin
  3101. StartProgram(false);
  3102. Add('type');
  3103. Add(' TColor = (Red, Green, Blue);');
  3104. Add(' TColors = set of tcolor;');
  3105. Add('var');
  3106. Add(' vC: TColor;');
  3107. Add(' vS: TColors;');
  3108. Add(' vT: TColors;');
  3109. Add(' vU: TColors;');
  3110. Add(' B: boolean;');
  3111. Add('begin');
  3112. Add(' include(vs,green);');
  3113. Add(' exclude(vs,vc);');
  3114. Add(' vs:=vt+vu;');
  3115. Add(' vs:=vt+[red];');
  3116. Add(' vs:=[red]+vt;');
  3117. Add(' vs:=[red]+[green];');
  3118. Add(' vs:=vt-vu;');
  3119. Add(' vs:=vt-[red];');
  3120. Add(' vs:=[red]-vt;');
  3121. Add(' vs:=[red]-[green];');
  3122. Add(' vs:=vt*vu;');
  3123. Add(' vs:=vt*[red];');
  3124. Add(' vs:=[red]*vt;');
  3125. Add(' vs:=[red]*[green];');
  3126. Add(' vs:=vt><vu;');
  3127. Add(' vs:=vt><[red];');
  3128. Add(' vs:=[red]><vt;');
  3129. Add(' vs:=[red]><[green];');
  3130. Add(' b:=vt=vu;');
  3131. Add(' b:=vt=[red];');
  3132. Add(' b:=[red]=vt;');
  3133. Add(' b:=[red]=[green];');
  3134. Add(' b:=vt<>vu;');
  3135. Add(' b:=vt<>[red];');
  3136. Add(' b:=[red]<>vt;');
  3137. Add(' b:=[red]<>[green];');
  3138. Add(' b:=vt<=vu;');
  3139. Add(' b:=vt<=[red];');
  3140. Add(' b:=[red]<=vt;');
  3141. Add(' b:=[red]<=[green];');
  3142. Add(' b:=vt>=vu;');
  3143. Add(' b:=vt>=[red];');
  3144. Add(' b:=[red]>=vt;');
  3145. Add(' b:=[red]>=[green];');
  3146. ConvertProgram;
  3147. CheckSource('TestSet_Operators',
  3148. LinesToStr([ // statements
  3149. 'this.TColor = {',
  3150. ' "0":"Red",',
  3151. ' Red:0,',
  3152. ' "1":"Green",',
  3153. ' Green:1,',
  3154. ' "2":"Blue",',
  3155. ' Blue:2',
  3156. ' };',
  3157. 'this.vC = 0;',
  3158. 'this.vS = {};',
  3159. 'this.vT = {};',
  3160. 'this.vU = {};',
  3161. 'this.B = false;'
  3162. ]),
  3163. LinesToStr([
  3164. '$mod.vS = rtl.includeSet($mod.vS,$mod.TColor.Green);',
  3165. '$mod.vS = rtl.excludeSet($mod.vS,$mod.vC);',
  3166. '$mod.vS = rtl.unionSet($mod.vT, $mod.vU);',
  3167. '$mod.vS = rtl.unionSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3168. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3169. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3170. '$mod.vS = rtl.diffSet($mod.vT, $mod.vU);',
  3171. '$mod.vS = rtl.diffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3172. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3173. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3174. '$mod.vS = rtl.intersectSet($mod.vT, $mod.vU);',
  3175. '$mod.vS = rtl.intersectSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3176. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3177. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3178. '$mod.vS = rtl.symDiffSet($mod.vT, $mod.vU);',
  3179. '$mod.vS = rtl.symDiffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3180. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3181. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3182. '$mod.B = rtl.eqSet($mod.vT, $mod.vU);',
  3183. '$mod.B = rtl.eqSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3184. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3185. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3186. '$mod.B = rtl.neSet($mod.vT, $mod.vU);',
  3187. '$mod.B = rtl.neSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3188. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3189. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3190. '$mod.B = rtl.leSet($mod.vT, $mod.vU);',
  3191. '$mod.B = rtl.leSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3192. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3193. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3194. '$mod.B = rtl.geSet($mod.vT, $mod.vU);',
  3195. '$mod.B = rtl.geSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3196. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3197. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3198. '']));
  3199. end;
  3200. procedure TTestModule.TestSet_Operator_In;
  3201. begin
  3202. StartProgram(false);
  3203. Add('type');
  3204. Add(' TColor = (Red, Green, Blue);');
  3205. Add(' TColors = set of tcolor;');
  3206. Add('var');
  3207. Add(' vC: tcolor;');
  3208. Add(' vT: tcolors;');
  3209. Add(' B: boolean;');
  3210. Add('begin');
  3211. Add(' b:=red in vt;');
  3212. Add(' b:=vc in vt;');
  3213. Add(' b:=green in [red..blue];');
  3214. Add(' b:=vc in [red..blue];');
  3215. Add(' ');
  3216. Add(' if red in vt then ;');
  3217. Add(' while vC in vt do ;');
  3218. Add(' repeat');
  3219. Add(' until vC in vt;');
  3220. ConvertProgram;
  3221. CheckSource('TestSet_Operator_In',
  3222. LinesToStr([ // statements
  3223. 'this.TColor = {',
  3224. ' "0":"Red",',
  3225. ' Red:0,',
  3226. ' "1":"Green",',
  3227. ' Green:1,',
  3228. ' "2":"Blue",',
  3229. ' Blue:2',
  3230. ' };',
  3231. 'this.vC = 0;',
  3232. 'this.vT = {};',
  3233. 'this.B = false;'
  3234. ]),
  3235. LinesToStr([
  3236. '$mod.B = $mod.TColor.Red in $mod.vT;',
  3237. '$mod.B = $mod.vC in $mod.vT;',
  3238. '$mod.B = $mod.TColor.Green in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  3239. '$mod.B = $mod.vC in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  3240. 'if ($mod.TColor.Red in $mod.vT) ;',
  3241. 'while ($mod.vC in $mod.vT) {',
  3242. '};',
  3243. 'do {',
  3244. '} while (!($mod.vC in $mod.vT));',
  3245. '']));
  3246. end;
  3247. procedure TTestModule.TestSet_Functions;
  3248. begin
  3249. StartProgram(false);
  3250. Add('type');
  3251. Add(' TMyEnum = (Red, Green);');
  3252. Add(' TMyEnums = set of TMyEnum;');
  3253. Add('var');
  3254. Add(' e: TMyEnum;');
  3255. Add(' s: TMyEnums;');
  3256. Add('begin');
  3257. Add(' e:=Low(TMyEnums);');
  3258. Add(' e:=Low(s);');
  3259. Add(' e:=High(TMyEnums);');
  3260. Add(' e:=High(s);');
  3261. ConvertProgram;
  3262. CheckSource('TestSetFunctions',
  3263. LinesToStr([ // statements
  3264. 'this.TMyEnum = {',
  3265. ' "0":"Red",',
  3266. ' Red:0,',
  3267. ' "1":"Green",',
  3268. ' Green:1',
  3269. ' };',
  3270. 'this.e = 0;',
  3271. 'this.s = {};'
  3272. ]),
  3273. LinesToStr([
  3274. '$mod.e=$mod.TMyEnum.Red;',
  3275. '$mod.e=$mod.TMyEnum.Red;',
  3276. '$mod.e=$mod.TMyEnum.Green;',
  3277. '$mod.e=$mod.TMyEnum.Green;',
  3278. '']));
  3279. end;
  3280. procedure TTestModule.TestSet_PassAsArgClone;
  3281. begin
  3282. StartProgram(false);
  3283. Add('type');
  3284. Add(' TMyEnum = (Red, Green);');
  3285. Add(' TMyEnums = set of TMyEnum;');
  3286. Add('procedure DoDefault(s: tmyenums); begin end;');
  3287. Add('procedure DoConst(const s: tmyenums); begin end;');
  3288. Add('var');
  3289. Add(' aSet: tmyenums;');
  3290. Add('begin');
  3291. Add(' dodefault(aset);');
  3292. Add(' doconst(aset);');
  3293. ConvertProgram;
  3294. CheckSource('TestSetFunctions',
  3295. LinesToStr([ // statements
  3296. 'this.TMyEnum = {',
  3297. ' "0":"Red",',
  3298. ' Red:0,',
  3299. ' "1":"Green",',
  3300. ' Green:1',
  3301. ' };',
  3302. 'this.DoDefault = function (s) {',
  3303. '};',
  3304. 'this.DoConst = function (s) {',
  3305. '};',
  3306. 'this.aSet = {};'
  3307. ]),
  3308. LinesToStr([
  3309. '$mod.DoDefault(rtl.refSet($mod.aSet));',
  3310. '$mod.DoConst($mod.aSet);',
  3311. '']));
  3312. end;
  3313. procedure TTestModule.TestSet_AsParams;
  3314. begin
  3315. StartProgram(false);
  3316. Add('type TEnum = (Red,Blue);');
  3317. Add('type TEnums = set of TEnum;');
  3318. Add('procedure DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums);');
  3319. Add('var vJ: TEnums;');
  3320. Add('begin');
  3321. Add(' vg:=vg;');
  3322. Add(' vj:=vh;');
  3323. Add(' vi:=vi;');
  3324. Add(' doit(vg,vg,vg);');
  3325. Add(' doit(vh,vh,vj);');
  3326. Add(' doit(vi,vi,vi);');
  3327. Add(' doit(vj,vj,vj);');
  3328. Add('end;');
  3329. Add('var i: TEnums;');
  3330. Add('begin');
  3331. Add(' doit(i,i,i);');
  3332. ConvertProgram;
  3333. CheckSource('TestSet_AsParams',
  3334. LinesToStr([ // statements
  3335. 'this.TEnum = {',
  3336. ' "0": "Red",',
  3337. ' Red: 0,',
  3338. ' "1": "Blue",',
  3339. ' Blue: 1',
  3340. '};',
  3341. 'this.DoIt = function (vG,vH,vI) {',
  3342. ' var vJ = {};',
  3343. ' vG = rtl.refSet(vG);',
  3344. ' vJ = rtl.refSet(vH);',
  3345. ' vI.set(rtl.refSet(vI.get()));',
  3346. ' $mod.DoIt(rtl.refSet(vG), vG, {',
  3347. ' get: function () {',
  3348. ' return vG;',
  3349. ' },',
  3350. ' set: function (v) {',
  3351. ' vG = v;',
  3352. ' }',
  3353. ' });',
  3354. ' $mod.DoIt(rtl.refSet(vH), vH, {',
  3355. ' get: function () {',
  3356. ' return vJ;',
  3357. ' },',
  3358. ' set: function (v) {',
  3359. ' vJ = v;',
  3360. ' }',
  3361. ' });',
  3362. ' $mod.DoIt(rtl.refSet(vI.get()), vI.get(), vI);',
  3363. ' $mod.DoIt(rtl.refSet(vJ), vJ, {',
  3364. ' get: function () {',
  3365. ' return vJ;',
  3366. ' },',
  3367. ' set: function (v) {',
  3368. ' vJ = v;',
  3369. ' }',
  3370. ' });',
  3371. '};',
  3372. 'this.i = {};'
  3373. ]),
  3374. LinesToStr([
  3375. '$mod.DoIt(rtl.refSet($mod.i),$mod.i,{',
  3376. ' p: $mod,',
  3377. ' get: function () {',
  3378. ' return this.p.i;',
  3379. ' },',
  3380. ' set: function (v) {',
  3381. ' this.p.i = v;',
  3382. ' }',
  3383. '});'
  3384. ]));
  3385. end;
  3386. procedure TTestModule.TestSet_Property;
  3387. begin
  3388. StartProgram(false);
  3389. Add('type');
  3390. Add(' TEnum = (Red,Blue);');
  3391. Add(' TEnums = set of TEnum;');
  3392. Add(' TObject = class');
  3393. Add(' function GetColors: TEnums; external name ''GetColors'';');
  3394. Add(' procedure SetColors(const Value: TEnums); external name ''SetColors'';');
  3395. Add(' property Colors: TEnums read GetColors write SetColors;');
  3396. Add(' end;');
  3397. Add('procedure DoIt(i: TEnums; const j: TEnums; var k: TEnums; out l: TEnums);');
  3398. Add('begin end;');
  3399. Add('var Obj: TObject;');
  3400. Add('begin');
  3401. Add(' Include(Obj.Colors,Red);');
  3402. Add(' Exclude(Obj.Colors,Red);');
  3403. //Add(' DoIt(Obj.Colors,Obj.Colors,Obj.Colors,Obj.Colors);');
  3404. ConvertProgram;
  3405. CheckSource('TestSet_Property',
  3406. LinesToStr([ // statements
  3407. 'this.TEnum = {',
  3408. ' "0": "Red",',
  3409. ' Red: 0,',
  3410. ' "1": "Blue",',
  3411. ' Blue: 1',
  3412. '};',
  3413. 'rtl.createClass($mod, "TObject", null, function () {',
  3414. ' this.$init = function () {',
  3415. ' };',
  3416. ' this.$final = function () {',
  3417. ' };',
  3418. '});',
  3419. 'this.DoIt = function (i, j, k, l) {',
  3420. '};',
  3421. 'this.Obj = null;',
  3422. '']),
  3423. LinesToStr([
  3424. '$mod.Obj.SetColors(rtl.includeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  3425. '$mod.Obj.SetColors(rtl.excludeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  3426. '']));
  3427. end;
  3428. procedure TTestModule.TestSet_EnumConst;
  3429. begin
  3430. StartProgram(false);
  3431. Add('type');
  3432. Add(' TEnum = (Red,Blue);');
  3433. Add(' TEnums = set of TEnum;');
  3434. Add('const');
  3435. Add(' Orange = red;');
  3436. Add('var');
  3437. Add(' Enum: tenum;');
  3438. Add(' Enums: tenums;');
  3439. Add('begin');
  3440. Add(' Include(enums,orange);');
  3441. Add(' Exclude(enums,orange);');
  3442. Add(' if orange in enums then;');
  3443. Add(' if orange in [orange,red] then;');
  3444. ConvertProgram;
  3445. CheckSource('TestEnumConst',
  3446. LinesToStr([ // statements
  3447. 'this.TEnum = {',
  3448. ' "0": "Red",',
  3449. ' Red: 0,',
  3450. ' "1": "Blue",',
  3451. ' Blue: 1',
  3452. '};',
  3453. 'this.Orange = $mod.TEnum.Red;',
  3454. 'this.Enum = 0;',
  3455. 'this.Enums = {};',
  3456. '']),
  3457. LinesToStr([
  3458. '$mod.Enums = rtl.includeSet($mod.Enums, $mod.Orange);',
  3459. '$mod.Enums = rtl.excludeSet($mod.Enums, $mod.Orange);',
  3460. 'if ($mod.Orange in $mod.Enums) ;',
  3461. 'if ($mod.Orange in rtl.createSet($mod.Orange, $mod.TEnum.Red)) ;',
  3462. '']));
  3463. end;
  3464. procedure TTestModule.TestSet_AnonymousEnumType;
  3465. begin
  3466. StartProgram(false);
  3467. Add('type');
  3468. Add(' TFlags = set of (red, green);');
  3469. Add('const');
  3470. Add(' favorite = red;');
  3471. Add('var');
  3472. Add(' f: TFlags;');
  3473. Add(' i: longint;');
  3474. Add('begin');
  3475. Add(' Include(f,red);');
  3476. Add(' Include(f,favorite);');
  3477. Add(' i:=ord(red);');
  3478. Add(' i:=ord(favorite);');
  3479. Add(' i:=ord(low(TFlags));');
  3480. Add(' i:=ord(low(f));');
  3481. Add(' i:=ord(low(favorite));');
  3482. Add(' i:=ord(high(TFlags));');
  3483. Add(' i:=ord(high(f));');
  3484. Add(' i:=ord(high(favorite));');
  3485. Add(' f:=[green,favorite];');
  3486. ConvertProgram;
  3487. CheckSource('TestSet_AnonymousEnumType',
  3488. LinesToStr([ // statements
  3489. 'this.TFlags$a = {',
  3490. ' "0": "red",',
  3491. ' red: 0,',
  3492. ' "1": "green",',
  3493. ' green: 1',
  3494. '};',
  3495. 'this.favorite = $mod.TFlags$a.red;',
  3496. 'this.f = {};',
  3497. 'this.i = 0;',
  3498. '']),
  3499. LinesToStr([
  3500. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  3501. '$mod.f = rtl.includeSet($mod.f, $mod.favorite);',
  3502. '$mod.i = $mod.TFlags$a.red;',
  3503. '$mod.i = $mod.favorite;',
  3504. '$mod.i = $mod.TFlags$a.red;',
  3505. '$mod.i = $mod.TFlags$a.red;',
  3506. '$mod.i = $mod.TFlags$a.red;',
  3507. '$mod.i = $mod.TFlags$a.green;',
  3508. '$mod.i = $mod.TFlags$a.green;',
  3509. '$mod.i = $mod.TFlags$a.green;',
  3510. '$mod.f = rtl.createSet($mod.TFlags$a.green, $mod.favorite);',
  3511. '']));
  3512. end;
  3513. procedure TTestModule.TestSet_ConstEnum;
  3514. begin
  3515. StartProgram(false);
  3516. Add([
  3517. 'type',
  3518. ' TEnum = (red,blue,green);',
  3519. ' TEnums = set of TEnum;',
  3520. 'const',
  3521. ' teAny = [low(TEnum)..high(TEnum)];',
  3522. ' teRedBlue = [low(TEnum)..pred(high(TEnum))];',
  3523. 'var',
  3524. ' e: TEnum;',
  3525. ' s: TEnums;',
  3526. 'begin',
  3527. ' if blue in teAny then;',
  3528. ' if blue in teAny+[e] then;',
  3529. ' if blue in teAny+teRedBlue then;',
  3530. ' if e in [red,blue] then;',
  3531. ' s:=teAny;',
  3532. ' s:=teAny+[e];',
  3533. ' s:=[e]+teAny;',
  3534. ' s:=teAny+teRedBlue;',
  3535. ' s:=teAny+teRedBlue+[e];',
  3536. '']);
  3537. ConvertProgram;
  3538. CheckSource('TestSet_ConstEnum',
  3539. LinesToStr([ // statements
  3540. 'this.TEnum = {',
  3541. ' "0": "red",',
  3542. ' red: 0,',
  3543. ' "1": "blue",',
  3544. ' blue: 1,',
  3545. ' "2": "green",',
  3546. ' green: 2',
  3547. '};',
  3548. 'this.teAny = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green);',
  3549. 'this.teRedBlue = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green - 1);',
  3550. 'this.e = 0;',
  3551. 'this.s = {};',
  3552. '']),
  3553. LinesToStr([
  3554. 'if ($mod.TEnum.blue in $mod.teAny) ;',
  3555. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, rtl.createSet($mod.e))) ;',
  3556. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, $mod.teRedBlue)) ;',
  3557. 'if ($mod.e in rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)) ;',
  3558. '$mod.s = rtl.refSet($mod.teAny);',
  3559. '$mod.s = rtl.unionSet($mod.teAny, rtl.createSet($mod.e));',
  3560. '$mod.s = rtl.unionSet(rtl.createSet($mod.e), $mod.teAny);',
  3561. '$mod.s = rtl.unionSet($mod.teAny, $mod.teRedBlue);',
  3562. '$mod.s = rtl.unionSet(rtl.unionSet($mod.teAny, $mod.teRedBlue), rtl.createSet($mod.e));',
  3563. '']));
  3564. end;
  3565. procedure TTestModule.TestSet_ConstChar;
  3566. begin
  3567. StartProgram(false);
  3568. Add([
  3569. 'const',
  3570. ' LowChars = [''a''..''z''];',
  3571. ' Chars = LowChars+[''A''..''Z''];',
  3572. 'var',
  3573. ' c: char;',
  3574. ' s: string;',
  3575. 'begin',
  3576. ' if c in lowchars then ;',
  3577. ' if ''a'' in lowchars then ;',
  3578. ' if s[1] in lowchars then ;',
  3579. ' if c in chars then ;',
  3580. ' if c in [''a''..''z'',''_''] then ;',
  3581. ' if ''b'' in [''a''..''z'',''_''] then ;',
  3582. '']);
  3583. ConvertProgram;
  3584. CheckSource('TestSet_ConstChar',
  3585. LinesToStr([ // statements
  3586. 'this.LowChars = rtl.createSet(null, 97, 122);',
  3587. 'this.Chars = rtl.unionSet($mod.LowChars, rtl.createSet(null, 65, 90));',
  3588. 'this.c = "";',
  3589. 'this.s = "";',
  3590. '']),
  3591. LinesToStr([
  3592. 'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
  3593. 'if (97 in $mod.LowChars) ;',
  3594. 'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
  3595. 'if ($mod.c.charCodeAt() in $mod.Chars) ;',
  3596. 'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
  3597. 'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
  3598. '']));
  3599. end;
  3600. procedure TTestModule.TestSet_ConstInt;
  3601. begin
  3602. StartProgram(false);
  3603. Add([
  3604. 'const',
  3605. ' Months = [1..12];',
  3606. ' Mirror = [-12..-1]+Months;',
  3607. 'var',
  3608. ' i: smallint;',
  3609. 'begin',
  3610. ' if 3 in Months then;',
  3611. ' if i in Months+[i] then;',
  3612. ' if i in Months+Mirror then;',
  3613. ' if i in [4..6,8] then;',
  3614. '']);
  3615. ConvertProgram;
  3616. CheckSource('TestSet_ConstInt',
  3617. LinesToStr([ // statements
  3618. 'this.Months = rtl.createSet(null, 1, 12);',
  3619. 'this.Mirror = rtl.unionSet(rtl.createSet(null, -12, -1), $mod.Months);',
  3620. 'this.i = 0;',
  3621. '']),
  3622. LinesToStr([
  3623. 'if (3 in $mod.Months) ;',
  3624. 'if ($mod.i in rtl.unionSet($mod.Months, rtl.createSet($mod.i))) ;',
  3625. 'if ($mod.i in rtl.unionSet($mod.Months, $mod.Mirror)) ;',
  3626. 'if ($mod.i in rtl.createSet(null, 4, 6, 8)) ;',
  3627. '']));
  3628. end;
  3629. procedure TTestModule.TestNestBegin;
  3630. begin
  3631. StartProgram(false);
  3632. Add('begin');
  3633. Add(' begin');
  3634. Add(' begin');
  3635. Add(' end;');
  3636. Add(' begin');
  3637. Add(' if true then ;');
  3638. Add(' end;');
  3639. Add(' end;');
  3640. ConvertProgram;
  3641. CheckSource('TestNestBegin',
  3642. '',
  3643. 'if (true) ;');
  3644. end;
  3645. procedure TTestModule.TestUnitImplVars;
  3646. begin
  3647. StartUnit(false);
  3648. Add('interface');
  3649. Add('implementation');
  3650. Add('var');
  3651. Add(' V1:longint;');
  3652. Add(' V2:longint = 3;');
  3653. Add(' V3:string = ''abc'';');
  3654. ConvertUnit;
  3655. CheckSource('TestUnitImplVars',
  3656. LinesToStr([ // statements
  3657. 'var $impl = $mod.$impl;',
  3658. '']),
  3659. '', // this.$init
  3660. LinesToStr([ // implementation
  3661. '$impl.V1 = 0;',
  3662. '$impl.V2 = 3;',
  3663. '$impl.V3 = "abc";',
  3664. '']) );
  3665. end;
  3666. procedure TTestModule.TestUnitImplConsts;
  3667. begin
  3668. StartUnit(false);
  3669. Add('interface');
  3670. Add('implementation');
  3671. Add('const');
  3672. Add(' v1 = 3;');
  3673. Add(' v2:longint = 4;');
  3674. Add(' v3:string = ''abc'';');
  3675. ConvertUnit;
  3676. CheckSource('TestUnitImplConsts',
  3677. LinesToStr([ // statements
  3678. 'var $impl = $mod.$impl;',
  3679. '']),
  3680. '', // this.$init
  3681. LinesToStr([ // implementation
  3682. '$impl.v1 = 3;',
  3683. '$impl.v2 = 4;',
  3684. '$impl.v3 = "abc";',
  3685. '']) );
  3686. end;
  3687. procedure TTestModule.TestUnitImplRecord;
  3688. begin
  3689. StartUnit(false);
  3690. Add('interface');
  3691. Add('implementation');
  3692. Add('type');
  3693. Add(' TMyRecord = record');
  3694. Add(' i: longint;');
  3695. Add(' end;');
  3696. Add('var aRec: TMyRecord;');
  3697. Add('initialization');
  3698. Add(' arec.i:=3;');
  3699. ConvertUnit;
  3700. CheckSource('TestUnitImplRecord',
  3701. LinesToStr([ // statements
  3702. 'var $impl = $mod.$impl;',
  3703. '']),
  3704. // this.$init
  3705. '$impl.aRec.i = 3;',
  3706. LinesToStr([ // implementation
  3707. '$impl.TMyRecord = function (s) {',
  3708. ' if (s) {',
  3709. ' this.i = s.i;',
  3710. ' } else {',
  3711. ' this.i = 0;',
  3712. ' };',
  3713. ' this.$equal = function (b) {',
  3714. ' return this.i === b.i;',
  3715. ' };',
  3716. '};',
  3717. '$impl.aRec = new $impl.TMyRecord();',
  3718. '']) );
  3719. end;
  3720. procedure TTestModule.TestRenameJSNameConflict;
  3721. begin
  3722. StartProgram(false);
  3723. Add('var apply: longint;');
  3724. Add('var bind: longint;');
  3725. Add('var call: longint;');
  3726. Add('begin');
  3727. ConvertProgram;
  3728. CheckSource('TestRenameJSNameConflict',
  3729. LinesToStr([ // statements
  3730. 'this.Apply = 0;',
  3731. 'this.Bind = 0;',
  3732. 'this.Call = 0;'
  3733. ]),
  3734. LinesToStr([ // this.$main
  3735. ''
  3736. ]));
  3737. end;
  3738. procedure TTestModule.TestLocalConst;
  3739. begin
  3740. StartProgram(false);
  3741. Add('procedure DoIt;');
  3742. Add('const');
  3743. Add(' cA: longint = 1;');
  3744. Add(' cB = 2;');
  3745. Add(' procedure Sub;');
  3746. Add(' const');
  3747. Add(' csA = 3;');
  3748. Add(' cB: double = 4;');
  3749. Add(' begin');
  3750. Add(' cb:=cb+csa;');
  3751. Add(' ca:=ca+csa+5;');
  3752. Add(' end;');
  3753. Add('begin');
  3754. Add(' ca:=ca+cb+6;');
  3755. Add('end;');
  3756. Add('begin');
  3757. ConvertProgram;
  3758. CheckSource('TestLocalConst',
  3759. LinesToStr([
  3760. 'var cA = 1;',
  3761. 'var cB = 2;',
  3762. 'var csA = 3;',
  3763. 'var cB$1 = 4;',
  3764. 'this.DoIt = function () {',
  3765. ' function Sub() {',
  3766. ' cB$1 = cB$1 + csA;',
  3767. ' cA = (cA + csA) + 5;',
  3768. ' };',
  3769. ' cA = (cA + cB) + 6;',
  3770. '};'
  3771. ]),
  3772. LinesToStr([
  3773. ]));
  3774. end;
  3775. procedure TTestModule.TestVarExternal;
  3776. begin
  3777. StartProgram(false);
  3778. Add('var');
  3779. Add(' NaN: double; external name ''Global.NaN'';');
  3780. Add(' d: double;');
  3781. Add('begin');
  3782. Add(' d:=NaN;');
  3783. ConvertProgram;
  3784. CheckSource('TestVarExternal',
  3785. LinesToStr([
  3786. 'this.d = 0.0;'
  3787. ]),
  3788. LinesToStr([
  3789. '$mod.d = Global.NaN;'
  3790. ]));
  3791. end;
  3792. procedure TTestModule.TestVarExternalOtherUnit;
  3793. begin
  3794. AddModuleWithIntfImplSrc('unit2.pas',
  3795. LinesToStr([
  3796. 'var NaN: double; external name ''Global.NaN'';',
  3797. 'var iV: longint;'
  3798. ]),
  3799. '');
  3800. StartUnit(true);
  3801. Add('interface');
  3802. Add('uses unit2;');
  3803. Add('implementation');
  3804. Add('var');
  3805. Add(' d: double;');
  3806. Add(' i: longint; external name ''$i'';');
  3807. Add('begin');
  3808. Add(' d:=nan;');
  3809. Add(' d:=uNit2.nan;');
  3810. Add(' d:=test1.d;');
  3811. Add(' i:=iv;');
  3812. Add(' i:=uNit2.iv;');
  3813. Add(' i:=test1.i;');
  3814. ConvertUnit;
  3815. CheckSource('TestVarExternalOtherUnit',
  3816. LinesToStr([
  3817. 'var $impl = $mod.$impl;',
  3818. '']),
  3819. LinesToStr([ // this.$init
  3820. '$impl.d = Global.NaN;',
  3821. '$impl.d = Global.NaN;',
  3822. '$impl.d = $impl.d;',
  3823. '$i = pas.unit2.iV;',
  3824. '$i = pas.unit2.iV;',
  3825. '$i = $i;',
  3826. '']),
  3827. LinesToStr([ // implementation
  3828. '$impl.d = 0.0;',
  3829. '']) );
  3830. end;
  3831. procedure TTestModule.TestVarAbsoluteFail;
  3832. begin
  3833. StartProgram(false);
  3834. Add([
  3835. 'var',
  3836. ' a: longint;',
  3837. ' b: longword absolute a;',
  3838. 'begin']);
  3839. SetExpectedPasResolverError('Invalid variable modifier "absolute"',nInvalidVariableModifier);
  3840. ConvertProgram;
  3841. end;
  3842. procedure TTestModule.TestDouble;
  3843. begin
  3844. StartProgram(false);
  3845. Add([
  3846. 'var',
  3847. ' d: double;',
  3848. 'begin',
  3849. ' d:=1.0;',
  3850. ' d:=1.0/3.0;',
  3851. ' d:=1/3;',
  3852. ' d:=5.0E-324;',
  3853. ' d:=1.7E308;',
  3854. ' d:=10**3;',
  3855. ' d:=10 mod 3;',
  3856. ' d:=10 div 3;',
  3857. '']);
  3858. ConvertProgram;
  3859. CheckSource('TestDouble',
  3860. LinesToStr([
  3861. 'this.d=0.0;'
  3862. ]),
  3863. LinesToStr([
  3864. '$mod.d = 1.0;',
  3865. '$mod.d = 1.0 / 3.0;',
  3866. '$mod.d = 1 / 3;',
  3867. '$mod.d = 5.0E-324;',
  3868. '$mod.d = 1.7E308;',
  3869. '$mod.d = Math.pow(10, 3);',
  3870. '$mod.d = 10 % 3;',
  3871. '$mod.d = Math.floor(10 / 3);',
  3872. '']));
  3873. end;
  3874. procedure TTestModule.TestIntegerRange;
  3875. begin
  3876. StartProgram(false);
  3877. Add([
  3878. 'const',
  3879. ' MinInt = -1;',
  3880. ' MaxInt = +1;',
  3881. 'type',
  3882. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  3883. ' TInt2 = 1..3;',
  3884. 'const',
  3885. ' a = low(TMyInt)+High(TMyInt);',
  3886. ' b = low(TInt2)+High(TInt2);',
  3887. ' s1 = [1];',
  3888. ' s2 = [1,2];',
  3889. ' s3 = [1..3];',
  3890. ' s4 = [low(shortint)..high(shortint)];',
  3891. ' s5 = [succ(low(shortint))..pred(high(shortint))];',
  3892. ' s6 = 1 in s2;',
  3893. 'var',
  3894. ' i: TMyInt;',
  3895. ' i2: TInt2;',
  3896. 'begin',
  3897. ' i:=i2;',
  3898. ' if i=i2 then ;']);
  3899. ConvertProgram;
  3900. CheckSource('TestIntegerRange',
  3901. LinesToStr([
  3902. 'this.MinInt = -1;',
  3903. 'this.MaxInt = +1;',
  3904. 'this.a = -1 + 1;',
  3905. 'this.b = 1 + 3;',
  3906. 'this.s1 = rtl.createSet(1);',
  3907. 'this.s2 = rtl.createSet(1, 2);',
  3908. 'this.s3 = rtl.createSet(null, 1, 3);',
  3909. 'this.s4 = rtl.createSet(null, -128, 127);',
  3910. 'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
  3911. 'this.s6 = 1 in $mod.s2;',
  3912. 'this.i = -1;',
  3913. 'this.i2 = 1;',
  3914. '']),
  3915. LinesToStr([
  3916. '$mod.i = $mod.i2;',
  3917. 'if ($mod.i === $mod.i2) ;',
  3918. '']));
  3919. end;
  3920. procedure TTestModule.TestForBoolDo;
  3921. begin
  3922. StartProgram(false);
  3923. Add([
  3924. 'var b: boolean;',
  3925. 'begin',
  3926. ' for b:=false to true do ;',
  3927. ' for b:=b downto false do ;',
  3928. '']);
  3929. ConvertProgram;
  3930. CheckSource('TestForBoolDo',
  3931. LinesToStr([ // statements
  3932. 'this.b = false;']),
  3933. LinesToStr([ // this.$main
  3934. 'for (var $l1 = 0; $l1 <= 1; $l1++) $mod.b = $l1 != 0;',
  3935. 'for (var $l2 = +$mod.b; $l2 >= 0; $l2--) $mod.b = $l2 != 0;',
  3936. '']));
  3937. end;
  3938. procedure TTestModule.TestCharConst;
  3939. begin
  3940. StartProgram(false);
  3941. Add('const');
  3942. Add(' c: char = ''1'';');
  3943. Add('begin');
  3944. Add(' c:=#0;');
  3945. Add(' c:=#1;');
  3946. Add(' c:=#9;');
  3947. Add(' c:=#10;');
  3948. Add(' c:=#13;');
  3949. Add(' c:=#31;');
  3950. Add(' c:=#32;');
  3951. Add(' c:=#$A;');
  3952. Add(' c:=#$0A;');
  3953. Add(' c:=#$b;');
  3954. Add(' c:=#$0b;');
  3955. Add(' c:=^A;');
  3956. Add(' c:=''"'';');
  3957. ConvertProgram;
  3958. CheckSource('TestCharConst',
  3959. LinesToStr([
  3960. 'this.c="1";'
  3961. ]),
  3962. LinesToStr([
  3963. '$mod.c="\x00";',
  3964. '$mod.c="\x01";',
  3965. '$mod.c="\t";',
  3966. '$mod.c="\n";',
  3967. '$mod.c="\r";',
  3968. '$mod.c="\x1F";',
  3969. '$mod.c=" ";',
  3970. '$mod.c="\n";',
  3971. '$mod.c="\n";',
  3972. '$mod.c="\x0B";',
  3973. '$mod.c="\x0B";',
  3974. '$mod.c="\x01";',
  3975. '$mod.c=''"'';'
  3976. ]));
  3977. end;
  3978. procedure TTestModule.TestChar_Compare;
  3979. begin
  3980. StartProgram(false);
  3981. Add('var');
  3982. Add(' c: char;');
  3983. Add(' b: boolean;');
  3984. Add('begin');
  3985. Add(' b:=c=''1'';');
  3986. Add(' b:=''2''=c;');
  3987. Add(' b:=''3''=''4'';');
  3988. Add(' b:=c<>''5'';');
  3989. Add(' b:=''6''<>c;');
  3990. Add(' b:=c>''7'';');
  3991. Add(' b:=''8''>c;');
  3992. Add(' b:=c>=''9'';');
  3993. Add(' b:=''A''>=c;');
  3994. Add(' b:=c<''B'';');
  3995. Add(' b:=''C''<c;');
  3996. Add(' b:=c<=''D'';');
  3997. Add(' b:=''E''<=c;');
  3998. ConvertProgram;
  3999. CheckSource('TestChar_Compare',
  4000. LinesToStr([
  4001. 'this.c="";',
  4002. 'this.b = false;'
  4003. ]),
  4004. LinesToStr([
  4005. '$mod.b = $mod.c === "1";',
  4006. '$mod.b = "2" === $mod.c;',
  4007. '$mod.b = "3" === "4";',
  4008. '$mod.b = $mod.c !== "5";',
  4009. '$mod.b = "6" !== $mod.c;',
  4010. '$mod.b = $mod.c > "7";',
  4011. '$mod.b = "8" > $mod.c;',
  4012. '$mod.b = $mod.c >= "9";',
  4013. '$mod.b = "A" >= $mod.c;',
  4014. '$mod.b = $mod.c < "B";',
  4015. '$mod.b = "C" < $mod.c;',
  4016. '$mod.b = $mod.c <= "D";',
  4017. '$mod.b = "E" <= $mod.c;',
  4018. '']));
  4019. end;
  4020. procedure TTestModule.TestChar_Ord;
  4021. begin
  4022. StartProgram(false);
  4023. Add('var');
  4024. Add(' c: char;');
  4025. Add(' i: longint;');
  4026. Add(' s: string;');
  4027. Add('begin');
  4028. Add(' i:=ord(c);');
  4029. Add(' i:=ord(s[i]);');
  4030. ConvertProgram;
  4031. CheckSource('TestChar_Ord',
  4032. LinesToStr([
  4033. 'this.c = "";',
  4034. 'this.i = 0;',
  4035. 'this.s = "";'
  4036. ]),
  4037. LinesToStr([
  4038. '$mod.i = $mod.c.charCodeAt();',
  4039. '$mod.i = $mod.s.charCodeAt($mod.i-1);',
  4040. '']));
  4041. end;
  4042. procedure TTestModule.TestChar_Chr;
  4043. begin
  4044. StartProgram(false);
  4045. Add('var');
  4046. Add(' c: char;');
  4047. Add(' i: longint;');
  4048. Add('begin');
  4049. Add(' c:=chr(i);');
  4050. ConvertProgram;
  4051. CheckSource('TestChar_Chr',
  4052. LinesToStr([
  4053. 'this.c = "";',
  4054. 'this.i = 0;'
  4055. ]),
  4056. LinesToStr([
  4057. '$mod.c = String.fromCharCode($mod.i);',
  4058. '']));
  4059. end;
  4060. procedure TTestModule.TestStringConst;
  4061. begin
  4062. StartProgram(false);
  4063. Add('var');
  4064. Add(' s: string = ''abc'';');
  4065. Add('begin');
  4066. Add(' s:='''';');
  4067. Add(' s:=#13#10;');
  4068. Add(' s:=#9''foo'';');
  4069. Add(' s:=#$A9;');
  4070. Add(' s:=''foo''#13''bar'';');
  4071. Add(' s:=''"'';');
  4072. Add(' s:=''"''''"'';');
  4073. ConvertProgram;
  4074. CheckSource('TestStringConst',
  4075. LinesToStr([
  4076. 'this.s="abc";'
  4077. ]),
  4078. LinesToStr([
  4079. '$mod.s="";',
  4080. '$mod.s="\r\n";',
  4081. '$mod.s="\tfoo";',
  4082. '$mod.s="©";',
  4083. '$mod.s="foo\rbar";',
  4084. '$mod.s=''"'';',
  4085. '$mod.s=''"\''"'';'
  4086. ]));
  4087. end;
  4088. procedure TTestModule.TestString_Length;
  4089. begin
  4090. StartProgram(false);
  4091. Add('const c = ''foo'';');
  4092. Add('var');
  4093. Add(' s: string;');
  4094. Add(' i: longint;');
  4095. Add('begin');
  4096. Add(' i:=length(s);');
  4097. Add(' i:=length(s+s);');
  4098. Add(' i:=length(''abc'');');
  4099. Add(' i:=length(c);');
  4100. ConvertProgram;
  4101. CheckSource('TestString_Length',
  4102. LinesToStr([
  4103. 'this.c = "foo";',
  4104. 'this.s = "";',
  4105. 'this.i = 0;',
  4106. '']),
  4107. LinesToStr([
  4108. '$mod.i = $mod.s.length;',
  4109. '$mod.i = ($mod.s+$mod.s).length;',
  4110. '$mod.i = "abc".length;',
  4111. '$mod.i = $mod.c.length;',
  4112. '']));
  4113. end;
  4114. procedure TTestModule.TestString_Compare;
  4115. begin
  4116. StartProgram(false);
  4117. Add('var');
  4118. Add(' s, t: string;');
  4119. Add(' b: boolean;');
  4120. Add('begin');
  4121. Add(' b:=s=t;');
  4122. Add(' b:=s<>t;');
  4123. Add(' b:=s>t;');
  4124. Add(' b:=s>=t;');
  4125. Add(' b:=s<t;');
  4126. Add(' b:=s<=t;');
  4127. ConvertProgram;
  4128. CheckSource('TestString_Compare',
  4129. LinesToStr([ // statements
  4130. 'this.s = "";',
  4131. 'this.t = "";',
  4132. 'this.b =false;'
  4133. ]),
  4134. LinesToStr([ // this.$main
  4135. '$mod.b = $mod.s === $mod.t;',
  4136. '$mod.b = $mod.s !== $mod.t;',
  4137. '$mod.b = $mod.s > $mod.t;',
  4138. '$mod.b = $mod.s >= $mod.t;',
  4139. '$mod.b = $mod.s < $mod.t;',
  4140. '$mod.b = $mod.s <= $mod.t;',
  4141. '']));
  4142. end;
  4143. procedure TTestModule.TestString_SetLength;
  4144. begin
  4145. StartProgram(false);
  4146. Add([
  4147. 'procedure DoIt(var s: string);',
  4148. 'begin',
  4149. ' SetLength(s,2);',
  4150. 'end;',
  4151. 'var s: string;',
  4152. 'begin',
  4153. ' SetLength(s,3);',
  4154. '']);
  4155. ConvertProgram;
  4156. CheckSource('TestString_SetLength',
  4157. LinesToStr([ // statements
  4158. 'this.DoIt = function (s) {',
  4159. ' s.set(rtl.strSetLength(s.get(), 2));',
  4160. '};',
  4161. 'this.s = "";',
  4162. '']),
  4163. LinesToStr([ // this.$main
  4164. '$mod.s = rtl.strSetLength($mod.s, 3);'
  4165. ]));
  4166. end;
  4167. procedure TTestModule.TestString_CharAt;
  4168. begin
  4169. StartProgram(false);
  4170. Add('var');
  4171. Add(' s: string;');
  4172. Add(' c: char;');
  4173. Add(' b: boolean;');
  4174. Add('begin');
  4175. Add(' b:= s[1] = c;');
  4176. Add(' b:= c = s[1];');
  4177. Add(' b:= c <> s[1];');
  4178. Add(' b:= c > s[1];');
  4179. Add(' b:= c >= s[1];');
  4180. Add(' b:= c < s[2];');
  4181. Add(' b:= c <= s[1];');
  4182. Add(' s[1] := c;');
  4183. Add(' s[2+3] := c;');
  4184. ConvertProgram;
  4185. CheckSource('TestString_CharAt',
  4186. LinesToStr([ // statements
  4187. 'this.s = "";',
  4188. 'this.c = "";',
  4189. 'this.b = false;'
  4190. ]),
  4191. LinesToStr([ // this.$main
  4192. '$mod.b = $mod.s.charAt(0) === $mod.c;',
  4193. '$mod.b = $mod.c === $mod.s.charAt(0);',
  4194. '$mod.b = $mod.c !== $mod.s.charAt(0);',
  4195. '$mod.b = $mod.c > $mod.s.charAt(0);',
  4196. '$mod.b = $mod.c >= $mod.s.charAt(0);',
  4197. '$mod.b = $mod.c < $mod.s.charAt(1);',
  4198. '$mod.b = $mod.c <= $mod.s.charAt(0);',
  4199. '$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
  4200. '$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
  4201. '']));
  4202. end;
  4203. procedure TTestModule.TestStr;
  4204. begin
  4205. StartProgram(false);
  4206. Add('var');
  4207. Add(' b: boolean;');
  4208. Add(' i: longint;');
  4209. Add(' d: double;');
  4210. Add(' s: string;');
  4211. Add('begin');
  4212. Add(' str(b,s);');
  4213. Add(' str(i,s);');
  4214. Add(' str(d,s);');
  4215. Add(' str(i:3,s);');
  4216. Add(' str(d:3:2,s);');
  4217. Add(' Str(12.456:12:1,s);');
  4218. Add(' Str(12.456:12,s);');
  4219. Add(' s:=str(b);');
  4220. Add(' s:=str(i);');
  4221. Add(' s:=str(d);');
  4222. Add(' s:=str(i,i);');
  4223. Add(' s:=str(i:3);');
  4224. Add(' s:=str(d:3:2);');
  4225. Add(' s:=str(i:4,i);');
  4226. Add(' s:=str(i,i:5);');
  4227. Add(' s:=str(i:4,i:5);');
  4228. Add(' s:=str(s,s);');
  4229. Add(' s:=str(s,''foo'');');
  4230. ConvertProgram;
  4231. CheckSource('TestStr',
  4232. LinesToStr([ // statements
  4233. 'this.b = false;',
  4234. 'this.i = 0;',
  4235. 'this.d = 0.0;',
  4236. 'this.s = "";',
  4237. '']),
  4238. LinesToStr([ // this.$main
  4239. '$mod.s = ""+$mod.b;',
  4240. '$mod.s = ""+$mod.i;',
  4241. '$mod.s = rtl.floatToStr($mod.d);',
  4242. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  4243. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  4244. '$mod.s = rtl.floatToStr(12.456,12,1);',
  4245. '$mod.s = rtl.floatToStr(12.456,12);',
  4246. '$mod.s = ""+$mod.b;',
  4247. '$mod.s = ""+$mod.i;',
  4248. '$mod.s = rtl.floatToStr($mod.d);',
  4249. '$mod.s = (""+$mod.i)+$mod.i;',
  4250. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  4251. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  4252. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
  4253. '$mod.s = ("" + $mod.i) + rtl.spaceLeft("" + $mod.i, 5);',
  4254. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
  4255. '$mod.s = $mod.s + $mod.s;',
  4256. '$mod.s = $mod.s + "foo";',
  4257. '']));
  4258. end;
  4259. procedure TTestModule.TestBaseType_AnsiStringFail;
  4260. begin
  4261. StartProgram(false);
  4262. Add('var s: AnsiString');
  4263. SetExpectedPasResolverError('identifier not found "AnsiString"',PasResolveEval.nIdentifierNotFound);
  4264. ConvertProgram;
  4265. end;
  4266. procedure TTestModule.TestBaseType_WideStringFail;
  4267. begin
  4268. StartProgram(false);
  4269. Add('var s: WideString');
  4270. SetExpectedPasResolverError('identifier not found "WideString"',PasResolveEval.nIdentifierNotFound);
  4271. ConvertProgram;
  4272. end;
  4273. procedure TTestModule.TestBaseType_ShortStringFail;
  4274. begin
  4275. StartProgram(false);
  4276. Add('var s: ShortString');
  4277. SetExpectedPasResolverError('identifier not found "ShortString"',PasResolveEval.nIdentifierNotFound);
  4278. ConvertProgram;
  4279. end;
  4280. procedure TTestModule.TestBaseType_RawByteStringFail;
  4281. begin
  4282. StartProgram(false);
  4283. Add('var s: RawByteString');
  4284. SetExpectedPasResolverError('identifier not found "RawByteString"',PasResolveEval.nIdentifierNotFound);
  4285. ConvertProgram;
  4286. end;
  4287. procedure TTestModule.TestTypeShortstring_Fail;
  4288. begin
  4289. StartProgram(false);
  4290. Add('type t = string[12];');
  4291. Add('var s: t;');
  4292. Add('begin');
  4293. SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
  4294. ConvertProgram;
  4295. end;
  4296. procedure TTestModule.TestCharSet_Custom;
  4297. begin
  4298. StartProgram(false);
  4299. Add([
  4300. 'type',
  4301. ' TCharRg = ''a''..''z'';',
  4302. ' TSetOfCharRg = set of TCharRg;',
  4303. ' TCharRg2 = ''m''..''p'';',
  4304. 'const',
  4305. ' crg: TCharRg = ''b'';',
  4306. 'var',
  4307. ' c: char;',
  4308. ' crg2: TCharRg2;',
  4309. ' s: TSetOfCharRg;',
  4310. 'begin',
  4311. ' c:=crg;',
  4312. ' crg:=c;',
  4313. ' crg2:=crg;',
  4314. ' if c=crg then ;',
  4315. ' if crg=c then ;',
  4316. ' if crg=crg2 then ;',
  4317. ' if c in s then ;',
  4318. ' if crg2 in s then ;',
  4319. '']);
  4320. ConvertProgram;
  4321. CheckSource('TestCharSet_Custom',
  4322. LinesToStr([ // statements
  4323. 'this.crg = "b";',
  4324. 'this.c = "";',
  4325. 'this.crg2 = "m";',
  4326. 'this.s = {};',
  4327. '']),
  4328. LinesToStr([ // this.$main
  4329. '$mod.c = $mod.crg;',
  4330. '$mod.crg = $mod.c;',
  4331. '$mod.crg2 = $mod.crg;',
  4332. 'if ($mod.c === $mod.crg) ;',
  4333. 'if ($mod.crg === $mod.c) ;',
  4334. 'if ($mod.crg === $mod.crg2) ;',
  4335. 'if ($mod.c.charCodeAt() in $mod.s) ;',
  4336. 'if ($mod.crg2.charCodeAt() in $mod.s) ;',
  4337. '']));
  4338. end;
  4339. procedure TTestModule.TestForCharDo;
  4340. begin
  4341. StartProgram(false);
  4342. Add([
  4343. 'var c: char;',
  4344. 'begin',
  4345. ' for c:=''a'' to ''c'' do ;',
  4346. ' for c:=c downto ''a'' do ;',
  4347. '']);
  4348. ConvertProgram;
  4349. CheckSource('TestForCharDo',
  4350. LinesToStr([ // statements
  4351. 'this.c = "";']),
  4352. LinesToStr([ // this.$main
  4353. 'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
  4354. 'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $l2--) $mod.c = String.fromCharCode($l2);',
  4355. '']));
  4356. end;
  4357. procedure TTestModule.TestForCharInDo;
  4358. begin
  4359. StartProgram(false);
  4360. Add([
  4361. 'type',
  4362. ' TSetOfChar = set of char;',
  4363. ' TCharRg = ''a''..''z'';',
  4364. ' TSetOfCharRg = set of TCharRg;',
  4365. 'const Foo = ''foo'';',
  4366. 'var',
  4367. ' c: char;',
  4368. ' s: string;',
  4369. ' a1: array of char;',
  4370. ' a2: array[1..3] of char;',
  4371. ' a3: array[1..3,4..5] of char;',
  4372. ' soc: TSetOfChar;',
  4373. ' socr: TSetOfCharRg;',
  4374. ' cr: TCharRg;',
  4375. 'begin',
  4376. ' for c in foo do ;',
  4377. ' for c in s do ;',
  4378. ' for c in char do ;',
  4379. //' for c in a1 do ;',
  4380. //' for c in a2 do ;',
  4381. //' for c in a3 do ;',
  4382. //' for c in [''1''..''3''] do ;',
  4383. //' for c in TSetOfChar do ;',
  4384. //' for c in TCharRg do ;',
  4385. //' for c in soc do ;',
  4386. //' for c in TSetOfCharRg do ;',
  4387. //' for c in socr do ;',
  4388. //' for cr in TCharRg do ;',
  4389. //' for cr in TSetOfCharRg do ;',
  4390. //' for cr in socr do ;',
  4391. '']);
  4392. ConvertProgram;
  4393. CheckSource('TestForCharInDo',
  4394. LinesToStr([ // statements
  4395. 'this.Foo = "foo";',
  4396. 'this.c = "";',
  4397. 'this.s = "";',
  4398. 'this.a1 = [];',
  4399. 'this.a2 = rtl.arraySetLength(null, "", 3);',
  4400. 'this.a3 = rtl.arraySetLength(null, "", 3, 2);',
  4401. 'this.soc = {};',
  4402. 'this.socr = {};',
  4403. 'this.cr = "a";',
  4404. '']),
  4405. LinesToStr([ // this.$main
  4406. 'for (var ($in1 = $mod.Foo, $l2 = 0), $end3 = $in1.length - 1; $l2 <= $end3; $l2++) $mod.c = $in1.charAt($l2);',
  4407. 'for (var ($in4 = $mod.s, $l5 = 0), $end6 = $in4.length - 1; $l5 <= $end6; $l5++) $mod.c = $in4.charAt($l5);',
  4408. 'for (var $l7 = 0, $end8 = 65535; $l7 <= $end8; $l7++) $mod.c = String.fromCharCode($l7);',
  4409. '']));
  4410. end;
  4411. procedure TTestModule.TestProcTwoArgs;
  4412. begin
  4413. StartProgram(false);
  4414. Add('procedure Test(a,b: longint);');
  4415. Add('begin');
  4416. Add('end;');
  4417. Add('begin');
  4418. ConvertProgram;
  4419. CheckSource('TestProcTwoArgs',
  4420. LinesToStr([ // statements
  4421. 'this.Test = function (a,b) {',
  4422. '};'
  4423. ]),
  4424. LinesToStr([ // this.$main
  4425. ''
  4426. ]));
  4427. end;
  4428. procedure TTestModule.TestProc_DefaultValue;
  4429. begin
  4430. StartProgram(false);
  4431. Add('procedure p1(i: longint = 1);');
  4432. Add('begin');
  4433. Add('end;');
  4434. Add('procedure p2(i: longint = 1; c: char = ''a'');');
  4435. Add('begin');
  4436. Add('end;');
  4437. Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');');
  4438. Add('begin');
  4439. Add('end;');
  4440. Add('begin');
  4441. Add(' p1;');
  4442. Add(' p1();');
  4443. Add(' p1(11);');
  4444. Add(' p2;');
  4445. Add(' p2();');
  4446. Add(' p2(12);');
  4447. Add(' p2(13,''b'');');
  4448. Add(' p3();');
  4449. ConvertProgram;
  4450. CheckSource('TestProc_DefaultValue',
  4451. LinesToStr([ // statements
  4452. 'this.p1 = function (i) {',
  4453. '};',
  4454. 'this.p2 = function (i,c) {',
  4455. '};',
  4456. 'this.p3 = function (d,b,s) {',
  4457. '};'
  4458. ]),
  4459. LinesToStr([ // this.$main
  4460. ' $mod.p1(1);',
  4461. ' $mod.p1(1);',
  4462. ' $mod.p1(11);',
  4463. ' $mod.p2(1,"a");',
  4464. ' $mod.p2(1,"a");',
  4465. ' $mod.p2(12,"a");',
  4466. ' $mod.p2(13,"b");',
  4467. ' $mod.p3(1.0,false,"abc");'
  4468. ]));
  4469. end;
  4470. procedure TTestModule.TestFunctionInt;
  4471. begin
  4472. StartProgram(false);
  4473. Add('function MyTest(Bar: longint): longint;');
  4474. Add('begin');
  4475. Add(' Result:=2*bar');
  4476. Add('end;');
  4477. Add('begin');
  4478. ConvertProgram;
  4479. CheckSource('TestFunctionInt',
  4480. LinesToStr([ // statements
  4481. 'this.MyTest = function (Bar) {',
  4482. ' var Result = 0;',
  4483. ' Result = 2*Bar;',
  4484. ' return Result;',
  4485. '};'
  4486. ]),
  4487. LinesToStr([ // this.$main
  4488. ''
  4489. ]));
  4490. end;
  4491. procedure TTestModule.TestFunctionString;
  4492. begin
  4493. StartProgram(false);
  4494. Add('function Test(Bar: string): string;');
  4495. Add('begin');
  4496. Add(' Result:=bar+BAR');
  4497. Add('end;');
  4498. Add('begin');
  4499. ConvertProgram;
  4500. CheckSource('TestFunctionString',
  4501. LinesToStr([ // statements
  4502. 'this.Test = function (Bar) {',
  4503. ' var Result = "";',
  4504. ' Result = Bar+Bar;',
  4505. ' return Result;',
  4506. '};'
  4507. ]),
  4508. LinesToStr([ // this.$main
  4509. ''
  4510. ]));
  4511. end;
  4512. procedure TTestModule.TestForLoop;
  4513. begin
  4514. StartProgram(false);
  4515. Add('var');
  4516. Add(' vI, vJ, vN: longint;');
  4517. Add('begin');
  4518. Add(' VJ:=0;');
  4519. Add(' VN:=3;');
  4520. Add(' for VI:=1 to VN do');
  4521. Add(' begin');
  4522. Add(' VJ:=VJ+VI;');
  4523. Add(' end;');
  4524. ConvertProgram;
  4525. CheckSource('TestForLoop',
  4526. LinesToStr([ // statements
  4527. 'this.vI = 0;',
  4528. 'this.vJ = 0;',
  4529. 'this.vN = 0;'
  4530. ]),
  4531. LinesToStr([ // this.$main
  4532. ' $mod.vJ = 0;',
  4533. ' $mod.vN = 3;',
  4534. ' for (var $l1 = 1, $end2 = $mod.vN; $l1 <= $end2; $l1++) {',
  4535. ' $mod.vI = $l1;',
  4536. ' $mod.vJ = $mod.vJ + $mod.vI;',
  4537. ' };',
  4538. '']));
  4539. end;
  4540. procedure TTestModule.TestForLoopInFunction;
  4541. begin
  4542. StartProgram(false);
  4543. Add('function SumNumbers(Count: longint): longint;');
  4544. Add('var');
  4545. Add(' vI, vJ: longint;');
  4546. Add('begin');
  4547. Add(' vj:=0;');
  4548. Add(' for vi:=1 to count do');
  4549. Add(' begin');
  4550. Add(' vj:=vj+vi;');
  4551. Add(' end;');
  4552. Add('end;');
  4553. Add('begin');
  4554. Add(' sumnumbers(3);');
  4555. ConvertProgram;
  4556. CheckSource('TestForLoopInFunction',
  4557. LinesToStr([ // statements
  4558. 'this.SumNumbers = function (Count) {',
  4559. ' var Result = 0;',
  4560. ' var vI = 0;',
  4561. ' var vJ = 0;',
  4562. ' vJ = 0;',
  4563. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  4564. ' vI = $l1;',
  4565. ' vJ = vJ + vI;',
  4566. ' };',
  4567. ' return Result;',
  4568. '};'
  4569. ]),
  4570. LinesToStr([ // $mod.$main
  4571. ' $mod.SumNumbers(3);'
  4572. ]));
  4573. end;
  4574. procedure TTestModule.TestForLoop_ReadVarAfter;
  4575. begin
  4576. StartProgram(false);
  4577. Add('var');
  4578. Add(' vI: longint;');
  4579. Add('begin');
  4580. Add(' for vi:=1 to 2 do ;');
  4581. Add(' if vi=3 then ;');
  4582. ConvertProgram;
  4583. CheckSource('TestForLoop',
  4584. LinesToStr([ // statements
  4585. 'this.vI = 0;'
  4586. ]),
  4587. LinesToStr([ // this.$main
  4588. ' for ($mod.vI = 1; $mod.vI <= 2; $mod.vI++) ;',
  4589. ' if ($mod.vI===3) ;'
  4590. ]));
  4591. end;
  4592. procedure TTestModule.TestForLoop_Nested;
  4593. begin
  4594. StartProgram(false);
  4595. Add('function SumNumbers(Count: longint): longint;');
  4596. Add('var');
  4597. Add(' vI, vJ, vK: longint;');
  4598. Add('begin');
  4599. Add(' VK:=0;');
  4600. Add(' for VI:=1 to count do');
  4601. Add(' begin');
  4602. Add(' for vj:=1 to vi do');
  4603. Add(' begin');
  4604. Add(' vk:=VK+VI;');
  4605. Add(' end;');
  4606. Add(' end;');
  4607. Add('end;');
  4608. Add('begin');
  4609. Add(' sumnumbers(3);');
  4610. ConvertProgram;
  4611. CheckSource('TestForLoopInFunction',
  4612. LinesToStr([ // statements
  4613. 'this.SumNumbers = function (Count) {',
  4614. ' var Result = 0;',
  4615. ' var vI = 0;',
  4616. ' var vJ = 0;',
  4617. ' var vK = 0;',
  4618. ' vK = 0;',
  4619. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  4620. ' vI = $l1;',
  4621. ' for (var $l3 = 1, $end4 = vI; $l3 <= $end4; $l3++) {',
  4622. ' vJ = $l3;',
  4623. ' vK = vK + vI;',
  4624. ' };',
  4625. ' };',
  4626. ' return Result;',
  4627. '};'
  4628. ]),
  4629. LinesToStr([ // $mod.$main
  4630. ' $mod.SumNumbers(3);'
  4631. ]));
  4632. end;
  4633. procedure TTestModule.TestRepeatUntil;
  4634. begin
  4635. StartProgram(false);
  4636. Add('var');
  4637. Add(' vI, vJ, vN: longint;');
  4638. Add('begin');
  4639. Add(' vn:=3;');
  4640. Add(' vj:=0;');
  4641. Add(' VI:=0;');
  4642. Add(' repeat');
  4643. Add(' VI:=vi+1;');
  4644. Add(' vj:=VJ+vI;');
  4645. Add(' until vi>=vn');
  4646. ConvertProgram;
  4647. CheckSource('TestRepeatUntil',
  4648. LinesToStr([ // statements
  4649. 'this.vI = 0;',
  4650. 'this.vJ = 0;',
  4651. 'this.vN = 0;'
  4652. ]),
  4653. LinesToStr([ // $mod.$main
  4654. ' $mod.vN = 3;',
  4655. ' $mod.vJ = 0;',
  4656. ' $mod.vI = 0;',
  4657. ' do{',
  4658. ' $mod.vI = $mod.vI + 1;',
  4659. ' $mod.vJ = $mod.vJ + $mod.vI;',
  4660. ' }while(!($mod.vI>=$mod.vN));'
  4661. ]));
  4662. end;
  4663. procedure TTestModule.TestAsmBlock;
  4664. begin
  4665. StartProgram(false);
  4666. Add('var');
  4667. Add(' vI: longint;');
  4668. Add('begin');
  4669. Add(' vi:=1;');
  4670. Add(' asm');
  4671. Add(' if (vI===1) {');
  4672. Add(' vI=2;');
  4673. Add(' }');
  4674. Add(' if (vI===2){ vI=3; }');
  4675. Add(' end;');
  4676. Add(' VI:=4;');
  4677. ConvertProgram;
  4678. CheckSource('TestAsmBlock',
  4679. LinesToStr([ // statements
  4680. 'this.vI = 0;'
  4681. ]),
  4682. LinesToStr([ // $mod.$main
  4683. '$mod.vI = 1;',
  4684. 'if (vI===1) {',
  4685. ' vI=2;',
  4686. '}',
  4687. 'if (vI===2){ vI=3; }',
  4688. ';',
  4689. '$mod.vI = 4;'
  4690. ]));
  4691. end;
  4692. procedure TTestModule.TestAsmPas_Impl;
  4693. begin
  4694. StartUnit(false);
  4695. Add('interface');
  4696. Add('const cIntf: longint = 1;');
  4697. Add('var vIntf: longint;');
  4698. Add('implementation');
  4699. Add('const cImpl: longint = 2;');
  4700. Add('var vImpl: longint;');
  4701. Add('procedure DoIt;');
  4702. Add('const cLoc: longint = 3;');
  4703. Add('var vLoc: longint;');
  4704. Add('begin;');
  4705. Add(' asm');
  4706. //Add(' pas(vIntf)=pas(cIntf);');
  4707. //Add(' pas(vImpl)=pas(cImpl);');
  4708. //Add(' pas(vLoc)=pas(cLoc);');
  4709. Add(' end;');
  4710. Add('end;');
  4711. ConvertUnit;
  4712. // ToDo: check use analyzer
  4713. CheckSource('TestAsmPas_Impl',
  4714. LinesToStr([
  4715. 'var $impl = $mod.$impl;',
  4716. 'this.cIntf = 1;',
  4717. 'this.vIntf = 0;',
  4718. '']),
  4719. '', // this.$init
  4720. LinesToStr([ // implementation
  4721. '$impl.cImpl = 2;',
  4722. '$impl.vImpl = 0;',
  4723. 'var cLoc = 3;',
  4724. '$impl.DoIt = function () {',
  4725. ' var vLoc = 0;',
  4726. '};',
  4727. '']) );
  4728. end;
  4729. procedure TTestModule.TestTryFinally;
  4730. begin
  4731. StartProgram(false);
  4732. Add('var i: longint;');
  4733. Add('begin');
  4734. Add(' try');
  4735. Add(' i:=0; i:=2 div i;');
  4736. Add(' finally');
  4737. Add(' i:=3');
  4738. Add(' end;');
  4739. ConvertProgram;
  4740. CheckSource('TestTryFinally',
  4741. LinesToStr([ // statements
  4742. 'this.i = 0;'
  4743. ]),
  4744. LinesToStr([ // $mod.$main
  4745. 'try {',
  4746. ' $mod.i = 0;',
  4747. ' $mod.i = Math.floor(2 / $mod.i);',
  4748. '} finally {',
  4749. ' $mod.i = 3;',
  4750. '};'
  4751. ]));
  4752. end;
  4753. procedure TTestModule.TestTryExcept;
  4754. begin
  4755. StartProgram(false);
  4756. Add('type');
  4757. Add(' TObject = class end;');
  4758. Add(' Exception = class Msg: string; end;');
  4759. Add(' EInvalidCast = class(Exception) end;');
  4760. Add('var vI: longint;');
  4761. Add('begin');
  4762. Add(' try');
  4763. Add(' vi:=1;');
  4764. Add(' except');
  4765. Add(' vi:=2');
  4766. Add(' end;');
  4767. Add(' try');
  4768. Add(' vi:=3;');
  4769. Add(' except');
  4770. Add(' raise;');
  4771. Add(' end;');
  4772. Add(' try');
  4773. Add(' VI:=4;');
  4774. Add(' except');
  4775. Add(' on einvalidcast do');
  4776. Add(' raise;');
  4777. Add(' on E: exception do');
  4778. Add(' if e.msg='''' then');
  4779. Add(' raise e;');
  4780. Add(' else');
  4781. Add(' vi:=5');
  4782. Add(' end;');
  4783. Add(' try');
  4784. Add(' VI:=6;');
  4785. Add(' except');
  4786. Add(' on einvalidcast do ;');
  4787. Add(' end;');
  4788. ConvertProgram;
  4789. CheckSource('TestTryExcept',
  4790. LinesToStr([ // statements
  4791. 'rtl.createClass($mod, "TObject", null, function () {',
  4792. ' this.$init = function () {',
  4793. ' };',
  4794. ' this.$final = function () {',
  4795. ' };',
  4796. '});',
  4797. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  4798. ' this.$init = function () {',
  4799. ' $mod.TObject.$init.call(this);',
  4800. ' this.Msg = "";',
  4801. ' };',
  4802. '});',
  4803. 'rtl.createClass($mod, "EInvalidCast", $mod.Exception, function () {',
  4804. '});',
  4805. 'this.vI = 0;'
  4806. ]),
  4807. LinesToStr([ // $mod.$main
  4808. 'try {',
  4809. ' $mod.vI = 1;',
  4810. '} catch ($e) {',
  4811. ' $mod.vI = 2;',
  4812. '};',
  4813. 'try {',
  4814. ' $mod.vI = 3;',
  4815. '} catch ($e) {',
  4816. ' throw $e;',
  4817. '};',
  4818. 'try {',
  4819. ' $mod.vI = 4;',
  4820. '} catch ($e) {',
  4821. ' if ($mod.EInvalidCast.isPrototypeOf($e)){',
  4822. ' throw $e',
  4823. ' } else if ($mod.Exception.isPrototypeOf($e)) {',
  4824. ' var E = $e;',
  4825. ' if (E.Msg === "") throw E;',
  4826. ' } else {',
  4827. ' $mod.vI = 5;',
  4828. ' }',
  4829. '};',
  4830. 'try {',
  4831. ' $mod.vI = 6;',
  4832. '} catch ($e) {',
  4833. ' if ($mod.EInvalidCast.isPrototypeOf($e)){' ,
  4834. ' } else throw $e',
  4835. '};',
  4836. '']));
  4837. end;
  4838. procedure TTestModule.TestCaseOf;
  4839. begin
  4840. StartProgram(false);
  4841. Add('var vI: longint;');
  4842. Add('begin');
  4843. Add(' case vi of');
  4844. Add(' 1: ;');
  4845. Add(' 2: vi:=3;');
  4846. Add(' else');
  4847. Add(' VI:=4');
  4848. Add(' end;');
  4849. ConvertProgram;
  4850. CheckSource('TestCaseOf',
  4851. LinesToStr([ // statements
  4852. 'this.vI = 0;'
  4853. ]),
  4854. LinesToStr([ // $mod.$main
  4855. 'var $tmp1 = $mod.vI;',
  4856. 'if ($tmp1 === 1) {} else if ($tmp1 === 2){ $mod.vI = 3 }else {',
  4857. ' $mod.vI = 4;',
  4858. '};'
  4859. ]));
  4860. end;
  4861. procedure TTestModule.TestCaseOf_UseSwitch;
  4862. begin
  4863. StartProgram(false);
  4864. Converter.UseSwitchStatement:=true;
  4865. Add('var Vi: longint;');
  4866. Add('begin');
  4867. Add(' case vi of');
  4868. Add(' 1: ;');
  4869. Add(' 2: VI:=3;');
  4870. Add(' else');
  4871. Add(' vi:=4');
  4872. Add(' end;');
  4873. ConvertProgram;
  4874. CheckSource('TestCaseOf_UseSwitch',
  4875. LinesToStr([ // statements
  4876. 'this.Vi = 0;'
  4877. ]),
  4878. LinesToStr([ // $mod.$main
  4879. 'switch ($mod.Vi) {',
  4880. 'case 1:',
  4881. ' break;',
  4882. 'case 2:',
  4883. ' $mod.Vi = 3;',
  4884. ' break;',
  4885. 'default:',
  4886. ' $mod.Vi = 4;',
  4887. '};'
  4888. ]));
  4889. end;
  4890. procedure TTestModule.TestCaseOfNoElse;
  4891. begin
  4892. StartProgram(false);
  4893. Add('var Vi: longint;');
  4894. Add('begin');
  4895. Add(' case vi of');
  4896. Add(' 1: begin vi:=2; VI:=3; end;');
  4897. Add(' end;');
  4898. ConvertProgram;
  4899. CheckSource('TestCaseOfNoElse',
  4900. LinesToStr([ // statements
  4901. 'this.Vi = 0;'
  4902. ]),
  4903. LinesToStr([ // $mod.$main
  4904. 'var $tmp1 = $mod.Vi;',
  4905. 'if ($tmp1 === 1) {',
  4906. ' $mod.Vi = 2;',
  4907. ' $mod.Vi = 3;',
  4908. '};'
  4909. ]));
  4910. end;
  4911. procedure TTestModule.TestCaseOfNoElse_UseSwitch;
  4912. begin
  4913. StartProgram(false);
  4914. Converter.UseSwitchStatement:=true;
  4915. Add('var vI: longint;');
  4916. Add('begin');
  4917. Add(' case vi of');
  4918. Add(' 1: begin VI:=2; vi:=3; end;');
  4919. Add(' end;');
  4920. ConvertProgram;
  4921. CheckSource('TestCaseOfNoElse_UseSwitch',
  4922. LinesToStr([ // statements
  4923. 'this.vI = 0;'
  4924. ]),
  4925. LinesToStr([ // $mod.$main
  4926. 'switch ($mod.vI) {',
  4927. 'case 1:',
  4928. ' $mod.vI = 2;',
  4929. ' $mod.vI = 3;',
  4930. ' break;',
  4931. '};'
  4932. ]));
  4933. end;
  4934. procedure TTestModule.TestCaseOfRange;
  4935. begin
  4936. StartProgram(false);
  4937. Add('var vI: longint;');
  4938. Add('begin');
  4939. Add(' case vi of');
  4940. Add(' 1..3: vi:=14;');
  4941. Add(' 4,5: vi:=16;');
  4942. Add(' 6..7,9..10: ;');
  4943. Add(' else ;');
  4944. Add(' end;');
  4945. ConvertProgram;
  4946. CheckSource('TestCaseOfRange',
  4947. LinesToStr([ // statements
  4948. 'this.vI = 0;'
  4949. ]),
  4950. LinesToStr([ // $mod.$main
  4951. 'var $tmp1 = $mod.vI;',
  4952. 'if (($tmp1 >= 1) && ($tmp1 <= 3)){',
  4953. ' $mod.vI = 14',
  4954. '} else if (($tmp1 === 4) || ($tmp1 === 5)){',
  4955. ' $mod.vI = 16',
  4956. '} else if ((($tmp1 >= 6) && ($tmp1 <= 7)) || (($tmp1 >= 9) && ($tmp1 <= 10))) ;'
  4957. ]));
  4958. end;
  4959. procedure TTestModule.TestArray_Dynamic;
  4960. begin
  4961. StartProgram(false);
  4962. Add('type');
  4963. Add(' TArrayInt = array of longint;');
  4964. Add('var');
  4965. Add(' Arr: TArrayInt;');
  4966. Add(' i: longint;');
  4967. Add(' b: boolean;');
  4968. Add('begin');
  4969. Add(' SetLength(arr,3);');
  4970. Add(' arr[0]:=4;');
  4971. Add(' arr[1]:=length(arr)+arr[0];');
  4972. Add(' arr[i]:=5;');
  4973. Add(' arr[arr[i]]:=arr[6];');
  4974. Add(' i:=low(arr);');
  4975. Add(' i:=high(arr);');
  4976. Add(' b:=Assigned(arr);');
  4977. ConvertProgram;
  4978. CheckSource('TestArray_Dynamic',
  4979. LinesToStr([ // statements
  4980. 'this.Arr = [];',
  4981. 'this.i = 0;',
  4982. 'this.b = false;'
  4983. ]),
  4984. LinesToStr([ // $mod.$main
  4985. '$mod.Arr = rtl.arraySetLength($mod.Arr,0,3);',
  4986. '$mod.Arr[0] = 4;',
  4987. '$mod.Arr[1] = rtl.length($mod.Arr) + $mod.Arr[0];',
  4988. '$mod.Arr[$mod.i] = 5;',
  4989. '$mod.Arr[$mod.Arr[$mod.i]] = $mod.Arr[6];',
  4990. '$mod.i = 0;',
  4991. '$mod.i = rtl.length($mod.Arr) - 1;',
  4992. '$mod.b = rtl.length($mod.Arr) > 0;',
  4993. '']));
  4994. end;
  4995. procedure TTestModule.TestArray_Dynamic_Nil;
  4996. begin
  4997. StartProgram(false);
  4998. Add('type');
  4999. Add(' TArrayInt = array of longint;');
  5000. Add('var');
  5001. Add(' Arr: TArrayInt;');
  5002. Add('procedure DoIt(const i: TArrayInt; j: TArrayInt); begin end;');
  5003. Add('begin');
  5004. Add(' arr:=nil;');
  5005. Add(' if arr=nil then;');
  5006. Add(' if nil=arr then;');
  5007. Add(' if arr<>nil then;');
  5008. Add(' if nil<>arr then;');
  5009. Add(' DoIt(nil,nil);');
  5010. ConvertProgram;
  5011. CheckSource('TestArray_Dynamic',
  5012. LinesToStr([ // statements
  5013. 'this.Arr = [];',
  5014. 'this.DoIt = function(i,j){',
  5015. '};'
  5016. ]),
  5017. LinesToStr([ // $mod.$main
  5018. '$mod.Arr = [];',
  5019. 'if (rtl.length($mod.Arr) === 0) ;',
  5020. 'if (rtl.length($mod.Arr) === 0) ;',
  5021. 'if (rtl.length($mod.Arr) > 0) ;',
  5022. 'if (rtl.length($mod.Arr) > 0) ;',
  5023. '$mod.DoIt([],[]);',
  5024. '']));
  5025. end;
  5026. procedure TTestModule.TestArray_DynMultiDimensional;
  5027. begin
  5028. StartProgram(false);
  5029. Add('type');
  5030. Add(' TArrayInt = array of longint;');
  5031. Add(' TArrayArrayInt = array of TArrayInt;');
  5032. Add('var');
  5033. Add(' Arr: TArrayInt;');
  5034. Add(' Arr2: TArrayArrayInt;');
  5035. Add(' i: longint;');
  5036. Add('begin');
  5037. Add(' arr2:=nil;');
  5038. Add(' if arr2=nil then;');
  5039. Add(' if nil=arr2 then;');
  5040. Add(' i:=low(arr2);');
  5041. Add(' i:=low(arr2[1]);');
  5042. Add(' i:=high(arr2);');
  5043. Add(' i:=high(arr2[2]);');
  5044. Add(' arr2[3]:=arr;');
  5045. Add(' arr2[4][5]:=i;');
  5046. Add(' i:=arr2[6][7];');
  5047. Add(' arr2[8,9]:=i;');
  5048. Add(' i:=arr2[10,11];');
  5049. Add(' SetLength(arr2,14);');
  5050. Add(' SetLength(arr2[15],16);');
  5051. ConvertProgram;
  5052. CheckSource('TestArray_Dynamic',
  5053. LinesToStr([ // statements
  5054. 'this.Arr = [];',
  5055. 'this.Arr2 = [];',
  5056. 'this.i = 0;'
  5057. ]),
  5058. LinesToStr([ // $mod.$main
  5059. '$mod.Arr2 = [];',
  5060. 'if (rtl.length($mod.Arr2) === 0) ;',
  5061. 'if (rtl.length($mod.Arr2) === 0) ;',
  5062. '$mod.i = 0;',
  5063. '$mod.i = 0;',
  5064. '$mod.i = rtl.length($mod.Arr2) - 1;',
  5065. '$mod.i = rtl.length($mod.Arr2[2]) - 1;',
  5066. '$mod.Arr2[3] = $mod.Arr;',
  5067. '$mod.Arr2[4][5] = $mod.i;',
  5068. '$mod.i = $mod.Arr2[6][7];',
  5069. '$mod.Arr2[8][9] = $mod.i;',
  5070. '$mod.i = $mod.Arr2[10][11];',
  5071. '$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
  5072. '$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
  5073. '']));
  5074. end;
  5075. procedure TTestModule.TestArray_StaticInt;
  5076. begin
  5077. StartProgram(false);
  5078. Add('type');
  5079. Add(' TArrayInt = array[2..4] of longint;');
  5080. Add('var');
  5081. Add(' Arr: TArrayInt;');
  5082. Add(' Arr2: TArrayInt = (5,6,7);');
  5083. Add(' i: longint;');
  5084. Add(' b: boolean;');
  5085. Add('begin');
  5086. Add(' arr[2]:=4;');
  5087. Add(' arr[3]:=arr[2]+arr[3];');
  5088. Add(' arr[i]:=5;');
  5089. Add(' arr[arr[i]]:=arr[high(arr)];');
  5090. Add(' i:=low(arr);');
  5091. Add(' i:=high(arr);');
  5092. Add(' b:=arr[2]=arr[3];');
  5093. ConvertProgram;
  5094. CheckSource('TestArray_StaticInt',
  5095. LinesToStr([ // statements
  5096. 'this.Arr = rtl.arraySetLength(null,0,3);',
  5097. 'this.Arr2 = [5, 6, 7];',
  5098. 'this.i = 0;',
  5099. 'this.b = false;'
  5100. ]),
  5101. LinesToStr([ // $mod.$main
  5102. '$mod.Arr[0] = 4;',
  5103. '$mod.Arr[1] = $mod.Arr[0] + $mod.Arr[1];',
  5104. '$mod.Arr[$mod.i-2] = 5;',
  5105. '$mod.Arr[$mod.Arr[$mod.i-2]-2] = $mod.Arr[2];',
  5106. '$mod.i = 2;',
  5107. '$mod.i = 4;',
  5108. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  5109. '']));
  5110. end;
  5111. procedure TTestModule.TestArray_StaticBool;
  5112. begin
  5113. StartProgram(false);
  5114. Add('type');
  5115. Add(' TBools = array[boolean] of boolean;');
  5116. Add(' TBool2 = array[true..true] of boolean;');
  5117. Add('var');
  5118. Add(' Arr: TBools;');
  5119. Add(' Arr2: TBool2;');
  5120. Add(' Arr3: TBools = (true,false);');
  5121. Add(' b: boolean;');
  5122. Add('begin');
  5123. Add(' b:=low(arr);');
  5124. Add(' b:=high(arr);');
  5125. Add(' arr[true]:=false;');
  5126. Add(' arr[false]:=arr[b] or arr[true];');
  5127. Add(' arr[b]:=true;');
  5128. Add(' arr[arr[b]]:=arr[high(arr)];');
  5129. Add(' b:=arr[false]=arr[true];');
  5130. Add(' b:=low(arr2);');
  5131. Add(' b:=high(arr2);');
  5132. Add(' arr2[true]:=true;');
  5133. Add(' arr2[true]:=arr2[true] and arr2[b];');
  5134. Add(' arr2[b]:=false;');
  5135. ConvertProgram;
  5136. CheckSource('TestArray_StaticBool',
  5137. LinesToStr([ // statements
  5138. 'this.Arr = rtl.arraySetLength(null,false,2);',
  5139. 'this.Arr2 = rtl.arraySetLength(null,false,1);',
  5140. 'this.Arr3 = [true, false];',
  5141. 'this.b = false;'
  5142. ]),
  5143. LinesToStr([ // $mod.$main
  5144. '$mod.b = false;',
  5145. '$mod.b = true;',
  5146. '$mod.Arr[1] = false;',
  5147. '$mod.Arr[0] = $mod.Arr[+$mod.b] || $mod.Arr[1];',
  5148. '$mod.Arr[+$mod.b] = true;',
  5149. '$mod.Arr[+$mod.Arr[+$mod.b]] = $mod.Arr[1];',
  5150. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  5151. '$mod.b = true;',
  5152. '$mod.b = true;',
  5153. '$mod.Arr2[0] = true;',
  5154. '$mod.Arr2[0] = $mod.Arr2[0] && $mod.Arr2[1-$mod.b];',
  5155. '$mod.Arr2[1-$mod.b] = false;',
  5156. '']));
  5157. end;
  5158. procedure TTestModule.TestArray_StaticChar;
  5159. begin
  5160. StartProgram(false);
  5161. Add('type');
  5162. Add(' TChars = array[char] of char;');
  5163. Add(' TChars2 = array[''a''..''z''] of char;');
  5164. Add('var');
  5165. Add(' Arr: TChars;');
  5166. Add(' Arr2: TChars2;');
  5167. Add(' Arr3: array[2..4] of char = (''p'',''a'',''s'');');
  5168. Add(' Arr4: array[11..13] of char = ''pas'';');
  5169. Add(' Arr5: array[21..22] of char = ''äö'';');
  5170. Add(' c: char;');
  5171. Add(' b: boolean;');
  5172. Add('begin');
  5173. Add(' c:=low(arr);');
  5174. Add(' c:=high(arr);');
  5175. Add(' arr[''B'']:=''a'';');
  5176. Add(' arr[''D'']:=arr[c];');
  5177. Add(' arr[c]:=arr[''d''];');
  5178. Add(' arr[arr[c]]:=arr[high(arr)];');
  5179. Add(' b:=arr[low(arr)]=arr[''e''];');
  5180. Add(' c:=low(arr2);');
  5181. Add(' c:=high(arr2);');
  5182. Add(' arr2[''b'']:=''f'';');
  5183. Add(' arr2[''a'']:=arr2[c];');
  5184. Add(' arr2[c]:=arr2[''g''];');
  5185. ConvertProgram;
  5186. CheckSource('TestArray_StaticChar',
  5187. LinesToStr([ // statements
  5188. 'this.Arr = rtl.arraySetLength(null, "", 65536);',
  5189. 'this.Arr2 = rtl.arraySetLength(null, "", 26);',
  5190. 'this.Arr3 = ["p", "a", "s"];',
  5191. 'this.Arr4 = ["p", "a", "s"];',
  5192. 'this.Arr5 = ["ä", "ö"];',
  5193. 'this.c = "";',
  5194. 'this.b = false;',
  5195. '']),
  5196. LinesToStr([ // $mod.$main
  5197. '$mod.c = "\x00";',
  5198. '$mod.c = "'#$EF#$BF#$BF'";',
  5199. '$mod.Arr[66] = "a";',
  5200. '$mod.Arr[68] = $mod.Arr[$mod.c.charCodeAt()];',
  5201. '$mod.Arr[$mod.c.charCodeAt()] = $mod.Arr[100];',
  5202. '$mod.Arr[$mod.Arr[$mod.c.charCodeAt()].charCodeAt()] = $mod.Arr[65535];',
  5203. '$mod.b = $mod.Arr[0] === $mod.Arr[101];',
  5204. '$mod.c = "a";',
  5205. '$mod.c = "z";',
  5206. '$mod.Arr2[1] = "f";',
  5207. '$mod.Arr2[0] = $mod.Arr2[$mod.c.charCodeAt() - 97];',
  5208. '$mod.Arr2[$mod.c.charCodeAt() - 97] = $mod.Arr2[6];',
  5209. '']));
  5210. end;
  5211. procedure TTestModule.TestArray_StaticMultiDim;
  5212. begin
  5213. exit;
  5214. StartProgram(false);
  5215. Add('type');
  5216. Add(' TArrayInt = array[1..3] of longint;');
  5217. Add(' TArrayArrayInt = array[5..6] of TArrayInt;');
  5218. Add('var');
  5219. Add(' Arr: TArrayInt;');
  5220. Add(' Arr2: TArrayArrayInt;');
  5221. Add(' i: longint;');
  5222. Add('begin');
  5223. Add(' i:=low(arr);');
  5224. Add(' i:=low(arr2);');
  5225. Add(' i:=low(arr2[5]);');
  5226. Add(' i:=high(arr);');
  5227. Add(' i:=high(arr2);');
  5228. Add(' i:=high(arr2[6]);');
  5229. Add(' arr2[3]:=arr;');
  5230. Add(' arr2[4][5]:=i;');
  5231. Add(' i:=arr2[6][7];');
  5232. Add(' arr2[8,9]:=i;');
  5233. Add(' i:=arr2[10,11];');
  5234. Add(' SetLength(arr2,14);');
  5235. Add(' SetLength(arr2[15],16);');
  5236. ConvertProgram;
  5237. CheckSource('TestArray_StaticMultiDim',
  5238. LinesToStr([ // statements
  5239. 'this.Arr = [];',
  5240. 'this.Arr2 = [];',
  5241. 'this.i = 0;'
  5242. ]),
  5243. LinesToStr([ // $mod.$main
  5244. '$mod.Arr2 = [];',
  5245. 'if (rtl.length($mod.Arr2) === 0) ;',
  5246. 'if (rtl.length($mod.Arr2) === 0) ;',
  5247. '$mod.i = 0;',
  5248. '$mod.i = 0;',
  5249. '$mod.i = rtl.length($mod.Arr2) - 1;',
  5250. '$mod.i = rtl.length($mod.Arr2[2]) - 1;',
  5251. '$mod.Arr2[3] = $mod.Arr;',
  5252. '$mod.Arr2[4][5] = $mod.i;',
  5253. '$mod.i = $mod.Arr2[6][7];',
  5254. '$mod.Arr2[8][9] = $mod.i;',
  5255. '$mod.i = $mod.Arr2[10][11];',
  5256. '$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
  5257. '$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
  5258. '']));
  5259. end;
  5260. procedure TTestModule.TestArrayOfRecord;
  5261. begin
  5262. StartProgram(false);
  5263. Add('type');
  5264. Add(' TRec = record');
  5265. Add(' Int: longint;');
  5266. Add(' end;');
  5267. Add(' TArrayRec = array of TRec;');
  5268. Add('var');
  5269. Add(' Arr: TArrayRec;');
  5270. Add(' r: TRec;');
  5271. Add(' i: longint;');
  5272. Add('begin');
  5273. Add(' SetLength(arr,3);');
  5274. Add(' arr[0].int:=4;');
  5275. Add(' arr[1].int:=length(arr)+arr[2].int;');
  5276. Add(' arr[arr[i].int].int:=arr[5].int;');
  5277. Add(' arr[7]:=r;');
  5278. Add(' r:=arr[8];');
  5279. Add(' i:=low(arr);');
  5280. Add(' i:=high(arr);');
  5281. ConvertProgram;
  5282. CheckSource('TestArrayOfRecord',
  5283. LinesToStr([ // statements
  5284. 'this.TRec = function (s) {',
  5285. ' if (s) {',
  5286. ' this.Int = s.Int;',
  5287. ' } else {',
  5288. ' this.Int = 0;',
  5289. ' };',
  5290. ' this.$equal = function (b) {',
  5291. ' return this.Int === b.Int;',
  5292. ' };',
  5293. '};',
  5294. 'this.Arr = [];',
  5295. 'this.r = new $mod.TRec();',
  5296. 'this.i = 0;'
  5297. ]),
  5298. LinesToStr([ // $mod.$main
  5299. '$mod.Arr = rtl.arraySetLength($mod.Arr,$mod.TRec,3);',
  5300. '$mod.Arr[0].Int = 4;',
  5301. '$mod.Arr[1].Int = rtl.length($mod.Arr)+$mod.Arr[2].Int;',
  5302. '$mod.Arr[$mod.Arr[$mod.i].Int].Int = $mod.Arr[5].Int;',
  5303. '$mod.Arr[7] = new $mod.TRec($mod.r);',
  5304. '$mod.r = new $mod.TRec($mod.Arr[8]);',
  5305. '$mod.i = 0;',
  5306. '$mod.i = rtl.length($mod.Arr)-1;',
  5307. '']));
  5308. end;
  5309. procedure TTestModule.TestArray_AsParams;
  5310. begin
  5311. StartProgram(false);
  5312. Add('type integer = longint;');
  5313. Add('type TArrInt = array of integer;');
  5314. Add('procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);');
  5315. Add('var vJ: TArrInt;');
  5316. Add('begin');
  5317. Add(' vg:=vg;');
  5318. Add(' vj:=vh;');
  5319. Add(' vi:=vi;');
  5320. Add(' doit(vg,vg,vg);');
  5321. Add(' doit(vh,vh,vj);');
  5322. Add(' doit(vi,vi,vi);');
  5323. Add(' doit(vj,vj,vj);');
  5324. Add('end;');
  5325. Add('var i: TArrInt;');
  5326. Add('begin');
  5327. Add(' doit(i,i,i);');
  5328. ConvertProgram;
  5329. CheckSource('TestArray_AsParams',
  5330. LinesToStr([ // statements
  5331. 'this.DoIt = function (vG,vH,vI) {',
  5332. ' var vJ = [];',
  5333. ' vG = vG;',
  5334. ' vJ = vH;',
  5335. ' vI.set(vI.get());',
  5336. ' $mod.DoIt(vG, vG, {',
  5337. ' get: function () {',
  5338. ' return vG;',
  5339. ' },',
  5340. ' set: function (v) {',
  5341. ' vG = v;',
  5342. ' }',
  5343. ' });',
  5344. ' $mod.DoIt(vH, vH, {',
  5345. ' get: function () {',
  5346. ' return vJ;',
  5347. ' },',
  5348. ' set: function (v) {',
  5349. ' vJ = v;',
  5350. ' }',
  5351. ' });',
  5352. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  5353. ' $mod.DoIt(vJ, vJ, {',
  5354. ' get: function () {',
  5355. ' return vJ;',
  5356. ' },',
  5357. ' set: function (v) {',
  5358. ' vJ = v;',
  5359. ' }',
  5360. ' });',
  5361. '};',
  5362. 'this.i = [];'
  5363. ]),
  5364. LinesToStr([
  5365. '$mod.DoIt($mod.i,$mod.i,{',
  5366. ' p: $mod,',
  5367. ' get: function () {',
  5368. ' return this.p.i;',
  5369. ' },',
  5370. ' set: function (v) {',
  5371. ' this.p.i = v;',
  5372. ' }',
  5373. '});'
  5374. ]));
  5375. end;
  5376. procedure TTestModule.TestArrayElement_AsParams;
  5377. begin
  5378. StartProgram(false);
  5379. Add('type integer = longint;');
  5380. Add('type TArrayInt = array of integer;');
  5381. Add('procedure DoIt(vG: Integer; const vH: Integer; var vI: Integer);');
  5382. Add('var vJ: tarrayint;');
  5383. Add('begin');
  5384. Add(' vi:=vi;');
  5385. Add(' doit(vi,vi,vi);');
  5386. Add(' doit(vj[1+1],vj[1+2],vj[1+3]);');
  5387. Add('end;');
  5388. Add('var a: TArrayInt;');
  5389. Add('begin');
  5390. Add(' doit(a[1+4],a[1+5],a[1+6]);');
  5391. ConvertProgram;
  5392. CheckSource('TestArrayElement_AsParams',
  5393. LinesToStr([ // statements
  5394. 'this.DoIt = function (vG,vH,vI) {',
  5395. ' var vJ = [];',
  5396. ' vI.set(vI.get());',
  5397. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  5398. ' $mod.DoIt(vJ[1+1], vJ[1+2], {',
  5399. ' a:1+3,',
  5400. ' p:vJ,',
  5401. ' get: function () {',
  5402. ' return this.p[this.a];',
  5403. ' },',
  5404. ' set: function (v) {',
  5405. ' this.p[this.a] = v;',
  5406. ' }',
  5407. ' });',
  5408. '};',
  5409. 'this.a = [];'
  5410. ]),
  5411. LinesToStr([
  5412. '$mod.DoIt($mod.a[1+4],$mod.a[1+5],{',
  5413. ' a: 1+6,',
  5414. ' p: $mod.a,',
  5415. ' get: function () {',
  5416. ' return this.p[this.a];',
  5417. ' },',
  5418. ' set: function (v) {',
  5419. ' this.p[this.a] = v;',
  5420. ' }',
  5421. '});'
  5422. ]));
  5423. end;
  5424. procedure TTestModule.TestArrayElementFromFuncResult_AsParams;
  5425. begin
  5426. StartProgram(false);
  5427. Add('type Integer = longint;');
  5428. Add('type TArrayInt = array of integer;');
  5429. Add('function GetArr(vB: integer = 0): tarrayint;');
  5430. Add('begin');
  5431. Add('end;');
  5432. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  5433. Add('begin');
  5434. Add('end;');
  5435. Add('begin');
  5436. Add(' doit(getarr[1+1],getarr[1+2],getarr[1+3]);');
  5437. Add(' doit(getarr()[2+1],getarr()[2+2],getarr()[2+3]);');
  5438. Add(' doit(getarr(7)[3+1],getarr(8)[3+2],getarr(9)[3+3]);');
  5439. ConvertProgram;
  5440. CheckSource('TestArrayElementFromFuncResult_AsParams',
  5441. LinesToStr([ // statements
  5442. 'this.GetArr = function (vB) {',
  5443. ' var Result = [];',
  5444. ' return Result;',
  5445. '};',
  5446. 'this.DoIt = function (vG,vH,vI) {',
  5447. '};'
  5448. ]),
  5449. LinesToStr([
  5450. '$mod.DoIt($mod.GetArr(0)[1+1],$mod.GetArr(0)[1+2],{',
  5451. ' a: 1+3,',
  5452. ' p: $mod.GetArr(0),',
  5453. ' get: function () {',
  5454. ' return this.p[this.a];',
  5455. ' },',
  5456. ' set: function (v) {',
  5457. ' this.p[this.a] = v;',
  5458. ' }',
  5459. '});',
  5460. '$mod.DoIt($mod.GetArr(0)[2+1],$mod.GetArr(0)[2+2],{',
  5461. ' a: 2+3,',
  5462. ' p: $mod.GetArr(0),',
  5463. ' get: function () {',
  5464. ' return this.p[this.a];',
  5465. ' },',
  5466. ' set: function (v) {',
  5467. ' this.p[this.a] = v;',
  5468. ' }',
  5469. '});',
  5470. '$mod.DoIt($mod.GetArr(7)[3+1],$mod.GetArr(8)[3+2],{',
  5471. ' a: 3+3,',
  5472. ' p: $mod.GetArr(9),',
  5473. ' get: function () {',
  5474. ' return this.p[this.a];',
  5475. ' },',
  5476. ' set: function (v) {',
  5477. ' this.p[this.a] = v;',
  5478. ' }',
  5479. '});',
  5480. '']));
  5481. end;
  5482. procedure TTestModule.TestArrayEnumTypeRange;
  5483. begin
  5484. StartProgram(false);
  5485. Add('type');
  5486. Add(' TEnum = (red,blue);');
  5487. Add(' TEnumArray = array[TEnum] of longint;');
  5488. Add('var');
  5489. Add(' e: TEnum;');
  5490. Add(' i: longint;');
  5491. Add(' a: TEnumArray;');
  5492. Add(' numbers: TEnumArray = (1,2);');
  5493. Add(' names: array[TEnum] of string = (''red'',''blue'');');
  5494. Add('begin');
  5495. Add(' e:=low(a);');
  5496. Add(' e:=high(a);');
  5497. Add(' i:=a[red];');
  5498. Add(' a[e]:=a[e];');
  5499. ConvertProgram;
  5500. CheckSource('TestArrayEnumTypeRange',
  5501. LinesToStr([ // statements
  5502. ' this.TEnum = {',
  5503. ' "0": "red",',
  5504. ' red: 0,',
  5505. ' "1": "blue",',
  5506. ' blue: 1',
  5507. '};',
  5508. 'this.e = 0;',
  5509. 'this.i = 0;',
  5510. 'this.a = rtl.arraySetLength(null,0,2);',
  5511. 'this.numbers = [1, 2];',
  5512. 'this.names = ["red", "blue"];',
  5513. '']),
  5514. LinesToStr([ // $mod.$main
  5515. '$mod.e = $mod.TEnum.red;',
  5516. '$mod.e = $mod.TEnum.blue;',
  5517. '$mod.i = $mod.a[$mod.TEnum.red];',
  5518. '$mod.a[$mod.e] = $mod.a[$mod.e];',
  5519. '']));
  5520. end;
  5521. procedure TTestModule.TestArray_SetLengthOutArg;
  5522. begin
  5523. StartProgram(false);
  5524. Add([
  5525. 'type TArrInt = array of longint;',
  5526. 'procedure DoIt(out a: TArrInt);',
  5527. 'begin',
  5528. ' SetLength(a,2);',
  5529. 'end;',
  5530. 'begin',
  5531. '']);
  5532. ConvertProgram;
  5533. CheckSource('TestArray_SetLengthOutArg',
  5534. LinesToStr([ // statements
  5535. 'this.DoIt = function (a) {',
  5536. ' a.set(rtl.arraySetLength(a.get(), 0, 2));',
  5537. '};',
  5538. '']),
  5539. LinesToStr([
  5540. '']));
  5541. end;
  5542. procedure TTestModule.TestArray_SetLengthProperty;
  5543. begin
  5544. StartProgram(false);
  5545. Add('type');
  5546. Add(' TArrInt = array of longint;');
  5547. Add(' TObject = class');
  5548. Add(' function GetColors: TArrInt; external name ''GetColors'';');
  5549. Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
  5550. Add(' property Colors: TArrInt read GetColors write SetColors;');
  5551. Add(' end;');
  5552. Add('var Obj: TObject;');
  5553. Add('begin');
  5554. Add(' SetLength(Obj.Colors,2);');
  5555. ConvertProgram;
  5556. CheckSource('TestArray_SetLengthProperty',
  5557. LinesToStr([ // statements
  5558. 'rtl.createClass($mod, "TObject", null, function () {',
  5559. ' this.$init = function () {',
  5560. ' };',
  5561. ' this.$final = function () {',
  5562. ' };',
  5563. '});',
  5564. 'this.Obj = null;',
  5565. '']),
  5566. LinesToStr([
  5567. '$mod.Obj.SetColors(rtl.arraySetLength($mod.Obj.GetColors(), 0, 2));',
  5568. '']));
  5569. end;
  5570. procedure TTestModule.TestArray_SetLengthMultiDim;
  5571. begin
  5572. StartProgram(false);
  5573. Add([
  5574. 'type',
  5575. ' TArrArrInt = array of array of longint;',
  5576. 'var',
  5577. ' a: TArrArrInt;',
  5578. 'begin',
  5579. ' SetLength(a,2);',
  5580. ' SetLength(a,3,4);',
  5581. '']);
  5582. ConvertProgram;
  5583. CheckSource('TestArray_SetLengthMultiDim',
  5584. LinesToStr([ // statements
  5585. 'this.a = [];']),
  5586. LinesToStr([
  5587. '$mod.a = rtl.arraySetLength($mod.a, [], 2);',
  5588. '$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
  5589. '']));
  5590. end;
  5591. procedure TTestModule.TestArray_OpenArrayOfString;
  5592. begin
  5593. StartProgram(false);
  5594. Add('procedure DoIt(const a: array of String);');
  5595. Add('var');
  5596. Add(' i: longint;');
  5597. Add(' s: string;');
  5598. Add('begin');
  5599. Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
  5600. Add('end;');
  5601. Add('var s: string;');
  5602. Add('begin');
  5603. Add(' DoIt([]);');
  5604. Add(' DoIt([s,''foo'','''',s+s]);');
  5605. ConvertProgram;
  5606. CheckSource('TestArray_OpenArrayOfString',
  5607. LinesToStr([ // statements
  5608. 'this.DoIt = function (a) {',
  5609. ' var i = 0;',
  5610. ' var s = "";',
  5611. ' for (var $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
  5612. ' i = $l1;',
  5613. ' s = a[(rtl.length(a) - i) - 1];',
  5614. ' };',
  5615. '};',
  5616. 'this.s = "";',
  5617. '']),
  5618. LinesToStr([
  5619. '$mod.DoIt([]);',
  5620. '$mod.DoIt([$mod.s, "foo", "", $mod.s + $mod.s]);',
  5621. '']));
  5622. end;
  5623. procedure TTestModule.TestArray_Concat;
  5624. begin
  5625. StartProgram(false);
  5626. Add('type');
  5627. Add(' integer = longint;');
  5628. Add(' TFlag = (big,small);');
  5629. Add(' TFlags = set of TFlag;');
  5630. Add(' TRec = record');
  5631. Add(' i: integer;');
  5632. Add(' end;');
  5633. Add(' TArrInt = array of integer;');
  5634. Add(' TArrRec = array of TRec;');
  5635. Add(' TArrSet = array of TFlags;');
  5636. Add(' TArrJSValue = array of jsvalue;');
  5637. Add('var');
  5638. Add(' ArrInt: tarrint;');
  5639. Add(' ArrRec: tarrrec;');
  5640. Add(' ArrSet: tarrset;');
  5641. Add(' ArrJSValue: tarrjsvalue;');
  5642. Add('begin');
  5643. Add(' arrint:=concat(arrint);');
  5644. Add(' arrint:=concat(arrint,arrint);');
  5645. Add(' arrint:=concat(arrint,arrint,arrint);');
  5646. Add(' arrrec:=concat(arrrec);');
  5647. Add(' arrrec:=concat(arrrec,arrrec);');
  5648. Add(' arrrec:=concat(arrrec,arrrec,arrrec);');
  5649. Add(' arrset:=concat(arrset);');
  5650. Add(' arrset:=concat(arrset,arrset);');
  5651. Add(' arrset:=concat(arrset,arrset,arrset);');
  5652. Add(' arrjsvalue:=concat(arrjsvalue);');
  5653. Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue);');
  5654. Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);');
  5655. ConvertProgram;
  5656. CheckSource('TestArray_Concat',
  5657. LinesToStr([ // statements
  5658. 'this.TFlag = {',
  5659. ' "0": "big",',
  5660. ' big: 0,',
  5661. ' "1": "small",',
  5662. ' small: 1',
  5663. '};',
  5664. 'this.TRec = function (s) {',
  5665. ' if (s) {',
  5666. ' this.i = s.i;',
  5667. ' } else {',
  5668. ' this.i = 0;',
  5669. ' };',
  5670. ' this.$equal = function (b) {',
  5671. ' return this.i === b.i;',
  5672. ' };',
  5673. '};',
  5674. 'this.ArrInt = [];',
  5675. 'this.ArrRec = [];',
  5676. 'this.ArrSet = [];',
  5677. 'this.ArrJSValue = [];',
  5678. '']),
  5679. LinesToStr([ // $mod.$main
  5680. '$mod.ArrInt = $mod.ArrInt;',
  5681. '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt);',
  5682. '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt,$mod.ArrInt);',
  5683. '$mod.ArrRec = $mod.ArrRec;',
  5684. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec);',
  5685. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
  5686. '$mod.ArrSet = $mod.ArrSet;',
  5687. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet);',
  5688. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
  5689. '$mod.ArrJSValue = $mod.ArrJSValue;',
  5690. '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue);',
  5691. '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue, $mod.ArrJSValue);',
  5692. '']));
  5693. end;
  5694. procedure TTestModule.TestArray_Copy;
  5695. begin
  5696. StartProgram(false);
  5697. Add('type');
  5698. Add(' integer = longint;');
  5699. Add(' TFlag = (big,small);');
  5700. Add(' TFlags = set of TFlag;');
  5701. Add(' TRec = record');
  5702. Add(' i: integer;');
  5703. Add(' end;');
  5704. Add(' TArrInt = array of integer;');
  5705. Add(' TArrRec = array of TRec;');
  5706. Add(' TArrSet = array of TFlags;');
  5707. Add(' TArrJSValue = array of jsvalue;');
  5708. Add('var');
  5709. Add(' ArrInt: tarrint;');
  5710. Add(' ArrRec: tarrrec;');
  5711. Add(' ArrSet: tarrset;');
  5712. Add(' ArrJSValue: tarrjsvalue;');
  5713. Add('begin');
  5714. Add(' arrint:=copy(arrint);');
  5715. Add(' arrint:=copy(arrint,2);');
  5716. Add(' arrint:=copy(arrint,3,4);');
  5717. Add(' arrrec:=copy(arrrec);');
  5718. Add(' arrrec:=copy(arrrec,5);');
  5719. Add(' arrrec:=copy(arrrec,6,7);');
  5720. Add(' arrset:=copy(arrset);');
  5721. Add(' arrset:=copy(arrset,8);');
  5722. Add(' arrset:=copy(arrset,9,10);');
  5723. Add(' arrjsvalue:=copy(arrjsvalue);');
  5724. Add(' arrjsvalue:=copy(arrjsvalue,11);');
  5725. Add(' arrjsvalue:=copy(arrjsvalue,12,13);');
  5726. ConvertProgram;
  5727. CheckSource('TestArray_Copy',
  5728. LinesToStr([ // statements
  5729. 'this.TFlag = {',
  5730. ' "0": "big",',
  5731. ' big: 0,',
  5732. ' "1": "small",',
  5733. ' small: 1',
  5734. '};',
  5735. 'this.TRec = function (s) {',
  5736. ' if (s) {',
  5737. ' this.i = s.i;',
  5738. ' } else {',
  5739. ' this.i = 0;',
  5740. ' };',
  5741. ' this.$equal = function (b) {',
  5742. ' return this.i === b.i;',
  5743. ' };',
  5744. '};',
  5745. 'this.ArrInt = [];',
  5746. 'this.ArrRec = [];',
  5747. 'this.ArrSet = [];',
  5748. 'this.ArrJSValue = [];',
  5749. '']),
  5750. LinesToStr([ // $mod.$main
  5751. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 0);',
  5752. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 2);',
  5753. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 3, 4);',
  5754. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 0);',
  5755. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 5);',
  5756. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 6, 7);',
  5757. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 0);',
  5758. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 8);',
  5759. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 9, 10);',
  5760. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 0);',
  5761. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 11);',
  5762. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 12, 13);',
  5763. '']));
  5764. end;
  5765. procedure TTestModule.TestArray_InsertDelete;
  5766. begin
  5767. StartProgram(false);
  5768. Add('type');
  5769. Add(' integer = longint;');
  5770. Add(' TFlag = (big,small);');
  5771. Add(' TFlags = set of TFlag;');
  5772. Add(' TRec = record');
  5773. Add(' i: integer;');
  5774. Add(' end;');
  5775. Add(' TArrInt = array of integer;');
  5776. Add(' TArrRec = array of TRec;');
  5777. Add(' TArrSet = array of TFlags;');
  5778. Add(' TArrJSValue = array of jsvalue;');
  5779. Add('var');
  5780. Add(' ArrInt: tarrint;');
  5781. Add(' ArrRec: tarrrec;');
  5782. Add(' ArrSet: tarrset;');
  5783. Add(' ArrJSValue: tarrjsvalue;');
  5784. Add('begin');
  5785. Add(' Insert(1,arrint,2);');
  5786. Add(' Insert(arrint[3],arrint,4);');
  5787. Add(' Insert(arrrec[5],arrrec,6);');
  5788. Add(' Insert(arrset[7],arrset,7);');
  5789. Add(' Insert(arrjsvalue[8],arrjsvalue,9);');
  5790. Add(' Insert(10,arrjsvalue,11);');
  5791. Add(' Delete(arrint,12,13);');
  5792. Add(' Delete(arrrec,14,15);');
  5793. Add(' Delete(arrset,17,18);');
  5794. Add(' Delete(arrjsvalue,19,10);');
  5795. ConvertProgram;
  5796. CheckSource('TestArray_InsertDelete',
  5797. LinesToStr([ // statements
  5798. 'this.TFlag = {',
  5799. ' "0": "big",',
  5800. ' big: 0,',
  5801. ' "1": "small",',
  5802. ' small: 1',
  5803. '};',
  5804. 'this.TRec = function (s) {',
  5805. ' if (s) {',
  5806. ' this.i = s.i;',
  5807. ' } else {',
  5808. ' this.i = 0;',
  5809. ' };',
  5810. ' this.$equal = function (b) {',
  5811. ' return this.i === b.i;',
  5812. ' };',
  5813. '};',
  5814. 'this.ArrInt = [];',
  5815. 'this.ArrRec = [];',
  5816. 'this.ArrSet = [];',
  5817. 'this.ArrJSValue = [];',
  5818. '']),
  5819. LinesToStr([ // $mod.$main
  5820. '$mod.ArrInt.splice(2, 0, 1);',
  5821. '$mod.ArrInt.splice(4, 0, $mod.ArrInt[3]);',
  5822. '$mod.ArrRec.splice(6, 0, $mod.ArrRec[5]);',
  5823. '$mod.ArrSet.splice(7, 0, $mod.ArrSet[7]);',
  5824. '$mod.ArrJSValue.splice(9, 0, $mod.ArrJSValue[8]);',
  5825. '$mod.ArrJSValue.splice(11, 0, 10);',
  5826. '$mod.ArrInt.splice(12, 13);',
  5827. '$mod.ArrRec.splice(14, 15);',
  5828. '$mod.ArrSet.splice(17, 18);',
  5829. '$mod.ArrJSValue.splice(19, 10);',
  5830. '']));
  5831. end;
  5832. procedure TTestModule.TestArray_DynArrayConst;
  5833. begin
  5834. StartProgram(false);
  5835. Add([
  5836. 'type',
  5837. ' integer = longint;',
  5838. ' TArrInt = array of integer;',
  5839. ' TArrStr = array of string;',
  5840. 'const',
  5841. ' Ints: TArrInt = (1,2,3);',
  5842. ' Names: array of string = (''a'',''foo'');',
  5843. ' Aliases: TarrStr = (''foo'',''b'');',
  5844. ' OneInt: TArrInt = (7);',
  5845. ' OneStr: array of integer = (7);',
  5846. //' Chars: array of char = ''aoc'';',
  5847. ' NameCount = low(Names)+high(Names)+length(Names);',
  5848. 'begin',
  5849. '']);
  5850. ConvertProgram;
  5851. CheckSource('TestArray_DynArrayConst',
  5852. LinesToStr([ // statements
  5853. 'this.Ints = [1, 2, 3];',
  5854. 'this.Names = ["a", "foo"];',
  5855. 'this.Aliases = ["foo", "b"];',
  5856. 'this.OneInt = [7];',
  5857. 'this.OneStr = [7];',
  5858. 'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
  5859. '']),
  5860. LinesToStr([ // $mod.$main
  5861. '']));
  5862. end;
  5863. procedure TTestModule.TestExternalClass_TypeCastArrayToExternalArray;
  5864. begin
  5865. StartProgram(false);
  5866. Add('{$modeswitch externalclass}');
  5867. Add('type');
  5868. Add(' TJSArray = class external name ''Array''');
  5869. Add(' class function isArray(Value: JSValue) : boolean;');
  5870. Add(' function concat() : TJSArray; varargs;');
  5871. Add(' end;');
  5872. Add('var');
  5873. Add(' aObj: TJSArray;');
  5874. Add(' a: array of longint;');
  5875. Add('begin');
  5876. Add(' if TJSArray.isArray(65) then ;');
  5877. Add(' aObj:=TJSArray(a).concat(a);');
  5878. ConvertProgram;
  5879. CheckSource('TestExternalClass_TypeCastArrayToExternalArray',
  5880. LinesToStr([ // statements
  5881. 'this.aObj = null;',
  5882. 'this.a = [];',
  5883. '']),
  5884. LinesToStr([ // $mod.$main
  5885. 'if (Array.isArray(65)) ;',
  5886. '$mod.aObj = $mod.a.concat($mod.a);',
  5887. '']));
  5888. end;
  5889. procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalArray;
  5890. begin
  5891. StartProgram(false);
  5892. Add('{$modeswitch externalclass}');
  5893. Add('type');
  5894. Add(' TArrStr = array of string;');
  5895. Add(' TJSArray = class external name ''Array''');
  5896. Add(' end;');
  5897. Add('var');
  5898. Add(' aObj: TJSArray;');
  5899. Add(' a: TArrStr;');
  5900. Add('begin');
  5901. Add(' a:=TArrStr(aObj);');
  5902. Add(' TArrStr(aObj)[1]:=TArrStr(aObj)[2];');
  5903. ConvertProgram;
  5904. CheckSource('TestExternalClass_TypeCastArrayFromExternalArray',
  5905. LinesToStr([ // statements
  5906. 'this.aObj = null;',
  5907. 'this.a = [];',
  5908. '']),
  5909. LinesToStr([ // $mod.$main
  5910. '$mod.a = $mod.aObj;',
  5911. '$mod.aObj[1] = $mod.aObj[2];',
  5912. '']));
  5913. end;
  5914. procedure TTestModule.TestRecord_Var;
  5915. begin
  5916. StartProgram(false);
  5917. Add('type');
  5918. Add(' TRecA = record');
  5919. Add(' Bold: longint;');
  5920. Add(' end;');
  5921. Add('var Rec: TRecA;');
  5922. Add('begin');
  5923. Add(' rec.bold:=123');
  5924. ConvertProgram;
  5925. CheckSource('TestRecord_Var',
  5926. LinesToStr([ // statements
  5927. 'this.TRecA = function (s) {',
  5928. ' if (s) {',
  5929. ' this.Bold = s.Bold;',
  5930. ' } else {',
  5931. ' this.Bold = 0;',
  5932. ' };',
  5933. ' this.$equal = function (b) {',
  5934. ' return this.Bold === b.Bold;',
  5935. ' };',
  5936. '};',
  5937. 'this.Rec = new $mod.TRecA();'
  5938. ]),
  5939. LinesToStr([ // $mod.$main
  5940. '$mod.Rec.Bold = 123;'
  5941. ]));
  5942. end;
  5943. procedure TTestModule.TestWithRecordDo;
  5944. begin
  5945. StartProgram(false);
  5946. Add('type');
  5947. Add(' TRec = record');
  5948. Add(' vI: longint;');
  5949. Add(' end;');
  5950. Add('var');
  5951. Add(' Int: longint;');
  5952. Add(' r: TRec;');
  5953. Add('begin');
  5954. Add(' with r do');
  5955. Add(' int:=vi;');
  5956. Add(' with r do begin');
  5957. Add(' int:=vi;');
  5958. Add(' vi:=int;');
  5959. Add(' end;');
  5960. ConvertProgram;
  5961. CheckSource('TestWithRecordDo',
  5962. LinesToStr([ // statements
  5963. 'this.TRec = function (s) {',
  5964. ' if (s) {',
  5965. ' this.vI = s.vI;',
  5966. ' } else {',
  5967. ' this.vI = 0;',
  5968. ' };',
  5969. ' this.$equal = function (b) {',
  5970. ' return this.vI === b.vI;',
  5971. ' };',
  5972. '};',
  5973. 'this.Int = 0;',
  5974. 'this.r = new $mod.TRec();'
  5975. ]),
  5976. LinesToStr([ // $mod.$main
  5977. 'var $with1 = $mod.r;',
  5978. '$mod.Int = $with1.vI;',
  5979. 'var $with2 = $mod.r;',
  5980. '$mod.Int = $with2.vI;',
  5981. '$with2.vI = $mod.Int;'
  5982. ]));
  5983. end;
  5984. procedure TTestModule.TestRecord_Assign;
  5985. begin
  5986. StartProgram(false);
  5987. Add('type');
  5988. Add(' TEnum = (red,green);');
  5989. Add(' TEnums = set of TEnum;');
  5990. Add(' TSmallRec = record');
  5991. Add(' N: longint;');
  5992. Add(' end;');
  5993. Add(' TBigRec = record');
  5994. Add(' Int: longint;');
  5995. Add(' D: double;');
  5996. Add(' Arr: array of longint;');
  5997. Add(' Small: TSmallRec;');
  5998. Add(' Enums: TEnums;');
  5999. Add(' end;');
  6000. Add('var');
  6001. Add(' r, s: TBigRec;');
  6002. Add('begin');
  6003. Add(' r:=s;');
  6004. ConvertProgram;
  6005. CheckSource('TestRecord_Assign',
  6006. LinesToStr([ // statements
  6007. 'this.TEnum = {',
  6008. ' "0": "red",',
  6009. ' red: 0,',
  6010. ' "1": "green",',
  6011. ' green: 1',
  6012. '};',
  6013. 'this.TSmallRec = function (s) {',
  6014. ' if(s){',
  6015. ' this.N = s.N;',
  6016. ' } else {',
  6017. ' this.N = 0;',
  6018. ' };',
  6019. ' this.$equal = function (b) {',
  6020. ' return this.N === b.N;',
  6021. ' };',
  6022. '};',
  6023. 'this.TBigRec = function (s) {',
  6024. ' if(s){',
  6025. ' this.Int = s.Int;',
  6026. ' this.D = s.D;',
  6027. ' this.Arr = s.Arr;',
  6028. ' this.Small = new $mod.TSmallRec(s.Small);',
  6029. ' this.Enums = rtl.refSet(s.Enums);',
  6030. ' } else {',
  6031. ' this.Int = 0;',
  6032. ' this.D = 0.0;',
  6033. ' this.Arr = [];',
  6034. ' this.Small = new $mod.TSmallRec();',
  6035. ' this.Enums = {};',
  6036. ' };',
  6037. ' this.$equal = function (b) {',
  6038. ' return (this.Int === b.Int) && ((this.D === b.D) && ((this.Arr === b.Arr)',
  6039. ' && (this.Small.$equal(b.Small) && rtl.eqSet(this.Enums, b.Enums))));',
  6040. ' };',
  6041. '};',
  6042. 'this.r = new $mod.TBigRec();',
  6043. 'this.s = new $mod.TBigRec();'
  6044. ]),
  6045. LinesToStr([ // $mod.$main
  6046. '$mod.r = new $mod.TBigRec($mod.s);',
  6047. '']));
  6048. end;
  6049. procedure TTestModule.TestRecord_PassAsArgClone;
  6050. begin
  6051. StartProgram(false);
  6052. Add('type');
  6053. Add(' TRecA = record');
  6054. Add(' Bold: longint;');
  6055. Add(' end;');
  6056. Add('procedure DoDefault(r: treca); begin end;');
  6057. Add('procedure DoConst(const r: treca); begin end;');
  6058. Add('var Rec: treca;');
  6059. Add('begin');
  6060. Add(' dodefault(rec);');
  6061. Add(' doconst(rec);');
  6062. ConvertProgram;
  6063. CheckSource('TestRecord_PassAsArgClone',
  6064. LinesToStr([ // statements
  6065. 'this.TRecA = function (s) {',
  6066. ' if (s) {',
  6067. ' this.Bold = s.Bold;',
  6068. ' } else {',
  6069. ' this.Bold = 0;',
  6070. ' };',
  6071. ' this.$equal = function (b) {',
  6072. ' return this.Bold === b.Bold;',
  6073. ' };',
  6074. '};',
  6075. 'this.DoDefault = function (r) {',
  6076. '};',
  6077. 'this.DoConst = function (r) {',
  6078. '};',
  6079. 'this.Rec = new $mod.TRecA();'
  6080. ]),
  6081. LinesToStr([ // $mod.$main
  6082. '$mod.DoDefault(new $mod.TRecA($mod.Rec));',
  6083. '$mod.DoConst($mod.Rec);',
  6084. '']));
  6085. end;
  6086. procedure TTestModule.TestRecord_AsParams;
  6087. begin
  6088. StartProgram(false);
  6089. Add('type');
  6090. Add(' integer = longint;');
  6091. Add(' TRecord = record');
  6092. Add(' i: integer;');
  6093. Add(' end;');
  6094. Add('procedure DoIt(vG: TRecord; const vH: TRecord; var vI: TRecord);');
  6095. Add('var vJ: TRecord;');
  6096. Add('begin');
  6097. Add(' vg:=vg;');
  6098. Add(' vj:=vh;');
  6099. Add(' vi:=vi;');
  6100. Add(' doit(vg,vg,vg);');
  6101. Add(' doit(vh,vh,vj);');
  6102. Add(' doit(vi,vi,vi);');
  6103. Add(' doit(vj,vj,vj);');
  6104. Add('end;');
  6105. Add('var i: TRecord;');
  6106. Add('begin');
  6107. Add(' doit(i,i,i);');
  6108. ConvertProgram;
  6109. CheckSource('TestRecord_AsParams',
  6110. LinesToStr([ // statements
  6111. 'this.TRecord = function (s) {',
  6112. ' if (s) {',
  6113. ' this.i = s.i;',
  6114. ' } else {',
  6115. ' this.i = 0;',
  6116. ' };',
  6117. ' this.$equal = function (b) {',
  6118. ' return this.i === b.i;',
  6119. ' };',
  6120. '};',
  6121. 'this.DoIt = function (vG,vH,vI) {',
  6122. ' var vJ = new $mod.TRecord();',
  6123. ' vG = new $mod.TRecord(vG);',
  6124. ' vJ = new $mod.TRecord(vH);',
  6125. ' vI.set(new $mod.TRecord(vI.get()));',
  6126. ' $mod.DoIt(new $mod.TRecord(vG), vG, {',
  6127. ' get: function () {',
  6128. ' return vG;',
  6129. ' },',
  6130. ' set: function (v) {',
  6131. ' vG = v;',
  6132. ' }',
  6133. ' });',
  6134. ' $mod.DoIt(new $mod.TRecord(vH), vH, {',
  6135. ' get: function () {',
  6136. ' return vJ;',
  6137. ' },',
  6138. ' set: function (v) {',
  6139. ' vJ = v;',
  6140. ' }',
  6141. ' });',
  6142. ' $mod.DoIt(new $mod.TRecord(vI.get()), vI.get(), vI);',
  6143. ' $mod.DoIt(new $mod.TRecord(vJ), vJ, {',
  6144. ' get: function () {',
  6145. ' return vJ;',
  6146. ' },',
  6147. ' set: function (v) {',
  6148. ' vJ = v;',
  6149. ' }',
  6150. ' });',
  6151. '};',
  6152. 'this.i = new $mod.TRecord();'
  6153. ]),
  6154. LinesToStr([
  6155. '$mod.DoIt(new $mod.TRecord($mod.i),$mod.i,{',
  6156. ' p: $mod,',
  6157. ' get: function () {',
  6158. ' return this.p.i;',
  6159. ' },',
  6160. ' set: function (v) {',
  6161. ' this.p.i = v;',
  6162. ' }',
  6163. '});'
  6164. ]));
  6165. end;
  6166. procedure TTestModule.TestRecordElement_AsParams;
  6167. begin
  6168. StartProgram(false);
  6169. Add('type');
  6170. Add(' integer = longint;');
  6171. Add(' TRecord = record');
  6172. Add(' i: integer;');
  6173. Add(' end;');
  6174. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  6175. Add('var vJ: TRecord;');
  6176. Add('begin');
  6177. Add(' doit(vj.i,vj.i,vj.i);');
  6178. Add('end;');
  6179. Add('var r: TRecord;');
  6180. Add('begin');
  6181. Add(' doit(r.i,r.i,r.i);');
  6182. ConvertProgram;
  6183. CheckSource('TestRecordElement_AsParams',
  6184. LinesToStr([ // statements
  6185. 'this.TRecord = function (s) {',
  6186. ' if (s) {',
  6187. ' this.i = s.i;',
  6188. ' } else {',
  6189. ' this.i = 0;',
  6190. ' };',
  6191. ' this.$equal = function (b) {',
  6192. ' return this.i === b.i;',
  6193. ' };',
  6194. '};',
  6195. 'this.DoIt = function (vG,vH,vI) {',
  6196. ' var vJ = new $mod.TRecord();',
  6197. ' $mod.DoIt(vJ.i, vJ.i, {',
  6198. ' p: vJ,',
  6199. ' get: function () {',
  6200. ' return this.p.i;',
  6201. ' },',
  6202. ' set: function (v) {',
  6203. ' this.p.i = v;',
  6204. ' }',
  6205. ' });',
  6206. '};',
  6207. 'this.r = new $mod.TRecord();'
  6208. ]),
  6209. LinesToStr([
  6210. '$mod.DoIt($mod.r.i,$mod.r.i,{',
  6211. ' p: $mod.r,',
  6212. ' get: function () {',
  6213. ' return this.p.i;',
  6214. ' },',
  6215. ' set: function (v) {',
  6216. ' this.p.i = v;',
  6217. ' }',
  6218. '});'
  6219. ]));
  6220. end;
  6221. procedure TTestModule.TestRecordElementFromFuncResult_AsParams;
  6222. begin
  6223. StartProgram(false);
  6224. Add('type');
  6225. Add(' integer = longint;');
  6226. Add(' TRecord = record');
  6227. Add(' i: integer;');
  6228. Add(' end;');
  6229. Add('function GetRec(vB: integer = 0): TRecord;');
  6230. Add('begin');
  6231. Add('end;');
  6232. Add('procedure DoIt(vG: integer; const vH: integer);');
  6233. Add('begin');
  6234. Add('end;');
  6235. Add('begin');
  6236. Add(' doit(getrec.i,getrec.i);');
  6237. Add(' doit(getrec().i,getrec().i);');
  6238. Add(' doit(getrec(1).i,getrec(2).i);');
  6239. ConvertProgram;
  6240. CheckSource('TestRecordElementFromFuncResult_AsParams',
  6241. LinesToStr([ // statements
  6242. 'this.TRecord = function (s) {',
  6243. ' if (s) {',
  6244. ' this.i = s.i;',
  6245. ' } else {',
  6246. ' this.i = 0;',
  6247. ' };',
  6248. ' this.$equal = function (b) {',
  6249. ' return this.i === b.i;',
  6250. ' };',
  6251. '};',
  6252. 'this.GetRec = function (vB) {',
  6253. ' var Result = new $mod.TRecord();',
  6254. ' return Result;',
  6255. '};',
  6256. 'this.DoIt = function (vG,vH) {',
  6257. '};'
  6258. ]),
  6259. LinesToStr([
  6260. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  6261. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  6262. '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);',
  6263. '']));
  6264. end;
  6265. procedure TTestModule.TestRecordElementFromWith_AsParams;
  6266. begin
  6267. StartProgram(false);
  6268. Add('type');
  6269. Add(' integer = longint;');
  6270. Add(' TRecord = record');
  6271. Add(' i: integer;');
  6272. Add(' end;');
  6273. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  6274. Add('begin');
  6275. Add('end;');
  6276. Add('var r: trecord;');
  6277. Add('begin');
  6278. Add(' with r do ');
  6279. Add(' doit(i,i,i);');
  6280. ConvertProgram;
  6281. CheckSource('TestRecordElementFromWith_AsParams',
  6282. LinesToStr([ // statements
  6283. 'this.TRecord = function (s) {',
  6284. ' if (s) {',
  6285. ' this.i = s.i;',
  6286. ' } else {',
  6287. ' this.i = 0;',
  6288. ' };',
  6289. ' this.$equal = function (b) {',
  6290. ' return this.i === b.i;',
  6291. ' };',
  6292. '};',
  6293. 'this.DoIt = function (vG,vH,vI) {',
  6294. '};',
  6295. 'this.r = new $mod.TRecord();'
  6296. ]),
  6297. LinesToStr([
  6298. 'var $with1 = $mod.r;',
  6299. '$mod.DoIt($with1.i,$with1.i,{',
  6300. ' p: $with1,',
  6301. ' get: function () {',
  6302. ' return this.p.i;',
  6303. ' },',
  6304. ' set: function (v) {',
  6305. ' this.p.i = v;',
  6306. ' }',
  6307. '});',
  6308. '']));
  6309. end;
  6310. procedure TTestModule.TestRecord_Equal;
  6311. begin
  6312. StartProgram(false);
  6313. Add('type');
  6314. Add(' integer = longint;');
  6315. Add(' TFlag = (red,blue);');
  6316. Add(' TFlags = set of TFlag;');
  6317. Add(' TProc = procedure;');
  6318. Add(' TRecord = record');
  6319. Add(' i: integer;');
  6320. Add(' Event: TProc;');
  6321. Add(' f: TFlags;');
  6322. Add(' end;');
  6323. Add(' TNested = record');
  6324. Add(' r: TRecord;');
  6325. Add(' end;');
  6326. Add('var');
  6327. Add(' b: boolean;');
  6328. Add(' r,s: trecord;');
  6329. Add('begin');
  6330. Add(' b:=r=s;');
  6331. Add(' b:=r<>s;');
  6332. ConvertProgram;
  6333. CheckSource('TestRecord_Equal',
  6334. LinesToStr([ // statements
  6335. 'this.TFlag = {',
  6336. ' "0": "red",',
  6337. ' red: 0,',
  6338. ' "1": "blue",',
  6339. ' blue: 1',
  6340. '};',
  6341. 'this.TRecord = function (s) {',
  6342. ' if (s) {',
  6343. ' this.i = s.i;',
  6344. ' this.Event = s.Event;',
  6345. ' this.f = rtl.refSet(s.f);',
  6346. ' } else {',
  6347. ' this.i = 0;',
  6348. ' this.Event = null;',
  6349. ' this.f = {};',
  6350. ' };',
  6351. ' this.$equal = function (b) {',
  6352. ' return (this.i === b.i) && (rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f));',
  6353. ' };',
  6354. '};',
  6355. 'this.TNested = function (s) {',
  6356. ' if (s) {',
  6357. ' this.r = new $mod.TRecord(s.r);',
  6358. ' } else {',
  6359. ' this.r = new $mod.TRecord();',
  6360. ' };',
  6361. ' this.$equal = function (b) {',
  6362. ' return this.r.$equal(b.r);',
  6363. ' };',
  6364. '};',
  6365. 'this.b = false;',
  6366. 'this.r = new $mod.TRecord();',
  6367. 'this.s = new $mod.TRecord();'
  6368. ]),
  6369. LinesToStr([
  6370. '$mod.b = $mod.r.$equal($mod.s);',
  6371. '$mod.b = !$mod.r.$equal($mod.s);',
  6372. '']));
  6373. end;
  6374. procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
  6375. begin
  6376. StartProgram(false);
  6377. Add('type');
  6378. Add(' TRecord = record');
  6379. Add(' i: longint;');
  6380. Add(' end;');
  6381. Add('var');
  6382. Add(' Jv: jsvalue;');
  6383. Add(' Rec: trecord;');
  6384. Add('begin');
  6385. Add(' rec:=trecord(jv);');
  6386. ConvertProgram;
  6387. CheckSource('TestRecord_TypeCastJSValueToRecord',
  6388. LinesToStr([ // statements
  6389. 'this.TRecord = function (s) {',
  6390. ' if (s) {',
  6391. ' this.i = s.i;',
  6392. ' } else {',
  6393. ' this.i = 0;',
  6394. ' };',
  6395. ' this.$equal = function (b) {',
  6396. ' return this.i === b.i;',
  6397. ' };',
  6398. '};',
  6399. 'this.Jv = undefined;',
  6400. 'this.Rec = new $mod.TRecord();'
  6401. ]),
  6402. LinesToStr([
  6403. '$mod.Rec = new $mod.TRecord(rtl.getObject($mod.Jv));',
  6404. '']));
  6405. end;
  6406. procedure TTestModule.TestClass_TObjectDefaultConstructor;
  6407. begin
  6408. StartProgram(false);
  6409. Add('type');
  6410. Add(' TObject = class');
  6411. Add(' public');
  6412. Add(' constructor Create;');
  6413. Add(' destructor Destroy;');
  6414. Add(' end;');
  6415. Add(' TBird = TObject;');
  6416. Add('constructor tobject.create;');
  6417. Add('begin end;');
  6418. Add('destructor tobject.destroy;');
  6419. Add('begin end;');
  6420. Add('var Obj: tobject;');
  6421. Add('begin');
  6422. Add(' obj:=tobject.create;');
  6423. Add(' obj:=tbird.create;');
  6424. Add(' obj.destroy;');
  6425. ConvertProgram;
  6426. CheckSource('TestClass_TObjectDefaultConstructor',
  6427. LinesToStr([ // statements
  6428. 'rtl.createClass($mod,"TObject",null,function(){',
  6429. ' this.$init = function () {',
  6430. ' };',
  6431. ' this.$final = function () {',
  6432. ' };',
  6433. ' this.Create = function(){',
  6434. ' };',
  6435. ' this.Destroy = function(){',
  6436. ' };',
  6437. '});',
  6438. 'this.Obj = null;'
  6439. ]),
  6440. LinesToStr([ // $mod.$main
  6441. '$mod.Obj = $mod.TObject.$create("Create");',
  6442. '$mod.Obj = $mod.TObject.$create("Create");',
  6443. '$mod.Obj.$destroy("Destroy");',
  6444. '']));
  6445. end;
  6446. procedure TTestModule.TestClass_TObjectConstructorWithParams;
  6447. begin
  6448. StartProgram(false);
  6449. Add('type');
  6450. Add(' TObject = class');
  6451. Add(' public');
  6452. Add(' constructor Create(Par: longint);');
  6453. Add(' end;');
  6454. Add('constructor tobject.create(par: longint);');
  6455. Add('begin end;');
  6456. Add('var Obj: tobject;');
  6457. Add('begin');
  6458. Add(' obj:=tobject.create(3);');
  6459. ConvertProgram;
  6460. CheckSource('TestClass_TObjectConstructorWithParams',
  6461. LinesToStr([ // statements
  6462. 'rtl.createClass($mod,"TObject",null,function(){',
  6463. ' this.$init = function () {',
  6464. ' };',
  6465. ' this.$final = function () {',
  6466. ' };',
  6467. ' this.Create = function(Par){',
  6468. ' };',
  6469. '});',
  6470. 'this.Obj = null;'
  6471. ]),
  6472. LinesToStr([ // $mod.$main
  6473. '$mod.Obj = $mod.TObject.$create("Create",[3]);'
  6474. ]));
  6475. end;
  6476. procedure TTestModule.TestClass_TObjectConstructorWithDefaultParam;
  6477. begin
  6478. StartProgram(false);
  6479. Add('type');
  6480. Add(' TObject = class');
  6481. Add(' public');
  6482. Add(' constructor Create;');
  6483. Add(' end;');
  6484. Add(' TTest = class(TObject)');
  6485. Add(' public');
  6486. Add(' constructor Create(const Par: longint = 1);');
  6487. Add(' end;');
  6488. Add('constructor tobject.create;');
  6489. Add('begin end;');
  6490. Add('constructor ttest.create(const par: longint);');
  6491. Add('begin end;');
  6492. Add('var t: ttest;');
  6493. Add('begin');
  6494. Add(' t:=ttest.create;');
  6495. Add(' t:=ttest.create(2);');
  6496. ConvertProgram;
  6497. CheckSource('TestClass_TObjectConstructorWithDefaultParam',
  6498. LinesToStr([ // statements
  6499. 'rtl.createClass($mod,"TObject",null,function(){',
  6500. ' this.$init = function () {',
  6501. ' };',
  6502. ' this.$final = function () {',
  6503. ' };',
  6504. ' this.Create = function(){',
  6505. ' };',
  6506. '});',
  6507. 'rtl.createClass($mod, "TTest", $mod.TObject, function () {',
  6508. ' this.Create$1 = function (Par) {',
  6509. ' };',
  6510. '});',
  6511. 'this.t = null;'
  6512. ]),
  6513. LinesToStr([ // $mod.$main
  6514. '$mod.t = $mod.TTest.$create("Create$1", [1]);',
  6515. '$mod.t = $mod.TTest.$create("Create$1", [2]);'
  6516. ]));
  6517. end;
  6518. procedure TTestModule.TestClass_Var;
  6519. begin
  6520. StartProgram(false);
  6521. Add('type');
  6522. Add(' TObject = class');
  6523. Add(' public');
  6524. Add(' vI: longint;');
  6525. Add(' constructor Create(Par: longint);');
  6526. Add(' end;');
  6527. Add('constructor tobject.create(par: longint);');
  6528. Add('begin');
  6529. Add(' vi:=par+3');
  6530. Add('end;');
  6531. Add('var Obj: tobject;');
  6532. Add('begin');
  6533. Add(' obj:=tobject.create(4);');
  6534. Add(' obj.vi:=obj.VI+5;');
  6535. ConvertProgram;
  6536. CheckSource('TestClass_Var',
  6537. LinesToStr([ // statements
  6538. 'rtl.createClass($mod,"TObject",null,function(){',
  6539. ' this.$init = function () {',
  6540. ' this.vI = 0;',
  6541. ' };',
  6542. ' this.$final = function () {',
  6543. ' };',
  6544. ' this.Create = function(Par){',
  6545. ' this.vI = Par+3;',
  6546. ' };',
  6547. '});',
  6548. 'this.Obj = null;'
  6549. ]),
  6550. LinesToStr([ // $mod.$main
  6551. '$mod.Obj = $mod.TObject.$create("Create",[4]);',
  6552. '$mod.Obj.vI = $mod.Obj.vI + 5;'
  6553. ]));
  6554. end;
  6555. procedure TTestModule.TestClass_Method;
  6556. begin
  6557. StartProgram(false);
  6558. Add('type');
  6559. Add(' TObject = class');
  6560. Add(' public');
  6561. Add(' vI: longint;');
  6562. Add(' Sub: TObject;');
  6563. Add(' constructor Create;');
  6564. Add(' function GetIt(Par: longint): tobject;');
  6565. Add(' end;');
  6566. Add('constructor tobject.create; begin end;');
  6567. Add('function tobject.getit(par: longint): tobject;');
  6568. Add('begin');
  6569. Add(' Self.vi:=par+3;');
  6570. Add(' Result:=self.sub;');
  6571. Add('end;');
  6572. Add('var Obj: tobject;');
  6573. Add('begin');
  6574. Add(' obj:=tobject.create;');
  6575. Add(' obj.getit(4);');
  6576. Add(' obj.sub.sub:=nil;');
  6577. Add(' obj.sub.getit(5);');
  6578. Add(' obj.sub.getit(6).SUB:=nil;');
  6579. Add(' obj.sub.getit(7).GETIT(8);');
  6580. Add(' obj.sub.getit(9).SuB.getit(10);');
  6581. ConvertProgram;
  6582. CheckSource('TestClass_Method',
  6583. LinesToStr([ // statements
  6584. 'rtl.createClass($mod,"TObject",null,function(){',
  6585. ' this.$init = function () {',
  6586. ' this.vI = 0;',
  6587. ' this.Sub = null;',
  6588. ' };',
  6589. ' this.$final = function () {',
  6590. ' this.Sub = undefined;',
  6591. ' };',
  6592. ' this.Create = function(){',
  6593. ' };',
  6594. ' this.GetIt = function(Par){',
  6595. ' var Result = null;',
  6596. ' this.vI = Par + 3;',
  6597. ' Result = this.Sub;',
  6598. ' return Result;',
  6599. ' };',
  6600. '});',
  6601. 'this.Obj = null;'
  6602. ]),
  6603. LinesToStr([ // $mod.$main
  6604. '$mod.Obj = $mod.TObject.$create("Create");',
  6605. '$mod.Obj.GetIt(4);',
  6606. '$mod.Obj.Sub.Sub=null;',
  6607. '$mod.Obj.Sub.GetIt(5);',
  6608. '$mod.Obj.Sub.GetIt(6).Sub=null;',
  6609. '$mod.Obj.Sub.GetIt(7).GetIt(8);',
  6610. '$mod.Obj.Sub.GetIt(9).Sub.GetIt(10);'
  6611. ]));
  6612. end;
  6613. procedure TTestModule.TestClass_Implementation;
  6614. begin
  6615. StartUnit(false);
  6616. Add([
  6617. 'interface',
  6618. 'type',
  6619. ' TObject = class',
  6620. ' constructor Create;',
  6621. ' end;',
  6622. 'implementation',
  6623. 'type',
  6624. ' TIntClass = class',
  6625. ' constructor Create; reintroduce;',
  6626. ' class procedure DoGlob;',
  6627. ' end;',
  6628. 'constructor tintclass.create;',
  6629. 'begin',
  6630. ' inherited;',
  6631. ' inherited create;',
  6632. ' doglob;',
  6633. 'end;',
  6634. 'class procedure tintclass.doglob;',
  6635. 'begin',
  6636. 'end;',
  6637. 'constructor tobject.create;',
  6638. 'var',
  6639. ' iC: tintclass;',
  6640. 'begin',
  6641. ' ic:=tintclass.create;',
  6642. ' tintclass.doglob;',
  6643. ' ic.doglob;',
  6644. 'end;',
  6645. 'initialization',
  6646. ' tintclass.doglob;',
  6647. '']);
  6648. ConvertUnit;
  6649. CheckSource('TestClass_Implementation',
  6650. LinesToStr([ // statements
  6651. 'var $impl = $mod.$impl;',
  6652. 'rtl.createClass($mod, "TObject", null, function () {',
  6653. ' this.$init = function () {',
  6654. ' };',
  6655. ' this.$final = function () {',
  6656. ' };',
  6657. ' this.Create = function () {',
  6658. ' var iC = null;',
  6659. ' iC = $impl.TIntClass.$create("Create$1");',
  6660. ' $impl.TIntClass.DoGlob();',
  6661. ' iC.$class.DoGlob();',
  6662. ' };',
  6663. '});',
  6664. '']),
  6665. LinesToStr([ // $mod.$main
  6666. '$impl.TIntClass.DoGlob();',
  6667. '']),
  6668. LinesToStr([
  6669. 'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
  6670. ' this.Create$1 = function () {',
  6671. ' $mod.TObject.Create.apply(this, arguments);',
  6672. ' $mod.TObject.Create.call(this);',
  6673. ' this.$class.DoGlob();',
  6674. ' };',
  6675. ' this.DoGlob = function () {',
  6676. ' };',
  6677. '});',
  6678. '']));
  6679. end;
  6680. procedure TTestModule.TestClass_Inheritance;
  6681. begin
  6682. StartProgram(false);
  6683. Add('type');
  6684. Add(' TObject = class');
  6685. Add(' public');
  6686. Add(' constructor Create;');
  6687. Add(' end;');
  6688. Add(' TClassA = class');
  6689. Add(' end;');
  6690. Add(' TClassB = class(TObject)');
  6691. Add(' procedure ProcB;');
  6692. Add(' end;');
  6693. Add('constructor tobject.create; begin end;');
  6694. Add('procedure tclassb.procb; begin end;');
  6695. Add('var');
  6696. Add(' oO: TObject;');
  6697. Add(' oA: TClassA;');
  6698. Add(' oB: TClassB;');
  6699. Add('begin');
  6700. Add(' oO:=tobject.Create;');
  6701. Add(' oA:=tclassa.Create;');
  6702. Add(' ob:=tclassb.Create;');
  6703. Add(' if oo is tclassa then ;');
  6704. Add(' ob:=oo as tclassb;');
  6705. Add(' (oo as tclassb).procb;');
  6706. ConvertProgram;
  6707. CheckSource('TestClass_Inheritance',
  6708. LinesToStr([ // statements
  6709. 'rtl.createClass($mod,"TObject",null,function(){',
  6710. ' this.$init = function () {',
  6711. ' };',
  6712. ' this.$final = function () {',
  6713. ' };',
  6714. ' this.Create = function () {',
  6715. ' };',
  6716. '});',
  6717. 'rtl.createClass($mod,"TClassA",$mod.TObject,function(){',
  6718. '});',
  6719. 'rtl.createClass($mod,"TClassB",$mod.TObject,function(){',
  6720. ' this.ProcB = function () {',
  6721. ' };',
  6722. '});',
  6723. 'this.oO = null;',
  6724. 'this.oA = null;',
  6725. 'this.oB = null;'
  6726. ]),
  6727. LinesToStr([ // $mod.$main
  6728. '$mod.oO = $mod.TObject.$create("Create");',
  6729. '$mod.oA = $mod.TClassA.$create("Create");',
  6730. '$mod.oB = $mod.TClassB.$create("Create");',
  6731. 'if ($mod.TClassA.isPrototypeOf($mod.oO));',
  6732. '$mod.oB = rtl.as($mod.oO, $mod.TClassB);',
  6733. 'rtl.as($mod.oO, $mod.TClassB).ProcB();'
  6734. ]));
  6735. end;
  6736. procedure TTestModule.TestClass_AbstractMethod;
  6737. begin
  6738. StartProgram(false);
  6739. Add('type');
  6740. Add(' TObject = class');
  6741. Add(' public');
  6742. Add(' procedure DoIt; virtual; abstract;');
  6743. Add(' end;');
  6744. Add('begin');
  6745. ConvertProgram;
  6746. CheckSource('TestClass_AbstractMethod',
  6747. LinesToStr([ // statements
  6748. 'rtl.createClass($mod,"TObject",null,function(){',
  6749. ' this.$init = function () {',
  6750. ' };',
  6751. ' this.$final = function () {',
  6752. ' };',
  6753. '});'
  6754. ]),
  6755. LinesToStr([ // this.$main
  6756. ''
  6757. ]));
  6758. end;
  6759. procedure TTestModule.TestClass_CallInherited_NoParams;
  6760. begin
  6761. StartProgram(false);
  6762. Add('type');
  6763. Add(' TObject = class');
  6764. Add(' procedure DoAbstract; virtual; abstract;');
  6765. Add(' procedure DoVirtual; virtual;');
  6766. Add(' procedure DoIt;');
  6767. Add(' end;');
  6768. Add(' TA = class');
  6769. Add(' procedure doabstract; override;');
  6770. Add(' procedure dovirtual; override;');
  6771. Add(' procedure DoSome;');
  6772. Add(' end;');
  6773. Add('procedure tobject.dovirtual;');
  6774. Add('begin');
  6775. Add(' inherited; // call non existing ancestor -> ignore silently');
  6776. Add('end;');
  6777. Add('procedure tobject.doit;');
  6778. Add('begin');
  6779. Add('end;');
  6780. Add('procedure ta.doabstract;');
  6781. Add('begin');
  6782. Add(' inherited dovirtual; // call TObject.DoVirtual');
  6783. Add('end;');
  6784. Add('procedure ta.dovirtual;');
  6785. Add('begin');
  6786. Add(' inherited; // call TObject.DoVirtual');
  6787. Add(' inherited dovirtual; // call TObject.DoVirtual');
  6788. Add(' inherited dovirtual(); // call TObject.DoVirtual');
  6789. Add(' doit;');
  6790. Add(' doit();');
  6791. Add('end;');
  6792. Add('procedure ta.dosome;');
  6793. Add('begin');
  6794. Add(' inherited; // call non existing ancestor method -> silently ignore');
  6795. Add('end;');
  6796. Add('begin');
  6797. ConvertProgram;
  6798. CheckSource('TestClass_CallInherited_NoParams',
  6799. LinesToStr([ // statements
  6800. 'rtl.createClass($mod,"TObject",null,function(){',
  6801. ' this.$init = function () {',
  6802. ' };',
  6803. ' this.$final = function () {',
  6804. ' };',
  6805. ' this.DoVirtual = function () {',
  6806. ' };',
  6807. ' this.DoIt = function () {',
  6808. ' };',
  6809. '});',
  6810. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  6811. ' this.DoAbstract = function () {',
  6812. ' $mod.TObject.DoVirtual.call(this);',
  6813. ' };',
  6814. ' this.DoVirtual = function () {',
  6815. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  6816. ' $mod.TObject.DoVirtual.call(this);',
  6817. ' $mod.TObject.DoVirtual.call(this);',
  6818. ' this.DoIt();',
  6819. ' this.DoIt();',
  6820. ' };',
  6821. ' this.DoSome = function () {',
  6822. ' };',
  6823. '});'
  6824. ]),
  6825. LinesToStr([ // this.$main
  6826. ''
  6827. ]));
  6828. end;
  6829. procedure TTestModule.TestClass_CallInherited_WithParams;
  6830. begin
  6831. StartProgram(false);
  6832. Add('type');
  6833. Add(' TObject = class');
  6834. Add(' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;');
  6835. Add(' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;');
  6836. Add(' procedure DoIt(pA: longint; pB: longint = 0);');
  6837. Add(' procedure DoIt2(pA: longint = 1; pB: longint = 2);');
  6838. Add(' end;');
  6839. Add(' TClassA = class');
  6840. Add(' procedure DoAbstract(pA: longint; pB: longint = 0); override;');
  6841. Add(' procedure DoVirtual(pA: longint; pB: longint = 0); override;');
  6842. Add(' end;');
  6843. Add('procedure tobject.dovirtual(pa: longint; pb: longint = 0);');
  6844. Add('begin');
  6845. Add('end;');
  6846. Add('procedure tobject.doit(pa: longint; pb: longint = 0);');
  6847. Add('begin');
  6848. Add('end;');
  6849. Add('procedure tobject.doit2(pa: longint; pb: longint = 0);');
  6850. Add('begin');
  6851. Add('end;');
  6852. Add('procedure tclassa.doabstract(pa: longint; pb: longint = 0);');
  6853. Add('begin');
  6854. Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
  6855. Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
  6856. Add('end;');
  6857. Add('procedure tclassa.dovirtual(pa: longint; pb: longint = 0);');
  6858. Add('begin');
  6859. Add(' inherited; // call TObject.DoVirtual(pA,pB)');
  6860. Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
  6861. Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
  6862. Add(' doit(pa,pb);');
  6863. Add(' doit(pa);');
  6864. Add(' doit2(pa);');
  6865. Add(' doit2;');
  6866. Add('end;');
  6867. Add('begin');
  6868. ConvertProgram;
  6869. CheckSource('TestClass_CallInherited_WithParams',
  6870. LinesToStr([ // statements
  6871. 'rtl.createClass($mod,"TObject",null,function(){',
  6872. ' this.$init = function () {',
  6873. ' };',
  6874. ' this.$final = function () {',
  6875. ' };',
  6876. ' this.DoVirtual = function (pA,pB) {',
  6877. ' };',
  6878. ' this.DoIt = function (pA,pB) {',
  6879. ' };',
  6880. ' this.DoIt2 = function (pA,pB) {',
  6881. ' };',
  6882. '});',
  6883. 'rtl.createClass($mod, "TClassA", $mod.TObject, function () {',
  6884. ' this.DoAbstract = function (pA,pB) {',
  6885. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  6886. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  6887. ' };',
  6888. ' this.DoVirtual = function (pA,pB) {',
  6889. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  6890. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  6891. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  6892. ' this.DoIt(pA,pB);',
  6893. ' this.DoIt(pA,0);',
  6894. ' this.DoIt2(pA,2);',
  6895. ' this.DoIt2(1,2);',
  6896. ' };',
  6897. '});'
  6898. ]),
  6899. LinesToStr([ // this.$main
  6900. ''
  6901. ]));
  6902. end;
  6903. procedure TTestModule.TestClasS_CallInheritedConstructor;
  6904. begin
  6905. StartProgram(false);
  6906. Add('type');
  6907. Add(' TObject = class');
  6908. Add(' constructor Create; virtual;');
  6909. Add(' constructor CreateWithB(b: boolean);');
  6910. Add(' end;');
  6911. Add(' TA = class');
  6912. Add(' constructor Create; override;');
  6913. Add(' constructor CreateWithC(c: char);');
  6914. Add(' procedure DoIt;');
  6915. Add(' class function DoSome: TObject;');
  6916. Add(' end;');
  6917. Add('constructor tobject.create;');
  6918. Add('begin');
  6919. Add(' inherited; // call non existing ancestor -> ignore silently');
  6920. Add('end;');
  6921. Add('constructor tobject.createwithb(b: boolean);');
  6922. Add('begin');
  6923. Add(' inherited; // call non existing ancestor -> ignore silently');
  6924. Add(' create; // normal call');
  6925. Add('end;');
  6926. Add('constructor ta.create;');
  6927. Add('begin');
  6928. Add(' inherited; // normal call TObject.Create');
  6929. Add(' inherited create; // normal call TObject.Create');
  6930. Add(' inherited createwithb(false); // normal call TObject.CreateWithB');
  6931. Add('end;');
  6932. Add('constructor ta.createwithc(c: char);');
  6933. Add('begin');
  6934. Add(' inherited create; // call TObject.Create');
  6935. Add(' inherited createwithb(true); // call TObject.CreateWithB');
  6936. Add(' doit;');
  6937. Add(' doit();');
  6938. Add(' dosome;');
  6939. Add('end;');
  6940. Add('procedure ta.doit;');
  6941. Add('begin');
  6942. Add(' create; // normal call');
  6943. Add(' createwithb(false); // normal call');
  6944. Add(' createwithc(''c''); // normal call');
  6945. Add('end;');
  6946. Add('class function ta.dosome: TObject;');
  6947. Add('begin');
  6948. Add(' Result:=create; // constructor');
  6949. Add(' Result:=createwithb(true); // constructor');
  6950. Add(' Result:=createwithc(''c''); // constructor');
  6951. Add('end;');
  6952. Add('begin');
  6953. ConvertProgram;
  6954. CheckSource('TestClass_CallInheritedConstructor',
  6955. LinesToStr([ // statements
  6956. 'rtl.createClass($mod,"TObject",null,function(){',
  6957. ' this.$init = function () {',
  6958. ' };',
  6959. ' this.$final = function () {',
  6960. ' };',
  6961. ' this.Create = function () {',
  6962. ' };',
  6963. ' this.CreateWithB = function (b) {',
  6964. ' this.Create();',
  6965. ' };',
  6966. '});',
  6967. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  6968. ' this.Create = function () {',
  6969. ' $mod.TObject.Create.apply(this, arguments);',
  6970. ' $mod.TObject.Create.call(this);',
  6971. ' $mod.TObject.CreateWithB.call(this, false);',
  6972. ' };',
  6973. ' this.CreateWithC = function (c) {',
  6974. ' $mod.TObject.Create.call(this);',
  6975. ' $mod.TObject.CreateWithB.call(this, true);',
  6976. ' this.DoIt();',
  6977. ' this.DoIt();',
  6978. ' this.$class.DoSome();',
  6979. ' };',
  6980. ' this.DoIt = function () {',
  6981. ' this.Create();',
  6982. ' this.CreateWithB(false);',
  6983. ' this.CreateWithC("c");',
  6984. ' };',
  6985. ' this.DoSome = function () {',
  6986. ' var Result = null;',
  6987. ' Result = this.$create("Create");',
  6988. ' Result = this.$create("CreateWithB", [true]);',
  6989. ' Result = this.$create("CreateWithC", ["c"]);',
  6990. ' return Result;',
  6991. ' };',
  6992. '});'
  6993. ]),
  6994. LinesToStr([ // this.$main
  6995. ''
  6996. ]));
  6997. end;
  6998. procedure TTestModule.TestClass_ClassVar;
  6999. begin
  7000. StartProgram(false);
  7001. Add('type');
  7002. Add(' TObject = class');
  7003. Add(' public');
  7004. Add(' class var vI: longint;');
  7005. Add(' class var Sub: TObject;');
  7006. Add(' constructor Create;');
  7007. Add(' class function GetIt(Par: longint): tobject;');
  7008. Add(' end;');
  7009. Add('constructor tobject.create;');
  7010. Add('begin');
  7011. Add(' vi:=vi+1;');
  7012. Add(' Self.vi:=Self.vi+1;');
  7013. Add('end;');
  7014. Add('class function tobject.getit(par: longint): tobject;');
  7015. Add('begin');
  7016. Add(' vi:=vi+par;');
  7017. Add(' Self.vi:=Self.vi+par;');
  7018. Add(' Result:=self.sub;');
  7019. Add('end;');
  7020. Add('var Obj: tobject;');
  7021. Add('begin');
  7022. Add(' obj:=tobject.create;');
  7023. Add(' tobject.vi:=3;');
  7024. Add(' if tobject.vi=4 then ;');
  7025. Add(' tobject.sub:=nil;');
  7026. Add(' obj.sub:=nil;');
  7027. Add(' obj.sub.sub:=nil;');
  7028. ConvertProgram;
  7029. CheckSource('TestClass_ClassVar',
  7030. LinesToStr([ // statements
  7031. 'rtl.createClass($mod,"TObject",null,function(){',
  7032. ' this.vI = 0;',
  7033. ' this.Sub = null;',
  7034. ' this.$init = function () {',
  7035. ' };',
  7036. ' this.$final = function () {',
  7037. ' };',
  7038. ' this.Create = function(){',
  7039. ' this.$class.vI = this.vI+1;',
  7040. ' this.$class.vI = this.vI+1;',
  7041. ' };',
  7042. ' this.GetIt = function(Par){',
  7043. ' var Result = null;',
  7044. ' this.vI = this.vI + Par;',
  7045. ' this.vI = this.vI + Par;',
  7046. ' Result = this.Sub;',
  7047. ' return Result;',
  7048. ' };',
  7049. '});',
  7050. 'this.Obj = null;'
  7051. ]),
  7052. LinesToStr([ // $mod.$main
  7053. '$mod.Obj = $mod.TObject.$create("Create");',
  7054. '$mod.TObject.vI = 3;',
  7055. 'if ($mod.TObject.vI === 4);',
  7056. '$mod.TObject.Sub=null;',
  7057. '$mod.Obj.$class.Sub=null;',
  7058. '$mod.Obj.Sub.$class.Sub=null;',
  7059. '']));
  7060. end;
  7061. procedure TTestModule.TestClass_CallClassMethod;
  7062. begin
  7063. StartProgram(false);
  7064. Add('type');
  7065. Add(' TObject = class');
  7066. Add(' public');
  7067. Add(' class var vI: longint;');
  7068. Add(' class var Sub: TObject;');
  7069. Add(' constructor Create;');
  7070. Add(' function GetMore(Par: longint): longint;');
  7071. Add(' class function GetIt(Par: longint): tobject;');
  7072. Add(' end;');
  7073. Add('constructor tobject.create;');
  7074. Add('begin');
  7075. Add(' sub:=getit(3);');
  7076. Add(' vi:=getmore(4);');
  7077. Add(' sub:=Self.getit(5);');
  7078. Add(' vi:=Self.getmore(6);');
  7079. Add('end;');
  7080. Add('function tobject.getmore(par: longint): longint;');
  7081. Add('begin');
  7082. Add(' sub:=getit(11);');
  7083. Add(' vi:=getmore(12);');
  7084. Add(' sub:=self.getit(13);');
  7085. Add(' vi:=self.getmore(14);');
  7086. Add('end;');
  7087. Add('class function tobject.getit(par: longint): tobject;');
  7088. Add('begin');
  7089. Add(' sub:=getit(21);');
  7090. Add(' vi:=sub.getmore(22);');
  7091. Add(' sub:=self.getit(23);');
  7092. Add(' vi:=self.sub.getmore(24);');
  7093. Add('end;');
  7094. Add('var Obj: tobject;');
  7095. Add('begin');
  7096. Add(' obj:=tobject.create;');
  7097. Add(' tobject.getit(5);');
  7098. Add(' obj.getit(6);');
  7099. Add(' obj.sub.getit(7);');
  7100. Add(' obj.sub.getit(8).SUB:=nil;');
  7101. Add(' obj.sub.getit(9).GETIT(10);');
  7102. Add(' obj.sub.getit(11).SuB.getit(12);');
  7103. ConvertProgram;
  7104. CheckSource('TestClass_CallClassMethod',
  7105. LinesToStr([ // statements
  7106. 'rtl.createClass($mod,"TObject",null,function(){',
  7107. ' this.vI = 0;',
  7108. ' this.Sub = null;',
  7109. ' this.$init = function () {',
  7110. ' };',
  7111. ' this.$final = function () {',
  7112. ' };',
  7113. ' this.Create = function(){',
  7114. ' this.$class.Sub = this.$class.GetIt(3);',
  7115. ' this.$class.vI = this.GetMore(4);',
  7116. ' this.$class.Sub = this.$class.GetIt(5);',
  7117. ' this.$class.vI = this.GetMore(6);',
  7118. ' };',
  7119. ' this.GetMore = function(Par){',
  7120. ' var Result = 0;',
  7121. ' this.$class.Sub = this.$class.GetIt(11);',
  7122. ' this.$class.vI = this.GetMore(12);',
  7123. ' this.$class.Sub = this.$class.GetIt(13);',
  7124. ' this.$class.vI = this.GetMore(14);',
  7125. ' return Result;',
  7126. ' };',
  7127. ' this.GetIt = function(Par){',
  7128. ' var Result = null;',
  7129. ' this.Sub = this.GetIt(21);',
  7130. ' this.vI = this.Sub.GetMore(22);',
  7131. ' this.Sub = this.GetIt(23);',
  7132. ' this.vI = this.Sub.GetMore(24);',
  7133. ' return Result;',
  7134. ' };',
  7135. '});',
  7136. 'this.Obj = null;'
  7137. ]),
  7138. LinesToStr([ // $mod.$main
  7139. '$mod.Obj = $mod.TObject.$create("Create");',
  7140. '$mod.TObject.GetIt(5);',
  7141. '$mod.Obj.$class.GetIt(6);',
  7142. '$mod.Obj.Sub.$class.GetIt(7);',
  7143. '$mod.Obj.Sub.$class.GetIt(8).$class.Sub=null;',
  7144. '$mod.Obj.Sub.$class.GetIt(9).$class.GetIt(10);',
  7145. '$mod.Obj.Sub.$class.GetIt(11).Sub.$class.GetIt(12);',
  7146. '']));
  7147. end;
  7148. procedure TTestModule.TestClass_Property;
  7149. begin
  7150. StartProgram(false);
  7151. Add('type');
  7152. Add(' TObject = class');
  7153. Add(' Fx: longint;');
  7154. Add(' Fy: longint;');
  7155. Add(' function GetInt: longint;');
  7156. Add(' procedure SetInt(Value: longint);');
  7157. Add(' procedure DoIt;');
  7158. Add(' property IntA: longint read Fx write Fy;');
  7159. Add(' property IntB: longint read GetInt write SetInt;');
  7160. Add(' end;');
  7161. Add('function tobject.getint: longint;');
  7162. Add('begin');
  7163. Add(' result:=fx;');
  7164. Add('end;');
  7165. Add('procedure tobject.setint(value: longint);');
  7166. Add('begin');
  7167. Add(' if value=fy then exit;');
  7168. Add(' fy:=value;');
  7169. Add('end;');
  7170. Add('procedure tobject.doit;');
  7171. Add('begin');
  7172. Add(' IntA:=IntA+1;');
  7173. Add(' Self.IntA:=Self.IntA+1;');
  7174. Add(' IntB:=IntB+1;');
  7175. Add(' Self.IntB:=Self.IntB+1;');
  7176. Add('end;');
  7177. Add('var Obj: tobject;');
  7178. Add('begin');
  7179. Add(' obj.inta:=obj.inta+1;');
  7180. Add(' if obj.intb=2 then;');
  7181. Add(' obj.intb:=obj.intb+2;');
  7182. Add(' obj.setint(obj.inta);');
  7183. ConvertProgram;
  7184. CheckSource('TestClass_Property',
  7185. LinesToStr([ // statements
  7186. 'rtl.createClass($mod, "TObject", null, function () {',
  7187. ' this.$init = function () {',
  7188. ' this.Fx = 0;',
  7189. ' this.Fy = 0;',
  7190. ' };',
  7191. ' this.$final = function () {',
  7192. ' };',
  7193. ' this.GetInt = function () {',
  7194. ' var Result = 0;',
  7195. ' Result = this.Fx;',
  7196. ' return Result;',
  7197. ' };',
  7198. ' this.SetInt = function (Value) {',
  7199. ' if (Value === this.Fy) return;',
  7200. ' this.Fy = Value;',
  7201. ' };',
  7202. ' this.DoIt = function () {',
  7203. ' this.Fy = this.Fx + 1;',
  7204. ' this.Fy = this.Fx + 1;',
  7205. ' this.SetInt(this.GetInt() + 1);',
  7206. ' this.SetInt(this.GetInt() + 1);',
  7207. ' };',
  7208. '});',
  7209. 'this.Obj = null;'
  7210. ]),
  7211. LinesToStr([ // $mod.$main
  7212. '$mod.Obj.Fy = $mod.Obj.Fx + 1;',
  7213. 'if ($mod.Obj.GetInt() === 2);',
  7214. '$mod.Obj.SetInt($mod.Obj.GetInt() + 2);',
  7215. '$mod.Obj.SetInt($mod.Obj.Fx);'
  7216. ]));
  7217. end;
  7218. procedure TTestModule.TestClass_Property_ClassMethod;
  7219. begin
  7220. StartProgram(false);
  7221. Add('type');
  7222. Add(' TObject = class');
  7223. Add(' class var Fx: longint;');
  7224. Add(' class var Fy: longint;');
  7225. Add(' class function GetInt: longint;');
  7226. Add(' class procedure SetInt(Value: longint);');
  7227. Add(' class procedure DoIt;');
  7228. Add(' class property IntA: longint read Fx write Fy;');
  7229. Add(' class property IntB: longint read GetInt write SetInt;');
  7230. Add(' end;');
  7231. Add('class function tobject.getint: longint;');
  7232. Add('begin');
  7233. Add(' result:=fx;');
  7234. Add('end;');
  7235. Add('class procedure tobject.setint(value: longint);');
  7236. Add('begin');
  7237. Add('end;');
  7238. Add('class procedure tobject.doit;');
  7239. Add('begin');
  7240. Add(' IntA:=IntA+1;');
  7241. Add(' Self.IntA:=Self.IntA+1;');
  7242. Add(' IntB:=IntB+1;');
  7243. Add(' Self.IntB:=Self.IntB+1;');
  7244. Add('end;');
  7245. Add('var Obj: tobject;');
  7246. Add('begin');
  7247. Add(' tobject.inta:=tobject.inta+1;');
  7248. Add(' if tobject.intb=2 then;');
  7249. Add(' tobject.intb:=tobject.intb+2;');
  7250. Add(' tobject.setint(tobject.inta);');
  7251. Add(' obj.inta:=obj.inta+1;');
  7252. Add(' if obj.intb=2 then;');
  7253. Add(' obj.intb:=obj.intb+2;');
  7254. Add(' obj.setint(obj.inta);');
  7255. ConvertProgram;
  7256. CheckSource('TestClass_Property_ClassMethod',
  7257. LinesToStr([ // statements
  7258. 'rtl.createClass($mod, "TObject", null, function () {',
  7259. ' this.Fx = 0;',
  7260. ' this.Fy = 0;',
  7261. ' this.$init = function () {',
  7262. ' };',
  7263. ' this.$final = function () {',
  7264. ' };',
  7265. ' this.GetInt = function () {',
  7266. ' var Result = 0;',
  7267. ' Result = this.Fx;',
  7268. ' return Result;',
  7269. ' };',
  7270. ' this.SetInt = function (Value) {',
  7271. ' };',
  7272. ' this.DoIt = function () {',
  7273. ' this.Fy = this.Fx + 1;',
  7274. ' this.Fy = this.Fx + 1;',
  7275. ' this.SetInt(this.GetInt() + 1);',
  7276. ' this.SetInt(this.GetInt() + 1);',
  7277. ' };',
  7278. '});',
  7279. 'this.Obj = null;'
  7280. ]),
  7281. LinesToStr([ // $mod.$main
  7282. '$mod.TObject.Fy = $mod.TObject.Fx + 1;',
  7283. 'if ($mod.TObject.GetInt() === 2);',
  7284. '$mod.TObject.SetInt($mod.TObject.GetInt() + 2);',
  7285. '$mod.TObject.SetInt($mod.TObject.Fx);',
  7286. '$mod.Obj.$class.Fy = $mod.Obj.Fx + 1;',
  7287. 'if ($mod.Obj.$class.GetInt() === 2);',
  7288. '$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
  7289. '$mod.Obj.$class.SetInt($mod.Obj.Fx);'
  7290. ]));
  7291. end;
  7292. procedure TTestModule.TestClass_Property_Indexed;
  7293. begin
  7294. StartProgram(false);
  7295. Add('type');
  7296. Add(' TObject = class');
  7297. Add(' FItems: array of longint;');
  7298. Add(' function GetItems(Index: longint): longint;');
  7299. Add(' procedure SetItems(Index: longint; Value: longint);');
  7300. Add(' procedure DoIt;');
  7301. Add(' property Items[Index: longint]: longint read getitems write setitems;');
  7302. Add(' end;');
  7303. Add('function tobject.getitems(index: longint): longint;');
  7304. Add('begin');
  7305. Add(' Result:=fitems[index];');
  7306. Add('end;');
  7307. Add('procedure tobject.setitems(index: longint; value: longint);');
  7308. Add('begin');
  7309. Add(' fitems[index]:=value;');
  7310. Add('end;');
  7311. Add('procedure tobject.doit;');
  7312. Add('begin');
  7313. Add(' items[1]:=2;');
  7314. Add(' items[3]:=items[4];');
  7315. Add(' self.items[5]:=self.items[6];');
  7316. Add(' items[items[7]]:=items[items[8]];');
  7317. Add('end;');
  7318. Add('var Obj: tobject;');
  7319. Add('begin');
  7320. Add(' obj.Items[11]:=obj.Items[12];');
  7321. ConvertProgram;
  7322. CheckSource('TestClass_Property_Indexed',
  7323. LinesToStr([ // statements
  7324. 'rtl.createClass($mod, "TObject", null, function () {',
  7325. ' this.$init = function () {',
  7326. ' this.FItems = [];',
  7327. ' };',
  7328. ' this.$final = function () {',
  7329. ' this.FItems = undefined;',
  7330. ' };',
  7331. ' this.GetItems = function (Index) {',
  7332. ' var Result = 0;',
  7333. ' Result = this.FItems[Index];',
  7334. ' return Result;',
  7335. ' };',
  7336. ' this.SetItems = function (Index, Value) {',
  7337. ' this.FItems[Index] = Value;',
  7338. ' };',
  7339. ' this.DoIt = function () {',
  7340. ' this.SetItems(1, 2);',
  7341. ' this.SetItems(3,this.GetItems(4));',
  7342. ' this.SetItems(5,this.GetItems(6));',
  7343. ' this.SetItems(this.GetItems(7), this.GetItems(this.GetItems(8)));',
  7344. ' };',
  7345. '});',
  7346. 'this.Obj = null;'
  7347. ]),
  7348. LinesToStr([ // $mod.$main
  7349. '$mod.Obj.SetItems(11,$mod.Obj.GetItems(12));'
  7350. ]));
  7351. end;
  7352. procedure TTestModule.TestClass_Property_IndexSpec;
  7353. begin
  7354. StartProgram(false);
  7355. Add([
  7356. 'type',
  7357. ' TEnum = (red, blue);',
  7358. ' TObject = class',
  7359. ' function GetIntBool(Index: longint): boolean; virtual; abstract;',
  7360. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  7361. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  7362. ' procedure SetEnumBool(Index: TEnum; b: boolean); virtual; abstract;',
  7363. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  7364. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  7365. ' property B1: boolean index 1 read GetIntBool write SetIntBool;',
  7366. ' property B2: boolean index TEnum.blue read GetEnumBool write SetEnumBool;',
  7367. ' property B3: boolean index ord(red) read GetIntBool write SetIntBool;',
  7368. ' property I1[A: String]: boolean index ord(blue) read GetStrIntBool write SetStrIntBool;',
  7369. ' end;',
  7370. 'procedure DoIt(b: boolean); begin end;',
  7371. 'var',
  7372. ' o: TObject;',
  7373. 'begin',
  7374. ' o.B1:=o.B1;',
  7375. ' o.B2:=o.B2;',
  7376. ' o.B3:=o.B3;',
  7377. ' o.I1[''a'']:=o.I1[''b''];',
  7378. ' doit(o.b1);',
  7379. ' doit(o.b2);',
  7380. ' doit(o.i1[''c'']);',
  7381. '']);
  7382. ConvertProgram;
  7383. CheckSource('TestClass_Property_IndexSpec',
  7384. LinesToStr([ // statements
  7385. 'this.TEnum = {',
  7386. ' "0": "red",',
  7387. ' red: 0,',
  7388. ' "1": "blue",',
  7389. ' blue: 1',
  7390. '};',
  7391. 'rtl.createClass($mod, "TObject", null, function () {',
  7392. ' this.$init = function () {',
  7393. ' };',
  7394. ' this.$final = function () {',
  7395. ' };',
  7396. '});',
  7397. 'this.DoIt = function (b) {',
  7398. '};',
  7399. 'this.o = null;',
  7400. '']),
  7401. LinesToStr([ // $mod.$main
  7402. '$mod.o.SetIntBool(1, $mod.o.GetIntBool(1));',
  7403. '$mod.o.SetEnumBool($mod.TEnum.blue, $mod.o.GetEnumBool($mod.TEnum.blue));',
  7404. '$mod.o.SetIntBool(0, $mod.o.GetIntBool(0));',
  7405. '$mod.o.SetStrIntBool("a", 1, $mod.o.GetStrIntBool("b", 1));',
  7406. '$mod.DoIt($mod.o.GetIntBool(1));',
  7407. '$mod.DoIt($mod.o.GetEnumBool($mod.TEnum.blue));',
  7408. '$mod.DoIt($mod.o.GetStrIntBool("c", 1));',
  7409. '']));
  7410. end;
  7411. procedure TTestModule.TestClass_PropertyOfTypeArray;
  7412. begin
  7413. StartProgram(false);
  7414. Add('type');
  7415. Add(' TArray = array of longint;');
  7416. Add(' TObject = class');
  7417. Add(' FItems: TArray;');
  7418. Add(' function GetItems: tarray;');
  7419. Add(' procedure SetItems(Value: tarray);');
  7420. Add(' property Items: tarray read getitems write setitems;');
  7421. Add(' end;');
  7422. Add('function tobject.getitems: tarray;');
  7423. Add('begin');
  7424. Add(' Result:=fitems;');
  7425. Add('end;');
  7426. Add('procedure tobject.setitems(value: tarray);');
  7427. Add('begin');
  7428. Add(' fitems:=value;');
  7429. Add(' fitems:=nil;');
  7430. Add(' Items:=nil;');
  7431. Add(' Items:=Items;');
  7432. Add(' Items[1]:=2;');
  7433. Add(' fitems[3]:=Items[4];');
  7434. Add(' Items[5]:=Items[6];');
  7435. Add(' Self.Items[7]:=8;');
  7436. Add(' Self.Items[9]:=Self.Items[10];');
  7437. Add(' Items[Items[11]]:=Items[Items[12]];');
  7438. Add('end;');
  7439. Add('var Obj: tobject;');
  7440. Add('begin');
  7441. Add(' obj.items:=nil;');
  7442. Add(' obj.items:=obj.items;');
  7443. Add(' obj.items[11]:=obj.items[12];');
  7444. ConvertProgram;
  7445. CheckSource('TestClass_PropertyOfTypeArray',
  7446. LinesToStr([ // statements
  7447. 'rtl.createClass($mod, "TObject", null, function () {',
  7448. ' this.$init = function () {',
  7449. ' this.FItems = [];',
  7450. ' };',
  7451. ' this.$final = function () {',
  7452. ' this.FItems = undefined;',
  7453. ' };',
  7454. ' this.GetItems = function () {',
  7455. ' var Result = [];',
  7456. ' Result = this.FItems;',
  7457. ' return Result;',
  7458. ' };',
  7459. ' this.SetItems = function (Value) {',
  7460. ' this.FItems = Value;',
  7461. ' this.FItems = [];',
  7462. ' this.SetItems([]);',
  7463. ' this.SetItems(this.GetItems());',
  7464. ' this.GetItems()[1] = 2;',
  7465. ' this.FItems[3] = this.GetItems()[4];',
  7466. ' this.GetItems()[5] = this.GetItems()[6];',
  7467. ' this.GetItems()[7] = 8;',
  7468. ' this.GetItems()[9] = this.GetItems()[10];',
  7469. ' this.GetItems()[this.GetItems()[11]] = this.GetItems()[this.GetItems()[12]];',
  7470. ' };',
  7471. '});',
  7472. 'this.Obj = null;'
  7473. ]),
  7474. LinesToStr([ // $mod.$main
  7475. '$mod.Obj.SetItems([]);',
  7476. '$mod.Obj.SetItems($mod.Obj.GetItems());',
  7477. '$mod.Obj.GetItems()[11] = $mod.Obj.GetItems()[12];'
  7478. ]));
  7479. end;
  7480. procedure TTestModule.TestClass_PropertyDefault;
  7481. begin
  7482. StartProgram(false);
  7483. Add('type');
  7484. Add(' TArray = array of longint;');
  7485. Add(' TObject = class');
  7486. Add(' FItems: TArray;');
  7487. Add(' function GetItems(Index: longint): longint;');
  7488. Add(' procedure SetItems(Index, Value: longint);');
  7489. Add(' property Items[Index: longint]: longint read getitems write setitems; default;');
  7490. Add(' end;');
  7491. Add('function tobject.getitems(index: longint): longint;');
  7492. Add('begin');
  7493. Add('end;');
  7494. Add('procedure tobject.setitems(index, value: longint);');
  7495. Add('begin');
  7496. Add(' Self[1]:=2;');
  7497. Add(' Self[3]:=Self[index];');
  7498. Add(' Self[index]:=Self[Self[value]];');
  7499. Add(' Self[Self[4]]:=value;');
  7500. Add('end;');
  7501. Add('var Obj: tobject;');
  7502. Add('begin');
  7503. Add(' obj[11]:=12;');
  7504. Add(' obj[13]:=obj[14];');
  7505. Add(' obj[obj[15]]:=obj[obj[15]];');
  7506. ConvertProgram;
  7507. CheckSource('TestClass_PropertyDefault',
  7508. LinesToStr([ // statements
  7509. 'rtl.createClass($mod, "TObject", null, function () {',
  7510. ' this.$init = function () {',
  7511. ' this.FItems = [];',
  7512. ' };',
  7513. ' this.$final = function () {',
  7514. ' this.FItems = undefined;',
  7515. ' };',
  7516. ' this.GetItems = function (Index) {',
  7517. ' var Result = 0;',
  7518. ' return Result;',
  7519. ' };',
  7520. ' this.SetItems = function (Index, Value) {',
  7521. ' this.SetItems(1, 2);',
  7522. ' this.SetItems(3, this.GetItems(Index));',
  7523. ' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
  7524. ' this.SetItems(this.GetItems(4), Value);',
  7525. ' };',
  7526. '});',
  7527. 'this.Obj = null;'
  7528. ]),
  7529. LinesToStr([ // $mod.$main
  7530. '$mod.Obj.SetItems(11, 12);',
  7531. '$mod.Obj.SetItems(13, $mod.Obj.GetItems(14));',
  7532. '$mod.Obj.SetItems($mod.Obj.GetItems(15), $mod.Obj.GetItems($mod.Obj.GetItems(15)));'
  7533. ]));
  7534. end;
  7535. procedure TTestModule.TestClass_PropertyOverride;
  7536. begin
  7537. StartProgram(false);
  7538. Add('type');
  7539. Add(' integer = longint;');
  7540. Add(' TObject = class');
  7541. Add(' FItem: integer;');
  7542. Add(' function GetItem: integer; external name ''GetItem'';');
  7543. Add(' procedure SetItem(Value: integer); external name ''SetItem'';');
  7544. Add(' property Item: integer read getitem write setitem;');
  7545. Add(' end;');
  7546. Add(' TCar = class');
  7547. Add(' FBag: integer;');
  7548. Add(' function GetBag: integer; external name ''GetBag'';');
  7549. Add(' property Item read getbag;');
  7550. Add(' end;');
  7551. Add('var');
  7552. Add(' Obj: tobject;');
  7553. Add(' Car: tcar;');
  7554. Add('begin');
  7555. Add(' Obj.Item:=Obj.Item;');
  7556. Add(' Car.Item:=Car.Item;');
  7557. ConvertProgram;
  7558. CheckSource('TestClass_PropertyOverride',
  7559. LinesToStr([ // statements
  7560. 'rtl.createClass($mod, "TObject", null, function () {',
  7561. ' this.$init = function () {',
  7562. ' this.FItem = 0;',
  7563. ' };',
  7564. ' this.$final = function () {',
  7565. ' };',
  7566. '});',
  7567. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  7568. ' this.$init = function () {',
  7569. ' $mod.TObject.$init.call(this);',
  7570. ' this.FBag = 0;',
  7571. ' };',
  7572. '});',
  7573. 'this.Obj = null;',
  7574. 'this.Car = null;',
  7575. '']),
  7576. LinesToStr([ // $mod.$main
  7577. '$mod.Obj.SetItem($mod.Obj.GetItem());',
  7578. '$mod.Car.SetItem($mod.Car.GetBag());',
  7579. '']));
  7580. end;
  7581. procedure TTestModule.TestClass_Assigned;
  7582. begin
  7583. StartProgram(false);
  7584. Add('type');
  7585. Add(' TObject = class');
  7586. Add(' end;');
  7587. Add('var');
  7588. Add(' Obj: tobject;');
  7589. Add(' b: boolean;');
  7590. Add('begin');
  7591. Add(' if Assigned(obj) then ;');
  7592. Add(' b:=Assigned(obj) or false;');
  7593. ConvertProgram;
  7594. CheckSource('TestClass_Assigned',
  7595. LinesToStr([ // statements
  7596. 'rtl.createClass($mod, "TObject", null, function () {',
  7597. ' this.$init = function () {',
  7598. ' };',
  7599. ' this.$final = function () {',
  7600. ' };',
  7601. '});',
  7602. 'this.Obj = null;',
  7603. 'this.b = false;'
  7604. ]),
  7605. LinesToStr([ // $mod.$main
  7606. 'if ($mod.Obj !== null);',
  7607. '$mod.b = ($mod.Obj !== null) || false;'
  7608. ]));
  7609. end;
  7610. procedure TTestModule.TestClass_WithClassDoCreate;
  7611. begin
  7612. StartProgram(false);
  7613. Add('type');
  7614. Add(' TObject = class');
  7615. Add(' aBool: boolean;');
  7616. Add(' Arr: array of boolean;');
  7617. Add(' constructor Create;');
  7618. Add(' end;');
  7619. Add('constructor TObject.Create; begin end;');
  7620. Add('var');
  7621. Add(' Obj: tobject;');
  7622. Add(' b: boolean;');
  7623. Add('begin');
  7624. Add(' with tobject.create do begin');
  7625. Add(' b:=abool;');
  7626. Add(' abool:=b;');
  7627. Add(' b:=arr[1];');
  7628. Add(' arr[2]:=b;');
  7629. Add(' end;');
  7630. Add(' with tobject do');
  7631. Add(' obj:=create;');
  7632. Add(' with obj do begin');
  7633. Add(' create;');
  7634. Add(' b:=abool;');
  7635. Add(' abool:=b;');
  7636. Add(' b:=arr[3];');
  7637. Add(' arr[4]:=b;');
  7638. Add(' end;');
  7639. ConvertProgram;
  7640. CheckSource('TestClass_WithClassDoCreate',
  7641. LinesToStr([ // statements
  7642. 'rtl.createClass($mod, "TObject", null, function () {',
  7643. ' this.$init = function () {',
  7644. ' this.aBool = false;',
  7645. ' this.Arr = [];',
  7646. ' };',
  7647. ' this.$final = function () {',
  7648. ' this.Arr = undefined;',
  7649. ' };',
  7650. ' this.Create = function () {',
  7651. ' };',
  7652. '});',
  7653. 'this.Obj = null;',
  7654. 'this.b = false;'
  7655. ]),
  7656. LinesToStr([ // $mod.$main
  7657. 'var $with1 = $mod.TObject.$create("Create");',
  7658. '$mod.b = $with1.aBool;',
  7659. '$with1.aBool = $mod.b;',
  7660. '$mod.b = $with1.Arr[1];',
  7661. '$with1.Arr[2] = $mod.b;',
  7662. 'var $with2 = $mod.TObject;',
  7663. '$mod.Obj = $with2.$create("Create");',
  7664. 'var $with3 = $mod.Obj;',
  7665. '$with3.Create();',
  7666. '$mod.b = $with3.aBool;',
  7667. '$with3.aBool = $mod.b;',
  7668. '$mod.b = $with3.Arr[3];',
  7669. '$with3.Arr[4] = $mod.b;',
  7670. '']));
  7671. end;
  7672. procedure TTestModule.TestClass_WithClassInstDoProperty;
  7673. begin
  7674. StartProgram(false);
  7675. Add('type');
  7676. Add(' TObject = class');
  7677. Add(' FInt: longint;');
  7678. Add(' constructor Create;');
  7679. Add(' function GetSize: longint;');
  7680. Add(' procedure SetSize(Value: longint);');
  7681. Add(' property Int: longint read FInt write FInt;');
  7682. Add(' property Size: longint read GetSize write SetSize;');
  7683. Add(' end;');
  7684. Add('constructor TObject.Create; begin end;');
  7685. Add('function TObject.GetSize: longint; begin; end;');
  7686. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  7687. Add('var');
  7688. Add(' Obj: tobject;');
  7689. Add(' i: longint;');
  7690. Add('begin');
  7691. Add(' with TObject.Create do begin');
  7692. Add(' i:=int;');
  7693. Add(' int:=i;');
  7694. Add(' i:=size;');
  7695. Add(' size:=i;');
  7696. Add(' end;');
  7697. Add(' with obj do begin');
  7698. Add(' i:=int;');
  7699. Add(' int:=i;');
  7700. Add(' i:=size;');
  7701. Add(' size:=i;');
  7702. Add(' end;');
  7703. ConvertProgram;
  7704. CheckSource('TestClass_WithClassInstDoProperty',
  7705. LinesToStr([ // statements
  7706. 'rtl.createClass($mod, "TObject", null, function () {',
  7707. ' this.$init = function () {',
  7708. ' this.FInt = 0;',
  7709. ' };',
  7710. ' this.$final = function () {',
  7711. ' };',
  7712. ' this.Create = function () {',
  7713. ' };',
  7714. ' this.GetSize = function () {',
  7715. ' var Result = 0;',
  7716. ' return Result;',
  7717. ' };',
  7718. ' this.SetSize = function (Value) {',
  7719. ' };',
  7720. '});',
  7721. 'this.Obj = null;',
  7722. 'this.i = 0;'
  7723. ]),
  7724. LinesToStr([ // $mod.$main
  7725. 'var $with1 = $mod.TObject.$create("Create");',
  7726. '$mod.i = $with1.FInt;',
  7727. '$with1.FInt = $mod.i;',
  7728. '$mod.i = $with1.GetSize();',
  7729. '$with1.SetSize($mod.i);',
  7730. 'var $with2 = $mod.Obj;',
  7731. '$mod.i = $with2.FInt;',
  7732. '$with2.FInt = $mod.i;',
  7733. '$mod.i = $with2.GetSize();',
  7734. '$with2.SetSize($mod.i);',
  7735. '']));
  7736. end;
  7737. procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
  7738. begin
  7739. StartProgram(false);
  7740. Add('type');
  7741. Add(' TObject = class');
  7742. Add(' constructor Create;');
  7743. Add(' function GetItems(Index: longint): longint;');
  7744. Add(' procedure SetItems(Index, Value: longint);');
  7745. Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
  7746. Add(' end;');
  7747. Add('constructor TObject.Create; begin end;');
  7748. Add('function tobject.getitems(index: longint): longint; begin; end;');
  7749. Add('procedure tobject.setitems(index, value: longint); begin; end;');
  7750. Add('var');
  7751. Add(' Obj: tobject;');
  7752. Add(' i: longint;');
  7753. Add('begin');
  7754. Add(' with TObject.Create do begin');
  7755. Add(' i:=Items[1];');
  7756. Add(' Items[2]:=i;');
  7757. Add(' end;');
  7758. Add(' with obj do begin');
  7759. Add(' i:=Items[3];');
  7760. Add(' Items[4]:=i;');
  7761. Add(' end;');
  7762. ConvertProgram;
  7763. CheckSource('TestClass_WithClassInstDoPropertyWithParams',
  7764. LinesToStr([ // statements
  7765. 'rtl.createClass($mod, "TObject", null, function () {',
  7766. ' this.$init = function () {',
  7767. ' };',
  7768. ' this.$final = function () {',
  7769. ' };',
  7770. ' this.Create = function () {',
  7771. ' };',
  7772. ' this.GetItems = function (Index) {',
  7773. ' var Result = 0;',
  7774. ' return Result;',
  7775. ' };',
  7776. ' this.SetItems = function (Index, Value) {',
  7777. ' };',
  7778. '});',
  7779. 'this.Obj = null;',
  7780. 'this.i = 0;'
  7781. ]),
  7782. LinesToStr([ // $mod.$main
  7783. 'var $with1 = $mod.TObject.$create("Create");',
  7784. '$mod.i = $with1.GetItems(1);',
  7785. '$with1.SetItems(2, $mod.i);',
  7786. 'var $with2 = $mod.Obj;',
  7787. '$mod.i = $with2.GetItems(3);',
  7788. '$with2.SetItems(4, $mod.i);',
  7789. '']));
  7790. end;
  7791. procedure TTestModule.TestClass_WithClassInstDoFunc;
  7792. begin
  7793. StartProgram(false);
  7794. Add('type');
  7795. Add(' TObject = class');
  7796. Add(' constructor Create;');
  7797. Add(' function GetSize: longint;');
  7798. Add(' procedure SetSize(Value: longint);');
  7799. Add(' end;');
  7800. Add('constructor TObject.Create; begin end;');
  7801. Add('function TObject.GetSize: longint; begin; end;');
  7802. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  7803. Add('var');
  7804. Add(' Obj: tobject;');
  7805. Add(' i: longint;');
  7806. Add('begin');
  7807. Add(' with TObject.Create do begin');
  7808. Add(' i:=GetSize;');
  7809. Add(' i:=GetSize();');
  7810. Add(' SetSize(i);');
  7811. Add(' end;');
  7812. Add(' with obj do begin');
  7813. Add(' i:=GetSize;');
  7814. Add(' i:=GetSize();');
  7815. Add(' SetSize(i);');
  7816. Add(' end;');
  7817. ConvertProgram;
  7818. CheckSource('TestClass_WithClassInstDoFunc',
  7819. LinesToStr([ // statements
  7820. 'rtl.createClass($mod, "TObject", null, function () {',
  7821. ' this.$init = function () {',
  7822. ' };',
  7823. ' this.$final = function () {',
  7824. ' };',
  7825. ' this.Create = function () {',
  7826. ' };',
  7827. ' this.GetSize = function () {',
  7828. ' var Result = 0;',
  7829. ' return Result;',
  7830. ' };',
  7831. ' this.SetSize = function (Value) {',
  7832. ' };',
  7833. '});',
  7834. 'this.Obj = null;',
  7835. 'this.i = 0;'
  7836. ]),
  7837. LinesToStr([ // $mod.$main
  7838. 'var $with1 = $mod.TObject.$create("Create");',
  7839. '$mod.i = $with1.GetSize();',
  7840. '$mod.i = $with1.GetSize();',
  7841. '$with1.SetSize($mod.i);',
  7842. 'var $with2 = $mod.Obj;',
  7843. '$mod.i = $with2.GetSize();',
  7844. '$mod.i = $with2.GetSize();',
  7845. '$with2.SetSize($mod.i);',
  7846. '']));
  7847. end;
  7848. procedure TTestModule.TestClass_TypeCast;
  7849. begin
  7850. StartProgram(false);
  7851. Add('type');
  7852. Add(' TObject = class');
  7853. Add(' Next: TObject;');
  7854. Add(' constructor Create;');
  7855. Add(' end;');
  7856. Add(' TControl = class(TObject)');
  7857. Add(' Arr: array of TObject;');
  7858. Add(' function GetIt(vI: longint = 0): TObject;');
  7859. Add(' end;');
  7860. Add('constructor tobject.create; begin end;');
  7861. Add('function tcontrol.getit(vi: longint = 0): tobject; begin end;');
  7862. Add('var');
  7863. Add(' Obj: tobject;');
  7864. Add('begin');
  7865. Add(' obj:=tcontrol(obj).next;');
  7866. Add(' tcontrol(obj):=nil;');
  7867. Add(' obj:=tcontrol(obj);');
  7868. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
  7869. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
  7870. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
  7871. Add(' tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
  7872. ConvertProgram;
  7873. CheckSource('TestClass_TypeCast',
  7874. LinesToStr([ // statements
  7875. 'rtl.createClass($mod, "TObject", null, function () {',
  7876. ' this.$init = function () {',
  7877. ' this.Next = null;',
  7878. ' };',
  7879. ' this.$final = function () {',
  7880. ' this.Next = undefined;',
  7881. ' };',
  7882. ' this.Create = function () {',
  7883. ' };',
  7884. '});',
  7885. 'rtl.createClass($mod, "TControl", $mod.TObject, function () {',
  7886. ' this.$init = function () {',
  7887. ' $mod.TObject.$init.call(this);',
  7888. ' this.Arr = [];',
  7889. ' };',
  7890. ' this.$final = function () {',
  7891. ' this.Arr = undefined;',
  7892. ' $mod.TObject.$final.call(this);',
  7893. ' };',
  7894. ' this.GetIt = function (vI) {',
  7895. ' var Result = null;',
  7896. ' return Result;',
  7897. ' };',
  7898. '});',
  7899. 'this.Obj = null;'
  7900. ]),
  7901. LinesToStr([ // $mod.$main
  7902. '$mod.Obj = $mod.Obj.Next;',
  7903. '$mod.Obj = null;',
  7904. '$mod.Obj = $mod.Obj;',
  7905. '$mod.Obj = $mod.Obj.GetIt(0);',
  7906. '$mod.Obj = $mod.Obj.GetIt(0);',
  7907. '$mod.Obj = $mod.Obj.GetIt(1);',
  7908. '$mod.Obj = $mod.Obj.GetIt(0).Arr[2];',
  7909. '']));
  7910. end;
  7911. procedure TTestModule.TestClass_TypeCastUntypedParam;
  7912. begin
  7913. StartProgram(false);
  7914. Add('type');
  7915. Add(' TObject = class end;');
  7916. Add('procedure ProcA(var A);');
  7917. Add('begin');
  7918. Add(' TObject(A):=nil;');
  7919. Add(' TObject(A):=TObject(A);');
  7920. Add(' if TObject(A)=nil then ;');
  7921. Add(' if nil=TObject(A) then ;');
  7922. Add('end;');
  7923. Add('procedure ProcB(out A);');
  7924. Add('begin');
  7925. Add(' TObject(A):=nil;');
  7926. Add(' TObject(A):=TObject(A);');
  7927. Add(' if TObject(A)=nil then ;');
  7928. Add(' if nil=TObject(A) then ;');
  7929. Add('end;');
  7930. Add('procedure ProcC(const A);');
  7931. Add('begin');
  7932. Add(' if TObject(A)=nil then ;');
  7933. Add(' if nil=TObject(A) then ;');
  7934. Add('end;');
  7935. Add('var o: TObject;');
  7936. Add('begin');
  7937. Add(' ProcA(o);');
  7938. Add(' ProcB(o);');
  7939. Add(' ProcC(o);');
  7940. ConvertProgram;
  7941. CheckSource('TestClass_TypeCastUntypedParam',
  7942. LinesToStr([ // statements
  7943. 'rtl.createClass($mod, "TObject", null, function () {',
  7944. ' this.$init = function () {',
  7945. ' };',
  7946. ' this.$final = function () {',
  7947. ' };',
  7948. '});',
  7949. 'this.ProcA = function (A) {',
  7950. ' A.set(null);',
  7951. ' A.set(A.get());',
  7952. ' if (A.get() === null);',
  7953. ' if (null === A.get());',
  7954. '};',
  7955. 'this.ProcB = function (A) {',
  7956. ' A.set(null);',
  7957. ' A.set(A.get());',
  7958. ' if (A.get() === null);',
  7959. ' if (null === A.get());',
  7960. '};',
  7961. 'this.ProcC = function (A) {',
  7962. ' if (A === null);',
  7963. ' if (null === A);',
  7964. '};',
  7965. 'this.o = null;',
  7966. '']),
  7967. LinesToStr([ // $mod.$main
  7968. '$mod.ProcA({',
  7969. ' p: $mod,',
  7970. ' get: function () {',
  7971. ' return this.p.o;',
  7972. ' },',
  7973. ' set: function (v) {',
  7974. ' this.p.o = v;',
  7975. ' }',
  7976. '});',
  7977. '$mod.ProcB({',
  7978. ' p: $mod,',
  7979. ' get: function () {',
  7980. ' return this.p.o;',
  7981. ' },',
  7982. ' set: function (v) {',
  7983. ' this.p.o = v;',
  7984. ' }',
  7985. '});',
  7986. '$mod.ProcC($mod.o);',
  7987. '']));
  7988. end;
  7989. procedure TTestModule.TestClass_Overloads;
  7990. begin
  7991. StartProgram(false);
  7992. Add('type');
  7993. Add(' TObject = class');
  7994. Add(' procedure DoIt;');
  7995. Add(' procedure DoIt(vI: longint);');
  7996. Add(' end;');
  7997. Add('procedure TObject.DoIt;');
  7998. Add('begin');
  7999. Add(' DoIt;');
  8000. Add(' DoIt(1);');
  8001. Add('end;');
  8002. Add('procedure TObject.DoIt(vI: longint); begin end;');
  8003. Add('begin');
  8004. ConvertProgram;
  8005. CheckSource('TestClass_Overloads',
  8006. LinesToStr([ // statements
  8007. 'rtl.createClass($mod, "TObject", null, function () {',
  8008. ' this.$init = function () {',
  8009. ' };',
  8010. ' this.$final = function () {',
  8011. ' };',
  8012. ' this.DoIt = function () {',
  8013. ' this.DoIt();',
  8014. ' this.DoIt$1(1);',
  8015. ' };',
  8016. ' this.DoIt$1 = function (vI) {',
  8017. ' };',
  8018. '});',
  8019. '']),
  8020. LinesToStr([ // $mod.$main
  8021. '']));
  8022. end;
  8023. procedure TTestModule.TestClass_OverloadsAncestor;
  8024. begin
  8025. StartProgram(false);
  8026. Add('type');
  8027. Add(' TObject = class;');
  8028. Add(' TObject = class');
  8029. Add(' procedure DoIt(vA: longint);');
  8030. Add(' procedure DoIt(vA, vB: longint);');
  8031. Add(' end;');
  8032. Add(' TCar = class;');
  8033. Add(' TCar = class');
  8034. Add(' procedure DoIt(vA: longint);');
  8035. Add(' procedure DoIt(vA, vB: longint);');
  8036. Add(' end;');
  8037. Add('procedure tobject.doit(va: longint);');
  8038. Add('begin');
  8039. Add(' doit(1);');
  8040. Add(' doit(1,2);');
  8041. Add('end;');
  8042. Add('procedure tobject.doit(va, vb: longint); begin end;');
  8043. Add('procedure tcar.doit(va: longint);');
  8044. Add('begin');
  8045. Add(' doit(1);');
  8046. Add(' doit(1,2);');
  8047. Add(' inherited doit(1);');
  8048. Add(' inherited doit(1,2);');
  8049. Add('end;');
  8050. Add('procedure tcar.doit(va, vb: longint); begin end;');
  8051. Add('begin');
  8052. ConvertProgram;
  8053. CheckSource('TestClass_OverloadsAncestor',
  8054. LinesToStr([ // statements
  8055. 'rtl.createClass($mod, "TObject", null, function () {',
  8056. ' this.$init = function () {',
  8057. ' };',
  8058. ' this.$final = function () {',
  8059. ' };',
  8060. ' this.DoIt = function (vA) {',
  8061. ' this.DoIt(1);',
  8062. ' this.DoIt$1(1,2);',
  8063. ' };',
  8064. ' this.DoIt$1 = function (vA, vB) {',
  8065. ' };',
  8066. '});',
  8067. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  8068. ' this.DoIt$2 = function (vA) {',
  8069. ' this.DoIt$2(1);',
  8070. ' this.DoIt$3(1, 2);',
  8071. ' $mod.TObject.DoIt.call(this, 1);',
  8072. ' $mod.TObject.DoIt$1.call(this, 1, 2);',
  8073. ' };',
  8074. ' this.DoIt$3 = function (vA, vB) {',
  8075. ' };',
  8076. '});',
  8077. '']),
  8078. LinesToStr([ // $mod.$main
  8079. '']));
  8080. end;
  8081. procedure TTestModule.TestClass_OverloadConstructor;
  8082. begin
  8083. StartProgram(false);
  8084. Add('type');
  8085. Add(' TObject = class');
  8086. Add(' constructor Create(vA: longint);');
  8087. Add(' constructor Create(vA, vB: longint);');
  8088. Add(' end;');
  8089. Add(' TCar = class');
  8090. Add(' constructor Create(vA: longint);');
  8091. Add(' constructor Create(vA, vB: longint);');
  8092. Add(' end;');
  8093. Add('constructor tobject.create(va: longint);');
  8094. Add('begin');
  8095. Add(' create(1);');
  8096. Add(' create(1,2);');
  8097. Add('end;');
  8098. Add('constructor tobject.create(va, vb: longint); begin end;');
  8099. Add('constructor tcar.create(va: longint);');
  8100. Add('begin');
  8101. Add(' create(1);');
  8102. Add(' create(1,2);');
  8103. Add(' inherited create(1);');
  8104. Add(' inherited create(1,2);');
  8105. Add('end;');
  8106. Add('constructor tcar.create(va, vb: longint); begin end;');
  8107. Add('begin');
  8108. Add(' tobject.create(1);');
  8109. Add(' tobject.create(1,2);');
  8110. Add(' tcar.create(1);');
  8111. Add(' tcar.create(1,2);');
  8112. ConvertProgram;
  8113. CheckSource('TestClass_OverloadConstructor',
  8114. LinesToStr([ // statements
  8115. 'rtl.createClass($mod, "TObject", null, function () {',
  8116. ' this.$init = function () {',
  8117. ' };',
  8118. ' this.$final = function () {',
  8119. ' };',
  8120. ' this.Create = function (vA) {',
  8121. ' this.Create(1);',
  8122. ' this.Create$1(1,2);',
  8123. ' };',
  8124. ' this.Create$1 = function (vA, vB) {',
  8125. ' };',
  8126. '});',
  8127. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  8128. ' this.Create$2 = function (vA) {',
  8129. ' this.Create$2(1);',
  8130. ' this.Create$3(1, 2);',
  8131. ' $mod.TObject.Create.call(this, 1);',
  8132. ' $mod.TObject.Create$1.call(this, 1, 2);',
  8133. ' };',
  8134. ' this.Create$3 = function (vA, vB) {',
  8135. ' };',
  8136. '});',
  8137. '']),
  8138. LinesToStr([ // $mod.$main
  8139. '$mod.TObject.$create("Create", [1]);',
  8140. '$mod.TObject.$create("Create$1", [1, 2]);',
  8141. '$mod.TCar.$create("Create$2", [1]);',
  8142. '$mod.TCar.$create("Create$3", [1, 2]);',
  8143. '']));
  8144. end;
  8145. procedure TTestModule.TestClass_OverloadDelphiOverride;
  8146. begin
  8147. StartProgram(false);
  8148. Add([
  8149. '{$mode delphi}',
  8150. 'type',
  8151. ' TObject = class end;',
  8152. ' TBird = class',
  8153. ' function {#a}GetValue: longint; overload; virtual;',
  8154. ' function {#b}GetValue(AValue: longint): longint; overload; virtual;',
  8155. ' end;',
  8156. ' TEagle = class(TBird)',
  8157. ' function {#c}GetValue: longint; overload; override;',
  8158. ' function {#d}GetValue(AValue: longint): longint; overload; override;',
  8159. ' end;',
  8160. 'function TBird.GetValue: longint;',
  8161. 'begin',
  8162. ' if 3={@a}GetValue then ;',
  8163. ' if 4={@b}GetValue(5) then ;',
  8164. 'end;',
  8165. 'function TBird.GetValue(AValue: longint): longint;',
  8166. 'begin',
  8167. 'end;',
  8168. 'function TEagle.GetValue: longint;',
  8169. 'begin',
  8170. ' if 13={@c}GetValue then ;',
  8171. ' if 14={@d}GetValue(15) then ;',
  8172. ' if 15=inherited {@a}GetValue then ;',
  8173. ' if 16=inherited {@b}GetValue(17) then ;',
  8174. 'end;',
  8175. 'function TEagle.GetValue(AValue: longint): longint;',
  8176. 'begin',
  8177. 'end;',
  8178. 'var',
  8179. ' e: TEagle;',
  8180. 'begin',
  8181. ' if 23=e.{@c}GetValue then ;',
  8182. ' if 24=e.{@d}GetValue(25) then ;']);
  8183. ConvertProgram;
  8184. CheckSource('TestClass_OverloadDelphiOverride',
  8185. LinesToStr([ // statements
  8186. 'rtl.createClass($mod, "TObject", null, function () {',
  8187. ' this.$init = function () {',
  8188. ' };',
  8189. ' this.$final = function () {',
  8190. ' };',
  8191. '});',
  8192. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  8193. ' this.GetValue = function () {',
  8194. ' var Result = 0;',
  8195. ' if (3 === this.GetValue()) ;',
  8196. ' if (4 === this.GetValue$1(5)) ;',
  8197. ' return Result;',
  8198. ' };',
  8199. ' this.GetValue$1 = function (AValue) {',
  8200. ' var Result = 0;',
  8201. ' return Result;',
  8202. ' };',
  8203. '});',
  8204. 'rtl.createClass($mod, "TEagle", $mod.TBird, function () {',
  8205. ' this.GetValue = function () {',
  8206. ' var Result = 0;',
  8207. ' if (13 === this.GetValue()) ;',
  8208. ' if (14 === this.GetValue$1(15)) ;',
  8209. ' if (15 === $mod.TBird.GetValue.call(this)) ;',
  8210. ' if (16 === $mod.TBird.GetValue$1.call(this, 17)) ;',
  8211. ' return Result;',
  8212. ' };',
  8213. ' this.GetValue$1 = function (AValue) {',
  8214. ' var Result = 0;',
  8215. ' return Result;',
  8216. ' };',
  8217. '});',
  8218. 'this.e = null;',
  8219. '']),
  8220. LinesToStr([ // $mod.$main
  8221. 'if (23 === $mod.e.GetValue()) ;',
  8222. 'if (24 === $mod.e.GetValue$1(25)) ;',
  8223. '']));
  8224. end;
  8225. procedure TTestModule.TestClass_ReintroducedVar;
  8226. begin
  8227. StartProgram(false);
  8228. Add('type');
  8229. Add(' TObject = class');
  8230. Add(' strict private');
  8231. Add(' Some: longint;');
  8232. Add(' end;');
  8233. Add(' TMobile = class');
  8234. Add(' strict private');
  8235. Add(' Some: string;');
  8236. Add(' end;');
  8237. Add(' TCar = class(tmobile)');
  8238. Add(' procedure Some;');
  8239. Add(' procedure Some(vA: longint);');
  8240. Add(' end;');
  8241. Add('procedure tcar.some;');
  8242. Add('begin');
  8243. Add(' Some;');
  8244. Add(' Some(1);');
  8245. Add('end;');
  8246. Add('procedure tcar.some(va: longint); begin end;');
  8247. Add('begin');
  8248. ConvertProgram;
  8249. CheckSource('TestClass_ReintroducedVar',
  8250. LinesToStr([ // statements
  8251. 'rtl.createClass($mod, "TObject", null, function () {',
  8252. ' this.$init = function () {',
  8253. ' this.Some = 0;',
  8254. ' };',
  8255. ' this.$final = function () {',
  8256. ' };',
  8257. '});',
  8258. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  8259. ' this.$init = function () {',
  8260. ' $mod.TObject.$init.call(this);',
  8261. ' this.Some$1 = "";',
  8262. ' };',
  8263. '});',
  8264. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  8265. ' this.Some$2 = function () {',
  8266. ' this.Some$2();',
  8267. ' this.Some$3(1);',
  8268. ' };',
  8269. ' this.Some$3 = function (vA) {',
  8270. ' };',
  8271. '});',
  8272. '']),
  8273. LinesToStr([ // $mod.$main
  8274. '']));
  8275. end;
  8276. procedure TTestModule.TestClass_RaiseDescendant;
  8277. begin
  8278. StartProgram(false);
  8279. Add([
  8280. 'type',
  8281. ' TObject = class',
  8282. ' constructor Create(Msg: string);',
  8283. ' end;',
  8284. ' Exception = class',
  8285. ' end;',
  8286. ' EConvertError = class(Exception)',
  8287. ' end;',
  8288. 'constructor TObject.Create(Msg: string); begin end;',
  8289. 'function AssertConv(Msg: string = ''def''): EConvertError; begin end;',
  8290. 'begin',
  8291. ' raise Exception.Create(''Bar1'');',
  8292. ' raise EConvertError.Create(''Bar2'');',
  8293. ' raise AssertConv(''Bar2'');',
  8294. ' raise AssertConv;',
  8295. '']);
  8296. ConvertProgram;
  8297. CheckSource('TestClass_RaiseDescendant',
  8298. LinesToStr([ // statements
  8299. 'rtl.createClass($mod, "TObject", null, function () {',
  8300. ' this.$init = function () {',
  8301. ' };',
  8302. ' this.$final = function () {',
  8303. ' };',
  8304. ' this.Create = function (Msg) {',
  8305. ' };',
  8306. '});',
  8307. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  8308. '});',
  8309. 'rtl.createClass($mod, "EConvertError", $mod.Exception, function () {',
  8310. '});',
  8311. 'this.AssertConv = function (Msg) {',
  8312. ' var Result = null;',
  8313. ' return Result;',
  8314. '};',
  8315. '']),
  8316. LinesToStr([ // $mod.$main
  8317. 'throw $mod.Exception.$create("Create",["Bar1"]);',
  8318. 'throw $mod.EConvertError.$create("Create",["Bar2"]);',
  8319. 'throw $mod.AssertConv("Bar2");',
  8320. 'throw $mod.AssertConv("def");',
  8321. '']));
  8322. end;
  8323. procedure TTestModule.TestClass_ExternalMethod;
  8324. begin
  8325. AddModuleWithIntfImplSrc('unit2.pas',
  8326. LinesToStr([
  8327. 'type',
  8328. ' TObject = class',
  8329. ' public',
  8330. ' procedure Intern; external name ''$DoIntern'';',
  8331. ' end;',
  8332. '']),
  8333. LinesToStr([
  8334. '']));
  8335. StartUnit(true);
  8336. Add('interface');
  8337. Add('uses unit2;');
  8338. Add('type');
  8339. Add(' TCar = class(TObject)');
  8340. Add(' public');
  8341. Add(' procedure Intern2; external name ''$DoIntern2'';');
  8342. Add(' procedure DoIt;');
  8343. Add(' end;');
  8344. Add('implementation');
  8345. Add('procedure tcar.doit;');
  8346. Add('begin');
  8347. Add(' Intern;');
  8348. Add(' Intern();');
  8349. Add(' Intern2;');
  8350. Add(' Intern2();');
  8351. Add('end;');
  8352. Add('var Obj: TCar;');
  8353. Add('begin');
  8354. Add(' obj.intern;');
  8355. Add(' obj.intern();');
  8356. Add(' obj.intern2;');
  8357. Add(' obj.intern2();');
  8358. Add(' obj.doit;');
  8359. Add(' obj.doit();');
  8360. Add(' with obj do begin');
  8361. Add(' Intern;');
  8362. Add(' Intern();');
  8363. Add(' Intern2;');
  8364. Add(' Intern2();');
  8365. Add(' end;');
  8366. ConvertUnit;
  8367. CheckSource('TestClass_ExternalMethod',
  8368. LinesToStr([
  8369. 'var $impl = $mod.$impl;',
  8370. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  8371. ' this.DoIt = function () {',
  8372. ' this.$DoIntern();',
  8373. ' this.$DoIntern();',
  8374. ' this.$DoIntern2();',
  8375. ' this.$DoIntern2();',
  8376. ' };',
  8377. ' });',
  8378. '']),
  8379. LinesToStr([ // this.$init
  8380. '$impl.Obj.$DoIntern();',
  8381. '$impl.Obj.$DoIntern();',
  8382. '$impl.Obj.$DoIntern2();',
  8383. '$impl.Obj.$DoIntern2();',
  8384. '$impl.Obj.DoIt();',
  8385. '$impl.Obj.DoIt();',
  8386. 'var $with1 = $impl.Obj;',
  8387. '$with1.$DoIntern();',
  8388. '$with1.$DoIntern();',
  8389. '$with1.$DoIntern2();',
  8390. '$with1.$DoIntern2();',
  8391. '']),
  8392. LinesToStr([ // implementation
  8393. '$impl.Obj = null;',
  8394. '']) );
  8395. end;
  8396. procedure TTestModule.TestClass_ExternalVirtualNameMismatchFail;
  8397. begin
  8398. StartProgram(false);
  8399. Add('type');
  8400. Add(' TObject = class');
  8401. Add(' procedure DoIt; virtual; external name ''Foo'';');
  8402. Add(' end;');
  8403. Add('begin');
  8404. SetExpectedPasResolverError('Virtual method name must match external',
  8405. nVirtualMethodNameMustMatchExternal);
  8406. ConvertProgram;
  8407. end;
  8408. procedure TTestModule.TestClass_ExternalOverrideFail;
  8409. begin
  8410. StartProgram(false);
  8411. Add('type');
  8412. Add(' TObject = class');
  8413. Add(' procedure DoIt; virtual; external name ''DoIt'';');
  8414. Add(' end;');
  8415. Add(' TCar = class');
  8416. Add(' procedure DoIt; override; external name ''DoIt'';');
  8417. Add(' end;');
  8418. Add('begin');
  8419. SetExpectedPasResolverError('Invalid procedure modifier override,external',
  8420. nInvalidXModifierY);
  8421. ConvertProgram;
  8422. end;
  8423. procedure TTestModule.TestClass_ExternalVar;
  8424. begin
  8425. AddModuleWithIntfImplSrc('unit2.pas',
  8426. LinesToStr([
  8427. '{$modeswitch externalclass}',
  8428. 'type',
  8429. ' TObject = class',
  8430. ' public',
  8431. ' Intern: longint external name ''$Intern'';',
  8432. ' end;',
  8433. '']),
  8434. LinesToStr([
  8435. '']));
  8436. StartUnit(true);
  8437. Add('interface');
  8438. Add('uses unit2;');
  8439. Add('{$modeswitch externalclass}');
  8440. Add('type');
  8441. Add(' TCar = class(tobject)');
  8442. Add(' public');
  8443. Add(' Intern2: longint external name ''$Intern2'';');
  8444. Add(' procedure DoIt;');
  8445. Add(' end;');
  8446. Add('implementation');
  8447. Add('procedure tcar.doit;');
  8448. Add('begin');
  8449. Add(' Intern:=Intern+1;');
  8450. Add(' Intern2:=Intern2+2;');
  8451. Add('end;');
  8452. Add('var Obj: TCar;');
  8453. Add('begin');
  8454. Add(' obj.intern:=obj.intern+1;');
  8455. Add(' obj.intern2:=obj.intern2+2;');
  8456. Add(' with obj do begin');
  8457. Add(' intern:=intern+1;');
  8458. Add(' intern2:=intern2+2;');
  8459. Add(' end;');
  8460. ConvertUnit;
  8461. CheckSource('TestClass_ExternalVar',
  8462. LinesToStr([
  8463. 'var $impl = $mod.$impl;',
  8464. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  8465. ' this.DoIt = function () {',
  8466. ' this.$Intern = this.$Intern + 1;',
  8467. ' this.$Intern2 = this.$Intern2 + 2;',
  8468. ' };',
  8469. ' });',
  8470. '']),
  8471. LinesToStr([
  8472. '$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
  8473. '$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
  8474. 'var $with1 = $impl.Obj;',
  8475. '$with1.$Intern = $with1.$Intern + 1;',
  8476. '$with1.$Intern2 = $with1.$Intern2 + 2;',
  8477. '']),
  8478. LinesToStr([ // implementation
  8479. '$impl.Obj = null;',
  8480. '']));
  8481. end;
  8482. procedure TTestModule.TestClass_Const;
  8483. begin
  8484. StartProgram(false);
  8485. Add('type');
  8486. Add(' integer = longint;');
  8487. Add(' TClass = class of TObject;');
  8488. Add(' TObject = class');
  8489. Add(' public');
  8490. Add(' const cI: integer = 3;');
  8491. Add(' procedure DoIt;');
  8492. Add(' class procedure DoMore;');
  8493. Add(' end;');
  8494. Add('implementation');
  8495. Add('procedure tobject.doit;');
  8496. Add('begin');
  8497. Add(' if cI=4 then;');
  8498. Add(' if 5=cI then;');
  8499. Add(' if Self.cI=6 then;');
  8500. Add(' if 7=Self.cI then;');
  8501. Add(' with Self do begin');
  8502. Add(' if cI=11 then;');
  8503. Add(' if 12=cI then;');
  8504. Add(' end;');
  8505. Add('end;');
  8506. Add('class procedure tobject.domore;');
  8507. Add('begin');
  8508. Add(' if cI=8 then;');
  8509. Add(' if Self.cI=9 then;');
  8510. Add(' if 10=cI then;');
  8511. Add(' if 11=Self.cI then;');
  8512. Add(' with Self do begin');
  8513. Add(' if cI=13 then;');
  8514. Add(' if 14=cI then;');
  8515. Add(' end;');
  8516. Add('end;');
  8517. Add('var');
  8518. Add(' Obj: TObject;');
  8519. Add(' Cla: TClass;');
  8520. Add('begin');
  8521. Add(' if TObject.cI=21 then ;');
  8522. Add(' if Obj.cI=22 then ;');
  8523. Add(' if Cla.cI=23 then ;');
  8524. Add(' with obj do if ci=24 then;');
  8525. Add(' with TObject do if ci=25 then;');
  8526. Add(' with Cla do if ci=26 then;');
  8527. ConvertProgram;
  8528. CheckSource('TestClass_Const',
  8529. LinesToStr([
  8530. 'rtl.createClass($mod, "TObject", null, function () {',
  8531. ' this.cI = 3;',
  8532. ' this.$init = function () {',
  8533. ' };',
  8534. ' this.$final = function () {',
  8535. ' };',
  8536. ' this.DoIt = function () {',
  8537. ' if (this.cI === 4) ;',
  8538. ' if (5 === this.cI) ;',
  8539. ' if (this.cI === 6) ;',
  8540. ' if (7 === this.cI) ;',
  8541. ' if (this.cI === 11) ;',
  8542. ' if (12 === this.cI) ;',
  8543. ' };',
  8544. ' this.DoMore = function () {',
  8545. ' if (this.cI === 8) ;',
  8546. ' if (this.cI === 9) ;',
  8547. ' if (10 === this.cI) ;',
  8548. ' if (11 === this.cI) ;',
  8549. ' if (this.cI === 13) ;',
  8550. ' if (14 === this.cI) ;',
  8551. ' };',
  8552. '});',
  8553. 'this.Obj = null;',
  8554. 'this.Cla = null;',
  8555. '']),
  8556. LinesToStr([
  8557. 'if ($mod.TObject.cI === 21) ;',
  8558. 'if ($mod.Obj.cI === 22) ;',
  8559. 'if ($mod.Cla.cI === 23) ;',
  8560. 'var $with1 = $mod.Obj;',
  8561. 'if ($with1.cI === 24) ;',
  8562. 'var $with2 = $mod.TObject;',
  8563. 'if ($with2.cI === 25) ;',
  8564. 'var $with3 = $mod.Cla;',
  8565. 'if ($with3.cI === 26) ;',
  8566. '']));
  8567. end;
  8568. procedure TTestModule.TestClass_LocalVarSelfFail;
  8569. begin
  8570. StartProgram(false);
  8571. Add([
  8572. 'type',
  8573. ' TObject = class',
  8574. ' constructor Create;',
  8575. ' end;',
  8576. 'constructor tobject.create;',
  8577. 'var self: longint;',
  8578. 'begin',
  8579. 'end',
  8580. 'begin',
  8581. '']);
  8582. SetExpectedPasResolverError('Duplicate identifier "self" at (0)',nDuplicateIdentifier);
  8583. ConvertProgram;
  8584. end;
  8585. procedure TTestModule.TestClass_ArgSelfFail;
  8586. begin
  8587. StartProgram(false);
  8588. Add([
  8589. 'type',
  8590. ' TObject = class',
  8591. ' procedure DoIt(Self: longint);',
  8592. ' end;',
  8593. 'procedure tobject.doit(self: longint);',
  8594. 'begin',
  8595. 'end',
  8596. 'begin',
  8597. '']);
  8598. SetExpectedPasResolverError('Duplicate identifier "Self" at test1.pp(5,24)',nDuplicateIdentifier);
  8599. ConvertProgram;
  8600. end;
  8601. procedure TTestModule.TestClass_NestedSelf;
  8602. begin
  8603. StartProgram(false);
  8604. Add([
  8605. 'type',
  8606. ' TObject = class',
  8607. ' Key: longint;',
  8608. ' class var State: longint;',
  8609. ' procedure DoIt;',
  8610. ' function GetSize: longint; virtual; abstract;',
  8611. ' procedure SetSize(Value: longint); virtual; abstract;',
  8612. ' property Size: longint read GetSize write SetSize;',
  8613. ' end;',
  8614. 'procedure tobject.doit;',
  8615. ' procedure Sub;',
  8616. ' begin',
  8617. ' key:=key+2;',
  8618. ' self.key:=self.key+3;',
  8619. ' state:=state+4;',
  8620. ' self.state:=self.state+5;',
  8621. ' tobject.state:=tobject.state+6;',
  8622. ' size:=size+7;',
  8623. ' self.size:=self.size+8;',
  8624. ' end;',
  8625. 'begin',
  8626. ' sub;',
  8627. ' key:=key+12;',
  8628. ' self.key:=self.key+13;',
  8629. ' state:=state+14;',
  8630. ' self.state:=self.state+15;',
  8631. ' tobject.state:=tobject.state+16;',
  8632. ' size:=size+17;',
  8633. ' self.size:=self.size+18;',
  8634. 'end;',
  8635. 'begin',
  8636. '']);
  8637. ConvertProgram;
  8638. CheckSource('TestClass_NestedSelf',
  8639. LinesToStr([ // statements
  8640. 'rtl.createClass($mod, "TObject", null, function () {',
  8641. ' this.State = 0;',
  8642. ' this.$init = function () {',
  8643. ' this.Key = 0;',
  8644. ' };',
  8645. ' this.$final = function () {',
  8646. ' };',
  8647. ' this.DoIt = function () {',
  8648. ' var Self = this;',
  8649. ' function Sub() {',
  8650. ' Self.Key = Self.Key + 2;',
  8651. ' Self.Key = Self.Key + 3;',
  8652. ' Self.$class.State = Self.State + 4;',
  8653. ' Self.$class.State = Self.State + 5;',
  8654. ' $mod.TObject.State = $mod.TObject.State + 6;',
  8655. ' Self.SetSize(Self.GetSize() + 7);',
  8656. ' Self.SetSize(Self.GetSize() + 8);',
  8657. ' };',
  8658. ' Sub();',
  8659. ' Self.Key = Self.Key + 12;',
  8660. ' Self.Key = Self.Key + 13;',
  8661. ' Self.$class.State = Self.State + 14;',
  8662. ' Self.$class.State = Self.State + 15;',
  8663. ' $mod.TObject.State = $mod.TObject.State + 16;',
  8664. ' Self.SetSize(Self.GetSize() + 17);',
  8665. ' Self.SetSize(Self.GetSize() + 18);',
  8666. ' };',
  8667. '});',
  8668. '']),
  8669. LinesToStr([ // $mod.$main
  8670. '']));
  8671. end;
  8672. procedure TTestModule.TestClass_NestedClassSelf;
  8673. begin
  8674. StartProgram(false);
  8675. Add([
  8676. 'type',
  8677. ' TObject = class',
  8678. ' class var State: longint;',
  8679. ' class procedure DoIt;',
  8680. ' class function GetSize: longint; virtual; abstract;',
  8681. ' class procedure SetSize(Value: longint); virtual; abstract;',
  8682. ' class property Size: longint read GetSize write SetSize;',
  8683. ' end;',
  8684. 'class procedure tobject.doit;',
  8685. ' procedure Sub;',
  8686. ' begin',
  8687. ' state:=state+2;',
  8688. ' self.state:=self.state+3;',
  8689. ' tobject.state:=tobject.state+4;',
  8690. ' size:=size+5;',
  8691. ' self.size:=self.size+6;',
  8692. ' tobject.size:=tobject.size+7;',
  8693. ' end;',
  8694. 'begin',
  8695. ' sub;',
  8696. ' state:=state+12;',
  8697. ' self.state:=self.state+13;',
  8698. ' tobject.state:=tobject.state+14;',
  8699. ' size:=size+15;',
  8700. ' self.size:=self.size+16;',
  8701. ' tobject.size:=tobject.size+17;',
  8702. 'end;',
  8703. 'begin',
  8704. '']);
  8705. ConvertProgram;
  8706. CheckSource('TestClass_NestedClassSelf',
  8707. LinesToStr([ // statements
  8708. 'rtl.createClass($mod, "TObject", null, function () {',
  8709. ' this.State = 0;',
  8710. ' this.$init = function () {',
  8711. ' };',
  8712. ' this.$final = function () {',
  8713. ' };',
  8714. ' this.DoIt = function () {',
  8715. ' var Self = this;',
  8716. ' function Sub() {',
  8717. ' Self.State = Self.State + 2;',
  8718. ' Self.State = Self.State + 3;',
  8719. ' $mod.TObject.State = $mod.TObject.State + 4;',
  8720. ' Self.SetSize(Self.GetSize() + 5);',
  8721. ' Self.SetSize(Self.GetSize() + 6);',
  8722. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 7);',
  8723. ' };',
  8724. ' Sub();',
  8725. ' Self.State = Self.State + 12;',
  8726. ' Self.State = Self.State + 13;',
  8727. ' $mod.TObject.State = $mod.TObject.State + 14;',
  8728. ' Self.SetSize(Self.GetSize() + 15);',
  8729. ' Self.SetSize(Self.GetSize() + 16);',
  8730. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
  8731. ' };',
  8732. '});',
  8733. '']),
  8734. LinesToStr([ // $mod.$main
  8735. '']));
  8736. end;
  8737. procedure TTestModule.TestClass_NestedCallInherited;
  8738. begin
  8739. StartProgram(false);
  8740. Add([
  8741. 'type',
  8742. ' TObject = class',
  8743. ' function DoIt(k: boolean): longint; virtual;',
  8744. ' end;',
  8745. ' TBird = class',
  8746. ' function DoIt(k: boolean): longint; override;',
  8747. ' end;',
  8748. 'function tobject.doit(k: boolean): longint;',
  8749. 'begin',
  8750. 'end;',
  8751. 'function tbird.doit(k: boolean): longint;',
  8752. ' procedure Sub;',
  8753. ' begin',
  8754. ' inherited DoIt(true);',
  8755. //' if inherited DoIt(false)=4 then ;',
  8756. ' end;',
  8757. 'begin',
  8758. ' Sub;',
  8759. ' inherited;',
  8760. ' inherited DoIt(true);',
  8761. //' if inherited DoIt(false)=14 then ;',
  8762. 'end;',
  8763. 'begin',
  8764. '']);
  8765. ConvertProgram;
  8766. CheckSource('TestClass_NestedCallInherited',
  8767. LinesToStr([ // statements
  8768. 'rtl.createClass($mod, "TObject", null, function () {',
  8769. ' this.$init = function () {',
  8770. ' };',
  8771. ' this.$final = function () {',
  8772. ' };',
  8773. ' this.DoIt = function (k) {',
  8774. ' var Result = 0;',
  8775. ' return Result;',
  8776. ' };',
  8777. '});',
  8778. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  8779. ' this.DoIt = function (k) {',
  8780. ' var Self = this;',
  8781. ' var Result = 0;',
  8782. ' function Sub() {',
  8783. ' $mod.TObject.DoIt.call(Self, true);',
  8784. ' };',
  8785. ' Sub();',
  8786. ' $mod.TObject.DoIt.apply(Self, arguments);',
  8787. ' $mod.TObject.DoIt.call(Self, true);',
  8788. ' return Result;',
  8789. ' };',
  8790. '});',
  8791. '']),
  8792. LinesToStr([ // $mod.$main
  8793. '']));
  8794. end;
  8795. procedure TTestModule.TestClass_TObjectFree;
  8796. begin
  8797. StartProgram(false);
  8798. Add([
  8799. 'type',
  8800. ' TObject = class',
  8801. ' Obj: tobject;',
  8802. ' procedure Free;',
  8803. ' end;',
  8804. 'procedure tobject.free;',
  8805. 'begin',
  8806. 'end;',
  8807. 'function DoIt(o: tobject): tobject;',
  8808. 'var l: tobject;',
  8809. 'begin',
  8810. ' o.free;',
  8811. ' o.free();',
  8812. ' l.free;',
  8813. ' l.free();',
  8814. ' o.obj.free;',
  8815. ' o.obj.free();',
  8816. ' with o do obj.free;',
  8817. ' with o do obj.free();',
  8818. ' result.Free;',
  8819. ' result.Free();',
  8820. 'end;',
  8821. 'var o: tobject;',
  8822. ' a: array of tobject;',
  8823. 'begin',
  8824. ' o.free;',
  8825. ' o.obj.free;',
  8826. ' a[1+2].free;',
  8827. '']);
  8828. ConvertProgram;
  8829. CheckSource('TestClass_TObjectFree',
  8830. LinesToStr([ // statements
  8831. 'rtl.createClass($mod, "TObject", null, function () {',
  8832. ' this.$init = function () {',
  8833. ' this.Obj = null;',
  8834. ' };',
  8835. ' this.$final = function () {',
  8836. ' this.Obj = undefined;',
  8837. ' };',
  8838. ' this.Free = function () {',
  8839. ' };',
  8840. '});',
  8841. 'this.DoIt = function (o) {',
  8842. ' var Result = null;',
  8843. ' var l = null;',
  8844. ' o = rtl.freeLoc(o);',
  8845. ' o = rtl.freeLoc(o);',
  8846. ' l = rtl.freeLoc(l);',
  8847. ' l = rtl.freeLoc(l);',
  8848. ' rtl.free(o, "Obj");',
  8849. ' rtl.free(o, "Obj");',
  8850. ' rtl.free(o, "Obj");',
  8851. ' rtl.free(o, "Obj");',
  8852. ' Result = rtl.freeLoc(Result);',
  8853. ' Result = rtl.freeLoc(Result);',
  8854. ' return Result;',
  8855. '};',
  8856. 'this.o = null;',
  8857. 'this.a = [];',
  8858. '']),
  8859. LinesToStr([ // $mod.$main
  8860. 'rtl.free($mod, "o");',
  8861. 'rtl.free($mod.o, "Obj");',
  8862. 'rtl.free($mod.a, 1 + 2);',
  8863. '']));
  8864. end;
  8865. procedure TTestModule.TestClass_TObjectFreeNewInstance;
  8866. begin
  8867. StartProgram(false);
  8868. Add([
  8869. 'type',
  8870. ' TObject = class',
  8871. ' constructor Create;',
  8872. ' procedure Free;',
  8873. ' end;',
  8874. 'constructor TObject.Create; begin end;',
  8875. 'procedure tobject.free; begin end;',
  8876. 'begin',
  8877. ' with tobject.create do free;',
  8878. '']);
  8879. ConvertProgram;
  8880. CheckSource('TestClass_TObjectFreeNewInstance',
  8881. LinesToStr([ // statements
  8882. 'rtl.createClass($mod, "TObject", null, function () {',
  8883. ' this.$init = function () {',
  8884. ' };',
  8885. ' this.$final = function () {',
  8886. ' };',
  8887. ' this.Create = function () {',
  8888. ' };',
  8889. ' this.Free = function () {',
  8890. ' };',
  8891. '});',
  8892. '']),
  8893. LinesToStr([ // $mod.$main
  8894. 'var $with1 = $mod.TObject.$create("Create");',
  8895. '$with1=rtl.freeLoc($with1);',
  8896. '']));
  8897. end;
  8898. procedure TTestModule.TestClass_TObjectFreeLowerCase;
  8899. begin
  8900. StartProgram(false);
  8901. Add([
  8902. 'type',
  8903. ' TObject = class',
  8904. ' destructor Destroy;',
  8905. ' procedure Free;',
  8906. ' end;',
  8907. 'destructor TObject.Destroy; begin end;',
  8908. 'procedure tobject.free; begin end;',
  8909. 'var o: tobject;',
  8910. 'begin',
  8911. ' o.free;',
  8912. '']);
  8913. Converter.UseLowerCase:=true;
  8914. ConvertProgram;
  8915. CheckSource('TestClass_TObjectFreeLowerCase',
  8916. LinesToStr([ // statements
  8917. 'rtl.createClass($mod, "tobject", null, function () {',
  8918. ' this.$init = function () {',
  8919. ' };',
  8920. ' this.$final = function () {',
  8921. ' };',
  8922. ' rtl.tObjectDestroy = "destroy";',
  8923. ' this.destroy = function () {',
  8924. ' };',
  8925. ' this.free = function () {',
  8926. ' };',
  8927. '});',
  8928. 'this.o = null;',
  8929. '']),
  8930. LinesToStr([ // $mod.$main
  8931. 'rtl.free($mod, "o");',
  8932. '']));
  8933. end;
  8934. procedure TTestModule.TestClass_TObjectFreeFunctionFail;
  8935. begin
  8936. StartProgram(false);
  8937. Add([
  8938. 'type',
  8939. ' TObject = class',
  8940. ' procedure Free;',
  8941. ' function GetObj: tobject; virtual; abstract;',
  8942. ' end;',
  8943. 'procedure tobject.free;',
  8944. 'begin',
  8945. 'end;',
  8946. 'var o: tobject;',
  8947. 'begin',
  8948. ' o.getobj.free;',
  8949. '']);
  8950. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  8951. ConvertProgram;
  8952. end;
  8953. procedure TTestModule.TestClass_TObjectFreePropertyFail;
  8954. begin
  8955. StartProgram(false);
  8956. Add([
  8957. 'type',
  8958. ' TObject = class',
  8959. ' procedure Free;',
  8960. ' FObj: TObject;',
  8961. ' property Obj: tobject read FObj write FObj;',
  8962. ' end;',
  8963. 'procedure tobject.free;',
  8964. 'begin',
  8965. 'end;',
  8966. 'var o: tobject;',
  8967. 'begin',
  8968. ' o.obj.free;',
  8969. '']);
  8970. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  8971. ConvertProgram;
  8972. end;
  8973. procedure TTestModule.TestClassOf_Create;
  8974. begin
  8975. StartProgram(false);
  8976. Add('type');
  8977. Add(' TObject = class');
  8978. Add(' constructor Create;');
  8979. Add(' end;');
  8980. Add(' TClass = class of TObject;');
  8981. Add('constructor tobject.create; begin end;');
  8982. Add('var');
  8983. Add(' Obj: tobject;');
  8984. Add(' C: tclass;');
  8985. Add('begin');
  8986. Add(' obj:=C.create;');
  8987. Add(' with c do obj:=create;');
  8988. ConvertProgram;
  8989. CheckSource('TestClassOf_Create',
  8990. LinesToStr([ // statements
  8991. 'rtl.createClass($mod, "TObject", null, function () {',
  8992. ' this.$init = function () {',
  8993. ' };',
  8994. ' this.$final = function () {',
  8995. ' };',
  8996. ' this.Create = function () {',
  8997. ' };',
  8998. '});',
  8999. 'this.Obj = null;',
  9000. 'this.C = null;'
  9001. ]),
  9002. LinesToStr([ // $mod.$main
  9003. '$mod.Obj = $mod.C.$create("Create");',
  9004. 'var $with1 = $mod.C;',
  9005. '$mod.Obj = $with1.$create("Create");',
  9006. '']));
  9007. end;
  9008. procedure TTestModule.TestClassOf_Call;
  9009. begin
  9010. StartProgram(false);
  9011. Add('type');
  9012. Add(' TObject = class');
  9013. Add(' class procedure DoIt;');
  9014. Add(' end;');
  9015. Add(' TClass = class of TObject;');
  9016. Add('class procedure tobject.doit; begin end;');
  9017. Add('var');
  9018. Add(' C: tclass;');
  9019. Add('begin');
  9020. Add(' c.doit;');
  9021. Add(' with c do doit;');
  9022. ConvertProgram;
  9023. CheckSource('TestClassOf_Call',
  9024. LinesToStr([ // statements
  9025. 'rtl.createClass($mod, "TObject", null, function () {',
  9026. ' this.$init = function () {',
  9027. ' };',
  9028. ' this.$final = function () {',
  9029. ' };',
  9030. ' this.DoIt = function () {',
  9031. ' };',
  9032. '});',
  9033. 'this.C = null;'
  9034. ]),
  9035. LinesToStr([ // $mod.$main
  9036. '$mod.C.DoIt();',
  9037. 'var $with1 = $mod.C;',
  9038. '$with1.DoIt();',
  9039. '']));
  9040. end;
  9041. procedure TTestModule.TestClassOf_Assign;
  9042. begin
  9043. StartProgram(false);
  9044. Add('type');
  9045. Add(' TClass = class of TObject;');
  9046. Add(' TObject = class');
  9047. Add(' ClassType: TClass; ');
  9048. Add(' end;');
  9049. Add('var');
  9050. Add(' Obj: tobject;');
  9051. Add(' C: tclass;');
  9052. Add('begin');
  9053. Add(' c:=nil;');
  9054. Add(' c:=obj.classtype;');
  9055. ConvertProgram;
  9056. CheckSource('TestClassOf_Assign',
  9057. LinesToStr([ // statements
  9058. 'rtl.createClass($mod, "TObject", null, function () {',
  9059. ' this.$init = function () {',
  9060. ' this.ClassType = null;',
  9061. ' };',
  9062. ' this.$final = function () {',
  9063. ' this.ClassType = undefined;',
  9064. ' };',
  9065. '});',
  9066. 'this.Obj = null;',
  9067. 'this.C = null;'
  9068. ]),
  9069. LinesToStr([ // $mod.$main
  9070. '$mod.C = null;',
  9071. '$mod.C = $mod.Obj.ClassType;',
  9072. '']));
  9073. end;
  9074. procedure TTestModule.TestClassOf_Is;
  9075. begin
  9076. StartProgram(false);
  9077. Add('type');
  9078. Add(' TClass = class of TObject;');
  9079. Add(' TObject = class');
  9080. Add(' end;');
  9081. Add(' TCar = class');
  9082. Add(' end;');
  9083. Add(' TCars = class of TCar;');
  9084. Add('var');
  9085. Add(' Obj: tobject;');
  9086. Add(' C: tclass;');
  9087. Add(' Cars: tcars;');
  9088. Add('begin');
  9089. Add(' if c is tcar then ;');
  9090. Add(' if c is tcars then ;');
  9091. ConvertProgram;
  9092. CheckSource('TestClassOf_Is',
  9093. LinesToStr([ // statements
  9094. 'rtl.createClass($mod, "TObject", null, function () {',
  9095. ' this.$init = function () {',
  9096. ' };',
  9097. ' this.$final = function () {',
  9098. ' };',
  9099. '});',
  9100. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  9101. '});',
  9102. 'this.Obj = null;',
  9103. 'this.C = null;',
  9104. 'this.Cars = null;'
  9105. ]),
  9106. LinesToStr([ // $mod.$main
  9107. 'if(rtl.is($mod.C,$mod.TCar));',
  9108. 'if(rtl.is($mod.C,$mod.TCar));',
  9109. '']));
  9110. end;
  9111. procedure TTestModule.TestClassOf_Compare;
  9112. begin
  9113. StartProgram(false);
  9114. Add('type');
  9115. Add(' TClass = class of TObject;');
  9116. Add(' TObject = class');
  9117. Add(' ClassType: TClass; ');
  9118. Add(' end;');
  9119. Add('var');
  9120. Add(' b: boolean;');
  9121. Add(' Obj: tobject;');
  9122. Add(' C: tclass;');
  9123. Add('begin');
  9124. Add(' b:=c=nil;');
  9125. Add(' b:=nil=c;');
  9126. Add(' b:=c=obj.classtype;');
  9127. Add(' b:=obj.classtype=c;');
  9128. Add(' b:=c=TObject;');
  9129. Add(' b:=TObject=c;');
  9130. Add(' b:=c<>nil;');
  9131. Add(' b:=nil<>c;');
  9132. Add(' b:=c<>obj.classtype;');
  9133. Add(' b:=obj.classtype<>c;');
  9134. Add(' b:=c<>TObject;');
  9135. Add(' b:=TObject<>c;');
  9136. ConvertProgram;
  9137. CheckSource('TestClassOf_Compare',
  9138. LinesToStr([ // statements
  9139. 'rtl.createClass($mod, "TObject", null, function () {',
  9140. ' this.$init = function () {',
  9141. ' this.ClassType = null;',
  9142. ' };',
  9143. ' this.$final = function () {',
  9144. ' this.ClassType = undefined;',
  9145. ' };',
  9146. '});',
  9147. 'this.b = false;',
  9148. 'this.Obj = null;',
  9149. 'this.C = null;'
  9150. ]),
  9151. LinesToStr([ // $mod.$main
  9152. '$mod.b = $mod.C === null;',
  9153. '$mod.b = null === $mod.C;',
  9154. '$mod.b = $mod.C === $mod.Obj.ClassType;',
  9155. '$mod.b = $mod.Obj.ClassType === $mod.C;',
  9156. '$mod.b = $mod.C === $mod.TObject;',
  9157. '$mod.b = $mod.TObject === $mod.C;',
  9158. '$mod.b = $mod.C !== null;',
  9159. '$mod.b = null !== $mod.C;',
  9160. '$mod.b = $mod.C !== $mod.Obj.ClassType;',
  9161. '$mod.b = $mod.Obj.ClassType !== $mod.C;',
  9162. '$mod.b = $mod.C !== $mod.TObject;',
  9163. '$mod.b = $mod.TObject !== $mod.C;',
  9164. '']));
  9165. end;
  9166. procedure TTestModule.TestClassOf_ClassVar;
  9167. begin
  9168. StartProgram(false);
  9169. Add('type');
  9170. Add(' TObject = class');
  9171. Add(' class var id: longint;');
  9172. Add(' end;');
  9173. Add(' TClass = class of TObject;');
  9174. Add('var');
  9175. Add(' C: tclass;');
  9176. Add('begin');
  9177. Add(' C.id:=C.id;');
  9178. ConvertProgram;
  9179. CheckSource('TestClassOf_ClassVar',
  9180. LinesToStr([ // statements
  9181. 'rtl.createClass($mod, "TObject", null, function () {',
  9182. ' this.id = 0;',
  9183. ' this.$init = function () {',
  9184. ' };',
  9185. ' this.$final = function () {',
  9186. ' };',
  9187. '});',
  9188. 'this.C = null;'
  9189. ]),
  9190. LinesToStr([ // $mod.$main
  9191. '$mod.C.id = $mod.C.id;',
  9192. '']));
  9193. end;
  9194. procedure TTestModule.TestClassOf_ClassMethod;
  9195. begin
  9196. StartProgram(false);
  9197. Add('type');
  9198. Add(' TObject = class');
  9199. Add(' class function DoIt(i: longint = 0): longint;');
  9200. Add(' end;');
  9201. Add(' TClass = class of TObject;');
  9202. Add('class function tobject.doit(i: longint = 0): longint; begin end;');
  9203. Add('var');
  9204. Add(' i: longint;');
  9205. Add(' C: tclass;');
  9206. Add('begin');
  9207. Add(' C.DoIt;');
  9208. Add(' C.DoIt();');
  9209. Add(' i:=C.DoIt;');
  9210. Add(' i:=C.DoIt();');
  9211. ConvertProgram;
  9212. CheckSource('TestClassOf_ClassMethod',
  9213. LinesToStr([ // statements
  9214. 'rtl.createClass($mod, "TObject", null, function () {',
  9215. ' this.$init = function () {',
  9216. ' };',
  9217. ' this.$final = function () {',
  9218. ' };',
  9219. ' this.DoIt = function (i) {',
  9220. ' var Result = 0;',
  9221. ' return Result;',
  9222. ' };',
  9223. '});',
  9224. 'this.i = 0;',
  9225. 'this.C = null;'
  9226. ]),
  9227. LinesToStr([ // $mod.$main
  9228. '$mod.C.DoIt(0);',
  9229. '$mod.C.DoIt(0);',
  9230. '$mod.i = $mod.C.DoIt(0);',
  9231. '$mod.i = $mod.C.DoIt(0);',
  9232. '']));
  9233. end;
  9234. procedure TTestModule.TestClassOf_ClassProperty;
  9235. begin
  9236. StartProgram(false);
  9237. Add('type');
  9238. Add(' TObject = class');
  9239. Add(' class var FA: longint;');
  9240. Add(' class function GetA: longint;');
  9241. Add(' class procedure SetA(Value: longint);');
  9242. Add(' class property pA: longint read fa write fa;');
  9243. Add(' class property pB: longint read geta write seta;');
  9244. Add(' end;');
  9245. Add(' TObjectClass = class of tobject;');
  9246. Add('class function tobject.geta: longint; begin end;');
  9247. Add('class procedure tobject.seta(value: longint); begin end;');
  9248. Add('var');
  9249. Add(' b: boolean;');
  9250. Add(' Obj: tobject;');
  9251. Add(' Cla: tobjectclass;');
  9252. Add('begin');
  9253. Add(' obj.pa:=obj.pa;');
  9254. Add(' obj.pb:=obj.pb;');
  9255. Add(' b:=obj.pa=4;');
  9256. Add(' b:=obj.pb=obj.pb;');
  9257. Add(' b:=5=obj.pa;');
  9258. Add(' cla.pa:=6;');
  9259. Add(' cla.pa:=cla.pa;');
  9260. Add(' cla.pb:=cla.pb;');
  9261. Add(' b:=cla.pa=7;');
  9262. Add(' b:=cla.pb=cla.pb;');
  9263. Add(' b:=8=cla.pa;');
  9264. Add(' tobject.pa:=9;');
  9265. Add(' tobject.pb:=tobject.pb;');
  9266. Add(' b:=tobject.pa=10;');
  9267. Add(' b:=11=tobject.pa;');
  9268. ConvertProgram;
  9269. CheckSource('TestClassOf_ClassProperty',
  9270. LinesToStr([ // statements
  9271. 'rtl.createClass($mod, "TObject", null, function () {',
  9272. ' this.FA = 0;',
  9273. ' this.$init = function () {',
  9274. ' };',
  9275. ' this.$final = function () {',
  9276. ' };',
  9277. ' this.GetA = function () {',
  9278. ' var Result = 0;',
  9279. ' return Result;',
  9280. ' };',
  9281. ' this.SetA = function (Value) {',
  9282. ' };',
  9283. '});',
  9284. 'this.b = false;',
  9285. 'this.Obj = null;',
  9286. 'this.Cla = null;'
  9287. ]),
  9288. LinesToStr([ // $mod.$main
  9289. '$mod.Obj.$class.FA = $mod.Obj.FA;',
  9290. '$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
  9291. '$mod.b = $mod.Obj.FA === 4;',
  9292. '$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
  9293. '$mod.b = 5 === $mod.Obj.FA;',
  9294. '$mod.Cla.FA = 6;',
  9295. '$mod.Cla.FA = $mod.Cla.FA;',
  9296. '$mod.Cla.SetA($mod.Cla.GetA());',
  9297. '$mod.b = $mod.Cla.FA === 7;',
  9298. '$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
  9299. '$mod.b = 8 === $mod.Cla.FA;',
  9300. '$mod.TObject.FA = 9;',
  9301. '$mod.TObject.SetA($mod.TObject.GetA());',
  9302. '$mod.b = $mod.TObject.FA === 10;',
  9303. '$mod.b = 11 === $mod.TObject.FA;',
  9304. '']));
  9305. end;
  9306. procedure TTestModule.TestClassOf_ClassMethodSelf;
  9307. begin
  9308. StartProgram(false);
  9309. Add('type');
  9310. Add(' TObject = class');
  9311. Add(' class var GlobalId: longint;');
  9312. Add(' class procedure ProcA;');
  9313. Add(' end;');
  9314. Add('class procedure tobject.proca;');
  9315. Add('var b: boolean;');
  9316. Add('begin');
  9317. Add(' b:=self=nil;');
  9318. Add(' b:=self.globalid=3;');
  9319. Add(' b:=4=self.globalid;');
  9320. Add(' self.globalid:=5;');
  9321. Add(' self.proca;');
  9322. Add('end;');
  9323. Add('begin');
  9324. ConvertProgram;
  9325. CheckSource('TestClassOf_ClassMethodSelf',
  9326. LinesToStr([ // statements
  9327. 'rtl.createClass($mod, "TObject", null, function () {',
  9328. ' this.GlobalId = 0;',
  9329. ' this.$init = function () {',
  9330. ' };',
  9331. ' this.$final = function () {',
  9332. ' };',
  9333. ' this.ProcA = function () {',
  9334. ' var b = false;',
  9335. ' b = this === null;',
  9336. ' b = this.GlobalId === 3;',
  9337. ' b = 4 === this.GlobalId;',
  9338. ' this.GlobalId = 5;',
  9339. ' this.ProcA();',
  9340. ' };',
  9341. '});'
  9342. ]),
  9343. LinesToStr([ // $mod.$main
  9344. '']));
  9345. end;
  9346. procedure TTestModule.TestClassOf_TypeCast;
  9347. begin
  9348. StartProgram(false);
  9349. Add('type');
  9350. Add(' TObject = class');
  9351. Add(' class procedure {#TObject_DoIt}DoIt;');
  9352. Add(' end;');
  9353. Add(' TClass = class of TObject;');
  9354. Add(' TMobile = class');
  9355. Add(' class procedure {#TMobile_DoIt}DoIt;');
  9356. Add(' end;');
  9357. Add(' TMobileClass = class of TMobile;');
  9358. Add(' TCar = class(TMobile)');
  9359. Add(' class procedure {#TCar_DoIt}DoIt;');
  9360. Add(' end;');
  9361. Add(' TCarClass = class of TCar;');
  9362. Add('class procedure TObject.DoIt;');
  9363. Add('begin');
  9364. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  9365. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  9366. Add('end;');
  9367. Add('class procedure TMobile.DoIt;');
  9368. Add('begin');
  9369. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  9370. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  9371. Add(' TCarClass(Self).{@TCar_DoIt}DoIt;');
  9372. Add('end;');
  9373. Add('class procedure TCar.DoIt; begin end;');
  9374. Add('var');
  9375. Add(' ObjC: TClass;');
  9376. Add(' MobileC: TMobileClass;');
  9377. Add(' CarC: TCarClass;');
  9378. Add('begin');
  9379. Add(' ObjC.{@TObject_DoIt}DoIt;');
  9380. Add(' MobileC.{@TMobile_DoIt}DoIt;');
  9381. Add(' CarC.{@TCar_DoIt}DoIt;');
  9382. Add(' TClass(ObjC).{@TObject_DoIt}DoIt;');
  9383. Add(' TMobileClass(ObjC).{@TMobile_DoIt}DoIt;');
  9384. Add(' TCarClass(ObjC).{@TCar_DoIt}DoIt;');
  9385. Add(' TClass(MobileC).{@TObject_DoIt}DoIt;');
  9386. Add(' TMobileClass(MobileC).{@TMobile_DoIt}DoIt;');
  9387. Add(' TCarClass(MobileC).{@TCar_DoIt}DoIt;');
  9388. Add(' TClass(CarC).{@TObject_DoIt}DoIt;');
  9389. Add(' TMobileClass(CarC).{@TMobile_DoIt}DoIt;');
  9390. Add(' TCarClass(CarC).{@TCar_DoIt}DoIt;');
  9391. ConvertProgram;
  9392. CheckSource('TestClassOf_TypeCast',
  9393. LinesToStr([ // statements
  9394. 'rtl.createClass($mod, "TObject", null, function () {',
  9395. ' this.$init = function () {',
  9396. ' };',
  9397. ' this.$final = function () {',
  9398. ' };',
  9399. ' this.DoIt = function () {',
  9400. ' this.DoIt();',
  9401. ' this.DoIt$1();',
  9402. ' };',
  9403. '});',
  9404. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  9405. ' this.DoIt$1 = function () {',
  9406. ' this.DoIt();',
  9407. ' this.DoIt$1();',
  9408. ' this.DoIt$2();',
  9409. ' };',
  9410. '});',
  9411. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  9412. ' this.DoIt$2 = function () {',
  9413. ' };',
  9414. '});',
  9415. 'this.ObjC = null;',
  9416. 'this.MobileC = null;',
  9417. 'this.CarC = null;',
  9418. '']),
  9419. LinesToStr([ // $mod.$main
  9420. '$mod.ObjC.DoIt();',
  9421. '$mod.MobileC.DoIt$1();',
  9422. '$mod.CarC.DoIt$2();',
  9423. '$mod.ObjC.DoIt();',
  9424. '$mod.ObjC.DoIt$1();',
  9425. '$mod.ObjC.DoIt$2();',
  9426. '$mod.MobileC.DoIt();',
  9427. '$mod.MobileC.DoIt$1();',
  9428. '$mod.MobileC.DoIt$2();',
  9429. '$mod.CarC.DoIt();',
  9430. '$mod.CarC.DoIt$1();',
  9431. '$mod.CarC.DoIt$2();',
  9432. '']));
  9433. end;
  9434. procedure TTestModule.TestClassOf_ImplicitFunctionCall;
  9435. begin
  9436. StartProgram(false);
  9437. Add('type');
  9438. Add(' TObject = class');
  9439. Add(' function CurNow: longint; ');
  9440. Add(' class function Now: longint; ');
  9441. Add(' end;');
  9442. Add('function TObject.CurNow: longint; begin end;');
  9443. Add('class function TObject.Now: longint; begin end;');
  9444. Add('var');
  9445. Add(' Obj: tobject;');
  9446. Add(' vI: longint;');
  9447. Add('begin');
  9448. Add(' obj.curnow;');
  9449. Add(' vi:=obj.curnow;');
  9450. Add(' tobject.now;');
  9451. Add(' vi:=tobject.now;');
  9452. ConvertProgram;
  9453. CheckSource('TestClassOf_ImplicitFunctionCall',
  9454. LinesToStr([ // statements
  9455. 'rtl.createClass($mod, "TObject", null, function () {',
  9456. ' this.$init = function () {',
  9457. ' };',
  9458. ' this.$final = function () {',
  9459. ' };',
  9460. ' this.CurNow = function () {',
  9461. ' var Result = 0;',
  9462. ' return Result;',
  9463. ' };',
  9464. ' this.Now = function () {',
  9465. ' var Result = 0;',
  9466. ' return Result;',
  9467. ' };',
  9468. '});',
  9469. 'this.Obj = null;',
  9470. 'this.vI = 0;',
  9471. '']),
  9472. LinesToStr([ // $mod.$main
  9473. '$mod.Obj.CurNow();',
  9474. '$mod.vI = $mod.Obj.CurNow();',
  9475. '$mod.TObject.Now();',
  9476. '$mod.vI = $mod.TObject.Now();',
  9477. '']));
  9478. end;
  9479. procedure TTestModule.TestClassOf_Const;
  9480. begin
  9481. StartProgram(false);
  9482. Add([
  9483. 'type',
  9484. ' TObject = class',
  9485. ' end;',
  9486. ' TBird = TObject;',
  9487. ' TBirds = class of TBird;',
  9488. ' TEagles = TBirds;',
  9489. ' THawk = class(TBird);',
  9490. 'const',
  9491. ' Hawk: TEagles = THawk;',
  9492. ' DefaultBirdClasses : Array [1..2] of TEagles = (',
  9493. ' TBird,',
  9494. ' THawk',
  9495. ' );',
  9496. 'begin']);
  9497. ConvertProgram;
  9498. CheckSource('TestClassOf_Const',
  9499. LinesToStr([ // statements
  9500. 'rtl.createClass($mod, "TObject", null, function () {',
  9501. ' this.$init = function () {',
  9502. ' };',
  9503. ' this.$final = function () {',
  9504. ' };',
  9505. '});',
  9506. 'rtl.createClass($mod, "THawk", $mod.TObject, function () {',
  9507. '});',
  9508. 'this.Hawk = $mod.THawk;',
  9509. 'this.DefaultBirdClasses = [$mod.TObject, $mod.THawk];',
  9510. '']),
  9511. LinesToStr([ // $mod.$main
  9512. '']));
  9513. end;
  9514. procedure TTestModule.TestNestedClass_Fail;
  9515. begin
  9516. StartProgram(false);
  9517. Add([
  9518. 'type',
  9519. ' TObject = class',
  9520. ' type TNested = longint;',
  9521. ' end;',
  9522. 'begin']);
  9523. SetExpectedPasResolverError('not yet implemented: TNested:TPasAliasType [20170608232534] nested types',
  9524. nNotYetImplemented);
  9525. ConvertProgram;
  9526. end;
  9527. procedure TTestModule.TestExternalClass_Var;
  9528. begin
  9529. StartProgram(false);
  9530. Add('{$modeswitch externalclass}');
  9531. Add('type');
  9532. Add(' TExtA = class external name ''ExtObj''');
  9533. Add(' Id: longint external name ''$Id'';');
  9534. Add(' B: longint;');
  9535. Add(' end;');
  9536. Add('var Obj: TExtA;');
  9537. Add('begin');
  9538. Add(' obj.id:=obj.id+1;');
  9539. Add(' obj.B:=obj.B+1;');
  9540. ConvertProgram;
  9541. CheckSource('TestExternalClass_Var',
  9542. LinesToStr([ // statements
  9543. 'this.Obj = null;',
  9544. '']),
  9545. LinesToStr([ // $mod.$main
  9546. '$mod.Obj.$Id = $mod.Obj.$Id + 1;',
  9547. '$mod.Obj.B = $mod.Obj.B + 1;',
  9548. '']));
  9549. end;
  9550. procedure TTestModule.TestExternalClass_Dollar;
  9551. begin
  9552. StartProgram(false);
  9553. Add([
  9554. '{$modeswitch externalclass}',
  9555. 'type',
  9556. ' TExtA = class external name ''$''',
  9557. ' Id: longint external name ''$'';',
  9558. ' function Bla(i: longint): longint; external name ''$'';',
  9559. ' end;',
  9560. 'function dollar(k: longint): longint; external name ''$'';',
  9561. 'var Obj: TExtA;',
  9562. 'begin',
  9563. ' dollar(1);',
  9564. ' obj.id:=obj.id+2;',
  9565. ' obj.Bla(3);',
  9566. '']);
  9567. ConvertProgram;
  9568. CheckSource('TestExternalClass_Dollar',
  9569. LinesToStr([ // statements
  9570. 'this.Obj = null;',
  9571. '']),
  9572. LinesToStr([ // $mod.$main
  9573. '$(1);',
  9574. '$mod.Obj.$ = $mod.Obj.$ + 2;',
  9575. '$mod.Obj.$(3);',
  9576. '']));
  9577. end;
  9578. procedure TTestModule.TestExternalClass_DuplicateVarFail;
  9579. begin
  9580. StartProgram(false);
  9581. Add('{$modeswitch externalclass}');
  9582. Add('type');
  9583. Add(' TExtA = class external name ''ExtA''');
  9584. Add(' Id: longint external name ''$Id'';');
  9585. Add(' end;');
  9586. Add(' TExtB = class external ''lib'' name ''ExtB''(TExtA)');
  9587. Add(' Id: longint;');
  9588. Add(' end;');
  9589. Add('begin');
  9590. SetExpectedPasResolverError('Duplicate identifier "Id" at test1.pp(6,5)',nDuplicateIdentifier);
  9591. ConvertProgram;
  9592. end;
  9593. procedure TTestModule.TestExternalClass_Method;
  9594. begin
  9595. StartProgram(false);
  9596. Add('{$modeswitch externalclass}');
  9597. Add('type');
  9598. Add(' TExtA = class external name ''ExtObj''');
  9599. Add(' procedure DoIt(Id: longint = 1); external name ''$Execute'';');
  9600. Add(' procedure DoSome(Id: longint = 1);');
  9601. Add(' end;');
  9602. Add('var Obj: texta;');
  9603. Add('begin');
  9604. Add(' obj.doit;');
  9605. Add(' obj.doit();');
  9606. Add(' obj.doit(2);');
  9607. Add(' with obj do begin');
  9608. Add(' doit;');
  9609. Add(' doit();');
  9610. Add(' doit(3);');
  9611. Add(' end;');
  9612. ConvertProgram;
  9613. CheckSource('TestExternalClass_Method',
  9614. LinesToStr([ // statements
  9615. 'this.Obj = null;',
  9616. '']),
  9617. LinesToStr([ // $mod.$main
  9618. '$mod.Obj.$Execute(1);',
  9619. '$mod.Obj.$Execute(1);',
  9620. '$mod.Obj.$Execute(2);',
  9621. 'var $with1 = $mod.Obj;',
  9622. '$with1.$Execute(1);',
  9623. '$with1.$Execute(1);',
  9624. '$with1.$Execute(3);',
  9625. '']));
  9626. end;
  9627. procedure TTestModule.TestExternalClass_NonExternalOverride;
  9628. begin
  9629. StartProgram(false);
  9630. Add('{$modeswitch externalclass}');
  9631. Add('type');
  9632. Add(' TExtA = class external name ''ExtObjA''');
  9633. Add(' procedure ProcA; virtual;');
  9634. Add(' procedure ProcB; virtual;');
  9635. Add(' end;');
  9636. Add(' TExtB = class external name ''ExtObjB'' (TExtA)');
  9637. Add(' end;');
  9638. Add(' TExtC = class (TExtB)');
  9639. Add(' procedure ProcA; override;');
  9640. Add(' end;');
  9641. Add('procedure TExtC.ProcA;');
  9642. Add('begin');
  9643. Add(' ProcA;');
  9644. Add(' Self.ProcA;');
  9645. Add(' ProcB;');
  9646. Add(' Self.ProcB;');
  9647. Add('end;');
  9648. Add('var');
  9649. Add(' A: texta;');
  9650. Add(' B: textb;');
  9651. Add(' C: textc;');
  9652. Add('begin');
  9653. Add(' a.proca;');
  9654. Add(' b.proca;');
  9655. Add(' c.proca;');
  9656. ConvertProgram;
  9657. CheckSource('TestExternalClass_NonExternalOverride',
  9658. LinesToStr([ // statements
  9659. 'rtl.createClassExt($mod, "TExtC", ExtObjB, "", function () {',
  9660. ' this.$init = function () {',
  9661. ' };',
  9662. ' this.$final = function () {',
  9663. ' };',
  9664. ' this.ProcA = function () {',
  9665. ' this.ProcA();',
  9666. ' this.ProcA();',
  9667. ' this.ProcB();',
  9668. ' this.ProcB();',
  9669. ' };',
  9670. '});',
  9671. 'this.A = null;',
  9672. 'this.B = null;',
  9673. 'this.C = null;',
  9674. '']),
  9675. LinesToStr([ // $mod.$main
  9676. '$mod.A.ProcA();',
  9677. '$mod.B.ProcA();',
  9678. '$mod.C.ProcA();',
  9679. '']));
  9680. end;
  9681. procedure TTestModule.TestExternalClass_Property;
  9682. begin
  9683. StartProgram(false);
  9684. Add('{$modeswitch externalclass}');
  9685. Add('type');
  9686. Add(' TExtA = class external name ''ExtA''');
  9687. Add(' function getYear: longint;');
  9688. Add(' procedure setYear(Value: longint);');
  9689. Add(' property Year: longint read getyear write setyear;');
  9690. Add(' end;');
  9691. Add(' TExtB = class (TExtA)');
  9692. Add(' procedure OtherSetYear(Value: longint);');
  9693. Add(' property year write othersetyear;');
  9694. Add(' end;');
  9695. Add('procedure textb.othersetyear(value: longint);');
  9696. Add('begin');
  9697. Add(' setYear(Value+4);');
  9698. Add('end;');
  9699. Add('var');
  9700. Add(' A: texta;');
  9701. Add(' B: textb;');
  9702. Add('begin');
  9703. Add(' a.year:=a.year+1;');
  9704. Add(' b.year:=b.year+2;');
  9705. ConvertProgram;
  9706. CheckSource('TestExternalClass_NonExternalOverride',
  9707. LinesToStr([ // statements
  9708. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  9709. ' this.$init = function () {',
  9710. ' };',
  9711. ' this.$final = function () {',
  9712. ' };',
  9713. ' this.OtherSetYear = function (Value) {',
  9714. ' this.setYear(Value+4);',
  9715. ' };',
  9716. '});',
  9717. 'this.A = null;',
  9718. 'this.B = null;',
  9719. '']),
  9720. LinesToStr([ // $mod.$main
  9721. '$mod.A.setYear($mod.A.getYear()+1);',
  9722. '$mod.B.OtherSetYear($mod.B.getYear()+2);',
  9723. '']));
  9724. end;
  9725. procedure TTestModule.TestExternalClass_ClassProperty;
  9726. begin
  9727. StartProgram(false);
  9728. Add('{$modeswitch externalclass}');
  9729. Add('type');
  9730. Add(' TExtA = class external name ''ExtA''');
  9731. Add(' class function getYear: longint;');
  9732. Add(' class procedure setYear(Value: longint);');
  9733. Add(' class property Year: longint read getyear write setyear;');
  9734. Add(' end;');
  9735. Add(' TExtB = class (TExtA)');
  9736. Add(' class function GetCentury: longint;');
  9737. Add(' class procedure SetCentury(Value: longint);');
  9738. Add(' class property Century: longint read getcentury write setcentury;');
  9739. Add(' end;');
  9740. Add('class function textb.getcentury: longint;');
  9741. Add('begin');
  9742. Add('end;');
  9743. Add('class procedure textb.setcentury(value: longint);');
  9744. Add('begin');
  9745. Add(' setyear(value+11);');
  9746. Add(' texta.year:=texta.year+12;');
  9747. Add(' year:=year+13;');
  9748. Add(' textb.century:=textb.century+14;');
  9749. Add(' century:=century+15;');
  9750. Add('end;');
  9751. Add('var');
  9752. Add(' A: texta;');
  9753. Add(' B: textb;');
  9754. Add('begin');
  9755. Add(' texta.year:=texta.year+1;');
  9756. Add(' textb.year:=textb.year+2;');
  9757. Add(' TextA.year:=TextA.year+3;');
  9758. Add(' b.year:=b.year+4;');
  9759. Add(' textb.century:=textb.century+5;');
  9760. Add(' b.century:=b.century+6;');
  9761. ConvertProgram;
  9762. CheckSource('TestExternalClass_ClassProperty',
  9763. LinesToStr([ // statements
  9764. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  9765. ' this.$init = function () {',
  9766. ' };',
  9767. ' this.$final = function () {',
  9768. ' };',
  9769. ' this.GetCentury = function () {',
  9770. ' var Result = 0;',
  9771. ' return Result;',
  9772. ' };',
  9773. ' this.SetCentury = function (Value) {',
  9774. ' this.setYear(Value + 11);',
  9775. ' ExtA.setYear(ExtA.getYear() + 12);',
  9776. ' this.setYear(this.getYear() + 13);',
  9777. ' $mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 14);',
  9778. ' this.SetCentury(this.GetCentury() + 15);',
  9779. ' };',
  9780. '});',
  9781. 'this.A = null;',
  9782. 'this.B = null;',
  9783. '']),
  9784. LinesToStr([ // $mod.$main
  9785. 'ExtA.setYear(ExtA.getYear() + 1);',
  9786. '$mod.TExtB.setYear($mod.TExtB.getYear() + 2);',
  9787. 'ExtA.setYear(ExtA.getYear() + 3);',
  9788. '$mod.B.setYear($mod.B.getYear() + 4);',
  9789. '$mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 5);',
  9790. '$mod.B.$class.SetCentury($mod.B.$class.GetCentury() + 6);',
  9791. '']));
  9792. end;
  9793. procedure TTestModule.TestExternalClass_ClassOf;
  9794. begin
  9795. StartProgram(false);
  9796. Add('{$modeswitch externalclass}');
  9797. Add('type');
  9798. Add(' TExtA = class external name ''ExtA''');
  9799. Add(' procedure ProcA; virtual;');
  9800. Add(' procedure ProcB; virtual;');
  9801. Add(' end;');
  9802. Add(' TExtAClass = class of TExtA;');
  9803. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  9804. Add(' end;');
  9805. Add(' TExtBClass = class of TExtB;');
  9806. Add(' TExtC = class (TExtB)');
  9807. Add(' procedure ProcA; override;');
  9808. Add(' end;');
  9809. Add(' TExtCClass = class of TExtC;');
  9810. Add('procedure TExtC.ProcA; begin end;');
  9811. Add('var');
  9812. Add(' A: texta; ClA: TExtAClass;');
  9813. Add(' B: textb; ClB: TExtBClass;');
  9814. Add(' C: textc; ClC: TExtCClass;');
  9815. Add('begin');
  9816. Add(' ClA:=texta;');
  9817. Add(' ClA:=textb;');
  9818. Add(' ClA:=textc;');
  9819. Add(' ClB:=textb;');
  9820. Add(' ClB:=textc;');
  9821. Add(' ClC:=textc;');
  9822. ConvertProgram;
  9823. CheckSource('TestExternalClass_ClassOf',
  9824. LinesToStr([ // statements
  9825. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  9826. ' this.$init = function () {',
  9827. ' };',
  9828. ' this.$final = function () {',
  9829. ' };',
  9830. ' this.ProcA = function () {',
  9831. ' };',
  9832. '});',
  9833. 'this.A = null;',
  9834. 'this.ClA = null;',
  9835. 'this.B = null;',
  9836. 'this.ClB = null;',
  9837. 'this.C = null;',
  9838. 'this.ClC = null;',
  9839. '']),
  9840. LinesToStr([ // $mod.$main
  9841. '$mod.ClA = ExtA;',
  9842. '$mod.ClA = ExtB;',
  9843. '$mod.ClA = $mod.TExtC;',
  9844. '$mod.ClB = ExtB;',
  9845. '$mod.ClB = $mod.TExtC;',
  9846. '$mod.ClC = $mod.TExtC;',
  9847. '']));
  9848. end;
  9849. procedure TTestModule.TestExternalClass_ClassOtherUnit;
  9850. begin
  9851. AddModuleWithIntfImplSrc('unit2.pas',
  9852. LinesToStr([
  9853. '{$modeswitch externalclass}',
  9854. 'type',
  9855. ' TExtA = class external name ''ExtA''',
  9856. ' class var Id: longint;',
  9857. ' end;',
  9858. '']),
  9859. '');
  9860. StartUnit(true);
  9861. Add('interface');
  9862. Add('uses unit2;');
  9863. Add('implementation');
  9864. Add('begin');
  9865. Add(' unit2.texta.id:=unit2.texta.id+1;');
  9866. ConvertUnit;
  9867. CheckSource('TestExternalClass_ClassOtherUnit',
  9868. LinesToStr([
  9869. '']),
  9870. LinesToStr([
  9871. 'ExtA.Id = ExtA.Id + 1;',
  9872. '']));
  9873. end;
  9874. procedure TTestModule.TestExternalClass_Is;
  9875. begin
  9876. StartProgram(false);
  9877. Add('{$modeswitch externalclass}');
  9878. Add('type');
  9879. Add(' TExtA = class external name ''ExtA''');
  9880. Add(' end;');
  9881. Add(' TExtAClass = class of TExtA;');
  9882. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  9883. Add(' end;');
  9884. Add(' TExtBClass = class of TExtB;');
  9885. Add(' TExtC = class (TExtB)');
  9886. Add(' end;');
  9887. Add(' TExtCClass = class of TExtC;');
  9888. Add('var');
  9889. Add(' A: texta; ClA: TExtAClass;');
  9890. Add(' B: textb; ClB: TExtBClass;');
  9891. Add(' C: textc; ClC: TExtCClass;');
  9892. Add('begin');
  9893. Add(' if a is textb then ;');
  9894. Add(' if a is textc then ;');
  9895. Add(' if b is textc then ;');
  9896. Add(' if cla is textb then ;');
  9897. Add(' if cla is textc then ;');
  9898. Add(' if clb is textc then ;');
  9899. ConvertProgram;
  9900. CheckSource('TestExternalClass_Is',
  9901. LinesToStr([ // statements
  9902. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  9903. ' this.$init = function () {',
  9904. ' };',
  9905. ' this.$final = function () {',
  9906. ' };',
  9907. '});',
  9908. 'this.A = null;',
  9909. 'this.ClA = null;',
  9910. 'this.B = null;',
  9911. 'this.ClB = null;',
  9912. 'this.C = null;',
  9913. 'this.ClC = null;',
  9914. '']),
  9915. LinesToStr([ // $mod.$main
  9916. 'if (rtl.isExt($mod.A, ExtB)) ;',
  9917. 'if ($mod.TExtC.isPrototypeOf($mod.A)) ;',
  9918. 'if ($mod.TExtC.isPrototypeOf($mod.B)) ;',
  9919. 'if (rtl.isExt($mod.ClA, ExtB)) ;',
  9920. 'if (rtl.is($mod.ClA, $mod.TExtC)) ;',
  9921. 'if (rtl.is($mod.ClB, $mod.TExtC)) ;',
  9922. '']));
  9923. end;
  9924. procedure TTestModule.TestExternalClass_As;
  9925. begin
  9926. StartProgram(false);
  9927. Add('{$modeswitch externalclass}');
  9928. Add('type');
  9929. Add(' TExtA = class external name ''ExtA''');
  9930. Add(' end;');
  9931. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  9932. Add(' end;');
  9933. Add(' TExtC = class (TExtB)');
  9934. Add(' end;');
  9935. Add('var');
  9936. Add(' A: texta;');
  9937. Add(' B: textb;');
  9938. Add(' C: textc;');
  9939. Add('begin');
  9940. Add(' b:=a as textb;');
  9941. Add(' c:=a as textc;');
  9942. Add(' c:=b as textc;');
  9943. ConvertProgram;
  9944. CheckSource('TestExternalClass_Is',
  9945. LinesToStr([ // statements
  9946. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  9947. ' this.$init = function () {',
  9948. ' };',
  9949. ' this.$final = function () {',
  9950. ' };',
  9951. '});',
  9952. 'this.A = null;',
  9953. 'this.B = null;',
  9954. 'this.C = null;',
  9955. '']),
  9956. LinesToStr([ // $mod.$main
  9957. '$mod.B = rtl.asExt($mod.A, ExtB);',
  9958. '$mod.C = rtl.as($mod.A, $mod.TExtC);',
  9959. '$mod.C = rtl.as($mod.B, $mod.TExtC);',
  9960. '']));
  9961. end;
  9962. procedure TTestModule.TestExternalClass_DestructorFail;
  9963. begin
  9964. StartProgram(false);
  9965. Add('{$modeswitch externalclass}');
  9966. Add('type');
  9967. Add(' TExtA = class external name ''ExtA''');
  9968. Add(' destructor Free;');
  9969. Add(' end;');
  9970. SetExpectedPasResolverError('Pascal element not supported: destructor',
  9971. nPasElementNotSupported);
  9972. ConvertProgram;
  9973. end;
  9974. procedure TTestModule.TestExternalClass_New;
  9975. begin
  9976. StartProgram(false);
  9977. Add('{$modeswitch externalclass}');
  9978. Add('type');
  9979. Add(' TExtA = class external name ''ExtA''');
  9980. Add(' constructor New;');
  9981. Add(' constructor New(i: longint; j: longint = 2);');
  9982. Add(' end;');
  9983. Add('var');
  9984. Add(' A: texta;');
  9985. Add('begin');
  9986. Add(' a:=texta.new;');
  9987. Add(' a:=texta.new();');
  9988. Add(' a:=texta.new(1);');
  9989. Add(' with texta do begin');
  9990. Add(' a:=new;');
  9991. Add(' a:=new();');
  9992. Add(' a:=new(2);');
  9993. Add(' end;');
  9994. Add(' a:=test1.texta.new;');
  9995. Add(' a:=test1.texta.new();');
  9996. Add(' a:=test1.texta.new(3);');
  9997. ConvertProgram;
  9998. CheckSource('TestExternalClass_New',
  9999. LinesToStr([ // statements
  10000. 'this.A = null;',
  10001. '']),
  10002. LinesToStr([ // $mod.$main
  10003. '$mod.A = new ExtA();',
  10004. '$mod.A = new ExtA();',
  10005. '$mod.A = new ExtA(1,2);',
  10006. '$mod.A = new ExtA();',
  10007. '$mod.A = new ExtA();',
  10008. '$mod.A = new ExtA(2,2);',
  10009. '$mod.A = new ExtA();',
  10010. '$mod.A = new ExtA();',
  10011. '$mod.A = new ExtA(3,2);',
  10012. '']));
  10013. end;
  10014. procedure TTestModule.TestExternalClass_ClassOf_New;
  10015. begin
  10016. StartProgram(false);
  10017. Add('{$modeswitch externalclass}');
  10018. Add('type');
  10019. Add(' TExtAClass = class of TExtA;');
  10020. Add(' TExtA = class external name ''ExtA''');
  10021. Add(' constructor New;');
  10022. Add(' end;');
  10023. Add('var');
  10024. Add(' A: texta;');
  10025. Add(' C: textaclass;');
  10026. Add('begin');
  10027. Add(' a:=c.new;');
  10028. Add(' a:=c.new();');
  10029. Add(' with C do begin');
  10030. Add(' a:=new;');
  10031. Add(' a:=new();');
  10032. Add(' end;');
  10033. Add(' a:=test1.c.new;');
  10034. Add(' a:=test1.c.new();');
  10035. ConvertProgram;
  10036. CheckSource('TestExternalClass_ClassOf_New',
  10037. LinesToStr([ // statements
  10038. 'this.A = null;',
  10039. 'this.C = null;',
  10040. '']),
  10041. LinesToStr([ // $mod.$main
  10042. '$mod.A = new $mod.C();',
  10043. '$mod.A = new $mod.C();',
  10044. 'var $with1 = $mod.C;',
  10045. '$mod.A = new $with1();',
  10046. '$mod.A = new $with1();',
  10047. '$mod.A = new $mod.C();',
  10048. '$mod.A = new $mod.C();',
  10049. '']));
  10050. end;
  10051. procedure TTestModule.TestExternalClass_FuncClassOf_New;
  10052. begin
  10053. StartProgram(false);
  10054. Add('{$modeswitch externalclass}');
  10055. Add('type');
  10056. Add(' TExtAClass = class of TExtA;');
  10057. Add(' TExtA = class external name ''ExtA''');
  10058. Add(' constructor New;');
  10059. Add(' end;');
  10060. Add('function GetCreator: TExtAClass;');
  10061. Add('begin');
  10062. Add(' Result:=TExtA;');
  10063. Add('end;');
  10064. Add('var');
  10065. Add(' A: texta;');
  10066. Add('begin');
  10067. Add(' a:=getcreator.new;');
  10068. Add(' a:=getcreator().new;');
  10069. Add(' a:=getcreator().new();');
  10070. Add(' a:=getcreator.new();');
  10071. Add(' with getcreator do begin');
  10072. Add(' a:=new;');
  10073. Add(' a:=new();');
  10074. Add(' end;');
  10075. ConvertProgram;
  10076. CheckSource('TestExternalClass_FuncClassOf_New',
  10077. LinesToStr([ // statements
  10078. 'this.GetCreator = function () {',
  10079. ' var Result = null;',
  10080. ' Result = ExtA;',
  10081. ' return Result;',
  10082. '};',
  10083. 'this.A = null;',
  10084. '']),
  10085. LinesToStr([ // $mod.$main
  10086. '$mod.A = new ($mod.GetCreator())();',
  10087. '$mod.A = new ($mod.GetCreator())();',
  10088. '$mod.A = new ($mod.GetCreator())();',
  10089. '$mod.A = new ($mod.GetCreator())();',
  10090. 'var $with1 = $mod.GetCreator();',
  10091. '$mod.A = new $with1();',
  10092. '$mod.A = new $with1();',
  10093. '']));
  10094. end;
  10095. procedure TTestModule.TestExternalClass_LocalConstSameName;
  10096. begin
  10097. StartProgram(false);
  10098. Add('{$modeswitch externalclass}');
  10099. Add('type');
  10100. Add(' TExtA = class external name ''ExtA''');
  10101. Add(' constructor New;');
  10102. Add(' end;');
  10103. Add('function DoIt: longint;');
  10104. Add('const ExtA = 3;');
  10105. Add('begin');
  10106. Add(' Result:=ExtA;');
  10107. Add('end;');
  10108. Add('var');
  10109. Add(' A: texta;');
  10110. Add('begin');
  10111. Add(' a:=texta.new;');
  10112. ConvertProgram;
  10113. CheckSource('TestExternalClass_LocalConstSameName',
  10114. LinesToStr([ // statements
  10115. 'var ExtA$1 = 3;',
  10116. 'this.DoIt = function () {',
  10117. ' var Result = 0;',
  10118. ' Result = ExtA$1;',
  10119. ' return Result;',
  10120. '};',
  10121. 'this.A = null;',
  10122. '']),
  10123. LinesToStr([ // $mod.$main
  10124. '$mod.A = new ExtA();',
  10125. '']));
  10126. end;
  10127. procedure TTestModule.TestExternalClass_ReintroduceOverload;
  10128. begin
  10129. StartProgram(false);
  10130. Add('{$modeswitch externalclass}');
  10131. Add('type');
  10132. Add(' TExtA = class external name ''ExtA''');
  10133. Add(' procedure DoIt;');
  10134. Add(' end;');
  10135. Add(' TMyA = class(TExtA)');
  10136. Add(' procedure DoIt;');
  10137. Add(' end;');
  10138. Add('procedure TMyA.DoIt; begin end;');
  10139. Add('begin');
  10140. ConvertProgram;
  10141. CheckSource('TestExternalClass_ReintroduceOverload',
  10142. LinesToStr([ // statements
  10143. 'rtl.createClassExt($mod, "TMyA", ExtA, "", function () {',
  10144. ' this.$init = function () {',
  10145. ' };',
  10146. ' this.$final = function () {',
  10147. ' };',
  10148. ' this.DoIt$1 = function () {',
  10149. ' };',
  10150. '});',
  10151. '']),
  10152. LinesToStr([ // $mod.$main
  10153. '']));
  10154. end;
  10155. procedure TTestModule.TestExternalClass_Inherited;
  10156. begin
  10157. StartProgram(false);
  10158. Add('{$modeswitch externalclass}');
  10159. Add('type');
  10160. Add(' TExtA = class external name ''ExtA''');
  10161. Add(' procedure DoIt(i: longint = 1); virtual;');
  10162. Add(' procedure DoSome(j: longint = 2);');
  10163. Add(' end;');
  10164. Add(' TExtB = class external name ''ExtB''(TExtA)');
  10165. Add(' end;');
  10166. Add(' TMyC = class(TExtB)');
  10167. Add(' procedure DoIt(i: longint = 1); override;');
  10168. Add(' procedure DoSome(j: longint = 2); reintroduce;');
  10169. Add(' end;');
  10170. Add('procedure TMyC.DoIt(i: longint);');
  10171. Add('begin');
  10172. Add(' inherited;');
  10173. Add(' inherited DoIt;');
  10174. Add(' inherited DoIt();');
  10175. Add(' inherited DoIt(3);');
  10176. Add(' inherited DoSome;');
  10177. Add(' inherited DoSome();');
  10178. Add(' inherited DoSome(4);');
  10179. Add('end;');
  10180. Add('procedure TMyC.DoSome(j: longint);');
  10181. Add('begin');
  10182. Add(' inherited;');
  10183. Add('end;');
  10184. Add('begin');
  10185. ConvertProgram;
  10186. CheckSource('TestExternalClass_ReintroduceOverload',
  10187. LinesToStr([ // statements
  10188. 'rtl.createClassExt($mod, "TMyC", ExtB, "", function () {',
  10189. ' this.$init = function () {',
  10190. ' };',
  10191. ' this.$final = function () {',
  10192. ' };',
  10193. ' this.DoIt = function (i) {',
  10194. ' ExtB.DoIt.apply(this, arguments);',
  10195. ' ExtB.DoIt.call(this, 1);',
  10196. ' ExtB.DoIt.call(this, 1);',
  10197. ' ExtB.DoIt.call(this, 3);',
  10198. ' ExtB.DoSome.call(this, 2);',
  10199. ' ExtB.DoSome.call(this, 2);',
  10200. ' ExtB.DoSome.call(this, 4);',
  10201. ' };',
  10202. ' this.DoSome$1 = function (j) {',
  10203. ' ExtB.DoSome.apply(this, arguments);',
  10204. ' };',
  10205. '});',
  10206. '']),
  10207. LinesToStr([ // $mod.$main
  10208. '']));
  10209. end;
  10210. procedure TTestModule.TestExternalClass_PascalAncestorFail;
  10211. begin
  10212. StartProgram(false);
  10213. Add('{$modeswitch externalclass}');
  10214. Add('type');
  10215. Add(' TObject = class');
  10216. Add(' end;');
  10217. Add(' TExtA = class external name ''ExtA''(TObject)');
  10218. Add(' end;');
  10219. Add('begin');
  10220. SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
  10221. ConvertProgram;
  10222. end;
  10223. procedure TTestModule.TestExternalClass_NewInstance;
  10224. begin
  10225. StartProgram(false);
  10226. Add('{$modeswitch externalclass}');
  10227. Add('type');
  10228. Add(' TExtA = class external name ''ExtA''');
  10229. Add(' end;');
  10230. Add(' TMyB = class(TExtA)');
  10231. Add(' protected');
  10232. Add(' class function NewInstance(fnname: string; const paramarray): TMyB; virtual;');
  10233. Add(' end;');
  10234. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  10235. Add('begin end;');
  10236. Add('begin');
  10237. ConvertProgram;
  10238. CheckSource('TestExternalClass_NewInstance',
  10239. LinesToStr([ // statements
  10240. 'rtl.createClassExt($mod, "TMyB", ExtA, "NewInstance", function () {',
  10241. ' this.$init = function () {',
  10242. ' };',
  10243. ' this.$final = function () {',
  10244. ' };',
  10245. ' this.NewInstance = function (fnname, paramarray) {',
  10246. ' var Result = null;',
  10247. ' return Result;',
  10248. ' };',
  10249. '});',
  10250. '']),
  10251. LinesToStr([ // $mod.$main
  10252. '']));
  10253. end;
  10254. procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
  10255. begin
  10256. StartProgram(false);
  10257. Add('{$modeswitch externalclass}');
  10258. Add('type');
  10259. Add(' TExtA = class external name ''ExtA''');
  10260. Add(' end;');
  10261. Add(' TMyB = class(TExtA)');
  10262. Add(' protected');
  10263. Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
  10264. Add(' end;');
  10265. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  10266. Add('begin end;');
  10267. Add('begin');
  10268. SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
  10269. ConvertProgram;
  10270. end;
  10271. procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
  10272. begin
  10273. StartProgram(false);
  10274. Add('{$modeswitch externalclass}');
  10275. Add('type');
  10276. Add(' TExtA = class external name ''ExtA''');
  10277. Add(' end;');
  10278. Add(' TMyB = class(TExtA)');
  10279. Add(' protected');
  10280. Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
  10281. Add(' end;');
  10282. Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
  10283. Add('begin end;');
  10284. Add('begin');
  10285. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
  10286. nIncompatibleTypeArgNo);
  10287. ConvertProgram;
  10288. end;
  10289. procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
  10290. begin
  10291. StartProgram(false);
  10292. Add('{$modeswitch externalclass}');
  10293. Add('type');
  10294. Add(' TExtA = class external name ''ExtA''');
  10295. Add(' end;');
  10296. Add(' TMyB = class(TExtA)');
  10297. Add(' protected');
  10298. Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
  10299. Add(' end;');
  10300. Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
  10301. Add('begin end;');
  10302. Add('begin');
  10303. SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
  10304. nIncompatibleTypeArgNo);
  10305. ConvertProgram;
  10306. end;
  10307. procedure TTestModule.TestExternalClass_PascalProperty;
  10308. begin
  10309. StartProgram(false);
  10310. Add('{$modeswitch externalclass}');
  10311. Add('type');
  10312. Add(' TJSElement = class;');
  10313. Add(' TJSNotifyEvent = procedure(Sender: TJSElement) of object;');
  10314. Add(' TJSElement = class external name ''ExtA''');
  10315. Add(' end;');
  10316. Add(' TControl = class(TJSElement)');
  10317. Add(' private');
  10318. Add(' FOnClick: TJSNotifyEvent;');
  10319. Add(' property OnClick: TJSNotifyEvent read FOnClick write FOnClick;');
  10320. Add(' procedure Click(Sender: TJSElement);');
  10321. Add(' end;');
  10322. Add('procedure TControl.Click(Sender: TJSElement);');
  10323. Add('begin');
  10324. Add(' OnClick(Self);');
  10325. Add('end;');
  10326. Add('var');
  10327. Add(' Ctrl: TControl;');
  10328. Add('begin');
  10329. Add(' Ctrl.OnClick:[email protected];');
  10330. Add(' Ctrl.OnClick(Ctrl);');
  10331. ConvertProgram;
  10332. CheckSource('TestExternalClass_PascalProperty',
  10333. LinesToStr([ // statements
  10334. 'rtl.createClassExt($mod, "TControl", ExtA, "", function () {',
  10335. ' this.$init = function () {',
  10336. ' this.FOnClick = null;',
  10337. ' };',
  10338. ' this.$final = function () {',
  10339. ' this.FOnClick = undefined;',
  10340. ' };',
  10341. ' this.Click = function (Sender) {',
  10342. ' this.FOnClick(this);',
  10343. ' };',
  10344. '});',
  10345. 'this.Ctrl = null;',
  10346. '']),
  10347. LinesToStr([ // $mod.$main
  10348. '$mod.Ctrl.FOnClick = rtl.createCallback($mod.Ctrl, "Click");',
  10349. '$mod.Ctrl.FOnClick($mod.Ctrl);',
  10350. '']));
  10351. end;
  10352. procedure TTestModule.TestExternalClass_TypeCastToRootClass;
  10353. begin
  10354. StartProgram(false);
  10355. Add('{$modeswitch externalclass}');
  10356. Add('type');
  10357. Add(' TObject = class');
  10358. Add(' end;');
  10359. Add(' TChild = class');
  10360. Add(' end;');
  10361. Add(' TExtRootA = class external name ''ExtRootA''');
  10362. Add(' end;');
  10363. Add(' TExtChildA = class external name ''ExtChildA''(TExtRootA)');
  10364. Add(' end;');
  10365. Add(' TExtRootB = class external name ''ExtRootB''');
  10366. Add(' end;');
  10367. Add(' TExtChildB = class external name ''ExtChildB''(TExtRootB)');
  10368. Add(' end;');
  10369. Add('var');
  10370. Add(' Obj: TObject;');
  10371. Add(' Child: TChild;');
  10372. Add(' RootA: TExtRootA;');
  10373. Add(' ChildA: TExtChildA;');
  10374. Add(' RootB: TExtRootB;');
  10375. Add(' ChildB: TExtChildB;');
  10376. Add('begin');
  10377. Add(' obj:=tobject(roota);');
  10378. Add(' obj:=tobject(childa);');
  10379. Add(' child:=tchild(tobject(roota));');
  10380. Add(' roota:=textroota(obj);');
  10381. Add(' roota:=textroota(child);');
  10382. Add(' roota:=textroota(rootb);');
  10383. Add(' roota:=textroota(childb);');
  10384. Add(' childa:=textchilda(textroota(obj));');
  10385. ConvertProgram;
  10386. CheckSource('TestExternalClass_TypeCastToRootClass',
  10387. LinesToStr([ // statements
  10388. 'rtl.createClass($mod, "TObject", null, function () {',
  10389. ' this.$init = function () {',
  10390. ' };',
  10391. ' this.$final = function () {',
  10392. ' };',
  10393. '});',
  10394. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  10395. '});',
  10396. 'this.Obj = null;',
  10397. 'this.Child = null;',
  10398. 'this.RootA = null;',
  10399. 'this.ChildA = null;',
  10400. 'this.RootB = null;',
  10401. 'this.ChildB = null;',
  10402. '']),
  10403. LinesToStr([ // $mod.$main
  10404. '$mod.Obj = $mod.RootA;',
  10405. '$mod.Obj = $mod.ChildA;',
  10406. '$mod.Child = $mod.RootA;',
  10407. '$mod.RootA = $mod.Obj;',
  10408. '$mod.RootA = $mod.Child;',
  10409. '$mod.RootA = $mod.RootB;',
  10410. '$mod.RootA = $mod.ChildB;',
  10411. '$mod.ChildA = $mod.Obj;',
  10412. '']));
  10413. end;
  10414. procedure TTestModule.TestExternalClass_TypeCastStringToExternalString;
  10415. begin
  10416. StartProgram(false);
  10417. Add('{$modeswitch externalclass}');
  10418. Add('type');
  10419. Add(' TJSString = class external name ''String''');
  10420. Add(' class function fromCharCode() : string; varargs;');
  10421. Add(' function anchor(const aName : string) : string;');
  10422. Add(' end;');
  10423. Add('var');
  10424. Add(' s: string;');
  10425. Add('begin');
  10426. Add(' s:=TJSString.fromCharCode(65,66);');
  10427. Add(' s:=TJSString(s).anchor(s);');
  10428. Add(' s:=TJSString(''foo'').anchor(s);');
  10429. ConvertProgram;
  10430. CheckSource('TestExternalClass_TypeCastStringToExternalString',
  10431. LinesToStr([ // statements
  10432. 'this.s = "";',
  10433. '']),
  10434. LinesToStr([ // $mod.$main
  10435. '$mod.s = String.fromCharCode(65, 66);',
  10436. '$mod.s = $mod.s.anchor($mod.s);',
  10437. '$mod.s = "foo".anchor($mod.s);',
  10438. '']));
  10439. end;
  10440. procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
  10441. begin
  10442. StartProgram(false);
  10443. Add('{$modeswitch externalclass}');
  10444. Add('type');
  10445. Add(' TJSString = class external name ''String''');
  10446. Add(' class function fromCharCode() : string; varargs;');
  10447. Add(' end;');
  10448. Add('var');
  10449. Add(' s: string;');
  10450. Add(' sObj: TJSString;');
  10451. Add('begin');
  10452. Add(' s:=sObj.fromCharCode(65,66);');
  10453. SetExpectedPasResolverError('External class instance cannot access static class function fromCharCode',
  10454. nExternalClassInstanceCannotAccessStaticX);
  10455. ConvertProgram;
  10456. end;
  10457. procedure TTestModule.TestExternalClass_BracketAccessor;
  10458. begin
  10459. StartProgram(false);
  10460. Add('{$modeswitch externalclass}');
  10461. Add('type');
  10462. Add(' TJSArray = class external name ''Array2''');
  10463. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  10464. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  10465. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  10466. Add(' end;');
  10467. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);');
  10468. Add('begin end;');
  10469. Add('var');
  10470. Add(' Arr: tjsarray;');
  10471. Add(' s: string;');
  10472. Add(' i: longint;');
  10473. Add(' v: jsvalue;');
  10474. Add('begin');
  10475. Add(' v:=arr[0];');
  10476. Add(' v:=arr.items[1];');
  10477. Add(' arr[2]:=s;');
  10478. Add(' arr.items[3]:=s;');
  10479. Add(' arr[4]:=i;');
  10480. Add(' arr[5]:=arr[6];');
  10481. Add(' arr.items[7]:=arr.items[8];');
  10482. Add(' with arr do items[9]:=items[10];');
  10483. Add(' doit(arr[7],arr[8],arr[9],arr[10]);');
  10484. ConvertProgram;
  10485. CheckSource('TestExternalClass_BracketAccessor',
  10486. LinesToStr([ // statements
  10487. 'this.DoIt = function (vI, vJ, vK, vL) {',
  10488. '};',
  10489. 'this.Arr = null;',
  10490. 'this.s = "";',
  10491. 'this.i = 0;',
  10492. 'this.v = undefined;',
  10493. '']),
  10494. LinesToStr([ // $mod.$main
  10495. '$mod.v = $mod.Arr[0];',
  10496. '$mod.v = $mod.Arr[1];',
  10497. '$mod.Arr[2] = $mod.s;',
  10498. '$mod.Arr[3] = $mod.s;',
  10499. '$mod.Arr[4] = $mod.i;',
  10500. '$mod.Arr[5] = $mod.Arr[6];',
  10501. '$mod.Arr[7] = $mod.Arr[8];',
  10502. 'var $with1 = $mod.Arr;',
  10503. '$with1[9] = $with1[10];',
  10504. '$mod.DoIt($mod.Arr[7], $mod.Arr[8], {',
  10505. ' a: 9,',
  10506. ' p: $mod.Arr,',
  10507. ' get: function () {',
  10508. ' return this.p[this.a];',
  10509. ' },',
  10510. ' set: function (v) {',
  10511. ' this.p[this.a] = v;',
  10512. ' }',
  10513. '}, {',
  10514. ' a: 10,',
  10515. ' p: $mod.Arr,',
  10516. ' get: function () {',
  10517. ' return this.p[this.a];',
  10518. ' },',
  10519. ' set: function (v) {',
  10520. ' this.p[this.a] = v;',
  10521. ' }',
  10522. '});',
  10523. '']));
  10524. end;
  10525. procedure TTestModule.TestExternalClass_BracketAccessor_2ParamsFail;
  10526. begin
  10527. StartProgram(false);
  10528. Add('{$modeswitch externalclass}');
  10529. Add('type');
  10530. Add(' TJSArray = class external name ''Array2''');
  10531. Add(' function GetItems(Index1, Index2: longint): jsvalue; external name ''[]'';');
  10532. Add(' procedure SetItems(Index1, Index2: longint; Value: jsvalue); external name ''[]'';');
  10533. Add(' property Items[Index1, Index2: longint]: jsvalue read GetItems write SetItems; default;');
  10534. Add(' end;');
  10535. Add('begin');
  10536. SetExpectedPasResolverError(sBracketAccessorOfExternalClassMustHaveOneParameter,
  10537. nBracketAccessorOfExternalClassMustHaveOneParameter);
  10538. ConvertProgram;
  10539. end;
  10540. procedure TTestModule.TestExternalClass_BracketAccessor_ReadOnly;
  10541. begin
  10542. StartProgram(false);
  10543. Add('{$modeswitch externalclass}');
  10544. Add('type');
  10545. Add(' TJSArray = class external name ''Array2''');
  10546. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  10547. Add(' property Items[Index: longint]: jsvalue read GetItems; default;');
  10548. Add(' end;');
  10549. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue);');
  10550. Add('begin end;');
  10551. Add('var');
  10552. Add(' Arr: tjsarray;');
  10553. Add(' v: jsvalue;');
  10554. Add('begin');
  10555. Add(' v:=arr[0];');
  10556. Add(' v:=arr.items[1];');
  10557. Add(' with arr do v:=items[2];');
  10558. Add(' doit(arr[3],arr[4]);');
  10559. ConvertProgram;
  10560. CheckSource('TestExternalClass_BracketAccessor_ReadOnly',
  10561. LinesToStr([ // statements
  10562. 'this.DoIt = function (vI, vJ) {',
  10563. '};',
  10564. 'this.Arr = null;',
  10565. 'this.v = undefined;',
  10566. '']),
  10567. LinesToStr([ // $mod.$main
  10568. '$mod.v = $mod.Arr[0];',
  10569. '$mod.v = $mod.Arr[1];',
  10570. 'var $with1 = $mod.Arr;',
  10571. '$mod.v = $with1[2];',
  10572. '$mod.DoIt($mod.Arr[3], $mod.Arr[4]);',
  10573. '']));
  10574. end;
  10575. procedure TTestModule.TestExternalClass_BracketAccessor_WriteOnly;
  10576. begin
  10577. StartProgram(false);
  10578. Add('{$modeswitch externalclass}');
  10579. Add('type');
  10580. Add(' TJSArray = class external name ''Array2''');
  10581. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  10582. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  10583. Add(' end;');
  10584. Add('var');
  10585. Add(' Arr: tjsarray;');
  10586. Add(' s: string;');
  10587. Add(' i: longint;');
  10588. Add(' v: jsvalue;');
  10589. Add('begin');
  10590. Add(' arr[2]:=s;');
  10591. Add(' arr.items[3]:=s;');
  10592. Add(' arr[4]:=i;');
  10593. Add(' with arr do items[5]:=i;');
  10594. ConvertProgram;
  10595. CheckSource('TestExternalClass_BracketAccessor_WriteOnly',
  10596. LinesToStr([ // statements
  10597. 'this.Arr = null;',
  10598. 'this.s = "";',
  10599. 'this.i = 0;',
  10600. 'this.v = undefined;',
  10601. '']),
  10602. LinesToStr([ // $mod.$main
  10603. '$mod.Arr[2] = $mod.s;',
  10604. '$mod.Arr[3] = $mod.s;',
  10605. '$mod.Arr[4] = $mod.i;',
  10606. 'var $with1 = $mod.Arr;',
  10607. '$with1[5] = $mod.i;',
  10608. '']));
  10609. end;
  10610. procedure TTestModule.TestExternalClass_BracketAccessor_MultiType;
  10611. begin
  10612. StartProgram(false);
  10613. Add('{$modeswitch externalclass}');
  10614. Add('type');
  10615. Add(' TJSArray = class external name ''Array2''');
  10616. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  10617. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  10618. Add(' procedure SetNumbers(Index: longint; Value: longint); external name ''[]'';');
  10619. Add(' property Numbers[Index: longint]: longint write SetNumbers;');
  10620. Add(' end;');
  10621. Add('var');
  10622. Add(' Arr: tjsarray;');
  10623. Add(' s: string;');
  10624. Add(' i: longint;');
  10625. Add(' v: jsvalue;');
  10626. Add('begin');
  10627. Add(' arr[2]:=s;');
  10628. Add(' arr.items[3]:=s;');
  10629. Add(' arr.numbers[4]:=i;');
  10630. Add(' with arr do items[5]:=i;');
  10631. Add(' with arr do numbers[6]:=i;');
  10632. ConvertProgram;
  10633. CheckSource('TestExternalClass_BracketAccessor_MultiType',
  10634. LinesToStr([ // statements
  10635. 'this.Arr = null;',
  10636. 'this.s = "";',
  10637. 'this.i = 0;',
  10638. 'this.v = undefined;',
  10639. '']),
  10640. LinesToStr([ // $mod.$main
  10641. '$mod.Arr[2] = $mod.s;',
  10642. '$mod.Arr[3] = $mod.s;',
  10643. '$mod.Arr[4] = $mod.i;',
  10644. 'var $with1 = $mod.Arr;',
  10645. '$with1[5] = $mod.i;',
  10646. 'var $with2 = $mod.Arr;',
  10647. '$with2[6] = $mod.i;',
  10648. '']));
  10649. end;
  10650. procedure TTestModule.TestExternalClass_BracketAccessor_Index;
  10651. begin
  10652. StartProgram(false);
  10653. Add('{$modeswitch externalclass}');
  10654. Add('type');
  10655. Add(' TJSArray = class external name ''Array2''');
  10656. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  10657. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  10658. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  10659. Add(' end;');
  10660. Add('var');
  10661. Add(' Arr: tjsarray;');
  10662. Add(' i: longint;');
  10663. Add(' IntArr: array of longint;');
  10664. Add(' v: jsvalue;');
  10665. Add('begin');
  10666. Add(' v:=arr.items[i];');
  10667. Add(' arr[longint(v)]:=arr.items[intarr[0]];');
  10668. Add(' arr.items[intarr[1]]:=arr[IntArr[2]];');
  10669. ConvertProgram;
  10670. CheckSource('TestExternalClass_BracketAccessor_Index',
  10671. LinesToStr([ // statements
  10672. 'this.Arr = null;',
  10673. 'this.i = 0;',
  10674. 'this.IntArr = [];',
  10675. 'this.v = undefined;',
  10676. '']),
  10677. LinesToStr([ // $mod.$main
  10678. '$mod.v = $mod.Arr[$mod.i];',
  10679. '$mod.Arr[Math.floor($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
  10680. '$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
  10681. '']));
  10682. end;
  10683. procedure TTestModule.TestClassInterface_Ignore;
  10684. begin
  10685. StartProgram(false);
  10686. Add([
  10687. '{$modeswitch ignoreinterfaces}',
  10688. 'type',
  10689. ' TGUID = record end;',
  10690. ' IUnknown = interface;',
  10691. ' IUnknown = interface',
  10692. ' [''{00000000-0000-0000-C000-000000000046}'']',
  10693. ' function QueryInterface(const iid : tguid;out obj) : longint;',
  10694. ' function _AddRef : longint; cdecl;',
  10695. ' function _Release : longint; stdcall;',
  10696. ' end;',
  10697. ' IInterface = IUnknown;',
  10698. ' TObject = class',
  10699. ' ClassName: string;',
  10700. ' end;',
  10701. ' TInterfacedObject = class(TObject,IUnknown)',
  10702. ' RefCount : longint;',
  10703. ' end;',
  10704. 'var i: TInterfacedObject;',
  10705. 'begin',
  10706. ' i.ClassName:=''a'';',
  10707. ' i.RefCount:=3;',
  10708. '']);
  10709. ConvertProgram;
  10710. CheckSource('TestClassInterface_Ignore',
  10711. LinesToStr([ // statements
  10712. 'this.TGUID = function (s) {',
  10713. '};',
  10714. 'rtl.createClass($mod, "TObject", null, function () {',
  10715. ' this.$init = function () {',
  10716. ' this.ClassName = "";',
  10717. ' };',
  10718. ' this.$final = function () {',
  10719. ' };',
  10720. '});',
  10721. 'rtl.createClass($mod, "TInterfacedObject", $mod.TObject, function () {',
  10722. ' this.$init = function () {',
  10723. ' $mod.TObject.$init.call(this);',
  10724. ' this.RefCount = 0;',
  10725. ' };',
  10726. '});',
  10727. 'this.i = null;',
  10728. '']),
  10729. LinesToStr([ // $mod.$main
  10730. '$mod.i.ClassName = "a";',
  10731. '$mod.i.RefCount = 3;',
  10732. '']));
  10733. end;
  10734. procedure TTestModule.TestProcType;
  10735. begin
  10736. StartProgram(false);
  10737. Add('type');
  10738. Add(' TProcInt = procedure(vI: longint = 1);');
  10739. Add('procedure DoIt(vJ: longint);');
  10740. Add('begin end;');
  10741. Add('var');
  10742. Add(' b: boolean;');
  10743. Add(' vP, vQ: tprocint;');
  10744. Add('begin');
  10745. Add(' vp:=nil;');
  10746. Add(' vp:=vp;');
  10747. Add(' vp:=@doit;');
  10748. Add(' vp;');
  10749. Add(' vp();');
  10750. Add(' vp(2);');
  10751. Add(' b:=vp=nil;');
  10752. Add(' b:=nil=vp;');
  10753. Add(' b:=vp=vq;');
  10754. Add(' b:=vp=@doit;');
  10755. Add(' b:=@doit=vp;');
  10756. Add(' b:=vp<>nil;');
  10757. Add(' b:=nil<>vp;');
  10758. Add(' b:=vp<>vq;');
  10759. Add(' b:=vp<>@doit;');
  10760. Add(' b:=@doit<>vp;');
  10761. Add(' b:=Assigned(vp);');
  10762. Add(' if Assigned(vp) then ;');
  10763. ConvertProgram;
  10764. CheckSource('TestProcType',
  10765. LinesToStr([ // statements
  10766. 'this.DoIt = function(vJ) {',
  10767. '};',
  10768. 'this.b = false;',
  10769. 'this.vP = null;',
  10770. 'this.vQ = null;'
  10771. ]),
  10772. LinesToStr([ // $mod.$main
  10773. '$mod.vP = null;',
  10774. '$mod.vP = $mod.vP;',
  10775. '$mod.vP = $mod.DoIt;',
  10776. '$mod.vP(1);',
  10777. '$mod.vP(1);',
  10778. '$mod.vP(2);',
  10779. '$mod.b = $mod.vP === null;',
  10780. '$mod.b = null === $mod.vP;',
  10781. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  10782. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  10783. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  10784. '$mod.b = $mod.vP !== null;',
  10785. '$mod.b = null !== $mod.vP;',
  10786. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  10787. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  10788. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  10789. '$mod.b = $mod.vP !== null;',
  10790. 'if ($mod.vP !== null) ;',
  10791. '']));
  10792. end;
  10793. procedure TTestModule.TestProcType_FunctionFPC;
  10794. begin
  10795. StartProgram(false);
  10796. Add('type');
  10797. Add(' TFuncInt = function(vA: longint = 1): longint;');
  10798. Add('function DoIt(vI: longint): longint;');
  10799. Add('begin end;');
  10800. Add('var');
  10801. Add(' b: boolean;');
  10802. Add(' vP, vQ: tfuncint;');
  10803. Add('begin');
  10804. Add(' vp:=nil;');
  10805. Add(' vp:=vp;');
  10806. Add(' vp:=@doit;'); // ok in fpc and delphi
  10807. //Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  10808. Add(' vp;'); // ok in fpc and delphi
  10809. Add(' vp();');
  10810. Add(' vp(2);');
  10811. Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  10812. Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  10813. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  10814. Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  10815. Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  10816. //Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  10817. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  10818. Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  10819. Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  10820. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  10821. Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  10822. Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  10823. //Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  10824. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  10825. Add(' b:=Assigned(vp);');
  10826. //Add(' doit(vp);'); // illegal in fpc, ok in delphi
  10827. Add(' doit(vp());'); // ok in fpc and delphi
  10828. Add(' doit(vp(2));'); // ok in fpc and delphi
  10829. ConvertProgram;
  10830. CheckSource('TestProcType_FunctionFPC',
  10831. LinesToStr([ // statements
  10832. 'this.DoIt = function(vI) {',
  10833. ' var Result = 0;',
  10834. ' return Result;',
  10835. '};',
  10836. 'this.b = false;',
  10837. 'this.vP = null;',
  10838. 'this.vQ = null;'
  10839. ]),
  10840. LinesToStr([ // $mod.$main
  10841. '$mod.vP = null;',
  10842. '$mod.vP = $mod.vP;',
  10843. '$mod.vP = $mod.DoIt;',
  10844. '$mod.vP(1);',
  10845. '$mod.vP(1);',
  10846. '$mod.vP(2);',
  10847. '$mod.b = $mod.vP === null;',
  10848. '$mod.b = null === $mod.vP;',
  10849. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  10850. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  10851. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  10852. '$mod.b = 4 === $mod.vP(1);',
  10853. '$mod.b = $mod.vP !== null;',
  10854. '$mod.b = null !== $mod.vP;',
  10855. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  10856. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  10857. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  10858. '$mod.b = 6 !== $mod.vP(1);',
  10859. '$mod.b = $mod.vP !== null;',
  10860. '$mod.DoIt($mod.vP(1));',
  10861. '$mod.DoIt($mod.vP(2));',
  10862. '']));
  10863. end;
  10864. procedure TTestModule.TestProcType_FunctionDelphi;
  10865. begin
  10866. StartProgram(false);
  10867. Add('{$mode Delphi}');
  10868. Add('type');
  10869. Add(' TFuncInt = function(vA: longint = 1): longint;');
  10870. Add('function DoIt(vI: longint): longint;');
  10871. Add('begin end;');
  10872. Add('var');
  10873. Add(' b: boolean;');
  10874. Add(' vP, vQ: tfuncint;');
  10875. Add('begin');
  10876. Add(' vp:=nil;');
  10877. Add(' vp:=vp;');
  10878. Add(' vp:=@doit;'); // ok in fpc and delphi
  10879. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  10880. Add(' vp;'); // ok in fpc and delphi
  10881. Add(' vp();');
  10882. Add(' vp(2);');
  10883. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  10884. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  10885. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  10886. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  10887. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  10888. Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  10889. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  10890. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  10891. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  10892. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  10893. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  10894. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  10895. Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  10896. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  10897. Add(' b:=Assigned(vp);');
  10898. Add(' doit(vp);'); // illegal in fpc, ok in delphi
  10899. Add(' doit(vp());'); // ok in fpc and delphi
  10900. Add(' doit(vp(2));'); // ok in fpc and delphi *)
  10901. ConvertProgram;
  10902. CheckSource('TestProcType_FunctionDelphi',
  10903. LinesToStr([ // statements
  10904. 'this.DoIt = function(vI) {',
  10905. ' var Result = 0;',
  10906. ' return Result;',
  10907. '};',
  10908. 'this.b = false;',
  10909. 'this.vP = null;',
  10910. 'this.vQ = null;'
  10911. ]),
  10912. LinesToStr([ // $mod.$main
  10913. '$mod.vP = null;',
  10914. '$mod.vP = $mod.vP;',
  10915. '$mod.vP = $mod.DoIt;',
  10916. '$mod.vP = $mod.DoIt;',
  10917. '$mod.vP(1);',
  10918. '$mod.vP(1);',
  10919. '$mod.vP(2);',
  10920. '$mod.b = $mod.vP(1) === $mod.vQ(1);',
  10921. '$mod.b = $mod.vP(1) === 3;',
  10922. '$mod.b = 4 === $mod.vP(1);',
  10923. '$mod.b = $mod.vP(1) !== $mod.vQ(1);',
  10924. '$mod.b = $mod.vP(1) !== 5;',
  10925. '$mod.b = 6 !== $mod.vP(1);',
  10926. '$mod.b = $mod.vP !== null;',
  10927. '$mod.DoIt($mod.vP(1));',
  10928. '$mod.DoIt($mod.vP(1));',
  10929. '$mod.DoIt($mod.vP(2));',
  10930. '']));
  10931. end;
  10932. procedure TTestModule.TestProcType_ProcedureDelphi;
  10933. begin
  10934. StartProgram(false);
  10935. Add('{$mode Delphi}');
  10936. Add('type');
  10937. Add(' TProc = procedure;');
  10938. Add('procedure DoIt;');
  10939. Add('begin end;');
  10940. Add('var');
  10941. Add(' b: boolean;');
  10942. Add(' vP, vQ: tproc;');
  10943. Add('begin');
  10944. Add(' vp:=nil;');
  10945. Add(' vp:=vp;');
  10946. Add(' vp:=vq;');
  10947. 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
  10948. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  10949. //Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
  10950. Add(' vp;'); // ok in fpc and delphi
  10951. Add(' vp();');
  10952. // equal
  10953. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  10954. Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
  10955. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  10956. Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
  10957. Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
  10958. //Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  10959. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  10960. Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
  10961. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  10962. Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
  10963. // unequal
  10964. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  10965. Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
  10966. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  10967. Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
  10968. //Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  10969. Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
  10970. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  10971. Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
  10972. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  10973. Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
  10974. Add(' b:=Assigned(vp);');
  10975. ConvertProgram;
  10976. CheckSource('TestProcType_ProcedureDelphi',
  10977. LinesToStr([ // statements
  10978. 'this.DoIt = function() {',
  10979. '};',
  10980. 'this.b = false;',
  10981. 'this.vP = null;',
  10982. 'this.vQ = null;'
  10983. ]),
  10984. LinesToStr([ // $mod.$main
  10985. '$mod.vP = null;',
  10986. '$mod.vP = $mod.vP;',
  10987. '$mod.vP = $mod.vQ;',
  10988. '$mod.vP = $mod.DoIt;',
  10989. '$mod.vP = $mod.DoIt;',
  10990. '$mod.vP();',
  10991. '$mod.vP();',
  10992. '$mod.b = $mod.vP === null;',
  10993. '$mod.b = null === $mod.vP;',
  10994. '$mod.b = rtl.eqCallback($mod.vP, $mod.vQ);',
  10995. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  10996. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  10997. '$mod.b = $mod.vP !== null;',
  10998. '$mod.b = null !== $mod.vP;',
  10999. '$mod.b = !rtl.eqCallback($mod.vP, $mod.vQ);',
  11000. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  11001. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  11002. '$mod.b = $mod.vP !== null;',
  11003. '']));
  11004. end;
  11005. procedure TTestModule.TestProcType_AsParam;
  11006. begin
  11007. StartProgram(false);
  11008. Add('type');
  11009. Add(' TFuncInt = function(vA: longint = 1): longint;');
  11010. Add('procedure DoIt(vG: tfuncint; const vH: tfuncint; var vI: tfuncint);');
  11011. Add('var vJ: tfuncint;');
  11012. Add('begin');
  11013. Add(' vg:=vg;');
  11014. Add(' vj:=vh;');
  11015. Add(' vi:=vi;');
  11016. Add(' doit(vg,vg,vg);');
  11017. Add(' doit(vh,vh,vj);');
  11018. Add(' doit(vi,vi,vi);');
  11019. Add(' doit(vj,vj,vj);');
  11020. Add('end;');
  11021. Add('var i: tfuncint;');
  11022. Add('begin');
  11023. Add(' doit(i,i,i);');
  11024. ConvertProgram;
  11025. CheckSource('TestProcType_AsParam',
  11026. LinesToStr([ // statements
  11027. 'this.DoIt = function (vG,vH,vI) {',
  11028. ' var vJ = null;',
  11029. ' vG = vG;',
  11030. ' vJ = vH;',
  11031. ' vI.set(vI.get());',
  11032. ' $mod.DoIt(vG, vG, {',
  11033. ' get: function () {',
  11034. ' return vG;',
  11035. ' },',
  11036. ' set: function (v) {',
  11037. ' vG = v;',
  11038. ' }',
  11039. ' });',
  11040. ' $mod.DoIt(vH, vH, {',
  11041. ' get: function () {',
  11042. ' return vJ;',
  11043. ' },',
  11044. ' set: function (v) {',
  11045. ' vJ = v;',
  11046. ' }',
  11047. ' });',
  11048. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  11049. ' $mod.DoIt(vJ, vJ, {',
  11050. ' get: function () {',
  11051. ' return vJ;',
  11052. ' },',
  11053. ' set: function (v) {',
  11054. ' vJ = v;',
  11055. ' }',
  11056. ' });',
  11057. '};',
  11058. 'this.i = null;'
  11059. ]),
  11060. LinesToStr([
  11061. '$mod.DoIt($mod.i,$mod.i,{',
  11062. ' p: $mod,',
  11063. ' get: function () {',
  11064. ' return this.p.i;',
  11065. ' },',
  11066. ' set: function (v) {',
  11067. ' this.p.i = v;',
  11068. ' }',
  11069. '});'
  11070. ]));
  11071. end;
  11072. procedure TTestModule.TestProcType_MethodFPC;
  11073. begin
  11074. StartProgram(false);
  11075. Add('type');
  11076. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  11077. Add(' TObject = class');
  11078. Add(' function DoIt(vA: longint = 1): longint;');
  11079. Add(' end;');
  11080. Add('function TObject.DoIt(vA: longint = 1): longint;');
  11081. Add('begin');
  11082. Add('end;');
  11083. Add('var');
  11084. Add(' Obj: TObject;');
  11085. Add(' vP: tfuncint;');
  11086. Add(' b: boolean;');
  11087. Add('begin');
  11088. Add(' vp:[email protected];'); // ok in fpc and delphi
  11089. //Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  11090. Add(' vp;'); // ok in fpc and delphi
  11091. Add(' vp();');
  11092. Add(' vp(2);');
  11093. Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  11094. Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  11095. Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  11096. Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  11097. ConvertProgram;
  11098. CheckSource('TestProcType_MethodFPC',
  11099. LinesToStr([ // statements
  11100. 'rtl.createClass($mod, "TObject", null, function () {',
  11101. ' this.$init = function () {',
  11102. ' };',
  11103. ' this.$final = function () {',
  11104. ' };',
  11105. ' this.DoIt = function (vA) {',
  11106. ' var Result = 0;',
  11107. ' return Result;',
  11108. ' };',
  11109. '});',
  11110. 'this.Obj = null;',
  11111. 'this.vP = null;',
  11112. 'this.b = false;'
  11113. ]),
  11114. LinesToStr([
  11115. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  11116. '$mod.vP(1);',
  11117. '$mod.vP(1);',
  11118. '$mod.vP(2);',
  11119. '$mod.b = rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  11120. '$mod.b = rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  11121. '$mod.b = !rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  11122. '$mod.b = !rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  11123. '']));
  11124. end;
  11125. procedure TTestModule.TestProcType_MethodDelphi;
  11126. begin
  11127. StartProgram(false);
  11128. Add('{$mode delphi}');
  11129. Add('type');
  11130. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  11131. Add(' TObject = class');
  11132. Add(' function DoIt(vA: longint = 1): longint;');
  11133. Add(' end;');
  11134. Add('function TObject.DoIt(vA: longint = 1): longint;');
  11135. Add('begin');
  11136. Add('end;');
  11137. Add('var');
  11138. Add(' Obj: TObject;');
  11139. Add(' vP: tfuncint;');
  11140. Add(' b: boolean;');
  11141. Add('begin');
  11142. Add(' vp:[email protected];'); // ok in fpc and delphi
  11143. Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  11144. Add(' vp;'); // ok in fpc and delphi
  11145. Add(' vp();');
  11146. Add(' vp(2);');
  11147. //Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  11148. //Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  11149. //Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  11150. //Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  11151. ConvertProgram;
  11152. CheckSource('TestProcType_MethodDelphi',
  11153. LinesToStr([ // statements
  11154. 'rtl.createClass($mod, "TObject", null, function () {',
  11155. ' this.$init = function () {',
  11156. ' };',
  11157. ' this.$final = function () {',
  11158. ' };',
  11159. ' this.DoIt = function (vA) {',
  11160. ' var Result = 0;',
  11161. ' return Result;',
  11162. ' };',
  11163. '});',
  11164. 'this.Obj = null;',
  11165. 'this.vP = null;',
  11166. 'this.b = false;'
  11167. ]),
  11168. LinesToStr([
  11169. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  11170. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  11171. '$mod.vP(1);',
  11172. '$mod.vP(1);',
  11173. '$mod.vP(2);',
  11174. '']));
  11175. end;
  11176. procedure TTestModule.TestProcType_PropertyFPC;
  11177. begin
  11178. StartProgram(false);
  11179. Add('type');
  11180. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  11181. Add(' TObject = class');
  11182. Add(' FOnFoo: TFuncInt;');
  11183. Add(' function DoIt(vA: longint = 1): longint;');
  11184. Add(' function GetFoo: TFuncInt;');
  11185. Add(' procedure SetFoo(const Value: TFuncInt);');
  11186. Add(' function GetEvents(Index: longint): TFuncInt;');
  11187. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  11188. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  11189. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  11190. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  11191. Add(' end;');
  11192. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  11193. Add('function tobject.getfoo: tfuncint; begin end;');
  11194. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  11195. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  11196. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  11197. Add('var');
  11198. Add(' Obj: TObject;');
  11199. Add(' vP: tfuncint;');
  11200. Add(' b: boolean;');
  11201. Add('begin');
  11202. Add(' obj.onfoo:=nil;');
  11203. Add(' obj.onbar:=nil;');
  11204. Add(' obj.events[1]:=nil;');
  11205. Add(' obj.onfoo:=obj.onfoo;');
  11206. Add(' obj.onbar:=obj.onbar;');
  11207. Add(' obj.events[2]:=obj.events[3];');
  11208. Add(' obj.onfoo:[email protected];');
  11209. Add(' obj.onbar:[email protected];');
  11210. Add(' obj.events[4]:[email protected];');
  11211. //Add(' obj.onfoo:=obj.doit;'); // delphi
  11212. //Add(' obj.onbar:=obj.doit;'); // delphi
  11213. //Add(' obj.events[4]:=obj.doit;'); // delphi
  11214. Add(' obj.onfoo;');
  11215. Add(' obj.onbar;');
  11216. //Add(' obj.events[5];'); ToDo in pasresolver
  11217. Add(' obj.onfoo();');
  11218. Add(' obj.onbar();');
  11219. Add(' obj.events[6]();');
  11220. Add(' b:=obj.onfoo=nil;');
  11221. Add(' b:=obj.onbar=nil;');
  11222. Add(' b:=obj.events[7]=nil;');
  11223. Add(' b:=obj.onfoo<>nil;');
  11224. Add(' b:=obj.onbar<>nil;');
  11225. Add(' b:=obj.events[8]<>nil;');
  11226. Add(' b:=obj.onfoo=vp;');
  11227. Add(' b:=obj.onbar=vp;');
  11228. Add(' b:=obj.events[9]=vp;');
  11229. Add(' b:=obj.onfoo=obj.onfoo;');
  11230. Add(' b:=obj.onbar=obj.onfoo;');
  11231. Add(' b:=obj.events[10]=obj.onfoo;');
  11232. Add(' b:=obj.onfoo<>obj.onfoo;');
  11233. Add(' b:=obj.onbar<>obj.onfoo;');
  11234. Add(' b:=obj.events[11]<>obj.onfoo;');
  11235. Add(' b:[email protected];');
  11236. Add(' b:[email protected];');
  11237. Add(' b:=obj.events[12][email protected];');
  11238. Add(' b:=obj.onfoo<>@obj.doit;');
  11239. Add(' b:=obj.onbar<>@obj.doit;');
  11240. Add(' b:=obj.events[12]<>@obj.doit;');
  11241. Add(' b:=Assigned(obj.onfoo);');
  11242. Add(' b:=Assigned(obj.onbar);');
  11243. Add(' b:=Assigned(obj.events[13]);');
  11244. ConvertProgram;
  11245. CheckSource('TestProcType_PropertyFPC',
  11246. LinesToStr([ // statements
  11247. 'rtl.createClass($mod, "TObject", null, function () {',
  11248. ' this.$init = function () {',
  11249. ' this.FOnFoo = null;',
  11250. ' };',
  11251. ' this.$final = function () {',
  11252. ' this.FOnFoo = undefined;',
  11253. ' };',
  11254. ' this.DoIt = function (vA) {',
  11255. ' var Result = 0;',
  11256. ' return Result;',
  11257. ' };',
  11258. 'this.GetFoo = function () {',
  11259. ' var Result = null;',
  11260. ' return Result;',
  11261. '};',
  11262. 'this.SetFoo = function (Value) {',
  11263. '};',
  11264. 'this.GetEvents = function (Index) {',
  11265. ' var Result = null;',
  11266. ' return Result;',
  11267. '};',
  11268. 'this.SetEvents = function (Index, Value) {',
  11269. '};',
  11270. '});',
  11271. 'this.Obj = null;',
  11272. 'this.vP = null;',
  11273. 'this.b = false;'
  11274. ]),
  11275. LinesToStr([
  11276. '$mod.Obj.FOnFoo = null;',
  11277. '$mod.Obj.SetFoo(null);',
  11278. '$mod.Obj.SetEvents(1, null);',
  11279. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  11280. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  11281. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  11282. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  11283. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  11284. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  11285. '$mod.Obj.FOnFoo(1);',
  11286. '$mod.Obj.GetFoo();',
  11287. '$mod.Obj.FOnFoo(1);',
  11288. '$mod.Obj.GetFoo()(1);',
  11289. '$mod.Obj.GetEvents(6)(1);',
  11290. '$mod.b = $mod.Obj.FOnFoo === null;',
  11291. '$mod.b = $mod.Obj.GetFoo() === null;',
  11292. '$mod.b = $mod.Obj.GetEvents(7) === null;',
  11293. '$mod.b = $mod.Obj.FOnFoo !== null;',
  11294. '$mod.b = $mod.Obj.GetFoo() !== null;',
  11295. '$mod.b = $mod.Obj.GetEvents(8) !== null;',
  11296. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.vP);',
  11297. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.vP);',
  11298. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(9), $mod.vP);',
  11299. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  11300. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  11301. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(10), $mod.Obj.FOnFoo);',
  11302. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  11303. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  11304. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(11), $mod.Obj.FOnFoo);',
  11305. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  11306. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  11307. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  11308. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  11309. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  11310. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  11311. '$mod.b = $mod.Obj.FOnFoo !== null;',
  11312. '$mod.b = $mod.Obj.GetFoo() !== null;',
  11313. '$mod.b = $mod.Obj.GetEvents(13) !== null;',
  11314. '']));
  11315. end;
  11316. procedure TTestModule.TestProcType_PropertyDelphi;
  11317. begin
  11318. StartProgram(false);
  11319. Add('{$mode delphi}');
  11320. Add('type');
  11321. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  11322. Add(' TObject = class');
  11323. Add(' FOnFoo: TFuncInt;');
  11324. Add(' function DoIt(vA: longint = 1): longint;');
  11325. Add(' function GetFoo: TFuncInt;');
  11326. Add(' procedure SetFoo(const Value: TFuncInt);');
  11327. Add(' function GetEvents(Index: longint): TFuncInt;');
  11328. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  11329. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  11330. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  11331. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  11332. Add(' end;');
  11333. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  11334. Add('function tobject.getfoo: tfuncint; begin end;');
  11335. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  11336. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  11337. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  11338. Add('var');
  11339. Add(' Obj: TObject;');
  11340. Add(' vP: tfuncint;');
  11341. Add(' b: boolean;');
  11342. Add('begin');
  11343. Add(' obj.onfoo:=nil;');
  11344. Add(' obj.onbar:=nil;');
  11345. Add(' obj.events[1]:=nil;');
  11346. Add(' obj.onfoo:=obj.onfoo;');
  11347. Add(' obj.onbar:=obj.onbar;');
  11348. Add(' obj.events[2]:=obj.events[3];');
  11349. Add(' obj.onfoo:[email protected];');
  11350. Add(' obj.onbar:[email protected];');
  11351. Add(' obj.events[4]:[email protected];');
  11352. Add(' obj.onfoo:=obj.doit;'); // delphi
  11353. Add(' obj.onbar:=obj.doit;'); // delphi
  11354. Add(' obj.events[4]:=obj.doit;'); // delphi
  11355. Add(' obj.onfoo;');
  11356. Add(' obj.onbar;');
  11357. //Add(' obj.events[5];'); ToDo in pasresolver
  11358. Add(' obj.onfoo();');
  11359. Add(' obj.onbar();');
  11360. Add(' obj.events[6]();');
  11361. //Add(' b:=obj.onfoo=nil;'); // fpc
  11362. //Add(' b:=obj.onbar=nil;'); // fpc
  11363. //Add(' b:=obj.events[7]=nil;'); // fpc
  11364. //Add(' b:=obj.onfoo<>nil;'); // fpc
  11365. //Add(' b:=obj.onbar<>nil;'); // fpc
  11366. //Add(' b:=obj.events[8]<>nil;'); // fpc
  11367. Add(' b:=obj.onfoo=vp;');
  11368. Add(' b:=obj.onbar=vp;');
  11369. //Add(' b:=obj.events[9]=vp;'); ToDo in pasresolver
  11370. Add(' b:=obj.onfoo=obj.onfoo;');
  11371. Add(' b:=obj.onbar=obj.onfoo;');
  11372. //Add(' b:=obj.events[10]=obj.onfoo;'); // ToDo in pasresolver
  11373. Add(' b:=obj.onfoo<>obj.onfoo;');
  11374. Add(' b:=obj.onbar<>obj.onfoo;');
  11375. //Add(' b:=obj.events[11]<>obj.onfoo;'); // ToDo in pasresolver
  11376. //Add(' b:[email protected];'); // fpc
  11377. //Add(' b:[email protected];'); // fpc
  11378. //Add(' b:=obj.events[12][email protected];'); // fpc
  11379. //Add(' b:=obj.onfoo<>@obj.doit;'); // fpc
  11380. //Add(' b:=obj.onbar<>@obj.doit;'); // fpc
  11381. //Add(' b:=obj.events[12]<>@obj.doit;'); // fpc
  11382. Add(' b:=Assigned(obj.onfoo);');
  11383. Add(' b:=Assigned(obj.onbar);');
  11384. Add(' b:=Assigned(obj.events[13]);');
  11385. ConvertProgram;
  11386. CheckSource('TestProcType_PropertyDelphi',
  11387. LinesToStr([ // statements
  11388. 'rtl.createClass($mod, "TObject", null, function () {',
  11389. ' this.$init = function () {',
  11390. ' this.FOnFoo = null;',
  11391. ' };',
  11392. ' this.$final = function () {',
  11393. ' this.FOnFoo = undefined;',
  11394. ' };',
  11395. ' this.DoIt = function (vA) {',
  11396. ' var Result = 0;',
  11397. ' return Result;',
  11398. ' };',
  11399. 'this.GetFoo = function () {',
  11400. ' var Result = null;',
  11401. ' return Result;',
  11402. '};',
  11403. 'this.SetFoo = function (Value) {',
  11404. '};',
  11405. 'this.GetEvents = function (Index) {',
  11406. ' var Result = null;',
  11407. ' return Result;',
  11408. '};',
  11409. 'this.SetEvents = function (Index, Value) {',
  11410. '};',
  11411. '});',
  11412. 'this.Obj = null;',
  11413. 'this.vP = null;',
  11414. 'this.b = false;'
  11415. ]),
  11416. LinesToStr([
  11417. '$mod.Obj.FOnFoo = null;',
  11418. '$mod.Obj.SetFoo(null);',
  11419. '$mod.Obj.SetEvents(1, null);',
  11420. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  11421. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  11422. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  11423. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  11424. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  11425. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  11426. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  11427. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  11428. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  11429. '$mod.Obj.FOnFoo(1);',
  11430. '$mod.Obj.GetFoo();',
  11431. '$mod.Obj.FOnFoo(1);',
  11432. '$mod.Obj.GetFoo()(1);',
  11433. '$mod.Obj.GetEvents(6)(1);',
  11434. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.vP(1);',
  11435. '$mod.b = $mod.Obj.GetFoo() === $mod.vP(1);',
  11436. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.Obj.FOnFoo(1);',
  11437. '$mod.b = $mod.Obj.GetFoo() === $mod.Obj.FOnFoo(1);',
  11438. '$mod.b = $mod.Obj.FOnFoo(1) !== $mod.Obj.FOnFoo(1);',
  11439. '$mod.b = $mod.Obj.GetFoo() !== $mod.Obj.FOnFoo(1);',
  11440. '$mod.b = $mod.Obj.FOnFoo !== null;',
  11441. '$mod.b = $mod.Obj.GetFoo() !== null;',
  11442. '$mod.b = $mod.Obj.GetEvents(13) !== null;',
  11443. '']));
  11444. end;
  11445. procedure TTestModule.TestProcType_WithClassInstDoPropertyFPC;
  11446. begin
  11447. StartProgram(false);
  11448. Add('type');
  11449. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  11450. Add(' TObject = class');
  11451. Add(' FOnFoo: TFuncInt;');
  11452. Add(' function DoIt(vA: longint = 1): longint;');
  11453. Add(' function GetFoo: TFuncInt;');
  11454. Add(' procedure SetFoo(const Value: TFuncInt);');
  11455. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  11456. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  11457. Add(' end;');
  11458. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  11459. Add('function tobject.getfoo: tfuncint; begin end;');
  11460. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  11461. Add('var');
  11462. Add(' Obj: TObject;');
  11463. Add(' vP: tfuncint;');
  11464. Add(' b: boolean;');
  11465. Add('begin');
  11466. Add('with obj do begin');
  11467. Add(' fonfoo:=nil;');
  11468. Add(' onfoo:=nil;');
  11469. Add(' onbar:=nil;');
  11470. Add(' fonfoo:=fonfoo;');
  11471. Add(' onfoo:=onfoo;');
  11472. Add(' onbar:=onbar;');
  11473. Add(' fonfoo:=@doit;');
  11474. Add(' onfoo:=@doit;');
  11475. Add(' onbar:=@doit;');
  11476. //Add(' fonfoo:=doit;'); // delphi
  11477. //Add(' onfoo:=doit;'); // delphi
  11478. //Add(' onbar:=doit;'); // delphi
  11479. Add(' fonfoo;');
  11480. Add(' onfoo;');
  11481. Add(' onbar;');
  11482. Add(' fonfoo();');
  11483. Add(' onfoo();');
  11484. Add(' onbar();');
  11485. Add(' b:=fonfoo=nil;');
  11486. Add(' b:=onfoo=nil;');
  11487. Add(' b:=onbar=nil;');
  11488. Add(' b:=fonfoo<>nil;');
  11489. Add(' b:=onfoo<>nil;');
  11490. Add(' b:=onbar<>nil;');
  11491. Add(' b:=fonfoo=vp;');
  11492. Add(' b:=onfoo=vp;');
  11493. Add(' b:=onbar=vp;');
  11494. Add(' b:=fonfoo=fonfoo;');
  11495. Add(' b:=onfoo=onfoo;');
  11496. Add(' b:=onbar=onfoo;');
  11497. Add(' b:=fonfoo<>fonfoo;');
  11498. Add(' b:=onfoo<>onfoo;');
  11499. Add(' b:=onbar<>onfoo;');
  11500. Add(' b:=fonfoo=@doit;');
  11501. Add(' b:=onfoo=@doit;');
  11502. Add(' b:=onbar=@doit;');
  11503. Add(' b:=fonfoo<>@doit;');
  11504. Add(' b:=onfoo<>@doit;');
  11505. Add(' b:=onbar<>@doit;');
  11506. Add(' b:=Assigned(fonfoo);');
  11507. Add(' b:=Assigned(onfoo);');
  11508. Add(' b:=Assigned(onbar);');
  11509. Add('end;');
  11510. ConvertProgram;
  11511. CheckSource('TestProcType_WithClassInstDoPropertyFPC',
  11512. LinesToStr([ // statements
  11513. 'rtl.createClass($mod, "TObject", null, function () {',
  11514. ' this.$init = function () {',
  11515. ' this.FOnFoo = null;',
  11516. ' };',
  11517. ' this.$final = function () {',
  11518. ' this.FOnFoo = undefined;',
  11519. ' };',
  11520. ' this.DoIt = function (vA) {',
  11521. ' var Result = 0;',
  11522. ' return Result;',
  11523. ' };',
  11524. ' this.GetFoo = function () {',
  11525. ' var Result = null;',
  11526. ' return Result;',
  11527. ' };',
  11528. ' this.SetFoo = function (Value) {',
  11529. ' };',
  11530. '});',
  11531. 'this.Obj = null;',
  11532. 'this.vP = null;',
  11533. 'this.b = false;'
  11534. ]),
  11535. LinesToStr([
  11536. 'var $with1 = $mod.Obj;',
  11537. '$with1.FOnFoo = null;',
  11538. '$with1.FOnFoo = null;',
  11539. '$with1.SetFoo(null);',
  11540. '$with1.FOnFoo = $with1.FOnFoo;',
  11541. '$with1.FOnFoo = $with1.FOnFoo;',
  11542. '$with1.SetFoo($with1.GetFoo());',
  11543. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  11544. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  11545. '$with1.SetFoo(rtl.createCallback($with1, "DoIt"));',
  11546. '$with1.FOnFoo(1);',
  11547. '$with1.FOnFoo(1);',
  11548. '$with1.GetFoo();',
  11549. '$with1.FOnFoo(1);',
  11550. '$with1.FOnFoo(1);',
  11551. '$with1.GetFoo()(1);',
  11552. '$mod.b = $with1.FOnFoo === null;',
  11553. '$mod.b = $with1.FOnFoo === null;',
  11554. '$mod.b = $with1.GetFoo() === null;',
  11555. '$mod.b = $with1.FOnFoo !== null;',
  11556. '$mod.b = $with1.FOnFoo !== null;',
  11557. '$mod.b = $with1.GetFoo() !== null;',
  11558. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  11559. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  11560. '$mod.b = rtl.eqCallback($with1.GetFoo(), $mod.vP);',
  11561. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  11562. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  11563. '$mod.b = rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  11564. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  11565. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  11566. '$mod.b = !rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  11567. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  11568. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  11569. '$mod.b = rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  11570. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  11571. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  11572. '$mod.b = !rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  11573. '$mod.b = $with1.FOnFoo !== null;',
  11574. '$mod.b = $with1.FOnFoo !== null;',
  11575. '$mod.b = $with1.GetFoo() !== null;',
  11576. '']));
  11577. end;
  11578. procedure TTestModule.TestProcType_Nested;
  11579. begin
  11580. StartProgram(false);
  11581. Add([
  11582. 'type',
  11583. ' TProcInt = procedure(vI: longint = 1);',
  11584. 'procedure DoIt(vJ: longint);',
  11585. 'var aProc: TProcInt;',
  11586. ' b: boolean;',
  11587. ' procedure Sub(vK: longint);',
  11588. ' var aSub: TProcInt;',
  11589. ' procedure SubSub(vK: longint);',
  11590. ' var aSubSub: TProcInt;',
  11591. ' begin;',
  11592. ' aProc:=@DoIt;',
  11593. ' aSub:=@DoIt;',
  11594. ' aSubSub:=@DoIt;',
  11595. ' aProc:=@Sub;',
  11596. ' aSub:=@Sub;',
  11597. ' aSubSub:=@Sub;',
  11598. ' aProc:=@SubSub;',
  11599. ' aSub:=@SubSub;',
  11600. ' aSubSub:=@SubSub;',
  11601. ' end;',
  11602. ' begin;',
  11603. ' end;',
  11604. 'begin;',
  11605. ' aProc:=@Sub;',
  11606. ' b:=aProc=@Sub;',
  11607. ' b:=@Sub=aProc;',
  11608. 'end;',
  11609. 'begin',
  11610. '']);
  11611. ConvertProgram;
  11612. CheckSource('TestProcType_Nested',
  11613. LinesToStr([ // statements
  11614. 'this.DoIt = function (vJ) {',
  11615. ' var aProc = null;',
  11616. ' var b = false;',
  11617. ' function Sub(vK) {',
  11618. ' var aSub = null;',
  11619. ' function SubSub(vK) {',
  11620. ' var aSubSub = null;',
  11621. ' aProc = $mod.DoIt;',
  11622. ' aSub = $mod.DoIt;',
  11623. ' aSubSub = $mod.DoIt;',
  11624. ' aProc = Sub;',
  11625. ' aSub = Sub;',
  11626. ' aSubSub = Sub;',
  11627. ' aProc = SubSub;',
  11628. ' aSub = SubSub;',
  11629. ' aSubSub = SubSub;',
  11630. ' };',
  11631. ' };',
  11632. ' aProc = Sub;',
  11633. ' b = rtl.eqCallback(aProc, Sub);',
  11634. ' b = rtl.eqCallback(Sub, aProc);',
  11635. '};',
  11636. '']),
  11637. LinesToStr([ // $mod.$main
  11638. '']));
  11639. end;
  11640. procedure TTestModule.TestProcType_NestedOfObject;
  11641. begin
  11642. StartProgram(false);
  11643. Add([
  11644. 'type',
  11645. ' TProcInt = procedure(vI: longint = 1) of object;',
  11646. ' TObject = class',
  11647. ' procedure DoIt(vJ: longint);',
  11648. ' end;',
  11649. 'procedure TObject.DoIt(vJ: longint);',
  11650. 'var aProc: TProcInt;',
  11651. ' b: boolean;',
  11652. ' procedure Sub(vK: longint);',
  11653. ' var aSub: TProcInt;',
  11654. ' procedure SubSub(vK: longint);',
  11655. ' var aSubSub: TProcInt;',
  11656. ' begin;',
  11657. ' aProc:=@DoIt;',
  11658. ' aSub:=@DoIt;',
  11659. ' aSubSub:=@DoIt;',
  11660. ' aProc:=@Sub;',
  11661. ' aSub:=@Sub;',
  11662. ' aSubSub:=@Sub;',
  11663. ' aProc:=@SubSub;',
  11664. ' aSub:=@SubSub;',
  11665. ' aSubSub:=@SubSub;',
  11666. ' end;',
  11667. ' begin;',
  11668. ' end;',
  11669. 'begin;',
  11670. ' aProc:=@Sub;',
  11671. ' b:=aProc=@Sub;',
  11672. ' b:=@Sub=aProc;',
  11673. 'end;',
  11674. 'begin',
  11675. '']);
  11676. ConvertProgram;
  11677. CheckSource('TestProcType_Nested',
  11678. LinesToStr([ // statements
  11679. 'rtl.createClass($mod, "TObject", null, function () {',
  11680. ' this.$init = function () {',
  11681. ' };',
  11682. ' this.$final = function () {',
  11683. ' };',
  11684. ' this.DoIt = function (vJ) {',
  11685. ' var Self = this;',
  11686. ' var aProc = null;',
  11687. ' var b = false;',
  11688. ' function Sub(vK) {',
  11689. ' var aSub = null;',
  11690. ' function SubSub(vK) {',
  11691. ' var aSubSub = null;',
  11692. ' aProc = rtl.createCallback(Self, "DoIt");',
  11693. ' aSub = rtl.createCallback(Self, "DoIt");',
  11694. ' aSubSub = rtl.createCallback(Self, "DoIt");',
  11695. ' aProc = Sub;',
  11696. ' aSub = Sub;',
  11697. ' aSubSub = Sub;',
  11698. ' aProc = SubSub;',
  11699. ' aSub = SubSub;',
  11700. ' aSubSub = SubSub;',
  11701. ' };',
  11702. ' };',
  11703. ' aProc = Sub;',
  11704. ' b = rtl.eqCallback(aProc, Sub);',
  11705. ' b = rtl.eqCallback(Sub, aProc);',
  11706. ' };',
  11707. '});',
  11708. '']),
  11709. LinesToStr([ // $mod.$main
  11710. '']));
  11711. end;
  11712. procedure TTestModule.TestProcType_ReferenceToProc;
  11713. begin
  11714. StartProgram(false);
  11715. Add([
  11716. 'type',
  11717. ' TProcRef = reference to procedure(i: longint = 0);',
  11718. ' TFuncRef = reference to function(i: longint = 0): longint;',
  11719. 'var',
  11720. ' p: TProcRef;',
  11721. ' f: TFuncRef;',
  11722. 'procedure DoIt(i: longint);',
  11723. 'begin',
  11724. 'end;',
  11725. 'function GetIt(i: longint): longint;',
  11726. 'begin',
  11727. ' p:=@DoIt;',
  11728. ' f:=@GetIt;',
  11729. ' f;',
  11730. ' f();',
  11731. ' f(1);',
  11732. 'end;',
  11733. 'begin',
  11734. ' p:=@DoIt;',
  11735. ' f:=@GetIt;',
  11736. ' f;',
  11737. ' f();',
  11738. ' f(1);',
  11739. ' p:=TProcRef(f);',
  11740. '']);
  11741. ConvertProgram;
  11742. CheckSource('TestProcType_ReferenceToProc',
  11743. LinesToStr([ // statements
  11744. 'this.p = null;',
  11745. 'this.f = null;',
  11746. 'this.DoIt = function (i) {',
  11747. '};',
  11748. 'this.GetIt = function (i) {',
  11749. ' var Result = 0;',
  11750. ' $mod.p = $mod.DoIt;',
  11751. ' $mod.f = $mod.GetIt;',
  11752. ' $mod.f(0);',
  11753. ' $mod.f(0);',
  11754. ' $mod.f(1);',
  11755. ' return Result;',
  11756. '};',
  11757. '']),
  11758. LinesToStr([ // $mod.$main
  11759. '$mod.p = $mod.DoIt;',
  11760. '$mod.f = $mod.GetIt;',
  11761. '$mod.f(0);',
  11762. '$mod.f(0);',
  11763. '$mod.f(1);',
  11764. '$mod.p = $mod.f;',
  11765. '']));
  11766. end;
  11767. procedure TTestModule.TestProcType_ReferenceToMethod;
  11768. begin
  11769. StartProgram(false);
  11770. Add([
  11771. 'type',
  11772. ' TFuncRef = reference to function(i: longint = 5): longint;',
  11773. ' TObject = class',
  11774. ' function Grow(s: longint): longint;',
  11775. ' end;',
  11776. 'var',
  11777. ' f: tfuncref;',
  11778. 'function tobject.grow(s: longint): longint;',
  11779. ' function GrowSub(i: longint): longint;',
  11780. ' begin',
  11781. ' f:=@grow;',
  11782. ' f:=@growsub;',
  11783. ' end;',
  11784. 'begin',
  11785. ' f:=@grow;',
  11786. ' f:=@growsub;',
  11787. 'end;',
  11788. 'begin',
  11789. '']);
  11790. ConvertProgram;
  11791. CheckSource('TestProcType_ReferenceToMethod',
  11792. LinesToStr([ // statements
  11793. 'rtl.createClass($mod, "TObject", null, function () {',
  11794. ' this.$init = function () {',
  11795. ' };',
  11796. ' this.$final = function () {',
  11797. ' };',
  11798. ' this.Grow = function (s) {',
  11799. ' var Self = this;',
  11800. ' var Result = 0;',
  11801. ' function GrowSub(i) {',
  11802. ' var Result = 0;',
  11803. ' $mod.f = rtl.createCallback(Self, "Grow");',
  11804. ' $mod.f = GrowSub;',
  11805. ' return Result;',
  11806. ' };',
  11807. ' $mod.f = rtl.createCallback(Self, "Grow");',
  11808. ' $mod.f = GrowSub;',
  11809. ' return Result;',
  11810. ' };',
  11811. '});',
  11812. 'this.f = null;',
  11813. '']),
  11814. LinesToStr([ // $mod.$main
  11815. '']));
  11816. end;
  11817. procedure TTestModule.TestProcType_Typecast;
  11818. begin
  11819. StartProgram(false);
  11820. Add([
  11821. 'type',
  11822. ' TNotifyEvent = procedure(Sender: Pointer) of object;',
  11823. ' TEvent = procedure of object;',
  11824. ' TGetter = function:longint of object;',
  11825. ' TProcA = procedure(i: longint);',
  11826. ' TFuncB = function(i, j: longint): longint;',
  11827. 'procedure DoIt(); varargs; begin end;',
  11828. 'var',
  11829. ' Notify: tnotifyevent;',
  11830. ' Event: tevent;',
  11831. ' Getter: tgetter;',
  11832. ' ProcA: tproca;',
  11833. ' FuncB: tfuncb;',
  11834. ' p: pointer;',
  11835. 'begin',
  11836. ' notify:=tnotifyevent(event);',
  11837. ' event:=tevent(event);',
  11838. ' event:=tevent(notify);',
  11839. ' event:=tevent(getter);',
  11840. ' event:=tevent(proca);',
  11841. ' proca:=tproca(funcb);',
  11842. ' funcb:=tfuncb(funcb);',
  11843. ' funcb:=tfuncb(proca);',
  11844. ' funcb:=tfuncb(getter);',
  11845. ' proca:=tproca(p);',
  11846. ' funcb:=tfuncb(p);',
  11847. ' getter:=tgetter(p);',
  11848. ' p:=pointer(notify);',
  11849. ' p:=notify;',
  11850. ' p:=pointer(proca);',
  11851. ' p:=proca;',
  11852. ' p:=pointer(funcb);',
  11853. ' p:=funcb;',
  11854. ' doit(Pointer(notify),pointer(event),pointer(proca));',
  11855. '']);
  11856. ConvertProgram;
  11857. CheckSource('TestProcType_Typecast',
  11858. LinesToStr([ // statements
  11859. 'this.DoIt = function () {',
  11860. '};',
  11861. 'this.Notify = null;',
  11862. 'this.Event = null;',
  11863. 'this.Getter = null;',
  11864. 'this.ProcA = null;',
  11865. 'this.FuncB = null;',
  11866. 'this.p = null;',
  11867. '']),
  11868. LinesToStr([ // $mod.$main
  11869. '$mod.Notify = $mod.Event;',
  11870. '$mod.Event = $mod.Event;',
  11871. '$mod.Event = $mod.Notify;',
  11872. '$mod.Event = $mod.Getter;',
  11873. '$mod.Event = $mod.ProcA;',
  11874. '$mod.ProcA = $mod.FuncB;',
  11875. '$mod.FuncB = $mod.FuncB;',
  11876. '$mod.FuncB = $mod.ProcA;',
  11877. '$mod.FuncB = $mod.Getter;',
  11878. '$mod.ProcA = $mod.p;',
  11879. '$mod.FuncB = $mod.p;',
  11880. '$mod.Getter = $mod.p;',
  11881. '$mod.p = $mod.Notify;',
  11882. '$mod.p = $mod.Notify;',
  11883. '$mod.p = $mod.ProcA;',
  11884. '$mod.p = $mod.ProcA;',
  11885. '$mod.p = $mod.FuncB;',
  11886. '$mod.p = $mod.FuncB;',
  11887. '$mod.DoIt($mod.Notify, $mod.Event, $mod.ProcA);',
  11888. '']));
  11889. end;
  11890. procedure TTestModule.TestProcType_PassProcToUntyped;
  11891. begin
  11892. StartProgram(false);
  11893. Add([
  11894. 'type',
  11895. ' TEvent = procedure of object;',
  11896. ' TFunc = function: longint;',
  11897. 'procedure DoIt(); varargs; begin end;',
  11898. 'procedure DoSome(const a; var b; p: pointer); begin end;',
  11899. 'var',
  11900. ' Event: tevent;',
  11901. ' Func: TFunc;',
  11902. 'begin',
  11903. ' doit(event,func);',
  11904. ' dosome(event,event,event);',
  11905. ' dosome(func,func,func);',
  11906. '']);
  11907. ConvertProgram;
  11908. CheckSource('TestProcType_PassProcToUntyped',
  11909. LinesToStr([ // statements
  11910. 'this.DoIt = function () {',
  11911. '};',
  11912. 'this.DoSome = function (a, b, p) {',
  11913. '};',
  11914. 'this.Event = null;',
  11915. 'this.Func = null;',
  11916. '']),
  11917. LinesToStr([ // $mod.$main
  11918. '$mod.DoIt($mod.Event, $mod.Func);',
  11919. '$mod.DoSome($mod.Event, {',
  11920. ' p: $mod,',
  11921. ' get: function () {',
  11922. ' return this.p.Event;',
  11923. ' },',
  11924. ' set: function (v) {',
  11925. ' this.p.Event = v;',
  11926. ' }',
  11927. '}, $mod.Event);',
  11928. '$mod.DoSome($mod.Func, {',
  11929. ' p: $mod,',
  11930. ' get: function () {',
  11931. ' return this.p.Func;',
  11932. ' },',
  11933. ' set: function (v) {',
  11934. ' this.p.Func = v;',
  11935. ' }',
  11936. '}, $mod.Func);',
  11937. '']));
  11938. end;
  11939. procedure TTestModule.TestPointer;
  11940. begin
  11941. StartProgram(false);
  11942. Add('type');
  11943. Add(' TObject = class end;');
  11944. Add(' TClass = class of TObject;');
  11945. Add(' TArrInt = array of longint;');
  11946. Add('var');
  11947. Add(' v: jsvalue;');
  11948. Add(' Obj: tobject;');
  11949. Add(' C: tclass;');
  11950. Add(' a: tarrint;');
  11951. Add(' p: Pointer;');
  11952. Add('begin');
  11953. Add(' p:=p;');
  11954. Add(' p:=nil;');
  11955. Add(' if p=nil then;');
  11956. Add(' if nil=p then;');
  11957. Add(' if Assigned(p) then;');
  11958. Add(' p:=Pointer(v);');
  11959. Add(' p:=obj;');
  11960. Add(' p:=c;');
  11961. Add(' p:=a;');
  11962. Add(' p:=tobject;');
  11963. Add(' obj:=TObject(p);');
  11964. Add(' c:=TClass(p);');
  11965. Add(' a:=TArrInt(p);');
  11966. ConvertProgram;
  11967. CheckSource('TestPointer',
  11968. LinesToStr([ // statements
  11969. 'rtl.createClass($mod, "TObject", null, function () {',
  11970. ' this.$init = function () {',
  11971. ' };',
  11972. ' this.$final = function () {',
  11973. ' };',
  11974. '});',
  11975. 'this.v = undefined;',
  11976. 'this.Obj = null;',
  11977. 'this.C = null;',
  11978. 'this.a = [];',
  11979. 'this.p = null;',
  11980. '']),
  11981. LinesToStr([ // $mod.$main
  11982. '$mod.p = $mod.p;',
  11983. '$mod.p = null;',
  11984. 'if ($mod.p === null) ;',
  11985. 'if (null === $mod.p) ;',
  11986. 'if ($mod.p !== null) ;',
  11987. '$mod.p = $mod.v;',
  11988. '$mod.p = $mod.Obj;',
  11989. '$mod.p = $mod.C;',
  11990. '$mod.p = $mod.a;',
  11991. '$mod.p = $mod.TObject;',
  11992. '$mod.Obj = $mod.p;',
  11993. '$mod.C = $mod.p;',
  11994. '$mod.a = $mod.p;',
  11995. '']));
  11996. end;
  11997. procedure TTestModule.TestPointer_Proc;
  11998. begin
  11999. StartProgram(false);
  12000. Add('type');
  12001. Add(' TObject = class');
  12002. Add(' procedure DoIt; virtual; abstract;');
  12003. Add(' end;');
  12004. Add('procedure DoSome; begin end;');
  12005. Add('var');
  12006. Add(' o: TObject;');
  12007. Add(' p: Pointer;');
  12008. Add('begin');
  12009. Add(' p:=@DoSome;');
  12010. Add(' p:[email protected];');
  12011. ConvertProgram;
  12012. CheckSource('TestPointer_Proc',
  12013. LinesToStr([ // statements
  12014. 'rtl.createClass($mod, "TObject", null, function () {',
  12015. ' this.$init = function () {',
  12016. ' };',
  12017. ' this.$final = function () {',
  12018. ' };',
  12019. '});',
  12020. 'this.DoSome = function () {',
  12021. '};',
  12022. 'this.o = null;',
  12023. 'this.p = null;',
  12024. '']),
  12025. LinesToStr([ // $mod.$main
  12026. '$mod.p = $mod.DoSome;',
  12027. '$mod.p = rtl.createCallback($mod.o, "DoIt");',
  12028. '']));
  12029. end;
  12030. procedure TTestModule.TestPointer_AssignRecordFail;
  12031. begin
  12032. StartProgram(false);
  12033. Add('type');
  12034. Add(' TRec = record end;');
  12035. Add('var');
  12036. Add(' p: Pointer;');
  12037. Add(' r: TRec;');
  12038. Add('begin');
  12039. Add(' p:=r;');
  12040. SetExpectedPasResolverError('Incompatible types: got "TRec" expected "Pointer"',
  12041. nIncompatibleTypesGotExpected);
  12042. ConvertProgram;
  12043. end;
  12044. procedure TTestModule.TestPointer_AssignStaticArrayFail;
  12045. begin
  12046. StartProgram(false);
  12047. Add('type');
  12048. Add(' TArr = array[boolean] of longint;');
  12049. Add('var');
  12050. Add(' p: Pointer;');
  12051. Add(' a: TArr;');
  12052. Add('begin');
  12053. Add(' p:=a;');
  12054. SetExpectedPasResolverError('Incompatible types: got "TArr" expected "Pointer"',
  12055. nIncompatibleTypesGotExpected);
  12056. ConvertProgram;
  12057. end;
  12058. procedure TTestModule.TestPointer_ArrayParamsFail;
  12059. begin
  12060. StartProgram(false);
  12061. Add('var');
  12062. Add(' p: Pointer;');
  12063. Add('begin');
  12064. Add(' p:=p[1];');
  12065. SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
  12066. ConvertProgram;
  12067. end;
  12068. procedure TTestModule.TestPointer_TypeCastJSValueToPointer;
  12069. begin
  12070. StartProgram(false);
  12071. Add([
  12072. 'procedure DoIt(args: array of jsvalue); begin end;',
  12073. 'procedure DoAll; varargs; begin end;',
  12074. 'var',
  12075. ' v: jsvalue;',
  12076. 'begin',
  12077. ' DoIt([pointer(v)]);',
  12078. ' DoAll(pointer(v));',
  12079. '']);
  12080. ConvertProgram;
  12081. CheckSource('TestPointer_TypeCastJSValueToPointer',
  12082. LinesToStr([ // statements
  12083. 'this.DoIt = function (args) {',
  12084. '};',
  12085. 'this.DoAll = function () {',
  12086. '};',
  12087. 'this.v = undefined;',
  12088. '']),
  12089. LinesToStr([ // $mod.$main
  12090. '$mod.DoIt([$mod.v]);',
  12091. '$mod.DoAll($mod.v);',
  12092. '']));
  12093. end;
  12094. procedure TTestModule.TestJSValue_AssignToJSValue;
  12095. begin
  12096. StartProgram(false);
  12097. Add('var');
  12098. Add(' v: jsvalue;');
  12099. Add(' i: longint;');
  12100. Add(' s: string;');
  12101. Add(' b: boolean;');
  12102. Add(' d: double;');
  12103. Add(' p: pointer;');
  12104. Add('begin');
  12105. Add(' v:=v;');
  12106. Add(' v:=1;');
  12107. Add(' v:=i;');
  12108. Add(' v:='''';');
  12109. Add(' v:=''c'';');
  12110. Add(' v:=''foo'';');
  12111. Add(' v:=s;');
  12112. Add(' v:=false;');
  12113. Add(' v:=true;');
  12114. Add(' v:=b;');
  12115. Add(' v:=0.1;');
  12116. Add(' v:=d;');
  12117. Add(' v:=nil;');
  12118. Add(' v:=p;');
  12119. ConvertProgram;
  12120. CheckSource('TestJSValue_AssignToJSValue',
  12121. LinesToStr([ // statements
  12122. 'this.v = undefined;',
  12123. 'this.i = 0;',
  12124. 'this.s = "";',
  12125. 'this.b = false;',
  12126. 'this.d = 0.0;',
  12127. 'this.p = null;',
  12128. '']),
  12129. LinesToStr([ // $mod.$main
  12130. '$mod.v = $mod.v;',
  12131. '$mod.v = 1;',
  12132. '$mod.v = $mod.i;',
  12133. '$mod.v = "";',
  12134. '$mod.v = "c";',
  12135. '$mod.v = "foo";',
  12136. '$mod.v = $mod.s;',
  12137. '$mod.v = false;',
  12138. '$mod.v = true;',
  12139. '$mod.v = $mod.b;',
  12140. '$mod.v = 0.1;',
  12141. '$mod.v = $mod.d;',
  12142. '$mod.v = null;',
  12143. '$mod.v = $mod.p;',
  12144. '']));
  12145. end;
  12146. procedure TTestModule.TestJSValue_TypeCastToBaseType;
  12147. begin
  12148. StartProgram(false);
  12149. Add('type');
  12150. Add(' integer = longint;');
  12151. Add(' TYesNo = boolean;');
  12152. Add(' TFloat = double;');
  12153. Add(' TCaption = string;');
  12154. Add(' TChar = char;');
  12155. Add('var');
  12156. Add(' v: jsvalue;');
  12157. Add(' i: integer;');
  12158. Add(' s: TCaption;');
  12159. Add(' b: TYesNo;');
  12160. Add(' d: TFloat;');
  12161. Add(' c: char;');
  12162. Add('begin');
  12163. Add(' i:=longint(v);');
  12164. Add(' i:=integer(v);');
  12165. Add(' s:=string(v);');
  12166. Add(' s:=TCaption(v);');
  12167. Add(' b:=boolean(v);');
  12168. Add(' b:=TYesNo(v);');
  12169. Add(' d:=double(v);');
  12170. Add(' d:=TFloat(v);');
  12171. Add(' c:=char(v);');
  12172. Add(' c:=TChar(v);');
  12173. ConvertProgram;
  12174. CheckSource('TestJSValue_TypeCastToBaseType',
  12175. LinesToStr([ // statements
  12176. 'this.v = undefined;',
  12177. 'this.i = 0;',
  12178. 'this.s = "";',
  12179. 'this.b = false;',
  12180. 'this.d = 0.0;',
  12181. 'this.c = "";',
  12182. '']),
  12183. LinesToStr([ // $mod.$main
  12184. '$mod.i = Math.floor($mod.v);',
  12185. '$mod.i = Math.floor($mod.v);',
  12186. '$mod.s = "" + $mod.v;',
  12187. '$mod.s = "" + $mod.v;',
  12188. '$mod.b = !($mod.v == false);',
  12189. '$mod.b = !($mod.v == false);',
  12190. '$mod.d = rtl.getNumber($mod.v);',
  12191. '$mod.d = rtl.getNumber($mod.v);',
  12192. '$mod.c = rtl.getChar($mod.v);',
  12193. '$mod.c = rtl.getChar($mod.v);',
  12194. '']));
  12195. end;
  12196. procedure TTestModule.TestJSValue_Equal;
  12197. begin
  12198. StartProgram(false);
  12199. Add('type');
  12200. Add(' integer = longint;');
  12201. Add(' TYesNo = boolean;');
  12202. Add(' TFloat = double;');
  12203. Add(' TCaption = string;');
  12204. Add(' TChar = char;');
  12205. Add(' TMulti = JSValue;');
  12206. Add('var');
  12207. Add(' v: jsvalue;');
  12208. Add(' i: integer;');
  12209. Add(' s: TCaption;');
  12210. Add(' b: TYesNo;');
  12211. Add(' d: TFloat;');
  12212. Add(' c: char;');
  12213. Add(' m: TMulti;');
  12214. Add('begin');
  12215. Add(' b:=v=v;');
  12216. Add(' b:=v<>v;');
  12217. Add(' b:=v=1;');
  12218. Add(' b:=v<>1;');
  12219. Add(' b:=2=v;');
  12220. Add(' b:=2<>v;');
  12221. Add(' b:=v=i;');
  12222. Add(' b:=i=v;');
  12223. Add(' b:=v=nil;');
  12224. Add(' b:=nil=v;');
  12225. Add(' b:=v=false;');
  12226. Add(' b:=true=v;');
  12227. Add(' b:=v=b;');
  12228. Add(' b:=b=v;');
  12229. Add(' b:=v=s;');
  12230. Add(' b:=s=v;');
  12231. Add(' b:=v=''foo'';');
  12232. Add(' b:=''''=v;');
  12233. Add(' b:=v=d;');
  12234. Add(' b:=d=v;');
  12235. Add(' b:=v=3.4;');
  12236. Add(' b:=5.6=v;');
  12237. Add(' b:=v=c;');
  12238. Add(' b:=c=v;');
  12239. Add(' b:=m=m;');
  12240. Add(' b:=v=m;');
  12241. Add(' b:=m=v;');
  12242. ConvertProgram;
  12243. CheckSource('TestJSValue_Equal',
  12244. LinesToStr([ // statements
  12245. 'this.v = undefined;',
  12246. 'this.i = 0;',
  12247. 'this.s = "";',
  12248. 'this.b = false;',
  12249. 'this.d = 0.0;',
  12250. 'this.c = "";',
  12251. 'this.m = undefined;',
  12252. '']),
  12253. LinesToStr([ // $mod.$main
  12254. '$mod.b = $mod.v == $mod.v;',
  12255. '$mod.b = $mod.v != $mod.v;',
  12256. '$mod.b = $mod.v == 1;',
  12257. '$mod.b = $mod.v != 1;',
  12258. '$mod.b = 2 == $mod.v;',
  12259. '$mod.b = 2 != $mod.v;',
  12260. '$mod.b = $mod.v == $mod.i;',
  12261. '$mod.b = $mod.i == $mod.v;',
  12262. '$mod.b = $mod.v == null;',
  12263. '$mod.b = null == $mod.v;',
  12264. '$mod.b = $mod.v == false;',
  12265. '$mod.b = true == $mod.v;',
  12266. '$mod.b = $mod.v == $mod.b;',
  12267. '$mod.b = $mod.b == $mod.v;',
  12268. '$mod.b = $mod.v == $mod.s;',
  12269. '$mod.b = $mod.s == $mod.v;',
  12270. '$mod.b = $mod.v == "foo";',
  12271. '$mod.b = "" == $mod.v;',
  12272. '$mod.b = $mod.v == $mod.d;',
  12273. '$mod.b = $mod.d == $mod.v;',
  12274. '$mod.b = $mod.v == 3.4;',
  12275. '$mod.b = 5.6 == $mod.v;',
  12276. '$mod.b = $mod.v == $mod.c;',
  12277. '$mod.b = $mod.c == $mod.v;',
  12278. '$mod.b = $mod.m == $mod.m;',
  12279. '$mod.b = $mod.v == $mod.m;',
  12280. '$mod.b = $mod.m == $mod.v;',
  12281. '']));
  12282. end;
  12283. procedure TTestModule.TestJSValue_If;
  12284. begin
  12285. StartProgram(false);
  12286. Add([
  12287. 'var',
  12288. ' v: jsvalue;',
  12289. 'begin',
  12290. ' if v then ;',
  12291. ' while v do ;',
  12292. ' repeat until v;',
  12293. '']);
  12294. ConvertProgram;
  12295. CheckSource('TestJSValue_If',
  12296. LinesToStr([ // statements
  12297. 'this.v = undefined;',
  12298. '']),
  12299. LinesToStr([ // $mod.$main
  12300. 'if ($mod.v) ;',
  12301. 'while($mod.v){',
  12302. '};',
  12303. 'do{',
  12304. '} while(!$mod.v);',
  12305. '']));
  12306. end;
  12307. procedure TTestModule.TestJSValue_Enum;
  12308. begin
  12309. StartProgram(false);
  12310. Add('type');
  12311. Add(' TColor = (red, blue);');
  12312. Add(' TRedBlue = TColor;');
  12313. Add('var');
  12314. Add(' v: jsvalue;');
  12315. Add(' e: TColor;');
  12316. Add('begin');
  12317. Add(' v:=e;');
  12318. Add(' v:=TColor(e);');
  12319. Add(' v:=TRedBlue(e);');
  12320. Add(' e:=TColor(v);');
  12321. Add(' e:=TRedBlue(v);');
  12322. ConvertProgram;
  12323. CheckSource('TestJSValue_Enum',
  12324. LinesToStr([ // statements
  12325. 'this.TColor = {',
  12326. ' "0": "red",',
  12327. ' red: 0,',
  12328. ' "1": "blue",',
  12329. ' blue: 1',
  12330. '};',
  12331. 'this.v = undefined;',
  12332. 'this.e = 0;',
  12333. '']),
  12334. LinesToStr([ // $mod.$main
  12335. '$mod.v = $mod.e;',
  12336. '$mod.v = $mod.e;',
  12337. '$mod.v = $mod.e;',
  12338. '$mod.e = $mod.v;',
  12339. '$mod.e = $mod.v;',
  12340. '']));
  12341. end;
  12342. procedure TTestModule.TestJSValue_ClassInstance;
  12343. begin
  12344. StartProgram(false);
  12345. Add('type');
  12346. Add(' TObject = class');
  12347. Add(' end;');
  12348. Add(' TBirdObject = TObject;');
  12349. Add('var');
  12350. Add(' v: jsvalue;');
  12351. Add(' o: TObject;');
  12352. Add('begin');
  12353. Add(' v:=o;');
  12354. Add(' v:=TObject(o);');
  12355. Add(' v:=TBirdObject(o);');
  12356. Add(' o:=TObject(v);');
  12357. Add(' o:=TBirdObject(v);');
  12358. ConvertProgram;
  12359. CheckSource('TestJSValue_ClassInstance',
  12360. LinesToStr([ // statements
  12361. 'rtl.createClass($mod, "TObject", null, function () {',
  12362. ' this.$init = function () {',
  12363. ' };',
  12364. ' this.$final = function () {',
  12365. ' };',
  12366. '});',
  12367. 'this.v = undefined;',
  12368. 'this.o = null;',
  12369. '']),
  12370. LinesToStr([ // $mod.$main
  12371. '$mod.v = $mod.o;',
  12372. '$mod.v = $mod.o;',
  12373. '$mod.v = $mod.o;',
  12374. '$mod.o = rtl.getObject($mod.v);',
  12375. '$mod.o = rtl.getObject($mod.v);',
  12376. '']));
  12377. end;
  12378. procedure TTestModule.TestJSValue_ClassOf;
  12379. begin
  12380. StartProgram(false);
  12381. Add('type');
  12382. Add(' TClass = class of TObject;');
  12383. Add(' TObject = class');
  12384. Add(' end;');
  12385. Add(' TBirds = class of TBird;');
  12386. Add(' TBird = class(TObject) end;');
  12387. Add('var');
  12388. Add(' v: jsvalue;');
  12389. Add(' c: TClass;');
  12390. Add('begin');
  12391. Add(' v:=c;');
  12392. Add(' v:=TObject;');
  12393. Add(' v:=TClass(c);');
  12394. Add(' v:=TBirds(c);');
  12395. Add(' c:=TClass(v);');
  12396. Add(' c:=TBirds(v);');
  12397. ConvertProgram;
  12398. CheckSource('TestJSValue_ClassOf',
  12399. LinesToStr([ // statements
  12400. 'rtl.createClass($mod, "TObject", null, function () {',
  12401. ' this.$init = function () {',
  12402. ' };',
  12403. ' this.$final = function () {',
  12404. ' };',
  12405. '});',
  12406. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  12407. '});',
  12408. 'this.v = undefined;',
  12409. 'this.c = null;',
  12410. '']),
  12411. LinesToStr([ // $mod.$main
  12412. '$mod.v = $mod.c;',
  12413. '$mod.v = $mod.TObject;',
  12414. '$mod.v = $mod.c;',
  12415. '$mod.v = $mod.c;',
  12416. '$mod.c = rtl.getObject($mod.v);',
  12417. '$mod.c = rtl.getObject($mod.v);',
  12418. '']));
  12419. end;
  12420. procedure TTestModule.TestJSValue_ArrayOfJSValue;
  12421. begin
  12422. StartProgram(false);
  12423. Add('type');
  12424. Add(' integer = longint;');
  12425. Add(' TArray = array of JSValue;');
  12426. Add(' TArrgh = tarray;');
  12427. Add(' TArrInt = array of integer;');
  12428. Add('var');
  12429. Add(' v: jsvalue;');
  12430. Add(' TheArray: tarray;');
  12431. Add(' Arr: tarrgh;');
  12432. Add(' i: integer;');
  12433. Add(' ArrInt: tarrint;');
  12434. Add('begin');
  12435. Add(' arr:=thearray;');
  12436. Add(' thearray:=arr;');
  12437. Add(' setlength(arr,2);');
  12438. Add(' setlength(thearray,3);');
  12439. Add(' arr[4]:=v;');
  12440. Add(' arr[5]:=length(thearray);');
  12441. Add(' arr[6]:=nil;');
  12442. Add(' arr[7]:=thearray[8];');
  12443. Add(' arr[low(arr)]:=high(thearray);');
  12444. Add(' arr:=arrint;');
  12445. Add(' arrInt:=tarrint(arr);');
  12446. Add(' if TheArray = nil then ;');
  12447. Add(' if nil = TheArray then ;');
  12448. Add(' if TheArray <> nil then ;');
  12449. Add(' if nil <> TheArray then ;');
  12450. ConvertProgram;
  12451. CheckSource('TestJSValue_ArrayOfJSValue',
  12452. LinesToStr([ // statements
  12453. 'this.v = undefined;',
  12454. 'this.TheArray = [];',
  12455. 'this.Arr = [];',
  12456. 'this.i = 0;',
  12457. 'this.ArrInt = [];',
  12458. '']),
  12459. LinesToStr([ // $mod.$main
  12460. '$mod.Arr = $mod.TheArray;',
  12461. '$mod.TheArray = $mod.Arr;',
  12462. '$mod.Arr = rtl.arraySetLength($mod.Arr,undefined,2);',
  12463. '$mod.TheArray = rtl.arraySetLength($mod.TheArray,undefined,3);',
  12464. '$mod.Arr[4] = $mod.v;',
  12465. '$mod.Arr[5] = rtl.length($mod.TheArray);',
  12466. '$mod.Arr[6] = null;',
  12467. '$mod.Arr[7] = $mod.TheArray[8];',
  12468. '$mod.Arr[0] = rtl.length($mod.TheArray) - 1;',
  12469. '$mod.Arr = $mod.ArrInt;',
  12470. '$mod.ArrInt = $mod.Arr;',
  12471. 'if (rtl.length($mod.TheArray) === 0) ;',
  12472. 'if (rtl.length($mod.TheArray) === 0) ;',
  12473. 'if (rtl.length($mod.TheArray) > 0) ;',
  12474. 'if (rtl.length($mod.TheArray) > 0) ;',
  12475. '']));
  12476. end;
  12477. procedure TTestModule.TestJSValue_Params;
  12478. begin
  12479. StartProgram(false);
  12480. Add('type');
  12481. Add(' integer = longint;');
  12482. Add(' TYesNo = boolean;');
  12483. Add(' TFloat = double;');
  12484. Add(' TCaption = string;');
  12485. Add(' TChar = char;');
  12486. Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
  12487. Add('var');
  12488. Add(' l: jsvalue;');
  12489. Add('begin');
  12490. Add(' a:=a;');
  12491. Add(' l:=b;');
  12492. Add(' c:=c;');
  12493. Add(' d:=d;');
  12494. Add(' Result:=l;');
  12495. Add('end;');
  12496. Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
  12497. Add('var');
  12498. Add(' v: jsvalue;');
  12499. Add(' i: integer;');
  12500. Add(' b: TYesNo;');
  12501. Add(' d: TFloat;');
  12502. Add(' s: TCaption;');
  12503. Add(' c: TChar;');
  12504. Add('begin');
  12505. Add(' v:=doit(v,v,v,v);');
  12506. Add(' i:=integer(dosome(i,i));');
  12507. Add(' b:=TYesNo(dosome(b,b));');
  12508. Add(' d:=TFloat(dosome(d,d));');
  12509. Add(' s:=TCaption(dosome(s,s));');
  12510. Add(' c:=TChar(dosome(c,c));');
  12511. ConvertProgram;
  12512. CheckSource('TestJSValue_Params',
  12513. LinesToStr([ // statements
  12514. 'this.DoIt = function (a, b, c, d) {',
  12515. ' var Result = undefined;',
  12516. ' var l = undefined;',
  12517. ' a = a;',
  12518. ' l = b;',
  12519. ' c.set(c.get());',
  12520. ' d.set(d.get());',
  12521. ' Result = l;',
  12522. ' return Result;',
  12523. '};',
  12524. 'this.DoSome = function (a, b) {',
  12525. ' var Result = undefined;',
  12526. ' return Result;',
  12527. '};',
  12528. 'this.v = undefined;',
  12529. 'this.i = 0;',
  12530. 'this.b = false;',
  12531. 'this.d = 0.0;',
  12532. 'this.s = "";',
  12533. 'this.c = "";',
  12534. '']),
  12535. LinesToStr([ // $mod.$main
  12536. '$mod.v = $mod.DoIt($mod.v, $mod.v, {',
  12537. ' p: $mod,',
  12538. ' get: function () {',
  12539. ' return this.p.v;',
  12540. ' },',
  12541. ' set: function (v) {',
  12542. ' this.p.v = v;',
  12543. ' }',
  12544. '}, {',
  12545. ' p: $mod,',
  12546. ' get: function () {',
  12547. ' return this.p.v;',
  12548. ' },',
  12549. ' set: function (v) {',
  12550. ' this.p.v = v;',
  12551. ' }',
  12552. '});',
  12553. '$mod.i = Math.floor($mod.DoSome($mod.i, $mod.i));',
  12554. '$mod.b = !($mod.DoSome($mod.b, $mod.b) == false);',
  12555. '$mod.d = rtl.getNumber($mod.DoSome($mod.d, $mod.d));',
  12556. '$mod.s = "" + $mod.DoSome($mod.s, $mod.s);',
  12557. '$mod.c = rtl.getChar($mod.DoSome($mod.c, $mod.c));',
  12558. '']));
  12559. end;
  12560. procedure TTestModule.TestJSValue_UntypedParam;
  12561. begin
  12562. StartProgram(false);
  12563. Add('function DoIt(const a; var b; out c): jsvalue;');
  12564. Add('begin');
  12565. Add(' Result:=a;');
  12566. Add(' Result:=b;');
  12567. Add(' Result:=c;');
  12568. Add(' b:=Result;');
  12569. Add(' c:=Result;');
  12570. Add('end;');
  12571. Add('var i: longint;');
  12572. Add('begin');
  12573. Add(' doit(i,i,i);');
  12574. ConvertProgram;
  12575. CheckSource('TestJSValue_UntypedParam',
  12576. LinesToStr([ // statements
  12577. 'this.DoIt = function (a, b, c) {',
  12578. ' var Result = undefined;',
  12579. ' Result = a;',
  12580. ' Result = b.get();',
  12581. ' Result = c.get();',
  12582. ' b.set(Result);',
  12583. ' c.set(Result);',
  12584. ' return Result;',
  12585. '};',
  12586. 'this.i = 0;',
  12587. '']),
  12588. LinesToStr([ // $mod.$main
  12589. '$mod.DoIt($mod.i, {',
  12590. ' p: $mod,',
  12591. ' get: function () {',
  12592. ' return this.p.i;',
  12593. ' },',
  12594. ' set: function (v) {',
  12595. ' this.p.i = v;',
  12596. ' }',
  12597. '}, {',
  12598. ' p: $mod,',
  12599. ' get: function () {',
  12600. ' return this.p.i;',
  12601. ' },',
  12602. ' set: function (v) {',
  12603. ' this.p.i = v;',
  12604. ' }',
  12605. '});',
  12606. '']));
  12607. end;
  12608. procedure TTestModule.TestJSValue_FuncResultType;
  12609. begin
  12610. StartProgram(false);
  12611. Add('type');
  12612. Add(' integer = longint;');
  12613. Add(' TJSValueArray = array of JSValue;');
  12614. Add(' TListSortCompare = function(Item1, Item2: JSValue): Integer;');
  12615. Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
  12616. Add('begin');
  12617. Add(' while Compare(P,aList[0])>0 do ;');
  12618. Add('end;');
  12619. Add('var');
  12620. Add(' Compare: TListSortCompare;');
  12621. Add(' V: JSValue;');
  12622. Add(' i: integer;');
  12623. Add('begin');
  12624. Add(' if Compare(V,V)>0 then ;');
  12625. Add(' if Compare(i,i)>1 then ;');
  12626. Add(' if Compare(nil,false)>2 then ;');
  12627. Add(' if Compare(1,true)>3 then ;');
  12628. ConvertProgram;
  12629. CheckSource('TestJSValue_UntypedParam',
  12630. LinesToStr([ // statements
  12631. 'this.Sort = function (P, aList, Compare) {',
  12632. ' while (Compare(P, aList[0]) > 0) {',
  12633. ' };',
  12634. '};',
  12635. 'this.Compare = null;',
  12636. 'this.V = undefined;',
  12637. 'this.i = 0;',
  12638. '']),
  12639. LinesToStr([ // $mod.$main
  12640. 'if ($mod.Compare($mod.V, $mod.V) > 0) ;',
  12641. 'if ($mod.Compare($mod.i, $mod.i) > 1) ;',
  12642. 'if ($mod.Compare(null, false) > 2) ;',
  12643. 'if ($mod.Compare(1, true) > 3) ;',
  12644. '']));
  12645. end;
  12646. procedure TTestModule.TestJSValue_ProcType_Assign;
  12647. begin
  12648. StartProgram(false);
  12649. Add('type');
  12650. Add(' integer = longint;');
  12651. Add(' TObject = class');
  12652. Add(' class function GetGlob: integer;');
  12653. Add(' function Getter: integer;');
  12654. Add(' end;');
  12655. Add('class function TObject.GetGlob: integer;');
  12656. Add('var v1: jsvalue;');
  12657. Add('begin');
  12658. Add(' v1:=@GetGlob;');
  12659. Add(' v1:[email protected];');
  12660. Add('end;');
  12661. Add('function TObject.Getter: integer;');
  12662. Add('var v2: jsvalue;');
  12663. Add('begin');
  12664. Add(' v2:=@Getter;');
  12665. Add(' v2:[email protected];');
  12666. Add(' v2:=@GetGlob;');
  12667. Add(' v2:[email protected];');
  12668. Add('end;');
  12669. Add('function GetIt(i: integer): integer;');
  12670. Add('var v3: jsvalue;');
  12671. Add('begin');
  12672. Add(' v3:=@GetIt;');
  12673. Add('end;');
  12674. Add('var');
  12675. Add(' V: JSValue;');
  12676. Add(' o: TObject;');
  12677. Add('begin');
  12678. Add(' v:=@GetIt;');
  12679. Add(' v:[email protected];');
  12680. Add(' v:[email protected];');
  12681. ConvertProgram;
  12682. CheckSource('TestJSValue_ProcType_Assign',
  12683. LinesToStr([ // statements
  12684. 'rtl.createClass($mod, "TObject", null, function () {',
  12685. ' this.$init = function () {',
  12686. ' };',
  12687. ' this.$final = function () {',
  12688. ' };',
  12689. ' this.GetGlob = function () {',
  12690. ' var Result = 0;',
  12691. ' var v1 = undefined;',
  12692. ' v1 = rtl.createCallback(this, "GetGlob");',
  12693. ' v1 = rtl.createCallback(this, "GetGlob");',
  12694. ' return Result;',
  12695. ' };',
  12696. ' this.Getter = function () {',
  12697. ' var Result = 0;',
  12698. ' var v2 = undefined;',
  12699. ' v2 = rtl.createCallback(this, "Getter");',
  12700. ' v2 = rtl.createCallback(this, "Getter");',
  12701. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  12702. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  12703. ' return Result;',
  12704. ' };',
  12705. '});',
  12706. 'this.GetIt = function (i) {',
  12707. ' var Result = 0;',
  12708. ' var v3 = undefined;',
  12709. ' v3 = $mod.GetIt;',
  12710. ' return Result;',
  12711. '};',
  12712. 'this.V = undefined;',
  12713. 'this.o = null;',
  12714. '']),
  12715. LinesToStr([ // $mod.$main
  12716. '$mod.V = $mod.GetIt;',
  12717. '$mod.V = rtl.createCallback($mod.o, "Getter");',
  12718. '$mod.V = rtl.createCallback($mod.o.$class, "GetGlob");',
  12719. '']));
  12720. end;
  12721. procedure TTestModule.TestJSValue_ProcType_Equal;
  12722. begin
  12723. StartProgram(false);
  12724. Add('type');
  12725. Add(' integer = longint;');
  12726. Add(' TObject = class');
  12727. Add(' class function GetGlob: integer;');
  12728. Add(' function Getter: integer;');
  12729. Add(' end;');
  12730. Add('class function TObject.GetGlob: integer;');
  12731. Add('var v1: jsvalue;');
  12732. Add('begin');
  12733. Add(' if v1=@GetGlob then;');
  12734. Add(' if [email protected] then ;');
  12735. Add('end;');
  12736. Add('function TObject.Getter: integer;');
  12737. Add('var v2: jsvalue;');
  12738. Add('begin');
  12739. Add(' if v2=@Getter then;');
  12740. Add(' if [email protected] then ;');
  12741. Add(' if v2=@GetGlob then;');
  12742. Add(' if [email protected] then;');
  12743. Add('end;');
  12744. Add('function GetIt(i: integer): integer;');
  12745. Add('var v3: jsvalue;');
  12746. Add('begin');
  12747. Add(' if v3=@GetIt then;');
  12748. Add('end;');
  12749. Add('var');
  12750. Add(' V: JSValue;');
  12751. Add(' o: TObject;');
  12752. Add('begin');
  12753. Add(' if v=@GetIt then;');
  12754. Add(' if [email protected] then;');
  12755. Add(' if [email protected] then;');
  12756. Add(' if @GetIt=v then;');
  12757. Add(' if @o.Getter=v then;');
  12758. Add(' if @o.GetGlob=v then;');
  12759. ConvertProgram;
  12760. CheckSource('TestJSValue_ProcType_Equal',
  12761. LinesToStr([ // statements
  12762. 'rtl.createClass($mod, "TObject", null, function () {',
  12763. ' this.$init = function () {',
  12764. ' };',
  12765. ' this.$final = function () {',
  12766. ' };',
  12767. ' this.GetGlob = function () {',
  12768. ' var Result = 0;',
  12769. ' var v1 = undefined;',
  12770. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  12771. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  12772. ' return Result;',
  12773. ' };',
  12774. ' this.Getter = function () {',
  12775. ' var Result = 0;',
  12776. ' var v2 = undefined;',
  12777. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  12778. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  12779. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  12780. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  12781. ' return Result;',
  12782. ' };',
  12783. '});',
  12784. 'this.GetIt = function (i) {',
  12785. ' var Result = 0;',
  12786. ' var v3 = undefined;',
  12787. ' if (rtl.eqCallback(v3, $mod.GetIt)) ;',
  12788. ' return Result;',
  12789. '};',
  12790. 'this.V = undefined;',
  12791. 'this.o = null;',
  12792. '']),
  12793. LinesToStr([ // $mod.$main
  12794. 'if (rtl.eqCallback($mod.V, $mod.GetIt)) ;',
  12795. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o, "Getter"))) ;',
  12796. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o.$class, "GetGlob"))) ;',
  12797. 'if (rtl.eqCallback($mod.GetIt, $mod.V)) ;',
  12798. 'if (rtl.eqCallback(rtl.createCallback($mod.o, "Getter"), $mod.V)) ;',
  12799. 'if (rtl.eqCallback(rtl.createCallback($mod.o.$class, "GetGlob"), $mod.V)) ;',
  12800. '']));
  12801. end;
  12802. procedure TTestModule.TestJSValue_AssignToPointerFail;
  12803. begin
  12804. StartProgram(false);
  12805. Add([
  12806. 'var',
  12807. ' v: JSValue;',
  12808. ' p: Pointer;',
  12809. 'begin',
  12810. ' p:=v;',
  12811. '']);
  12812. SetExpectedPasResolverError('Incompatible types: got "JSValue" expected "Pointer"',
  12813. nIncompatibleTypesGotExpected);
  12814. ConvertProgram;
  12815. end;
  12816. procedure TTestModule.TestJSValue_OverloadDouble;
  12817. begin
  12818. StartProgram(false);
  12819. Add([
  12820. 'type',
  12821. ' integer = longint;',
  12822. ' tdatetime = double;',
  12823. 'procedure DoIt(d: double); begin end;',
  12824. 'procedure DoIt(v: jsvalue); begin end;',
  12825. 'var',
  12826. ' d: double;',
  12827. ' dt: tdatetime;',
  12828. ' i: integer;',
  12829. ' b: byte;',
  12830. ' shi: shortint;',
  12831. ' w: word;',
  12832. ' smi: smallint;',
  12833. ' lw: longword;',
  12834. ' li: longint;',
  12835. ' ni: nativeint;',
  12836. ' nu: nativeuint;',
  12837. 'begin',
  12838. ' DoIt(d);',
  12839. ' DoIt(dt);',
  12840. ' DoIt(i);',
  12841. ' DoIt(b);',
  12842. ' DoIt(shi);',
  12843. ' DoIt(w);',
  12844. ' DoIt(smi);',
  12845. ' DoIt(lw);',
  12846. ' DoIt(li);',
  12847. ' DoIt(ni);',
  12848. ' DoIt(nu);',
  12849. '']);
  12850. ConvertProgram;
  12851. CheckSource('TestJSValue_OverloadDouble',
  12852. LinesToStr([ // statements
  12853. 'this.DoIt = function (d) {',
  12854. '};',
  12855. 'this.DoIt$1 = function (v) {',
  12856. '};',
  12857. 'this.d = 0.0;',
  12858. 'this.dt = 0.0;',
  12859. 'this.i = 0;',
  12860. 'this.b = 0;',
  12861. 'this.shi = 0;',
  12862. 'this.w = 0;',
  12863. 'this.smi = 0;',
  12864. 'this.lw = 0;',
  12865. 'this.li = 0;',
  12866. 'this.ni = 0;',
  12867. 'this.nu = 0;',
  12868. '']),
  12869. LinesToStr([ // $mod.$main
  12870. '$mod.DoIt($mod.d);',
  12871. '$mod.DoIt($mod.dt);',
  12872. '$mod.DoIt($mod.i);',
  12873. '$mod.DoIt($mod.b);',
  12874. '$mod.DoIt($mod.shi);',
  12875. '$mod.DoIt($mod.w);',
  12876. '$mod.DoIt($mod.smi);',
  12877. '$mod.DoIt($mod.lw);',
  12878. '$mod.DoIt($mod.li);',
  12879. '$mod.DoIt($mod.ni);',
  12880. '$mod.DoIt($mod.nu);',
  12881. '']));
  12882. end;
  12883. procedure TTestModule.TestJSValue_OverloadNativeInt;
  12884. begin
  12885. StartProgram(false);
  12886. Add([
  12887. 'type',
  12888. ' integer = longint;',
  12889. ' int53 = nativeint;',
  12890. ' tdatetime = double;',
  12891. 'procedure DoIt(n: nativeint); begin end;',
  12892. 'procedure DoIt(v: jsvalue); begin end;',
  12893. 'var',
  12894. ' d: double;',
  12895. ' dt: tdatetime;',
  12896. ' i: integer;',
  12897. ' b: byte;',
  12898. ' shi: shortint;',
  12899. ' w: word;',
  12900. ' smi: smallint;',
  12901. ' lw: longword;',
  12902. ' li: longint;',
  12903. ' ni: nativeint;',
  12904. ' nu: nativeuint;',
  12905. 'begin',
  12906. ' DoIt(d);',
  12907. ' DoIt(dt);',
  12908. ' DoIt(i);',
  12909. ' DoIt(b);',
  12910. ' DoIt(shi);',
  12911. ' DoIt(w);',
  12912. ' DoIt(smi);',
  12913. ' DoIt(lw);',
  12914. ' DoIt(li);',
  12915. ' DoIt(ni);',
  12916. ' DoIt(nu);',
  12917. '']);
  12918. ConvertProgram;
  12919. CheckSource('TestJSValue_OverloadNativeInt',
  12920. LinesToStr([ // statements
  12921. 'this.DoIt = function (n) {',
  12922. '};',
  12923. 'this.DoIt$1 = function (v) {',
  12924. '};',
  12925. 'this.d = 0.0;',
  12926. 'this.dt = 0.0;',
  12927. 'this.i = 0;',
  12928. 'this.b = 0;',
  12929. 'this.shi = 0;',
  12930. 'this.w = 0;',
  12931. 'this.smi = 0;',
  12932. 'this.lw = 0;',
  12933. 'this.li = 0;',
  12934. 'this.ni = 0;',
  12935. 'this.nu = 0;',
  12936. '']),
  12937. LinesToStr([ // $mod.$main
  12938. '$mod.DoIt$1($mod.d);',
  12939. '$mod.DoIt$1($mod.dt);',
  12940. '$mod.DoIt($mod.i);',
  12941. '$mod.DoIt($mod.b);',
  12942. '$mod.DoIt($mod.shi);',
  12943. '$mod.DoIt($mod.w);',
  12944. '$mod.DoIt($mod.smi);',
  12945. '$mod.DoIt($mod.lw);',
  12946. '$mod.DoIt($mod.li);',
  12947. '$mod.DoIt($mod.ni);',
  12948. '$mod.DoIt($mod.nu);',
  12949. '']));
  12950. end;
  12951. procedure TTestModule.TestJSValue_OverloadWord;
  12952. begin
  12953. StartProgram(false);
  12954. Add([
  12955. 'type',
  12956. ' integer = longint;',
  12957. ' int53 = nativeint;',
  12958. ' tdatetime = double;',
  12959. 'procedure DoIt(w: word); begin end;',
  12960. 'procedure DoIt(v: jsvalue); begin end;',
  12961. 'var',
  12962. ' d: double;',
  12963. ' dt: tdatetime;',
  12964. ' i: integer;',
  12965. ' b: byte;',
  12966. ' shi: shortint;',
  12967. ' w: word;',
  12968. ' smi: smallint;',
  12969. ' lw: longword;',
  12970. ' li: longint;',
  12971. ' ni: nativeint;',
  12972. ' nu: nativeuint;',
  12973. 'begin',
  12974. ' DoIt(d);',
  12975. ' DoIt(dt);',
  12976. ' DoIt(i);',
  12977. ' DoIt(b);',
  12978. ' DoIt(shi);',
  12979. ' DoIt(w);',
  12980. ' DoIt(smi);',
  12981. ' DoIt(lw);',
  12982. ' DoIt(li);',
  12983. ' DoIt(ni);',
  12984. ' DoIt(nu);',
  12985. '']);
  12986. ConvertProgram;
  12987. CheckSource('TestJSValue_OverloadWord',
  12988. LinesToStr([ // statements
  12989. 'this.DoIt = function (w) {',
  12990. '};',
  12991. 'this.DoIt$1 = function (v) {',
  12992. '};',
  12993. 'this.d = 0.0;',
  12994. 'this.dt = 0.0;',
  12995. 'this.i = 0;',
  12996. 'this.b = 0;',
  12997. 'this.shi = 0;',
  12998. 'this.w = 0;',
  12999. 'this.smi = 0;',
  13000. 'this.lw = 0;',
  13001. 'this.li = 0;',
  13002. 'this.ni = 0;',
  13003. 'this.nu = 0;',
  13004. '']),
  13005. LinesToStr([ // $mod.$main
  13006. '$mod.DoIt$1($mod.d);',
  13007. '$mod.DoIt$1($mod.dt);',
  13008. '$mod.DoIt$1($mod.i);',
  13009. '$mod.DoIt($mod.b);',
  13010. '$mod.DoIt($mod.shi);',
  13011. '$mod.DoIt($mod.w);',
  13012. '$mod.DoIt$1($mod.smi);',
  13013. '$mod.DoIt$1($mod.lw);',
  13014. '$mod.DoIt$1($mod.li);',
  13015. '$mod.DoIt$1($mod.ni);',
  13016. '$mod.DoIt$1($mod.nu);',
  13017. '']));
  13018. end;
  13019. procedure TTestModule.TestJSValue_OverloadString;
  13020. begin
  13021. StartProgram(false);
  13022. Add([
  13023. 'type',
  13024. ' uni = string;',
  13025. ' WChar = char;',
  13026. 'procedure DoIt(s: string); begin end;',
  13027. 'procedure DoIt(v: jsvalue); begin end;',
  13028. 'var',
  13029. ' s: string;',
  13030. ' c: char;',
  13031. ' u: uni;',
  13032. 'begin',
  13033. ' DoIt(s);',
  13034. ' DoIt(c);',
  13035. ' DoIt(u);',
  13036. '']);
  13037. ConvertProgram;
  13038. CheckSource('TestJSValue_OverloadString',
  13039. LinesToStr([ // statements
  13040. 'this.DoIt = function (s) {',
  13041. '};',
  13042. 'this.DoIt$1 = function (v) {',
  13043. '};',
  13044. 'this.s = "";',
  13045. 'this.c = "";',
  13046. 'this.u = "";',
  13047. '']),
  13048. LinesToStr([ // $mod.$main
  13049. '$mod.DoIt($mod.s);',
  13050. '$mod.DoIt($mod.c);',
  13051. '$mod.DoIt($mod.u);',
  13052. '']));
  13053. end;
  13054. procedure TTestModule.TestJSValue_OverloadChar;
  13055. begin
  13056. StartProgram(false);
  13057. Add([
  13058. 'type',
  13059. ' uni = string;',
  13060. ' WChar = char;',
  13061. 'procedure DoIt(c: char); begin end;',
  13062. 'procedure DoIt(v: jsvalue); begin end;',
  13063. 'var',
  13064. ' s: string;',
  13065. ' c: char;',
  13066. ' u: uni;',
  13067. 'begin',
  13068. ' DoIt(s);',
  13069. ' DoIt(c);',
  13070. ' DoIt(u);',
  13071. '']);
  13072. ConvertProgram;
  13073. CheckSource('TestJSValue_OverloadChar',
  13074. LinesToStr([ // statements
  13075. 'this.DoIt = function (c) {',
  13076. '};',
  13077. 'this.DoIt$1 = function (v) {',
  13078. '};',
  13079. 'this.s = "";',
  13080. 'this.c = "";',
  13081. 'this.u = "";',
  13082. '']),
  13083. LinesToStr([ // $mod.$main
  13084. '$mod.DoIt$1($mod.s);',
  13085. '$mod.DoIt($mod.c);',
  13086. '$mod.DoIt$1($mod.u);',
  13087. '']));
  13088. end;
  13089. procedure TTestModule.TestJSValue_OverloadPointer;
  13090. begin
  13091. StartProgram(false);
  13092. Add([
  13093. 'type',
  13094. ' TObject = class end;',
  13095. 'procedure DoIt(p: pointer); begin end;',
  13096. 'procedure DoIt(v: jsvalue); begin end;',
  13097. 'var',
  13098. ' o: TObject;',
  13099. 'begin',
  13100. ' DoIt(o);',
  13101. '']);
  13102. ConvertProgram;
  13103. CheckSource('TestJSValue_OverloadPointer',
  13104. LinesToStr([ // statements
  13105. 'rtl.createClass($mod, "TObject", null, function () {',
  13106. ' this.$init = function () {',
  13107. ' };',
  13108. ' this.$final = function () {',
  13109. ' };',
  13110. '});',
  13111. 'this.DoIt = function (p) {',
  13112. '};',
  13113. 'this.DoIt$1 = function (v) {',
  13114. '};',
  13115. 'this.o = null;',
  13116. '']),
  13117. LinesToStr([ // $mod.$main
  13118. '$mod.DoIt($mod.o);',
  13119. '']));
  13120. end;
  13121. procedure TTestModule.TestRTTI_ProcType;
  13122. begin
  13123. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13124. StartProgram(false);
  13125. Add('type');
  13126. Add(' TProcA = procedure;');
  13127. Add(' TMethodB = procedure of object;');
  13128. Add(' TProcC = procedure; varargs;');
  13129. Add(' TProcD = procedure(i: longint; const j: string; var c: char; out d: double);');
  13130. Add(' TProcE = function: nativeint;');
  13131. Add(' TProcF = function(const p: TProcA): nativeuint;');
  13132. Add('var p: pointer;');
  13133. Add('begin');
  13134. Add(' p:=typeinfo(tproca);');
  13135. ConvertProgram;
  13136. CheckSource('TestRTTI_ProcType',
  13137. LinesToStr([ // statements
  13138. '$mod.$rtti.$ProcVar("TProcA", {',
  13139. ' procsig: rtl.newTIProcSig(null)',
  13140. '});',
  13141. '$mod.$rtti.$MethodVar("TMethodB", {',
  13142. ' procsig: rtl.newTIProcSig(null),',
  13143. ' methodkind: 0',
  13144. '});',
  13145. '$mod.$rtti.$ProcVar("TProcC", {',
  13146. ' procsig: rtl.newTIProcSig(null, 2)',
  13147. '});',
  13148. '$mod.$rtti.$ProcVar("TProcD", {',
  13149. ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
  13150. '});',
  13151. '$mod.$rtti.$ProcVar("TProcE", {',
  13152. ' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
  13153. '});',
  13154. '$mod.$rtti.$ProcVar("TProcF", {',
  13155. ' procsig: rtl.newTIProcSig([["p", $mod.$rtti["TProcA"], 2]], rtl.nativeuint)',
  13156. '});',
  13157. 'this.p = null;',
  13158. '']),
  13159. LinesToStr([ // $mod.$main
  13160. '$mod.p = $mod.$rtti["TProcA"];',
  13161. '']));
  13162. end;
  13163. procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
  13164. begin
  13165. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13166. AddModuleWithIntfImplSrc('unit2.pas',
  13167. LinesToStr([
  13168. 'type',
  13169. ' TObject = class end;'
  13170. ]),
  13171. '');
  13172. StartUnit(true);
  13173. Add('interface');
  13174. Add('uses unit2;');
  13175. Add('type');
  13176. Add(' TProcA = function(o: tobject): tobject;');
  13177. Add('implementation');
  13178. Add('type');
  13179. Add(' TProcB = function(o: tobject): tobject;');
  13180. Add('var p: Pointer;');
  13181. Add('initialization');
  13182. Add(' p:=typeinfo(tproca);');
  13183. Add(' p:=typeinfo(tprocb);');
  13184. ConvertUnit;
  13185. CheckSource('TestRTTI_ProcType_ArgFromOtherUnit',
  13186. LinesToStr([ // statements
  13187. 'var $impl = $mod.$impl;',
  13188. '$mod.$rtti.$ProcVar("TProcA", {',
  13189. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  13190. '});',
  13191. '']),
  13192. LinesToStr([ // this.$init
  13193. '$impl.p = $mod.$rtti["TProcA"];',
  13194. '$impl.p = $mod.$rtti["TProcB"];',
  13195. '']),
  13196. LinesToStr([ // implementation
  13197. '$mod.$rtti.$ProcVar("TProcB", {',
  13198. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  13199. '});',
  13200. '$impl.p = null;',
  13201. '']) );
  13202. end;
  13203. procedure TTestModule.TestRTTI_EnumAndSetType;
  13204. begin
  13205. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13206. StartProgram(false);
  13207. Add('type');
  13208. Add(' TFlag = (light,dark);');
  13209. Add(' TFlags = set of TFlag;');
  13210. Add(' TProc = function(f: TFlags): TFlag;');
  13211. Add('var p: pointer;');
  13212. Add('begin');
  13213. Add(' p:=typeinfo(tflag);');
  13214. Add(' p:=typeinfo(tflags);');
  13215. ConvertProgram;
  13216. CheckSource('TestRTTI_EnumAndType',
  13217. LinesToStr([ // statements
  13218. 'this.TFlag = {',
  13219. ' "0": "light",',
  13220. ' light: 0,',
  13221. ' "1": "dark",',
  13222. ' dark: 1',
  13223. '};',
  13224. '$mod.$rtti.$Enum("TFlag", {',
  13225. ' minvalue: 0,',
  13226. ' maxvalue: 1,',
  13227. ' ordtype: 1,',
  13228. ' enumtype: this.TFlag',
  13229. '});',
  13230. '$mod.$rtti.$Set("TFlags", {',
  13231. ' comptype: $mod.$rtti["TFlag"]',
  13232. '});',
  13233. '$mod.$rtti.$ProcVar("TProc", {',
  13234. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TFlags"]]], $mod.$rtti["TFlag"])',
  13235. '});',
  13236. 'this.p = null;',
  13237. '']),
  13238. LinesToStr([ // $mod.$main
  13239. '$mod.p = $mod.$rtti["TFlag"];',
  13240. '$mod.p = $mod.$rtti["TFlags"];',
  13241. '']));
  13242. end;
  13243. procedure TTestModule.TestRTTI_EnumRange;
  13244. begin
  13245. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13246. StartProgram(false);
  13247. Add([
  13248. 'type',
  13249. ' TCol = (red,green,blue);',
  13250. ' TColRg = green..blue;',
  13251. ' TSetOfColRg = set of TColRg;',
  13252. 'var p: pointer;',
  13253. 'begin',
  13254. ' p:=typeinfo(tcolrg);',
  13255. ' p:=typeinfo(tsetofcolrg);',
  13256. '']);
  13257. ConvertProgram;
  13258. end;
  13259. procedure TTestModule.TestRTTI_AnonymousEnumType;
  13260. begin
  13261. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13262. StartProgram(false);
  13263. Add('type');
  13264. Add(' TFlags = set of (red, green);');
  13265. Add('var');
  13266. Add(' f: TFlags;');
  13267. Add('begin');
  13268. Add(' Include(f,red);');
  13269. ConvertProgram;
  13270. CheckSource('TestRTTI_AnonymousEnumType',
  13271. LinesToStr([ // statements
  13272. 'this.TFlags$a = {',
  13273. ' "0": "red",',
  13274. ' red: 0,',
  13275. ' "1": "green",',
  13276. ' green: 1',
  13277. '};',
  13278. '$mod.$rtti.$Enum("TFlags$a", {',
  13279. ' minvalue: 0,',
  13280. ' maxvalue: 1,',
  13281. ' ordtype: 1,',
  13282. ' enumtype: this.TFlags$a',
  13283. '});',
  13284. '$mod.$rtti.$Set("TFlags", {',
  13285. ' comptype: $mod.$rtti["TFlags$a"]',
  13286. '});',
  13287. 'this.f = {};',
  13288. '']),
  13289. LinesToStr([
  13290. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  13291. '']));
  13292. end;
  13293. procedure TTestModule.TestRTTI_StaticArray;
  13294. begin
  13295. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13296. StartProgram(false);
  13297. Add('type');
  13298. Add(' TFlag = (light,dark);');
  13299. Add(' TFlagNames = array[TFlag] of string;');
  13300. Add(' TBoolNames = array[boolean] of string;');
  13301. Add(' TByteArray = array[1..32768] of byte;');
  13302. Add(' TProc = function(f: TBoolNames): TFlagNames;');
  13303. Add('var p: pointer;');
  13304. Add('begin');
  13305. Add(' p:=typeinfo(TFlagNames);');
  13306. Add(' p:=typeinfo(TBoolNames);');
  13307. ConvertProgram;
  13308. CheckSource('TestRTTI_StaticArray',
  13309. LinesToStr([ // statements
  13310. 'this.TFlag = {',
  13311. ' "0": "light",',
  13312. ' light: 0,',
  13313. ' "1": "dark",',
  13314. ' dark: 1',
  13315. '};',
  13316. '$mod.$rtti.$Enum("TFlag", {',
  13317. ' minvalue: 0,',
  13318. ' maxvalue: 1,',
  13319. ' ordtype: 1,',
  13320. ' enumtype: this.TFlag',
  13321. '});',
  13322. '$mod.$rtti.$StaticArray("TFlagNames", {',
  13323. ' dims: [2],',
  13324. ' eltype: rtl.string',
  13325. '});',
  13326. '$mod.$rtti.$StaticArray("TBoolNames", {',
  13327. ' dims: [2],',
  13328. ' eltype: rtl.string',
  13329. '});',
  13330. '$mod.$rtti.$StaticArray("TByteArray", {',
  13331. ' dims: [32768],',
  13332. ' eltype: rtl.byte',
  13333. '});',
  13334. '$mod.$rtti.$ProcVar("TProc", {',
  13335. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TBoolNames"]]], $mod.$rtti["TFlagNames"])',
  13336. '});',
  13337. 'this.p = null;',
  13338. '']),
  13339. LinesToStr([ // $mod.$main
  13340. '$mod.p = $mod.$rtti["TFlagNames"];',
  13341. '$mod.p = $mod.$rtti["TBoolNames"];',
  13342. '']));
  13343. end;
  13344. procedure TTestModule.TestRTTI_DynArray;
  13345. begin
  13346. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13347. StartProgram(false);
  13348. Add('type');
  13349. Add(' TArrStr = array of string;');
  13350. Add(' TArr2Dim = array of tarrstr;');
  13351. Add(' TProc = function(f: TArrStr): TArr2Dim;');
  13352. Add('var p: pointer;');
  13353. Add('begin');
  13354. Add(' p:=typeinfo(tarrstr);');
  13355. Add(' p:=typeinfo(tarr2dim);');
  13356. ConvertProgram;
  13357. CheckSource('TestRTTI_DynArray',
  13358. LinesToStr([ // statements
  13359. '$mod.$rtti.$DynArray("TArrStr", {',
  13360. ' eltype: rtl.string',
  13361. '});',
  13362. '$mod.$rtti.$DynArray("TArr2Dim", {',
  13363. ' eltype: $mod.$rtti["TArrStr"]',
  13364. '});',
  13365. '$mod.$rtti.$ProcVar("TProc", {',
  13366. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TArrStr"]]], $mod.$rtti["TArr2Dim"])',
  13367. '});',
  13368. 'this.p = null;',
  13369. '']),
  13370. LinesToStr([ // $mod.$main
  13371. '$mod.p = $mod.$rtti["TArrStr"];',
  13372. '$mod.p = $mod.$rtti["TArr2Dim"];',
  13373. '']));
  13374. end;
  13375. procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
  13376. begin
  13377. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13378. StartProgram(false);
  13379. Add('type');
  13380. Add(' TArr = array of array of longint;');
  13381. Add('var a: TArr;');
  13382. Add('begin');
  13383. ConvertProgram;
  13384. CheckSource('TestRTTI_ArrayNestedAnonymous',
  13385. LinesToStr([ // statements
  13386. '$mod.$rtti.$DynArray("TArr$a", {',
  13387. ' eltype: rtl.longint',
  13388. '});',
  13389. '$mod.$rtti.$DynArray("TArr", {',
  13390. ' eltype: $mod.$rtti["TArr$a"]',
  13391. '});',
  13392. 'this.a = [];',
  13393. '']),
  13394. LinesToStr([ // $mod.$main
  13395. ]));
  13396. end;
  13397. procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
  13398. begin
  13399. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13400. StartProgram(false);
  13401. Add('type');
  13402. Add(' TObject = class');
  13403. Add(' published');
  13404. Add(' procedure Proc; virtual; abstract;');
  13405. Add(' procedure Proc(Sender: tobject); virtual; abstract;');
  13406. Add(' end;');
  13407. Add('begin');
  13408. SetExpectedPasResolverError('Duplicate identifier "Proc" at test1.pp(6,19)',
  13409. nDuplicateIdentifier);
  13410. ConvertProgram;
  13411. end;
  13412. procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
  13413. begin
  13414. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13415. StartProgram(false);
  13416. Add('type');
  13417. Add(' TObject = class');
  13418. Add(' published');
  13419. Add(' procedure Proc; external name ''foo'';');
  13420. Add(' end;');
  13421. Add('begin');
  13422. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  13423. nPublishedNameMustMatchExternal);
  13424. ConvertProgram;
  13425. end;
  13426. procedure TTestModule.TestRTTI_PublishedClassPropertyFail;
  13427. begin
  13428. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13429. StartProgram(false);
  13430. Add('type');
  13431. Add(' TObject = class');
  13432. Add(' class var FA: longint;');
  13433. Add(' published');
  13434. Add(' class property A: longint read FA;');
  13435. Add(' end;');
  13436. Add('begin');
  13437. SetExpectedPasResolverError('Invalid published property modifier "class"',
  13438. nInvalidXModifierY);
  13439. ConvertProgram;
  13440. end;
  13441. procedure TTestModule.TestRTTI_PublishedClassFieldFail;
  13442. begin
  13443. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13444. StartProgram(false);
  13445. Add('type');
  13446. Add(' TObject = class');
  13447. Add(' published');
  13448. Add(' class var FA: longint;');
  13449. Add(' end;');
  13450. Add('begin');
  13451. SetExpectedPasResolverError(sSymbolCannotBePublished,
  13452. nSymbolCannotBePublished);
  13453. ConvertProgram;
  13454. end;
  13455. procedure TTestModule.TestRTTI_PublishedFieldExternalFail;
  13456. begin
  13457. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13458. StartProgram(false);
  13459. Add('{$modeswitch externalclass}');
  13460. Add('type');
  13461. Add(' TObject = class');
  13462. Add(' published');
  13463. Add(' V: longint; external name ''foo'';');
  13464. Add(' end;');
  13465. Add('begin');
  13466. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  13467. nPublishedNameMustMatchExternal);
  13468. ConvertProgram;
  13469. end;
  13470. procedure TTestModule.TestRTTI_IndexModifier;
  13471. begin
  13472. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13473. StartProgram(false);
  13474. Add([
  13475. 'type',
  13476. ' TEnum = (red, blue);',
  13477. ' TObject = class',
  13478. ' FB: boolean;',
  13479. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  13480. ' function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
  13481. ' procedure SetBoolBool(Index: boolean; b: boolean); virtual; abstract;',
  13482. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  13483. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  13484. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  13485. ' published',
  13486. ' property B1: boolean index 1 read FB write SetIntBool;',
  13487. ' property B2: boolean index TEnum.blue read GetEnumBool write FB;',
  13488. ' property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
  13489. ' end;',
  13490. 'begin']);
  13491. ConvertProgram;
  13492. CheckSource('TestRTTI_IndexModifier',
  13493. LinesToStr([ // statements
  13494. 'this.TEnum = {',
  13495. ' "0": "red",',
  13496. ' red: 0,',
  13497. ' "1": "blue",',
  13498. ' blue: 1',
  13499. '};',
  13500. '$mod.$rtti.$Enum("TEnum", {',
  13501. ' minvalue: 0,',
  13502. ' maxvalue: 1,',
  13503. ' ordtype: 1,',
  13504. ' enumtype: this.TEnum',
  13505. '});',
  13506. 'rtl.createClass($mod, "TObject", null, function () {',
  13507. ' this.$init = function () {',
  13508. ' this.FB = false;',
  13509. ' };',
  13510. ' this.$final = function () {',
  13511. ' };',
  13512. ' var $r = this.$rtti;',
  13513. ' $r.addProperty(',
  13514. ' "B1",',
  13515. ' 18,',
  13516. ' rtl.boolean,',
  13517. ' "FB",',
  13518. ' "SetIntBool",',
  13519. ' {',
  13520. ' index: 1',
  13521. ' }',
  13522. ' );',
  13523. ' $r.addProperty(',
  13524. ' "B2",',
  13525. ' 17,',
  13526. ' rtl.boolean,',
  13527. ' "GetEnumBool",',
  13528. ' "FB",',
  13529. ' {',
  13530. ' index: $mod.TEnum.blue',
  13531. ' }',
  13532. ' );',
  13533. ' $r.addProperty(',
  13534. ' "I1",',
  13535. ' 19,',
  13536. ' rtl.boolean,',
  13537. ' "GetStrIntBool",',
  13538. ' "SetStrIntBool",',
  13539. ' {',
  13540. ' index: 2',
  13541. ' }',
  13542. ' );',
  13543. '});',
  13544. '']),
  13545. LinesToStr([ // $mod.$main
  13546. '']));
  13547. end;
  13548. procedure TTestModule.TestRTTI_StoredModifier;
  13549. begin
  13550. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13551. StartProgram(false);
  13552. Add([
  13553. 'const',
  13554. ' ConstB = true;',
  13555. 'type',
  13556. ' TObject = class',
  13557. ' private',
  13558. ' FB: boolean;',
  13559. ' function IsBStored: boolean; virtual; abstract;',
  13560. ' published',
  13561. ' property BoolA: boolean read FB stored true;',
  13562. ' property BoolB: boolean read FB stored false;',
  13563. ' property BoolC: boolean read FB stored FB;',
  13564. ' property BoolD: boolean read FB stored ConstB;',
  13565. ' property BoolE: boolean read FB stored IsBStored;',
  13566. ' end;',
  13567. 'begin']);
  13568. ConvertProgram;
  13569. CheckSource('TestRTTI_StoredModifier',
  13570. LinesToStr([ // statements
  13571. 'this.ConstB = true;',
  13572. 'rtl.createClass($mod, "TObject", null, function () {',
  13573. ' this.$init = function () {',
  13574. ' this.FB = false;',
  13575. ' };',
  13576. ' this.$final = function () {',
  13577. ' };',
  13578. ' var $r = this.$rtti;',
  13579. ' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
  13580. ' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
  13581. ' $r.addProperty(',
  13582. ' "BoolC",',
  13583. ' 8,',
  13584. ' rtl.boolean,',
  13585. ' "FB",',
  13586. ' "",',
  13587. ' {',
  13588. ' stored: "FB"',
  13589. ' }',
  13590. ' );',
  13591. ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
  13592. ' $r.addProperty(',
  13593. ' "BoolE",',
  13594. ' 12,',
  13595. ' rtl.boolean,',
  13596. ' "FB",',
  13597. ' "",',
  13598. ' {',
  13599. ' stored: "IsBStored"',
  13600. ' }',
  13601. ' );',
  13602. '});',
  13603. '']),
  13604. LinesToStr([ // $mod.$main
  13605. '']));
  13606. end;
  13607. procedure TTestModule.TestRTTI_DefaultValue;
  13608. begin
  13609. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13610. StartProgram(false);
  13611. Add([
  13612. 'type',
  13613. ' TEnum = (red, blue);',
  13614. 'const',
  13615. ' CB = true or false;',
  13616. ' CI = 1+2;',
  13617. 'type',
  13618. ' TObject = class',
  13619. ' FB: boolean;',
  13620. ' FI: longint;',
  13621. ' FE: TEnum;',
  13622. ' published',
  13623. ' property B1: boolean read FB default true;',
  13624. ' property B2: boolean read FB default CB;',
  13625. ' property B3: boolean read FB default test1.cb;',
  13626. ' property I1: longint read FI default 2;',
  13627. ' property I2: longint read FI default CI;',
  13628. ' property E1: TEnum read FE default red;',
  13629. ' property E2: TEnum read FE default TEnum.blue;',
  13630. ' end;',
  13631. 'begin']);
  13632. ConvertProgram;
  13633. CheckSource('TestRTTI_DefaultValue',
  13634. LinesToStr([ // statements
  13635. 'this.TEnum = {',
  13636. ' "0": "red",',
  13637. ' red: 0,',
  13638. ' "1": "blue",',
  13639. ' blue: 1',
  13640. '};',
  13641. '$mod.$rtti.$Enum("TEnum", {',
  13642. ' minvalue: 0,',
  13643. ' maxvalue: 1,',
  13644. ' ordtype: 1,',
  13645. ' enumtype: this.TEnum',
  13646. '});',
  13647. 'this.CB = true || false;',
  13648. 'this.CI = 1 + 2;',
  13649. 'rtl.createClass($mod, "TObject", null, function () {',
  13650. ' this.$init = function () {',
  13651. ' this.FB = false;',
  13652. ' this.FI = 0;',
  13653. ' this.FE = 0;',
  13654. ' };',
  13655. ' this.$final = function () {',
  13656. ' };',
  13657. ' var $r = this.$rtti;',
  13658. ' $r.addProperty(',
  13659. ' "B1",',
  13660. ' 0,',
  13661. ' rtl.boolean,',
  13662. ' "FB",',
  13663. ' "",',
  13664. ' {',
  13665. ' Default: true',
  13666. ' }',
  13667. ' );',
  13668. ' $r.addProperty(',
  13669. ' "B2",',
  13670. ' 0,',
  13671. ' rtl.boolean,',
  13672. ' "FB",',
  13673. ' "",',
  13674. ' {',
  13675. ' Default: true',
  13676. ' }',
  13677. ' );',
  13678. ' $r.addProperty(',
  13679. ' "B3",',
  13680. ' 0,',
  13681. ' rtl.boolean,',
  13682. ' "FB",',
  13683. ' "",',
  13684. ' {',
  13685. ' Default: true',
  13686. ' }',
  13687. ' );',
  13688. ' $r.addProperty(',
  13689. ' "I1",',
  13690. ' 0,',
  13691. ' rtl.longint,',
  13692. ' "FI",',
  13693. ' "",',
  13694. ' {',
  13695. ' Default: 2',
  13696. ' }',
  13697. ' );',
  13698. ' $r.addProperty(',
  13699. ' "I2",',
  13700. ' 0,',
  13701. ' rtl.longint,',
  13702. ' "FI",',
  13703. ' "",',
  13704. ' {',
  13705. ' Default: 3',
  13706. ' }',
  13707. ' );',
  13708. ' $r.addProperty(',
  13709. ' "E1",',
  13710. ' 0,',
  13711. ' $mod.$rtti["TEnum"],',
  13712. ' "FE",',
  13713. ' "",',
  13714. ' {',
  13715. ' Default: $mod.TEnum.red',
  13716. ' }',
  13717. ' );',
  13718. ' $r.addProperty(',
  13719. ' "E2",',
  13720. ' 0,',
  13721. ' $mod.$rtti["TEnum"],',
  13722. ' "FE",',
  13723. ' "",',
  13724. ' {',
  13725. ' Default: $mod.TEnum.blue',
  13726. ' }',
  13727. ' );',
  13728. '});',
  13729. '']),
  13730. LinesToStr([ // $mod.$main
  13731. '']));
  13732. end;
  13733. procedure TTestModule.TestRTTI_DefaultValueSet;
  13734. begin
  13735. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13736. StartProgram(false);
  13737. Add([
  13738. 'type',
  13739. ' TEnum = (red, blue);',
  13740. ' TSet = set of TEnum;',
  13741. 'const',
  13742. ' CSet = [red,blue];',
  13743. 'type',
  13744. ' TObject = class',
  13745. ' FSet: TSet;',
  13746. ' published',
  13747. ' property Set1: TSet read FSet default [];',
  13748. ' property Set2: TSet read FSet default [red];',
  13749. ' property Set3: TSet read FSet default [red,blue];',
  13750. ' property Set4: TSet read FSet default CSet;',
  13751. ' end;',
  13752. 'begin']);
  13753. ConvertProgram;
  13754. CheckSource('TestRTTI_DefaultValueSet',
  13755. LinesToStr([ // statements
  13756. 'this.TEnum = {',
  13757. ' "0": "red",',
  13758. ' red: 0,',
  13759. ' "1": "blue",',
  13760. ' blue: 1',
  13761. '};',
  13762. '$mod.$rtti.$Enum("TEnum", {',
  13763. ' minvalue: 0,',
  13764. ' maxvalue: 1,',
  13765. ' ordtype: 1,',
  13766. ' enumtype: this.TEnum',
  13767. '});',
  13768. '$mod.$rtti.$Set("TSet", {',
  13769. ' comptype: $mod.$rtti["TEnum"]',
  13770. '});',
  13771. 'this.CSet = rtl.createSet($mod.TEnum.red, $mod.TEnum.blue);',
  13772. 'rtl.createClass($mod, "TObject", null, function () {',
  13773. ' this.$init = function () {',
  13774. ' this.FSet = {};',
  13775. ' };',
  13776. ' this.$final = function () {',
  13777. ' this.FSet = undefined;',
  13778. ' };',
  13779. ' var $r = this.$rtti;',
  13780. ' $r.addProperty(',
  13781. ' "Set1",',
  13782. ' 0,',
  13783. ' $mod.$rtti["TSet"],',
  13784. ' "FSet",',
  13785. ' "",',
  13786. ' {',
  13787. ' Default: {}',
  13788. ' }',
  13789. ' );',
  13790. ' $r.addProperty(',
  13791. ' "Set2",',
  13792. ' 0,',
  13793. ' $mod.$rtti["TSet"],',
  13794. ' "FSet",',
  13795. ' "",',
  13796. ' {',
  13797. ' Default: rtl.createSet($mod.TEnum.red)',
  13798. ' }',
  13799. ' );',
  13800. ' $r.addProperty(',
  13801. ' "Set3",',
  13802. ' 0,',
  13803. ' $mod.$rtti["TSet"],',
  13804. ' "FSet",',
  13805. ' "",',
  13806. ' {',
  13807. ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
  13808. ' }',
  13809. ' );',
  13810. ' $r.addProperty(',
  13811. ' "Set4",',
  13812. ' 0,',
  13813. ' $mod.$rtti["TSet"],',
  13814. ' "FSet",',
  13815. ' "",',
  13816. ' {',
  13817. ' Default: $mod.CSet',
  13818. ' }',
  13819. ' );',
  13820. '});',
  13821. '']),
  13822. LinesToStr([ // $mod.$main
  13823. '']));
  13824. end;
  13825. procedure TTestModule.TestRTTI_DefaultValueRangeType;
  13826. begin
  13827. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13828. StartProgram(false);
  13829. Add([
  13830. 'type',
  13831. ' TRg = -1..1;',
  13832. 'const',
  13833. ' l = low(TRg);',
  13834. ' h = high(TRg);',
  13835. 'type',
  13836. ' TObject = class',
  13837. ' FV: TRg;',
  13838. ' published',
  13839. ' property V1: TRg read FV default -1;',
  13840. ' end;',
  13841. 'begin']);
  13842. ConvertProgram;
  13843. CheckSource('TestRTTI_DefaultValueRangeType',
  13844. LinesToStr([ // statements
  13845. '$mod.$rtti.$Int("TRg", {',
  13846. ' minvalue: -1,',
  13847. ' maxvalue: 1,',
  13848. ' ordtype: 0',
  13849. '});',
  13850. 'this.l = -1;',
  13851. 'this.h = 1;',
  13852. 'rtl.createClass($mod, "TObject", null, function () {',
  13853. ' this.$init = function () {',
  13854. ' this.FV = -1;',
  13855. ' };',
  13856. ' this.$final = function () {',
  13857. ' };',
  13858. ' var $r = this.$rtti;',
  13859. ' $r.addProperty(',
  13860. ' "V1",',
  13861. ' 0,',
  13862. ' $mod.$rtti["TRg"],',
  13863. ' "FV",',
  13864. ' "",',
  13865. ' {',
  13866. ' Default: -1',
  13867. ' }',
  13868. ' );',
  13869. '});',
  13870. '']),
  13871. LinesToStr([ // $mod.$main
  13872. '']));
  13873. end;
  13874. procedure TTestModule.TestRTTI_Class_Field;
  13875. begin
  13876. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13877. StartProgram(false);
  13878. Add('{$modeswitch externalclass}');
  13879. Add('type');
  13880. Add(' TObject = class');
  13881. Add(' private');
  13882. Add(' FPropA: string;');
  13883. Add(' published');
  13884. Add(' VarLI: longint;');
  13885. Add(' VarC: char;');
  13886. Add(' VarS: string;');
  13887. Add(' VarD: double;');
  13888. Add(' VarB: boolean;');
  13889. Add(' VarLW: longword;');
  13890. Add(' VarSmI: smallint;');
  13891. Add(' VarW: word;');
  13892. Add(' VarShI: shortint;');
  13893. Add(' VarBy: byte;');
  13894. Add(' VarExt: longint external name ''VarExt'';');
  13895. Add(' end;');
  13896. Add('var p: pointer;');
  13897. Add(' Obj: tobject;');
  13898. Add('begin');
  13899. Add(' p:=typeinfo(tobject);');
  13900. Add(' p:=typeinfo(p);');
  13901. Add(' p:=typeinfo(obj);');
  13902. ConvertProgram;
  13903. CheckSource('TestRTTI_Class_Field',
  13904. LinesToStr([ // statements
  13905. 'rtl.createClass($mod, "TObject", null, function () {',
  13906. ' this.$init = function () {',
  13907. ' this.FPropA = "";',
  13908. ' this.VarLI = 0;',
  13909. ' this.VarC = "";',
  13910. ' this.VarS = "";',
  13911. ' this.VarD = 0.0;',
  13912. ' this.VarB = false;',
  13913. ' this.VarLW = 0;',
  13914. ' this.VarSmI = 0;',
  13915. ' this.VarW = 0;',
  13916. ' this.VarShI = 0;',
  13917. ' this.VarBy = 0;',
  13918. ' };',
  13919. ' this.$final = function () {',
  13920. ' };',
  13921. ' var $r = this.$rtti;',
  13922. ' $r.addField("VarLI", rtl.longint);',
  13923. ' $r.addField("VarC", rtl.char);',
  13924. ' $r.addField("VarS", rtl.string);',
  13925. ' $r.addField("VarD", rtl.double);',
  13926. ' $r.addField("VarB", rtl.boolean);',
  13927. ' $r.addField("VarLW", rtl.longword);',
  13928. ' $r.addField("VarSmI", rtl.smallint);',
  13929. ' $r.addField("VarW", rtl.word);',
  13930. ' $r.addField("VarShI", rtl.shortint);',
  13931. ' $r.addField("VarBy", rtl.byte);',
  13932. ' $r.addField("VarExt", rtl.longint);',
  13933. '});',
  13934. 'this.p = null;',
  13935. 'this.Obj = null;',
  13936. '']),
  13937. LinesToStr([ // $mod.$main
  13938. '$mod.p = $mod.$rtti["TObject"];',
  13939. '$mod.p = rtl.pointer;',
  13940. '$mod.p = $mod.Obj.$rtti;',
  13941. '']));
  13942. end;
  13943. procedure TTestModule.TestRTTI_Class_Method;
  13944. begin
  13945. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13946. StartProgram(false);
  13947. Add('type');
  13948. Add(' TObject = class');
  13949. Add(' private');
  13950. Add(' procedure Internal; external name ''$intern'';');
  13951. Add(' published');
  13952. Add(' procedure Click; virtual; abstract;');
  13953. Add(' procedure Notify(Sender: TObject); virtual; abstract;');
  13954. Add(' function GetNotify: boolean; external name ''GetNotify'';');
  13955. Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
  13956. Add(' end;');
  13957. Add('begin');
  13958. ConvertProgram;
  13959. CheckSource('TestRTTI_Class_Method',
  13960. LinesToStr([ // statements
  13961. 'rtl.createClass($mod, "TObject", null, function () {',
  13962. ' this.$init = function () {',
  13963. ' };',
  13964. ' this.$final = function () {',
  13965. ' };',
  13966. ' var $r = this.$rtti;',
  13967. ' $r.addMethod("Click", 0, null);',
  13968. ' $r.addMethod("Notify", 0, [["Sender", $r]]);',
  13969. ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
  13970. ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
  13971. ' flags: 2',
  13972. ' });',
  13973. '});',
  13974. '']),
  13975. LinesToStr([ // $mod.$main
  13976. '']));
  13977. end;
  13978. procedure TTestModule.TestRTTI_Class_MethodArgFlags;
  13979. begin
  13980. Converter.Options:=Converter.Options-[coNoTypeInfo];
  13981. StartProgram(false);
  13982. Add('type');
  13983. Add(' TObject = class');
  13984. Add(' published');
  13985. Add(' procedure OpenArray(const Args: array of string); virtual; abstract;');
  13986. Add(' procedure ByRef(var Value: longint; out Item: longint); virtual; abstract;');
  13987. Add(' procedure Untyped(var Value; out Item); virtual; abstract;');
  13988. Add(' end;');
  13989. Add('begin');
  13990. ConvertProgram;
  13991. CheckSource('TestRTTI_Class_MethodOpenArray',
  13992. LinesToStr([ // statements
  13993. 'rtl.createClass($mod, "TObject", null, function () {',
  13994. ' this.$init = function () {',
  13995. ' };',
  13996. ' this.$final = function () {',
  13997. ' };',
  13998. ' var $r = this.$rtti;',
  13999. '$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
  14000. '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
  14001. '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
  14002. '});',
  14003. '']),
  14004. LinesToStr([ // $mod.$main
  14005. '']));
  14006. end;
  14007. procedure TTestModule.TestRTTI_Class_Property;
  14008. begin
  14009. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14010. StartProgram(false);
  14011. Add('{$modeswitch externalclass}');
  14012. Add('type');
  14013. Add(' TObject = class');
  14014. Add(' private');
  14015. Add(' FColor: longint;');
  14016. Add(' FColorStored: boolean;');
  14017. Add(' procedure SetColor(Value: longint); virtual; abstract;');
  14018. Add(' function GetColor: longint; virtual; abstract;');
  14019. Add(' function GetColorStored: boolean; virtual; abstract;');
  14020. Add(' FExtSize: longint external name ''$extSize'';');
  14021. Add(' FExtSizeStored: boolean external name ''$extSizeStored'';');
  14022. Add(' procedure SetExtSize(Value: longint); external name ''$setSize'';');
  14023. Add(' function GetExtSize: longint; external name ''$getSize'';');
  14024. Add(' function GetExtSizeStored: boolean; external name ''$getExtSizeStored'';');
  14025. Add(' published');
  14026. Add(' property ColorA: longint read FColor;');
  14027. Add(' property ColorB: longint write FColor;');
  14028. Add(' property ColorC: longint read GetColor write SetColor;');
  14029. Add(' property ColorD: longint read FColor write FColor stored FColorStored;');
  14030. Add(' property ExtSizeA: longint read FExtSize write FExtSize;');
  14031. Add(' property ExtSizeB: longint read GetExtSize write SetExtSize stored FExtSizeStored;');
  14032. Add(' property ExtSizeC: longint read FExtSize write FExtSize stored GetExtSizeStored;');
  14033. Add(' end;');
  14034. Add('begin');
  14035. ConvertProgram;
  14036. CheckSource('TestRTTI_Class_Property',
  14037. LinesToStr([ // statements
  14038. 'rtl.createClass($mod, "TObject", null, function () {',
  14039. ' this.$init = function () {',
  14040. ' this.FColor = 0;',
  14041. ' this.FColorStored = false;',
  14042. ' };',
  14043. ' this.$final = function () {',
  14044. ' };',
  14045. ' var $r = this.$rtti;',
  14046. ' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
  14047. ' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
  14048. ' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
  14049. ' $r.addProperty(',
  14050. ' "ColorD",',
  14051. ' 8,',
  14052. ' rtl.longint,',
  14053. ' "FColor",',
  14054. ' "FColor",',
  14055. ' {',
  14056. ' stored: "FColorStored"',
  14057. ' }',
  14058. ' );',
  14059. ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
  14060. ' $r.addProperty(',
  14061. ' "ExtSizeB",',
  14062. ' 11,',
  14063. ' rtl.longint,',
  14064. ' "$getSize",',
  14065. ' "$setSize",',
  14066. ' {',
  14067. ' stored: "$extSizeStored"',
  14068. ' }',
  14069. ' );',
  14070. ' $r.addProperty(',
  14071. ' "ExtSizeC",',
  14072. ' 12,',
  14073. ' rtl.longint,',
  14074. ' "$extSize",',
  14075. ' "$extSize",',
  14076. ' {',
  14077. ' stored: "$getExtSizeStored"',
  14078. ' }',
  14079. ' );',
  14080. '});',
  14081. '']),
  14082. LinesToStr([ // $mod.$main
  14083. '']));
  14084. end;
  14085. procedure TTestModule.TestRTTI_Class_PropertyParams;
  14086. begin
  14087. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14088. StartProgram(false);
  14089. Add('{$modeswitch externalclass}');
  14090. Add('type');
  14091. Add(' integer = longint;');
  14092. Add(' TObject = class');
  14093. Add(' private');
  14094. Add(' function GetItems(i: integer): tobject; virtual; abstract;');
  14095. Add(' procedure SetItems(i: integer; value: tobject); virtual; abstract;');
  14096. Add(' function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
  14097. Add(' procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
  14098. Add(' published');
  14099. Add(' property Items[Index: integer]: tobject read getitems write setitems;');
  14100. Add(' property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
  14101. Add(' end;');
  14102. Add('begin');
  14103. ConvertProgram;
  14104. CheckSource('TestRTTI_Class_PropertyParams',
  14105. LinesToStr([ // statements
  14106. 'rtl.createClass($mod, "TObject", null, function () {',
  14107. ' this.$init = function () {',
  14108. ' };',
  14109. ' this.$final = function () {',
  14110. ' };',
  14111. ' var $r = this.$rtti;',
  14112. ' $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
  14113. ' $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
  14114. '});',
  14115. '']),
  14116. LinesToStr([ // $mod.$main
  14117. '']));
  14118. end;
  14119. procedure TTestModule.TestRTTI_OverrideMethod;
  14120. begin
  14121. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14122. StartProgram(false);
  14123. Add('type');
  14124. Add(' TObject = class');
  14125. Add(' published');
  14126. Add(' procedure DoIt; virtual; abstract;');
  14127. Add(' end;');
  14128. Add(' TSky = class');
  14129. Add(' published');
  14130. Add(' procedure DoIt; override;');
  14131. Add(' end;');
  14132. Add('procedure TSky.DoIt; begin end;');
  14133. Add('begin');
  14134. ConvertProgram;
  14135. CheckSource('TestRTTI_OverrideMethod',
  14136. LinesToStr([ // statements
  14137. 'rtl.createClass($mod, "TObject", null, function () {',
  14138. ' this.$init = function () {',
  14139. ' };',
  14140. ' this.$final = function () {',
  14141. ' };',
  14142. ' var $r = this.$rtti;',
  14143. ' $r.addMethod("DoIt", 0, null);',
  14144. '});',
  14145. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  14146. ' this.DoIt = function () {',
  14147. ' };',
  14148. '});',
  14149. '']),
  14150. LinesToStr([ // $mod.$main
  14151. '']));
  14152. end;
  14153. procedure TTestModule.TestRTTI_OverloadProperty;
  14154. begin
  14155. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14156. StartProgram(false);
  14157. Add('type');
  14158. Add(' TObject = class');
  14159. Add(' protected');
  14160. Add(' FFlag: longint;');
  14161. Add(' published');
  14162. Add(' property Flag: longint read fflag;');
  14163. Add(' end;');
  14164. Add(' TSky = class');
  14165. Add(' published');
  14166. Add(' property FLAG: longint write fflag;');
  14167. Add(' end;');
  14168. Add('begin');
  14169. ConvertProgram;
  14170. CheckSource('TestRTTI_OverrideMethod',
  14171. LinesToStr([ // statements
  14172. 'rtl.createClass($mod, "TObject", null, function () {',
  14173. ' this.$init = function () {',
  14174. ' this.FFlag = 0;',
  14175. ' };',
  14176. ' this.$final = function () {',
  14177. ' };',
  14178. ' var $r = this.$rtti;',
  14179. ' $r.addProperty("Flag", 0, rtl.longint, "FFlag", "");',
  14180. '});',
  14181. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  14182. ' var $r = this.$rtti;',
  14183. ' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
  14184. '});',
  14185. '']),
  14186. LinesToStr([ // $mod.$main
  14187. '']));
  14188. end;
  14189. procedure TTestModule.TestRTTI_ClassForward;
  14190. begin
  14191. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14192. StartProgram(false);
  14193. Add('type');
  14194. Add(' TObject = class end;');
  14195. Add(' tbridge = class;');
  14196. Add(' TProc = function: tbridge;');
  14197. Add(' TOger = class');
  14198. Add(' published');
  14199. Add(' FBridge: tbridge;');
  14200. Add(' procedure SetBridge(Value: tbridge); virtual; abstract;');
  14201. Add(' property Bridge: tbridge read fbridge write setbridge;');
  14202. Add(' end;');
  14203. Add(' TBridge = class');
  14204. Add(' FOger: toger;');
  14205. Add(' end;');
  14206. Add('var p: Pointer;');
  14207. Add(' b: tbridge;');
  14208. Add('begin');
  14209. Add(' p:=typeinfo(tbridge);');
  14210. Add(' p:=typeinfo(b);');
  14211. ConvertProgram;
  14212. CheckSource('TestRTTI_ClassForward',
  14213. LinesToStr([ // statements
  14214. 'rtl.createClass($mod, "TObject", null, function () {',
  14215. ' this.$init = function () {',
  14216. ' };',
  14217. ' this.$final = function () {',
  14218. ' };',
  14219. '});',
  14220. '$mod.$rtti.$Class("TBridge");',
  14221. '$mod.$rtti.$ProcVar("TProc", {',
  14222. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TBridge"])',
  14223. '});',
  14224. 'rtl.createClass($mod, "TOger", $mod.TObject, function () {',
  14225. ' this.$init = function () {',
  14226. ' $mod.TObject.$init.call(this);',
  14227. ' this.FBridge = null;',
  14228. ' };',
  14229. ' this.$final = function () {',
  14230. ' this.FBridge = undefined;',
  14231. ' $mod.TObject.$final.call(this);',
  14232. ' };',
  14233. ' var $r = this.$rtti;',
  14234. ' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
  14235. ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
  14236. ' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
  14237. '});',
  14238. 'rtl.createClass($mod, "TBridge", $mod.TObject, function () {',
  14239. ' this.$init = function () {',
  14240. ' $mod.TObject.$init.call(this);',
  14241. ' this.FOger = null;',
  14242. ' };',
  14243. ' this.$final = function () {',
  14244. ' this.FOger = undefined;',
  14245. ' $mod.TObject.$final.call(this);',
  14246. ' };',
  14247. '});',
  14248. 'this.p = null;',
  14249. 'this.b = null;',
  14250. '']),
  14251. LinesToStr([ // $mod.$main
  14252. '$mod.p = $mod.$rtti["TBridge"];',
  14253. '$mod.p = $mod.b.$rtti;',
  14254. '']));
  14255. end;
  14256. procedure TTestModule.TestRTTI_ClassOf;
  14257. begin
  14258. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14259. StartProgram(false);
  14260. Add('type');
  14261. Add(' TClass = class of tobject;');
  14262. Add(' TProcA = function: TClass;');
  14263. Add(' TObject = class');
  14264. Add(' published');
  14265. Add(' C: tclass;');
  14266. Add(' end;');
  14267. Add(' tfox = class;');
  14268. Add(' TBird = class end;');
  14269. Add(' TBirds = class of tbird;');
  14270. Add(' TFox = class end;');
  14271. Add(' TFoxes = class of tfox;');
  14272. Add(' TCows = class of TCow;');
  14273. Add(' TCow = class;');
  14274. Add(' TCow = class end;');
  14275. Add('begin');
  14276. ConvertProgram;
  14277. CheckSource('TestRTTI_ClassOf',
  14278. LinesToStr([ // statements
  14279. '$mod.$rtti.$Class("TObject");',
  14280. '$mod.$rtti.$ClassRef("TClass", {',
  14281. ' instancetype: $mod.$rtti["TObject"]',
  14282. '});',
  14283. '$mod.$rtti.$ProcVar("TProcA", {',
  14284. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TClass"])',
  14285. '});',
  14286. 'rtl.createClass($mod, "TObject", null, function () {',
  14287. ' this.$init = function () {',
  14288. ' this.C = null;',
  14289. ' };',
  14290. ' this.$final = function () {',
  14291. ' this.C = undefined;',
  14292. ' };',
  14293. ' var $r = this.$rtti;',
  14294. ' $r.addField("C", $mod.$rtti["TClass"]);',
  14295. '});',
  14296. '$mod.$rtti.$Class("TFox");',
  14297. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  14298. '});',
  14299. '$mod.$rtti.$ClassRef("TBirds", {',
  14300. ' instancetype: $mod.$rtti["TBird"]',
  14301. '});',
  14302. 'rtl.createClass($mod, "TFox", $mod.TObject, function () {',
  14303. '});',
  14304. '$mod.$rtti.$ClassRef("TFoxes", {',
  14305. ' instancetype: $mod.$rtti["TFox"]',
  14306. '});',
  14307. '$mod.$rtti.$Class("TCow");',
  14308. '$mod.$rtti.$ClassRef("TCows", {',
  14309. ' instancetype: $mod.$rtti["TCow"]',
  14310. '});',
  14311. 'rtl.createClass($mod, "TCow", $mod.TObject, function () {',
  14312. '});',
  14313. '']),
  14314. LinesToStr([ // $mod.$main
  14315. '']));
  14316. end;
  14317. procedure TTestModule.TestRTTI_Record;
  14318. begin
  14319. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14320. StartProgram(false);
  14321. Add('type');
  14322. Add(' integer = longint;');
  14323. Add(' TPoint = record');
  14324. Add(' x,y: integer;');
  14325. Add(' end;');
  14326. Add('var p: pointer;');
  14327. Add(' r: tpoint;');
  14328. Add('begin');
  14329. Add(' p:=typeinfo(tpoint);');
  14330. Add(' p:=typeinfo(r);');
  14331. Add(' p:=typeinfo(r.x);');
  14332. ConvertProgram;
  14333. CheckSource('TestRTTI_Record',
  14334. LinesToStr([ // statements
  14335. 'this.TPoint = function (s) {',
  14336. ' if (s) {',
  14337. ' this.x = s.x;',
  14338. ' this.y = s.y;',
  14339. ' } else {',
  14340. ' this.x = 0;',
  14341. ' this.y = 0;',
  14342. ' };',
  14343. ' this.$equal = function (b) {',
  14344. ' return (this.x === b.x) && (this.y === b.y);',
  14345. ' };',
  14346. '};',
  14347. '$mod.$rtti.$Record("TPoint", {}).addFields("x", rtl.longint, "y", rtl.longint);',
  14348. 'this.p = null;',
  14349. 'this.r = new $mod.TPoint();',
  14350. '']),
  14351. LinesToStr([ // $mod.$main
  14352. '$mod.p = $mod.$rtti["TPoint"];',
  14353. '$mod.p = $mod.$rtti["TPoint"];',
  14354. '$mod.p = rtl.longint;',
  14355. '']));
  14356. end;
  14357. procedure TTestModule.TestRTTI_RecordAnonymousArray;
  14358. begin
  14359. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14360. StartProgram(false);
  14361. Add('type');
  14362. Add(' TFloatRec = record');
  14363. Add(' d: array of char;');
  14364. // Add(' i: array of array of longint;');
  14365. Add(' end;');
  14366. Add('var p: pointer;');
  14367. Add(' r: tfloatrec;');
  14368. Add('begin');
  14369. Add(' p:=typeinfo(tfloatrec);');
  14370. Add(' p:=typeinfo(r);');
  14371. Add(' p:=typeinfo(r.d);');
  14372. ConvertProgram;
  14373. CheckSource('TestRTTI_Record',
  14374. LinesToStr([ // statements
  14375. 'this.TFloatRec = function (s) {',
  14376. ' if (s) {',
  14377. ' this.d = s.d;',
  14378. ' } else {',
  14379. ' this.d = [];',
  14380. ' };',
  14381. ' this.$equal = function (b) {',
  14382. ' return this.d === b.d;',
  14383. ' };',
  14384. '};',
  14385. '$mod.$rtti.$DynArray("TFloatRec.d$a", {',
  14386. ' eltype: rtl.char',
  14387. '});',
  14388. '$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);',
  14389. 'this.p = null;',
  14390. 'this.r = new $mod.TFloatRec();',
  14391. '']),
  14392. LinesToStr([ // $mod.$main
  14393. '$mod.p = $mod.$rtti["TFloatRec"];',
  14394. '$mod.p = $mod.$rtti["TFloatRec"];',
  14395. '$mod.p = $mod.$rtti["TFloatRec.d$a"];',
  14396. '']));
  14397. end;
  14398. procedure TTestModule.TestRTTI_LocalTypes;
  14399. begin
  14400. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14401. StartProgram(false);
  14402. Add('procedure DoIt;');
  14403. Add('type');
  14404. Add(' integer = longint;');
  14405. Add(' TPoint = record');
  14406. Add(' x,y: integer;');
  14407. Add(' end;');
  14408. Add('begin');
  14409. Add('end;');
  14410. Add('begin');
  14411. ConvertProgram;
  14412. CheckSource('TestRTTI_LocalTypes',
  14413. LinesToStr([ // statements
  14414. 'this.DoIt = function () {',
  14415. ' this.TPoint = function (s) {',
  14416. ' if (s) {',
  14417. ' this.x = s.x;',
  14418. ' this.y = s.y;',
  14419. ' } else {',
  14420. ' this.x = 0;',
  14421. ' this.y = 0;',
  14422. ' };',
  14423. ' this.$equal = function (b) {',
  14424. ' return (this.x === b.x) && (this.y === b.y);',
  14425. ' };',
  14426. ' };',
  14427. '};',
  14428. '']),
  14429. LinesToStr([ // $mod.$main
  14430. '']));
  14431. end;
  14432. procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
  14433. begin
  14434. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14435. StartProgram(false);
  14436. Add('type');
  14437. Add(' TCaption = string;');
  14438. Add(' TYesNo = boolean;');
  14439. Add(' TLetter = char;');
  14440. Add(' TFloat = double;');
  14441. Add(' TPtr = pointer;');
  14442. Add(' TShortInt = shortint;');
  14443. Add(' TByte = byte;');
  14444. Add(' TSmallInt = smallint;');
  14445. Add(' TWord = word;');
  14446. Add(' TInt32 = longint;');
  14447. Add(' TDWord = longword;');
  14448. Add(' TValue = jsvalue;');
  14449. Add('var p: TPtr;');
  14450. Add('begin');
  14451. Add(' p:=typeinfo(string);');
  14452. Add(' p:=typeinfo(tcaption);');
  14453. Add(' p:=typeinfo(boolean);');
  14454. Add(' p:=typeinfo(tyesno);');
  14455. Add(' p:=typeinfo(char);');
  14456. Add(' p:=typeinfo(tletter);');
  14457. Add(' p:=typeinfo(double);');
  14458. Add(' p:=typeinfo(tfloat);');
  14459. Add(' p:=typeinfo(pointer);');
  14460. Add(' p:=typeinfo(tptr);');
  14461. Add(' p:=typeinfo(shortint);');
  14462. Add(' p:=typeinfo(tshortint);');
  14463. Add(' p:=typeinfo(byte);');
  14464. Add(' p:=typeinfo(tbyte);');
  14465. Add(' p:=typeinfo(smallint);');
  14466. Add(' p:=typeinfo(tsmallint);');
  14467. Add(' p:=typeinfo(word);');
  14468. Add(' p:=typeinfo(tword);');
  14469. Add(' p:=typeinfo(longword);');
  14470. Add(' p:=typeinfo(tdword);');
  14471. Add(' p:=typeinfo(jsvalue);');
  14472. Add(' p:=typeinfo(tvalue);');
  14473. ConvertProgram;
  14474. CheckSource('TestRTTI_TypeInfo_BaseTypes',
  14475. LinesToStr([ // statements
  14476. 'this.p = null;',
  14477. '']),
  14478. LinesToStr([ // $mod.$main
  14479. '$mod.p = rtl.string;',
  14480. '$mod.p = rtl.string;',
  14481. '$mod.p = rtl.boolean;',
  14482. '$mod.p = rtl.boolean;',
  14483. '$mod.p = rtl.char;',
  14484. '$mod.p = rtl.char;',
  14485. '$mod.p = rtl.double;',
  14486. '$mod.p = rtl.double;',
  14487. '$mod.p = rtl.pointer;',
  14488. '$mod.p = rtl.pointer;',
  14489. '$mod.p = rtl.shortint;',
  14490. '$mod.p = rtl.shortint;',
  14491. '$mod.p = rtl.byte;',
  14492. '$mod.p = rtl.byte;',
  14493. '$mod.p = rtl.smallint;',
  14494. '$mod.p = rtl.smallint;',
  14495. '$mod.p = rtl.word;',
  14496. '$mod.p = rtl.word;',
  14497. '$mod.p = rtl.longword;',
  14498. '$mod.p = rtl.longword;',
  14499. '$mod.p = rtl.jsvalue;',
  14500. '$mod.p = rtl.jsvalue;',
  14501. '']));
  14502. end;
  14503. procedure TTestModule.TestRTTI_TypeInfo_LocalFail;
  14504. begin
  14505. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14506. StartProgram(false);
  14507. Add('procedure DoIt;');
  14508. Add('type');
  14509. Add(' integer = longint;');
  14510. Add(' TPoint = record');
  14511. Add(' x,y: integer;');
  14512. Add(' end;');
  14513. Add('var p: pointer;');
  14514. Add('begin');
  14515. Add(' p:=typeinfo(tpoint);');
  14516. Add('end;');
  14517. Add('begin');
  14518. SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
  14519. ConvertProgram;
  14520. end;
  14521. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  14522. begin
  14523. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14524. StartProgram(false);
  14525. Add('{$modeswitch externalclass}');
  14526. Add('type');
  14527. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  14528. Add(' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;');
  14529. Add(' TFlag = (up,down);');
  14530. Add(' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;');
  14531. Add(' TFlags = set of TFlag;');
  14532. Add(' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;');
  14533. Add('var');
  14534. Add(' ti: TTypeInfo;');
  14535. Add(' tiInt: TTypeInfoInteger;');
  14536. Add(' tiEnum: TTypeInfoEnum;');
  14537. Add(' tiSet: TTypeInfoSet;');
  14538. Add('begin');
  14539. Add(' ti:=typeinfo(string);');
  14540. Add(' ti:=typeinfo(boolean);');
  14541. Add(' ti:=typeinfo(char);');
  14542. Add(' ti:=typeinfo(double);');
  14543. Add(' tiInt:=typeinfo(shortint);');
  14544. Add(' tiInt:=typeinfo(byte);');
  14545. Add(' tiInt:=typeinfo(smallint);');
  14546. Add(' tiInt:=typeinfo(word);');
  14547. Add(' tiInt:=typeinfo(longint);');
  14548. Add(' tiInt:=typeinfo(longword);');
  14549. Add(' ti:=typeinfo(jsvalue);');
  14550. Add(' tiEnum:=typeinfo(tflag);');
  14551. Add(' tiSet:=typeinfo(tflags);');
  14552. ConvertProgram;
  14553. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
  14554. LinesToStr([ // statements
  14555. 'this.TFlag = {',
  14556. ' "0": "up",',
  14557. ' up: 0,',
  14558. ' "1": "down",',
  14559. ' down: 1',
  14560. '};',
  14561. '$mod.$rtti.$Enum("TFlag", {',
  14562. ' minvalue: 0,',
  14563. ' maxvalue: 1,',
  14564. ' ordtype: 1,',
  14565. ' enumtype: this.TFlag',
  14566. '});',
  14567. '$mod.$rtti.$Set("TFlags", {',
  14568. ' comptype: $mod.$rtti["TFlag"]',
  14569. '});',
  14570. 'this.ti = null;',
  14571. 'this.tiInt = null;',
  14572. 'this.tiEnum = null;',
  14573. 'this.tiSet = null;',
  14574. '']),
  14575. LinesToStr([ // $mod.$main
  14576. '$mod.ti = rtl.string;',
  14577. '$mod.ti = rtl.boolean;',
  14578. '$mod.ti = rtl.char;',
  14579. '$mod.ti = rtl.double;',
  14580. '$mod.tiInt = rtl.shortint;',
  14581. '$mod.tiInt = rtl.byte;',
  14582. '$mod.tiInt = rtl.smallint;',
  14583. '$mod.tiInt = rtl.word;',
  14584. '$mod.tiInt = rtl.longint;',
  14585. '$mod.tiInt = rtl.longword;',
  14586. '$mod.ti = rtl.jsvalue;',
  14587. '$mod.tiEnum = $mod.$rtti["TFlag"];',
  14588. '$mod.tiSet = $mod.$rtti["TFlags"];',
  14589. '']));
  14590. end;
  14591. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  14592. begin
  14593. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14594. StartProgram(false);
  14595. Add('{$modeswitch externalclass}');
  14596. Add('type');
  14597. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  14598. Add(' TStaticArr = array[boolean] of string;');
  14599. Add(' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
  14600. Add(' TDynArr = array of string;');
  14601. Add(' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
  14602. Add(' TProc = procedure;');
  14603. Add(' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
  14604. Add(' TMethod = procedure of object;');
  14605. Add(' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
  14606. Add('var');
  14607. Add(' StaticArray: TStaticArr;');
  14608. Add(' tiStaticArray: TTypeInfoStaticArray;');
  14609. Add(' DynArray: TDynArr;');
  14610. Add(' tiDynArray: TTypeInfoDynArray;');
  14611. Add(' ProcVar: TProc;');
  14612. Add(' tiProcVar: TTypeInfoProcVar;');
  14613. Add(' MethodVar: TMethod;');
  14614. Add(' tiMethodVar: TTypeInfoMethodVar;');
  14615. Add('begin');
  14616. Add(' tiStaticArray:=typeinfo(StaticArray);');
  14617. Add(' tiStaticArray:=typeinfo(TStaticArr);');
  14618. Add(' tiDynArray:=typeinfo(DynArray);');
  14619. Add(' tiDynArray:=typeinfo(TDynArr);');
  14620. Add(' tiProcVar:=typeinfo(ProcVar);');
  14621. Add(' tiProcVar:=typeinfo(TProc);');
  14622. Add(' tiMethodVar:=typeinfo(MethodVar);');
  14623. Add(' tiMethodVar:=typeinfo(TMethod);');
  14624. ConvertProgram;
  14625. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
  14626. LinesToStr([ // statements
  14627. ' $mod.$rtti.$StaticArray("TStaticArr", {',
  14628. ' dims: [2],',
  14629. ' eltype: rtl.string',
  14630. '});',
  14631. '$mod.$rtti.$DynArray("TDynArr", {',
  14632. ' eltype: rtl.string',
  14633. '});',
  14634. '$mod.$rtti.$ProcVar("TProc", {',
  14635. ' procsig: rtl.newTIProcSig(null)',
  14636. '});',
  14637. '$mod.$rtti.$MethodVar("TMethod", {',
  14638. ' procsig: rtl.newTIProcSig(null),',
  14639. ' methodkind: 0',
  14640. '});',
  14641. 'this.StaticArray = rtl.arraySetLength(null,"",2);',
  14642. 'this.tiStaticArray = null;',
  14643. 'this.DynArray = [];',
  14644. 'this.tiDynArray = null;',
  14645. 'this.ProcVar = null;',
  14646. 'this.tiProcVar = null;',
  14647. 'this.MethodVar = null;',
  14648. 'this.tiMethodVar = null;',
  14649. '']),
  14650. LinesToStr([ // $mod.$main
  14651. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  14652. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  14653. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  14654. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  14655. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  14656. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  14657. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  14658. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  14659. '']));
  14660. end;
  14661. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  14662. begin
  14663. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14664. StartProgram(false);
  14665. Add('{$modeswitch externalclass}');
  14666. Add('type');
  14667. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  14668. Add(' TRec = record end;');
  14669. Add(' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
  14670. // ToDo: ^PRec
  14671. Add(' TObject = class end;');
  14672. Add(' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
  14673. Add(' TClass = class of tobject;');
  14674. Add(' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
  14675. Add(' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
  14676. Add('var');
  14677. Add(' Rec: trec;');
  14678. Add(' tiRecord: ttypeinforecord;');
  14679. Add(' Obj: tobject;');
  14680. Add(' tiClass: ttypeinfoclass;');
  14681. Add(' aClass: tclass;');
  14682. Add(' tiClassRef: ttypeinfoclassref;');
  14683. // ToDo: ^PRec
  14684. Add(' tiPointer: ttypeinfopointer;');
  14685. Add('begin');
  14686. Add(' tirecord:=typeinfo(trec);');
  14687. Add(' tirecord:=typeinfo(trec);');
  14688. Add(' ticlass:=typeinfo(obj);');
  14689. Add(' ticlass:=typeinfo(tobject);');
  14690. Add(' ticlass:=typeinfo(aclass);');
  14691. Add(' ticlassref:=typeinfo(tclass);');
  14692. ConvertProgram;
  14693. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
  14694. LinesToStr([ // statements
  14695. 'this.TRec = function (s) {',
  14696. '};',
  14697. '$mod.$rtti.$Record("TRec", {});',
  14698. 'rtl.createClass($mod, "TObject", null, function () {',
  14699. ' this.$init = function () {',
  14700. ' };',
  14701. ' this.$final = function () {',
  14702. ' };',
  14703. '});',
  14704. '$mod.$rtti.$ClassRef("TClass", {',
  14705. ' instancetype: $mod.$rtti["TObject"]',
  14706. '});',
  14707. 'this.Rec = new $mod.TRec();',
  14708. 'this.tiRecord = null;',
  14709. 'this.Obj = null;',
  14710. 'this.tiClass = null;',
  14711. 'this.aClass = null;',
  14712. 'this.tiClassRef = null;',
  14713. 'this.tiPointer = null;',
  14714. '']),
  14715. LinesToStr([ // $mod.$main
  14716. '$mod.tiRecord = $mod.$rtti["TRec"];',
  14717. '$mod.tiRecord = $mod.$rtti["TRec"];',
  14718. '$mod.tiClass = $mod.Obj.$rtti;',
  14719. '$mod.tiClass = $mod.$rtti["TObject"];',
  14720. '$mod.tiClass = $mod.aClass.$rtti;',
  14721. '$mod.tiClassRef = $mod.$rtti["TClass"];',
  14722. '']));
  14723. end;
  14724. procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
  14725. begin
  14726. Converter.Options:=Converter.Options-[coNoTypeInfo];
  14727. StartProgram(false);
  14728. Add([
  14729. '{$modeswitch externalclass}',
  14730. 'type',
  14731. ' TClass = class of tobject;',
  14732. ' TObject = class',
  14733. ' function MyClass: TClass;',
  14734. ' class function ClassType: TClass;',
  14735. ' end;',
  14736. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  14737. ' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
  14738. 'function TObject.MyClass: TClass;',
  14739. 'var t: TTypeInfoClass;',
  14740. 'begin',
  14741. ' t:=TypeInfo(Self);',
  14742. ' t:=TypeInfo(Result);',
  14743. 'end;',
  14744. 'class function TObject.ClassType: TClass;',
  14745. 'var t: TTypeInfoClass;',
  14746. 'begin',
  14747. ' t:=TypeInfo(Self);',
  14748. ' t:=TypeInfo(Result);',
  14749. 'end;',
  14750. 'var',
  14751. ' Obj: TObject;',
  14752. ' t: TTypeInfoClass;',
  14753. 'begin',
  14754. ' t:=TypeInfo(TObject.ClassType);',
  14755. ' t:=TypeInfo(Obj.ClassType);',
  14756. ' t:=TypeInfo(Obj.MyClass);',
  14757. '']);
  14758. ConvertProgram;
  14759. CheckSource('TestRTTI_TypeInfo_FunctionClassType',
  14760. LinesToStr([ // statements
  14761. '$mod.$rtti.$Class("TObject");',
  14762. '$mod.$rtti.$ClassRef("TClass", {',
  14763. ' instancetype: $mod.$rtti["TObject"]',
  14764. '});',
  14765. 'rtl.createClass($mod, "TObject", null, function () {',
  14766. ' this.$init = function () {',
  14767. ' };',
  14768. ' this.$final = function () {',
  14769. ' };',
  14770. ' this.MyClass = function () {',
  14771. ' var Result = null;',
  14772. ' var t = null;',
  14773. ' t = this.$rtti;',
  14774. ' t = Result.$rtti;',
  14775. ' return Result;',
  14776. ' };',
  14777. ' this.ClassType = function () {',
  14778. ' var Result = null;',
  14779. ' var t = null;',
  14780. ' t = this.$rtti;',
  14781. ' t = Result.$rtti;',
  14782. ' return Result;',
  14783. ' };',
  14784. '});',
  14785. 'this.Obj = null;',
  14786. 'this.t = null;',
  14787. '']),
  14788. LinesToStr([ // $mod.$main
  14789. '$mod.t = $mod.TObject.ClassType().$rtti;',
  14790. '$mod.t = $mod.Obj.$class.ClassType().$rtti;',
  14791. '$mod.t = $mod.Obj.MyClass().$rtti;',
  14792. '']));
  14793. end;
  14794. procedure TTestModule.TestResourcestringProgram;
  14795. begin
  14796. StartProgram(false);
  14797. Add([
  14798. 'const Bar = ''bar'';',
  14799. 'resourcestring',
  14800. ' Red = ''red'';',
  14801. ' Foobar = ''fOo''+bar;',
  14802. 'var s: string;',
  14803. ' c: char;',
  14804. 'begin',
  14805. ' s:=red;',
  14806. ' s:=test1.red;',
  14807. ' c:=red[1];',
  14808. ' c:=test1.red[2];',
  14809. ' if red=foobar then ;',
  14810. ' if red[3]=red[4] then ;']);
  14811. ConvertProgram;
  14812. CheckSource('TestResourcestringProgram',
  14813. LinesToStr([ // statements
  14814. 'this.Bar = "bar";',
  14815. 'this.s = "";',
  14816. 'this.c = "";',
  14817. '$mod.$resourcestrings = {',
  14818. ' Red: {',
  14819. ' org: "red"',
  14820. ' },',
  14821. ' Foobar: {',
  14822. ' org: "fOobar"',
  14823. ' }',
  14824. '};',
  14825. '']),
  14826. LinesToStr([ // $mod.$main
  14827. '$mod.s = rtl.getResStr(pas.program, "Red");',
  14828. '$mod.s = rtl.getResStr(pas.program, "Red");',
  14829. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(0);',
  14830. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(1);',
  14831. 'if (rtl.getResStr(pas.program, "Red") === rtl.getResStr(pas.program, "Foobar")) ;',
  14832. 'if (rtl.getResStr(pas.program, "Red").charAt(2) === rtl.getResStr(pas.program, "Red").charAt(3)) ;',
  14833. '']));
  14834. end;
  14835. procedure TTestModule.TestResourcestringUnit;
  14836. begin
  14837. StartUnit(false);
  14838. Add([
  14839. 'interface',
  14840. 'const Red = ''rEd'';',
  14841. 'resourcestring',
  14842. ' Blue = ''blue'';',
  14843. ' NotRed = ''not''+Red;',
  14844. 'var s: string;',
  14845. 'implementation',
  14846. 'resourcestring',
  14847. ' ImplGreen = ''green'';',
  14848. 'initialization',
  14849. ' s:=blue+ImplGreen;',
  14850. ' s:=test1.blue+test1.implgreen;',
  14851. ' s:=blue[1]+implgreen[2];']);
  14852. ConvertUnit;
  14853. CheckSource('TestResourcestringUnit',
  14854. LinesToStr([ // statements
  14855. 'this.Red = "rEd";',
  14856. 'this.s = "";',
  14857. '$mod.$resourcestrings = {',
  14858. ' Blue: {',
  14859. ' org: "blue"',
  14860. ' },',
  14861. ' NotRed: {',
  14862. ' org: "notrEd"',
  14863. ' },',
  14864. ' ImplGreen: {',
  14865. ' org: "green"',
  14866. ' }',
  14867. '};',
  14868. '']),
  14869. LinesToStr([ // $mod.$main
  14870. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  14871. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  14872. '$mod.s = rtl.getResStr(pas.Test1, "Blue").charAt(0) + rtl.getResStr(pas.Test1, "ImplGreen").charAt(1);',
  14873. '']));
  14874. end;
  14875. procedure TTestModule.TestResourcestringImplementation;
  14876. begin
  14877. StartUnit(false);
  14878. Add([
  14879. 'interface',
  14880. 'implementation',
  14881. 'resourcestring',
  14882. ' ImplRed = ''red'';']);
  14883. ConvertUnit;
  14884. CheckSource('TestResourcestringImplementation',
  14885. LinesToStr([ // intf statements
  14886. 'var $impl = $mod.$impl;']),
  14887. LinesToStr([ // $mod.$init
  14888. '']),
  14889. LinesToStr([ // impl statements
  14890. '$mod.$resourcestrings = {',
  14891. ' ImplRed: {',
  14892. ' org: "red"',
  14893. ' }',
  14894. '};',
  14895. '']));
  14896. end;
  14897. procedure TTestModule.TestAtributes_Ignore;
  14898. begin
  14899. StartProgram(false);
  14900. Add([
  14901. '{$modeswitch ignoreattributes}',
  14902. 'type',
  14903. ' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
  14904. ' TObject = class',
  14905. ' [custom5()] FS: string;',
  14906. ' [customProp] property S: string read FS;',
  14907. ' end;',
  14908. 'var',
  14909. ' [custom6]',
  14910. ' o: TObject;',
  14911. 'begin',
  14912. '']);
  14913. ConvertProgram;
  14914. CheckSource('TestAtributes_Ignore',
  14915. LinesToStr([ // statements
  14916. 'rtl.createClass($mod, "TObject", null, function () {',
  14917. ' this.$init = function () {',
  14918. ' this.FS = "";',
  14919. ' };',
  14920. ' this.$final = function () {',
  14921. ' };',
  14922. '});',
  14923. 'this.o = null;',
  14924. '']),
  14925. LinesToStr([ // $mod.$main
  14926. '']));
  14927. end;
  14928. Initialization
  14929. RegisterTests([TTestModule]);
  14930. end.