tcmodules.pas 555 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382153831538415385153861538715388153891539015391153921539315394153951539615397153981539915400154011540215403154041540515406154071540815409154101541115412154131541415415154161541715418154191542015421154221542315424154251542615427154281542915430154311543215433154341543515436154371543815439154401544115442154431544415445154461544715448154491545015451154521545315454154551545615457154581545915460154611546215463154641546515466154671546815469154701547115472154731547415475154761547715478154791548015481154821548315484154851548615487154881548915490154911549215493154941549515496154971549815499155001550115502155031550415505155061550715508155091551015511155121551315514155151551615517155181551915520155211552215523155241552515526155271552815529155301553115532155331553415535155361553715538155391554015541155421554315544155451554615547155481554915550155511555215553155541555515556155571555815559155601556115562155631556415565155661556715568155691557015571155721557315574155751557615577155781557915580155811558215583155841558515586155871558815589155901559115592155931559415595155961559715598155991560015601156021560315604156051560615607156081560915610156111561215613156141561515616156171561815619156201562115622156231562415625156261562715628156291563015631156321563315634156351563615637156381563915640156411564215643156441564515646156471564815649156501565115652156531565415655156561565715658156591566015661156621566315664156651566615667156681566915670156711567215673156741567515676156771567815679156801568115682156831568415685156861568715688156891569015691156921569315694156951569615697156981569915700157011570215703157041570515706157071570815709157101571115712157131571415715157161571715718157191572015721157221572315724157251572615727157281572915730157311573215733157341573515736157371573815739157401574115742157431574415745157461574715748157491575015751157521575315754157551575615757157581575915760157611576215763157641576515766157671576815769157701577115772157731577415775157761577715778157791578015781157821578315784157851578615787157881578915790157911579215793157941579515796157971579815799158001580115802158031580415805158061580715808158091581015811158121581315814158151581615817158181581915820158211582215823158241582515826158271582815829158301583115832158331583415835158361583715838158391584015841158421584315844158451584615847158481584915850158511585215853158541585515856158571585815859158601586115862158631586415865158661586715868158691587015871158721587315874158751587615877158781587915880158811588215883158841588515886158871588815889158901589115892158931589415895158961589715898158991590015901159021590315904159051590615907159081590915910159111591215913159141591515916159171591815919159201592115922159231592415925159261592715928159291593015931159321593315934159351593615937159381593915940159411594215943159441594515946159471594815949159501595115952159531595415955159561595715958159591596015961159621596315964159651596615967159681596915970159711597215973159741597515976159771597815979159801598115982159831598415985159861598715988159891599015991159921599315994159951599615997159981599916000160011600216003160041600516006160071600816009160101601116012160131601416015160161601716018160191602016021160221602316024160251602616027160281602916030160311603216033160341603516036160371603816039160401604116042160431604416045160461604716048160491605016051160521605316054160551605616057160581605916060160611606216063160641606516066160671606816069160701607116072160731607416075160761607716078160791608016081160821608316084160851608616087160881608916090160911609216093160941609516096160971609816099161001610116102161031610416105161061610716108161091611016111161121611316114161151611616117161181611916120161211612216123161241612516126161271612816129161301613116132161331613416135161361613716138161391614016141161421614316144161451614616147161481614916150161511615216153161541615516156161571615816159161601616116162161631616416165161661616716168161691617016171161721617316174161751617616177161781617916180161811618216183161841618516186161871618816189161901619116192161931619416195161961619716198161991620016201162021620316204162051620616207162081620916210162111621216213162141621516216162171621816219162201622116222162231622416225162261622716228162291623016231162321623316234162351623616237162381623916240162411624216243162441624516246162471624816249162501625116252162531625416255162561625716258162591626016261162621626316264162651626616267162681626916270162711627216273162741627516276162771627816279162801628116282162831628416285162861628716288162891629016291162921629316294162951629616297162981629916300163011630216303163041630516306163071630816309163101631116312163131631416315163161631716318163191632016321163221632316324163251632616327163281632916330163311633216333163341633516336163371633816339163401634116342163431634416345163461634716348163491635016351163521635316354163551635616357163581635916360163611636216363163641636516366163671636816369163701637116372163731637416375163761637716378163791638016381163821638316384163851638616387163881638916390163911639216393163941639516396163971639816399164001640116402164031640416405164061640716408164091641016411164121641316414164151641616417164181641916420164211642216423164241642516426164271642816429164301643116432164331643416435164361643716438164391644016441164421644316444164451644616447164481644916450164511645216453164541645516456164571645816459164601646116462164631646416465164661646716468164691647016471164721647316474164751647616477164781647916480164811648216483164841648516486164871648816489164901649116492164931649416495164961649716498164991650016501165021650316504165051650616507165081650916510165111651216513165141651516516165171651816519165201652116522165231652416525165261652716528165291653016531165321653316534165351653616537165381653916540165411654216543165441654516546165471654816549165501655116552165531655416555165561655716558165591656016561165621656316564165651656616567165681656916570165711657216573165741657516576165771657816579165801658116582165831658416585165861658716588165891659016591165921659316594165951659616597165981659916600166011660216603166041660516606166071660816609166101661116612166131661416615166161661716618166191662016621166221662316624166251662616627166281662916630166311663216633166341663516636166371663816639166401664116642166431664416645166461664716648166491665016651166521665316654166551665616657166581665916660166611666216663166641666516666166671666816669166701667116672166731667416675166761667716678166791668016681166821668316684166851668616687166881668916690166911669216693166941669516696166971669816699167001670116702167031670416705167061670716708167091671016711167121671316714167151671616717167181671916720167211672216723167241672516726167271672816729167301673116732167331673416735167361673716738167391674016741167421674316744167451674616747167481674916750167511675216753167541675516756167571675816759167601676116762167631676416765167661676716768167691677016771167721677316774167751677616777167781677916780167811678216783167841678516786167871678816789167901679116792167931679416795167961679716798167991680016801168021680316804168051680616807168081680916810168111681216813168141681516816168171681816819168201682116822168231682416825168261682716828168291683016831168321683316834168351683616837168381683916840168411684216843168441684516846168471684816849168501685116852168531685416855168561685716858168591686016861168621686316864168651686616867168681686916870168711687216873168741687516876168771687816879168801688116882168831688416885168861688716888168891689016891168921689316894168951689616897168981689916900169011690216903169041690516906169071690816909169101691116912169131691416915169161691716918169191692016921169221692316924169251692616927169281692916930169311693216933169341693516936169371693816939169401694116942169431694416945169461694716948169491695016951169521695316954169551695616957169581695916960169611696216963169641696516966169671696816969169701697116972169731697416975169761697716978169791698016981169821698316984169851698616987169881698916990169911699216993169941699516996169971699816999170001700117002170031700417005170061700717008170091701017011170121701317014170151701617017170181701917020170211702217023170241702517026170271702817029170301703117032170331703417035170361703717038170391704017041170421704317044170451704617047170481704917050170511705217053170541705517056170571705817059170601706117062170631706417065170661706717068170691707017071170721707317074170751707617077170781707917080170811708217083170841708517086170871708817089170901709117092170931709417095170961709717098170991710017101171021710317104171051710617107171081710917110171111711217113171141711517116171171711817119171201712117122171231712417125171261712717128171291713017131171321713317134171351713617137171381713917140171411714217143171441714517146171471714817149171501715117152171531715417155171561715717158171591716017161171621716317164171651716617167171681716917170171711717217173171741717517176171771717817179171801718117182171831718417185171861718717188171891719017191171921719317194171951719617197171981719917200172011720217203172041720517206172071720817209172101721117212172131721417215172161721717218172191722017221172221722317224172251722617227172281722917230172311723217233172341723517236172371723817239172401724117242172431724417245172461724717248172491725017251172521725317254172551725617257172581725917260172611726217263172641726517266172671726817269172701727117272172731727417275172761727717278172791728017281172821728317284172851728617287172881728917290172911729217293172941729517296172971729817299173001730117302173031730417305173061730717308173091731017311173121731317314173151731617317173181731917320173211732217323173241732517326173271732817329173301733117332173331733417335173361733717338173391734017341173421734317344173451734617347173481734917350173511735217353173541735517356173571735817359173601736117362173631736417365173661736717368173691737017371173721737317374173751737617377173781737917380173811738217383173841738517386173871738817389173901739117392173931739417395173961739717398173991740017401174021740317404174051740617407174081740917410174111741217413174141741517416174171741817419174201742117422174231742417425174261742717428174291743017431174321743317434174351743617437174381743917440174411744217443174441744517446174471744817449174501745117452174531745417455174561745717458174591746017461174621746317464174651746617467174681746917470174711747217473174741747517476174771747817479174801748117482174831748417485174861748717488174891749017491174921749317494174951749617497174981749917500175011750217503175041750517506175071750817509175101751117512175131751417515175161751717518175191752017521175221752317524175251752617527175281752917530175311753217533175341753517536175371753817539175401754117542175431754417545175461754717548175491755017551175521755317554175551755617557175581755917560175611756217563175641756517566175671756817569175701757117572175731757417575175761757717578175791758017581175821758317584175851758617587175881758917590175911759217593175941759517596175971759817599176001760117602176031760417605176061760717608176091761017611176121761317614176151761617617176181761917620176211762217623176241762517626176271762817629176301763117632176331763417635176361763717638176391764017641176421764317644176451764617647176481764917650176511765217653176541765517656176571765817659176601766117662176631766417665176661766717668176691767017671176721767317674176751767617677176781767917680176811768217683176841768517686176871768817689176901769117692176931769417695176961769717698176991770017701177021770317704177051770617707177081770917710177111771217713177141771517716177171771817719177201772117722177231772417725177261772717728177291773017731177321773317734177351773617737177381773917740177411774217743177441774517746177471774817749177501775117752177531775417755177561775717758177591776017761177621776317764177651776617767177681776917770177711777217773177741777517776177771777817779177801778117782177831778417785177861778717788177891779017791177921779317794177951779617797177981779917800178011780217803178041780517806178071780817809178101781117812178131781417815178161781717818178191782017821178221782317824178251782617827178281782917830178311783217833178341783517836178371783817839178401784117842178431784417845178461784717848178491785017851178521785317854178551785617857178581785917860178611786217863178641786517866178671786817869178701787117872178731787417875178761787717878178791788017881178821788317884178851788617887178881788917890178911789217893178941789517896178971789817899179001790117902179031790417905179061790717908179091791017911179121791317914179151791617917179181791917920179211792217923179241792517926179271792817929179301793117932179331793417935179361793717938179391794017941179421794317944179451794617947179481794917950179511795217953179541795517956179571795817959179601796117962179631796417965179661796717968179691797017971179721797317974179751797617977179781797917980179811798217983179841798517986179871798817989179901799117992179931799417995179961799717998179991800018001180021800318004180051800618007180081800918010180111801218013180141801518016180171801818019180201802118022180231802418025180261802718028180291803018031180321803318034180351803618037180381803918040180411804218043180441804518046180471804818049180501805118052180531805418055180561805718058180591806018061180621806318064180651806618067180681806918070180711807218073180741807518076180771807818079180801808118082180831808418085180861808718088180891809018091180921809318094180951809618097180981809918100181011810218103181041810518106181071810818109181101811118112181131811418115181161811718118181191812018121181221812318124181251812618127181281812918130181311813218133181341813518136181371813818139181401814118142181431814418145181461814718148181491815018151181521815318154181551815618157181581815918160181611816218163181641816518166181671816818169181701817118172181731817418175181761817718178181791818018181181821818318184181851818618187181881818918190181911819218193181941819518196181971819818199182001820118202182031820418205182061820718208182091821018211182121821318214182151821618217182181821918220182211822218223182241822518226182271822818229182301823118232182331823418235182361823718238182391824018241182421824318244182451824618247182481824918250182511825218253182541825518256182571825818259182601826118262182631826418265182661826718268182691827018271182721827318274182751827618277182781827918280182811828218283182841828518286182871828818289182901829118292182931829418295182961829718298182991830018301183021830318304183051830618307183081830918310183111831218313183141831518316183171831818319183201832118322183231832418325183261832718328183291833018331183321833318334183351833618337183381833918340183411834218343183441834518346183471834818349183501835118352183531835418355183561835718358183591836018361183621836318364183651836618367183681836918370183711837218373183741837518376183771837818379183801838118382183831838418385183861838718388183891839018391183921839318394183951839618397183981839918400184011840218403184041840518406184071840818409184101841118412184131841418415184161841718418184191842018421184221842318424184251842618427184281842918430184311843218433184341843518436184371843818439184401844118442184431844418445184461844718448184491845018451184521845318454184551845618457184581845918460184611846218463184641846518466184671846818469184701847118472184731847418475184761847718478184791848018481184821848318484184851848618487184881848918490184911849218493184941849518496184971849818499185001850118502185031850418505185061850718508185091851018511185121851318514185151851618517185181851918520185211852218523185241852518526185271852818529185301853118532185331853418535185361853718538185391854018541185421854318544185451854618547185481854918550185511855218553185541855518556185571855818559185601856118562185631856418565185661856718568185691857018571185721857318574185751857618577185781857918580185811858218583185841858518586185871858818589185901859118592185931859418595185961859718598185991860018601186021860318604186051860618607186081860918610186111861218613186141861518616186171861818619186201862118622186231862418625186261862718628186291863018631186321863318634186351863618637186381863918640186411864218643186441864518646186471864818649186501865118652186531865418655186561865718658186591866018661186621866318664186651866618667186681866918670186711867218673186741867518676186771867818679186801868118682186831868418685186861868718688186891869018691186921869318694186951869618697186981869918700187011870218703187041870518706187071870818709187101871118712187131871418715187161871718718187191872018721187221872318724187251872618727187281872918730187311873218733187341873518736187371873818739187401874118742187431874418745187461874718748187491875018751187521875318754187551875618757187581875918760187611876218763187641876518766187671876818769187701877118772187731877418775187761877718778187791878018781187821878318784187851878618787187881878918790187911879218793187941879518796187971879818799188001880118802188031880418805188061880718808188091881018811188121881318814188151881618817188181881918820188211882218823188241882518826188271882818829188301883118832188331883418835188361883718838188391884018841188421884318844188451884618847188481884918850188511885218853188541885518856188571885818859188601886118862188631886418865188661886718868188691887018871188721887318874188751887618877188781887918880188811888218883188841888518886188871888818889188901889118892188931889418895188961889718898188991890018901189021890318904189051890618907189081890918910189111891218913189141891518916189171891818919189201892118922189231892418925189261892718928189291893018931189321893318934189351893618937189381893918940189411894218943189441894518946189471894818949189501895118952189531895418955189561895718958189591896018961189621896318964189651896618967189681896918970189711897218973189741897518976189771897818979189801898118982189831898418985189861898718988189891899018991189921899318994189951899618997189981899919000190011900219003190041900519006190071900819009190101901119012190131901419015190161901719018190191902019021190221902319024190251902619027190281902919030190311903219033190341903519036190371903819039190401904119042190431904419045190461904719048190491905019051190521905319054190551905619057190581905919060190611906219063190641906519066190671906819069190701907119072190731907419075190761907719078190791908019081190821908319084190851908619087190881908919090190911909219093190941909519096190971909819099191001910119102191031910419105191061910719108191091911019111191121911319114191151911619117191181911919120191211912219123191241912519126191271912819129191301913119132191331913419135191361913719138191391914019141191421914319144191451914619147191481914919150191511915219153191541915519156191571915819159191601916119162191631916419165191661916719168191691917019171191721917319174191751917619177191781917919180191811918219183191841918519186191871918819189191901919119192191931919419195191961919719198191991920019201192021920319204192051920619207192081920919210192111921219213192141921519216192171921819219192201922119222192231922419225192261922719228192291923019231192321923319234192351923619237192381923919240192411924219243192441924519246192471924819249192501925119252192531925419255192561925719258192591926019261192621926319264192651926619267192681926919270192711927219273192741927519276192771927819279192801928119282192831928419285192861928719288192891929019291192921929319294192951929619297192981929919300193011930219303193041930519306193071930819309193101931119312193131931419315193161931719318193191932019321193221932319324193251932619327193281932919330193311933219333193341933519336193371933819339193401934119342193431934419345193461934719348193491935019351193521935319354193551935619357193581935919360193611936219363193641936519366193671936819369193701937119372193731937419375193761937719378193791938019381193821938319384193851938619387193881938919390193911939219393193941939519396193971939819399194001940119402194031940419405194061940719408194091941019411194121941319414194151941619417194181941919420194211942219423194241942519426194271942819429194301943119432194331943419435194361943719438194391944019441194421944319444194451944619447194481944919450194511945219453194541945519456194571945819459194601946119462194631946419465194661946719468194691947019471194721947319474194751947619477194781947919480194811948219483194841948519486194871948819489194901949119492194931949419495194961949719498194991950019501195021950319504195051950619507195081950919510195111951219513195141951519516195171951819519195201952119522195231952419525195261952719528195291953019531195321953319534195351953619537195381953919540195411954219543195441954519546195471954819549195501955119552195531955419555195561955719558195591956019561195621956319564195651956619567195681956919570195711957219573195741957519576195771957819579195801958119582195831958419585195861958719588195891959019591195921959319594195951959619597195981959919600196011960219603196041960519606196071960819609196101961119612196131961419615196161961719618196191962019621196221962319624196251962619627196281962919630196311963219633196341963519636196371963819639196401964119642196431964419645196461964719648196491965019651196521965319654196551965619657196581965919660196611966219663196641966519666196671966819669196701967119672196731967419675196761967719678196791968019681196821968319684196851968619687196881968919690196911969219693196941969519696196971969819699197001970119702197031970419705197061970719708197091971019711197121971319714197151971619717197181971919720197211972219723197241972519726197271972819729197301973119732197331973419735197361973719738197391974019741197421974319744197451974619747197481974919750197511975219753197541975519756197571975819759197601976119762197631976419765197661976719768197691977019771197721977319774197751977619777197781977919780197811978219783197841978519786197871978819789197901979119792197931979419795197961979719798197991980019801198021980319804198051980619807198081980919810198111981219813198141981519816198171981819819198201982119822198231982419825198261982719828198291983019831198321983319834198351983619837198381983919840198411984219843198441984519846198471984819849198501985119852198531985419855198561985719858198591986019861198621986319864198651986619867198681986919870198711987219873198741987519876198771987819879198801988119882198831988419885198861988719888198891989019891198921989319894198951989619897198981989919900199011990219903199041990519906199071990819909199101991119912199131991419915199161991719918199191992019921199221992319924199251992619927199281992919930199311993219933199341993519936199371993819939199401994119942199431994419945199461994719948199491995019951199521995319954199551995619957199581995919960199611996219963199641996519966199671996819969199701997119972199731997419975199761997719978199791998019981199821998319984199851998619987199881998919990199911999219993199941999519996199971999819999200002000120002200032000420005200062000720008200092001020011200122001320014200152001620017200182001920020200212002220023200242002520026200272002820029200302003120032200332003420035200362003720038200392004020041200422004320044200452004620047200482004920050200512005220053200542005520056200572005820059200602006120062200632006420065200662006720068200692007020071200722007320074200752007620077200782007920080200812008220083200842008520086200872008820089200902009120092200932009420095200962009720098200992010020101201022010320104201052010620107201082010920110201112011220113201142011520116201172011820119201202012120122201232012420125201262012720128201292013020131201322013320134201352013620137201382013920140201412014220143201442014520146201472014820149201502015120152201532015420155201562015720158201592016020161201622016320164201652016620167201682016920170201712017220173201742017520176201772017820179201802018120182201832018420185201862018720188201892019020191201922019320194201952019620197201982019920200202012020220203202042020520206202072020820209202102021120212202132021420215202162021720218202192022020221202222022320224202252022620227202282022920230202312023220233202342023520236202372023820239202402024120242202432024420245202462024720248202492025020251202522025320254202552025620257202582025920260202612026220263202642026520266202672026820269202702027120272202732027420275202762027720278202792028020281202822028320284202852028620287202882028920290202912029220293202942029520296202972029820299203002030120302203032030420305203062030720308203092031020311203122031320314203152031620317203182031920320203212032220323203242032520326203272032820329203302033120332203332033420335203362033720338203392034020341203422034320344203452034620347203482034920350203512035220353203542035520356203572035820359203602036120362203632036420365203662036720368203692037020371203722037320374203752037620377203782037920380203812038220383203842038520386203872038820389203902039120392203932039420395203962039720398203992040020401204022040320404204052040620407204082040920410204112041220413204142041520416204172041820419204202042120422204232042420425204262042720428204292043020431204322043320434204352043620437204382043920440204412044220443204442044520446204472044820449204502045120452204532045420455204562045720458204592046020461204622046320464204652046620467204682046920470204712047220473204742047520476204772047820479204802048120482204832048420485204862048720488204892049020491204922049320494204952049620497204982049920500205012050220503205042050520506205072050820509205102051120512205132051420515205162051720518205192052020521205222052320524205252052620527205282052920530205312053220533205342053520536205372053820539205402054120542205432054420545205462054720548205492055020551205522055320554205552055620557205582055920560205612056220563205642056520566205672056820569205702057120572205732057420575205762057720578205792058020581205822058320584205852058620587205882058920590205912059220593205942059520596205972059820599206002060120602206032060420605206062060720608206092061020611206122061320614206152061620617206182061920620206212062220623206242062520626206272062820629206302063120632206332063420635206362063720638206392064020641206422064320644206452064620647206482064920650206512065220653206542065520656206572065820659206602066120662206632066420665206662066720668206692067020671206722067320674206752067620677206782067920680206812068220683206842068520686206872068820689206902069120692206932069420695206962069720698206992070020701207022070320704207052070620707207082070920710207112071220713207142071520716207172071820719207202072120722207232072420725207262072720728207292073020731207322073320734207352073620737207382073920740207412074220743207442074520746207472074820749207502075120752207532075420755207562075720758207592076020761207622076320764207652076620767207682076920770207712077220773207742077520776207772077820779207802078120782207832078420785207862078720788207892079020791207922079320794207952079620797207982079920800208012080220803208042080520806208072080820809208102081120812208132081420815208162081720818208192082020821
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 2018 by Michael Van Canneyt
  4. Unit tests for Pascal-to-Javascript converter class.
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************
  11. Examples:
  12. ./testpas2js --suite=TTestModule.TestEmptyProgram
  13. ./testpas2js --suite=TTestModule.TestEmptyUnit
  14. }
  15. unit tcmodules;
  16. {$mode objfpc}{$H+}
  17. interface
  18. uses
  19. Classes, SysUtils, fpcunit, testregistry, contnrs,
  20. jstree, jswriter, jsbase,
  21. PasTree, PScanner, PasResolver, PParser, PasResolveEval,
  22. FPPas2Js;
  23. const
  24. // default parser+scanner options
  25. po_tcmodules = po_Pas2js+[po_KeepScannerError];
  26. co_tcmodules = [coNoTypeInfo];
  27. type
  28. { TTestPasParser }
  29. TTestPasParser = Class(TPasParser)
  30. end;
  31. TOnFindUnit = function(const aUnitName: String): TPasModule of object;
  32. { TTestEnginePasResolver }
  33. TTestEnginePasResolver = class(TPas2JsResolver)
  34. private
  35. FFilename: string;
  36. FModule: TPasModule;
  37. FOnFindUnit: TOnFindUnit;
  38. FParser: TTestPasParser;
  39. FStreamResolver: TStreamResolver;
  40. FScanner: TPascalScanner;
  41. FSource: string;
  42. procedure SetModule(AValue: TPasModule);
  43. public
  44. destructor Destroy; override;
  45. function FindUnit(const AName, InFilename: String; NameExpr,
  46. InFileExpr: TPasExpr): TPasModule; override;
  47. procedure UsedInterfacesFinished(Section: TPasSection); override;
  48. property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
  49. property Filename: string read FFilename write FFilename;
  50. property StreamResolver: TStreamResolver read FStreamResolver write FStreamResolver;
  51. property Scanner: TPascalScanner read FScanner write FScanner;
  52. property Parser: TTestPasParser read FParser write FParser;
  53. property Source: string read FSource write FSource;
  54. property Module: TPasModule read FModule write SetModule;
  55. end;
  56. { TCustomTestModule }
  57. TCustomTestModule = Class(TTestCase)
  58. private
  59. FConverter: TPasToJSConverter;
  60. FEngine: TTestEnginePasResolver;
  61. FExpectedErrorClass: ExceptClass;
  62. FExpectedErrorMsg: string;
  63. FExpectedErrorNumber: integer;
  64. FFilename: string;
  65. FFileResolver: TStreamResolver;
  66. FJSImplementationSrc: TJSSourceElements;
  67. FJSImplementationUses: TJSArrayLiteral;
  68. FJSInitBody: TJSFunctionBody;
  69. FJSImplentationUses: TJSArrayLiteral;
  70. FJSInterfaceUses: TJSArrayLiteral;
  71. FJSModule: TJSSourceElements;
  72. FJSModuleSrc: TJSSourceElements;
  73. FJSSource: TStringList;
  74. FModule: TPasModule;
  75. FJSModuleCallArgs: TJSArguments;
  76. FModules: TObjectList;// list of TTestEnginePasResolver
  77. FParser: TTestPasParser;
  78. FPasProgram: TPasProgram;
  79. FJSRegModuleCall: TJSCallExpression;
  80. FScanner: TPascalScanner;
  81. FSkipTests: boolean;
  82. FSource: TStringList;
  83. FFirstPasStatement: TPasImplBlock;
  84. function GetResolverCount: integer;
  85. function GetResolvers(Index: integer): TTestEnginePasResolver;
  86. function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
  87. protected
  88. procedure SetUp; override;
  89. function CreateConverter: TPasToJSConverter; virtual;
  90. function LoadUnit(const aUnitName: String): TPasModule;
  91. procedure InitScanner(aScanner: TPascalScanner); virtual;
  92. procedure TearDown; override;
  93. Procedure Add(Line: string); virtual;
  94. Procedure Add(const Lines: array of string);
  95. Procedure StartParsing; virtual;
  96. procedure ParseModuleQueue; virtual;
  97. procedure ParseModule; virtual;
  98. procedure ParseProgram; virtual;
  99. procedure ParseUnit; virtual;
  100. protected
  101. function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; virtual;
  102. function AddModule(aFilename: string): TTestEnginePasResolver; virtual;
  103. function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; virtual;
  104. function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  105. ImplementationSrc: string): TTestEnginePasResolver; virtual;
  106. procedure AddSystemUnit; virtual;
  107. procedure StartProgram(NeedSystemUnit: boolean); virtual;
  108. procedure StartUnit(NeedSystemUnit: boolean); virtual;
  109. procedure ConvertModule; virtual;
  110. procedure ConvertProgram; virtual;
  111. procedure ConvertUnit; virtual;
  112. function ConvertJSModuleToString(El: TJSElement): string; virtual;
  113. procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
  114. function GetDottedIdentifier(El: TJSElement): string;
  115. procedure CheckSource(Msg,Statements: String; InitStatements: string = '';
  116. ImplStatements: string = ''); virtual;
  117. procedure CheckDiff(Msg, Expected, Actual: string); virtual;
  118. procedure CheckUnit(Filename, ExpectedSrc: string); virtual;
  119. procedure SetExpectedScannerError(Msg: string; MsgNumber: integer);
  120. procedure SetExpectedParserError(Msg: string; MsgNumber: integer);
  121. procedure SetExpectedPasResolverError(Msg: string; MsgNumber: integer);
  122. procedure SetExpectedConverterError(Msg: string; MsgNumber: integer);
  123. function IsErrorExpected(E: Exception): boolean;
  124. procedure HandleScannerError(E: EScannerError);
  125. procedure HandleParserError(E: EParserError);
  126. procedure HandlePasResolveError(E: EPasResolve);
  127. procedure HandlePas2JSError(E: EPas2JS);
  128. procedure HandleException(E: Exception);
  129. procedure FailException(E: Exception);
  130. procedure WriteSources(const aFilename: string; aRow, aCol: integer);
  131. function IndexOfResolver(const Filename: string): integer;
  132. function GetResolver(const Filename: string): TTestEnginePasResolver;
  133. function GetDefaultNamespace: string;
  134. property PasProgram: TPasProgram Read FPasProgram;
  135. property Resolvers[Index: integer]: TTestEnginePasResolver read GetResolvers;
  136. property ResolverCount: integer read GetResolverCount;
  137. property Engine: TTestEnginePasResolver read FEngine;
  138. property Filename: string read FFilename;
  139. Property Module: TPasModule Read FModule;
  140. property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
  141. property Converter: TPasToJSConverter read FConverter;
  142. property JSSource: TStringList read FJSSource;
  143. property JSModule: TJSSourceElements read FJSModule;
  144. property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
  145. property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
  146. property JSImplementationUses: TJSArrayLiteral read FJSImplementationUses;
  147. property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
  148. property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
  149. property JSInitBody: TJSFunctionBody read FJSInitBody;
  150. property JSImplementationSrc: TJSSourceElements read FJSImplementationSrc;
  151. property ExpectedErrorClass: ExceptClass read FExpectedErrorClass write FExpectedErrorClass;
  152. property ExpectedErrorMsg: string read FExpectedErrorMsg write FExpectedErrorMsg;
  153. property ExpectedErrorNumber: integer read FExpectedErrorNumber write FExpectedErrorNumber;
  154. property SkipTests: boolean read FSkipTests write FSkipTests;
  155. public
  156. property Source: TStringList read FSource;
  157. property FileResolver: TStreamResolver read FFileResolver;
  158. property Scanner: TPascalScanner read FScanner;
  159. property Parser: TTestPasParser read FParser;
  160. end;
  161. { TTestModule }
  162. TTestModule = class(TCustomTestModule)
  163. Published
  164. // program/units
  165. Procedure TestEmptyProgram;
  166. Procedure TestEmptyProgramUseStrict;
  167. Procedure TestEmptyUnit;
  168. Procedure TestEmptyUnitUseStrict;
  169. Procedure TestDottedUnitNames;
  170. Procedure TestDottedUnitNameImpl;
  171. Procedure TestDottedUnitExpr;
  172. Procedure Test_ModeFPCFail;
  173. Procedure Test_ModeSwitchCBlocksFail;
  174. Procedure TestUnit_Intf1Impl2Intf1;
  175. // vars/const
  176. Procedure TestVarInt;
  177. Procedure TestVarBaseTypes;
  178. Procedure TestBaseTypeSingleFail;
  179. Procedure TestBaseTypeExtendedFail;
  180. Procedure TestConstBaseTypes;
  181. Procedure TestUnitImplVars;
  182. Procedure TestUnitImplConsts;
  183. Procedure TestUnitImplRecord;
  184. Procedure TestRenameJSNameConflict;
  185. Procedure TestLocalConst;
  186. Procedure TestVarExternal;
  187. Procedure TestVarExternalOtherUnit;
  188. Procedure TestVarAbsoluteFail;
  189. Procedure TestConstExternal;
  190. // numbers
  191. Procedure TestDouble;
  192. Procedure TestInteger;
  193. Procedure TestIntegerRange;
  194. Procedure TestIntegerTypecasts;
  195. Procedure TestCurrency;
  196. Procedure TestForBoolDo;
  197. Procedure TestForIntDo;
  198. Procedure TestForIntInDo;
  199. // strings
  200. Procedure TestCharConst;
  201. Procedure TestChar_Compare;
  202. Procedure TestChar_Ord;
  203. Procedure TestChar_Chr;
  204. Procedure TestStringConst;
  205. Procedure TestStringConstSurrogate;
  206. Procedure TestString_Length;
  207. Procedure TestString_Compare;
  208. Procedure TestString_SetLength;
  209. Procedure TestString_CharAt;
  210. Procedure TestStr;
  211. Procedure TestBaseType_AnsiStringFail;
  212. Procedure TestBaseType_WideStringFail;
  213. Procedure TestBaseType_ShortStringFail;
  214. Procedure TestBaseType_RawByteStringFail;
  215. Procedure TestTypeShortstring_Fail;
  216. Procedure TestCharSet_Custom;
  217. Procedure TestForCharDo;
  218. Procedure TestForCharInDo;
  219. // alias types
  220. Procedure TestAliasTypeRef;
  221. Procedure TestTypeCast_BaseTypes;
  222. Procedure TestTypeCast_AliasBaseTypes;
  223. // functions
  224. Procedure TestEmptyProc;
  225. Procedure TestProcOneParam;
  226. Procedure TestFunctionWithoutParams;
  227. Procedure TestProcedureWithoutParams;
  228. Procedure TestPrgProcVar;
  229. Procedure TestProcTwoArgs;
  230. Procedure TestProc_DefaultValue;
  231. Procedure TestUnitProcVar;
  232. Procedure TestImplProc;
  233. Procedure TestFunctionResult;
  234. Procedure TestNestedProc;
  235. Procedure TestNestedProc_ResultString;
  236. Procedure TestForwardProc;
  237. Procedure TestNestedForwardProc;
  238. Procedure TestAssignFunctionResult;
  239. Procedure TestFunctionResultInCondition;
  240. Procedure TestFunctionResultInForLoop;
  241. Procedure TestExit;
  242. Procedure TestBreak;
  243. Procedure TestBreakAsVar;
  244. Procedure TestContinue;
  245. Procedure TestProc_External;
  246. Procedure TestProc_ExternalOtherUnit;
  247. Procedure TestProc_Asm;
  248. Procedure TestProc_Assembler;
  249. Procedure TestProc_VarParam;
  250. Procedure TestProc_VarParamString;
  251. Procedure TestProc_VarParamV;
  252. Procedure TestProc_Overload;
  253. Procedure TestProc_OverloadForward;
  254. Procedure TestProc_OverloadIntfImpl;
  255. Procedure TestProc_OverloadNested;
  256. Procedure TestProc_OverloadUnitCycle;
  257. Procedure TestProc_Varargs;
  258. Procedure TestProc_ConstOrder;
  259. Procedure TestProc_DuplicateConst;
  260. Procedure TestProc_LocalVarAbsolute;
  261. // enums, sets
  262. Procedure TestEnum_Name;
  263. Procedure TestEnum_Number;
  264. Procedure TestEnum_ConstFail;
  265. Procedure TestEnum_Functions;
  266. Procedure TestEnum_AsParams;
  267. Procedure TestEnumRange_Array;
  268. Procedure TestEnum_ForIn;
  269. Procedure TestEnum_ScopedNumber;
  270. Procedure TestSet;
  271. Procedure TestSet_Operators;
  272. Procedure TestSet_Operator_In;
  273. Procedure TestSet_Functions;
  274. Procedure TestSet_PassAsArgClone;
  275. Procedure TestSet_AsParams;
  276. Procedure TestSet_Property;
  277. Procedure TestSet_EnumConst;
  278. Procedure TestSet_AnonymousEnumType;
  279. Procedure TestSet_AnonymousEnumTypeChar; // ToDo
  280. Procedure TestSet_ConstEnum;
  281. Procedure TestSet_ConstChar;
  282. Procedure TestSet_ConstInt;
  283. Procedure TestSet_ForIn;
  284. // statements
  285. Procedure TestNestBegin;
  286. Procedure TestIncDec;
  287. Procedure TestAssignments;
  288. Procedure TestArithmeticOperators1;
  289. Procedure TestLogicalOperators;
  290. Procedure TestBitwiseOperators;
  291. Procedure TestFunctionInt;
  292. Procedure TestFunctionString;
  293. Procedure TestForLoop;
  294. Procedure TestForLoopInsideFunction;
  295. Procedure TestForLoop_ReadVarAfter;
  296. Procedure TestForLoop_Nested;
  297. Procedure TestRepeatUntil;
  298. Procedure TestAsmBlock;
  299. Procedure TestAsmPas_Impl; // ToDo
  300. Procedure TestTryFinally;
  301. Procedure TestTryExcept;
  302. Procedure TestCaseOf;
  303. Procedure TestCaseOf_UseSwitch;
  304. Procedure TestCaseOfNoElse;
  305. Procedure TestCaseOfNoElse_UseSwitch;
  306. Procedure TestCaseOfRange;
  307. Procedure TestCaseOfString;
  308. // arrays
  309. Procedure TestArray_Dynamic;
  310. Procedure TestArray_Dynamic_Nil;
  311. Procedure TestArray_DynMultiDimensional;
  312. Procedure TestArray_StaticInt;
  313. Procedure TestArray_StaticBool;
  314. Procedure TestArray_StaticChar;
  315. Procedure TestArray_StaticMultiDim; // ToDo
  316. Procedure TestArrayOfRecord;
  317. // ToDo: Procedure TestArrayOfSet;
  318. Procedure TestArray_DynAsParam;
  319. Procedure TestArray_StaticAsParam;
  320. Procedure TestArrayElement_AsParams;
  321. Procedure TestArrayElementFromFuncResult_AsParams;
  322. Procedure TestArrayEnumTypeRange;
  323. Procedure TestArray_SetLengthOutArg;
  324. Procedure TestArray_SetLengthProperty;
  325. Procedure TestArray_SetLengthMultiDim;
  326. Procedure TestArray_OpenArrayOfString;
  327. Procedure TestArray_Concat;
  328. Procedure TestArray_Copy;
  329. Procedure TestArray_InsertDelete;
  330. Procedure TestArray_DynArrayConst;
  331. Procedure TestArray_ForInArrOfString;
  332. Procedure TestExternalClass_TypeCastArrayToExternalArray;
  333. Procedure TestExternalClass_TypeCastArrayFromExternalArray;
  334. // record
  335. Procedure TestRecord_Empty;
  336. Procedure TestRecord_Var;
  337. Procedure TestWithRecordDo;
  338. Procedure TestRecord_Assign;
  339. Procedure TestRecord_PassAsArgClone;
  340. Procedure TestRecord_AsParams;
  341. Procedure TestRecordElement_AsParams;
  342. Procedure TestRecordElementFromFuncResult_AsParams;
  343. Procedure TestRecordElementFromWith_AsParams;
  344. Procedure TestRecord_Equal;
  345. Procedure TestRecord_TypeCastJSValueToRecord;
  346. Procedure TestRecord_VariantFail;
  347. Procedure TestRecord_FieldArray;
  348. Procedure TestRecord_Const;
  349. Procedure TestRecord_TypecastFail;
  350. // classes
  351. Procedure TestClass_TObjectDefaultConstructor;
  352. Procedure TestClass_TObjectConstructorWithParams;
  353. Procedure TestClass_TObjectConstructorWithDefaultParam;
  354. Procedure TestClass_Var;
  355. Procedure TestClass_Method;
  356. Procedure TestClass_Implementation;
  357. Procedure TestClass_Inheritance;
  358. Procedure TestClass_TypeAlias;
  359. Procedure TestClass_AbstractMethod;
  360. Procedure TestClass_CallInherited_NoParams;
  361. Procedure TestClass_CallInherited_WithParams;
  362. Procedure TestClasS_CallInheritedConstructor;
  363. Procedure TestClass_ClassVar;
  364. Procedure TestClass_CallClassMethod;
  365. Procedure TestClass_Property;
  366. Procedure TestClass_Property_ClassMethod;
  367. Procedure TestClass_Property_Indexed;
  368. Procedure TestClass_Property_IndexSpec;
  369. Procedure TestClass_PropertyOfTypeArray;
  370. Procedure TestClass_PropertyDefault;
  371. Procedure TestClass_PropertyDefault2;
  372. Procedure TestClass_PropertyOverride;
  373. Procedure TestClass_PropertyIncVisibility;
  374. Procedure TestClass_Assigned;
  375. Procedure TestClass_WithClassDoCreate;
  376. Procedure TestClass_WithClassInstDoProperty;
  377. Procedure TestClass_WithClassInstDoPropertyWithParams;
  378. Procedure TestClass_WithClassInstDoFunc;
  379. Procedure TestClass_TypeCast;
  380. Procedure TestClass_TypeCastUntypedParam;
  381. Procedure TestClass_Overloads;
  382. Procedure TestClass_OverloadsAncestor;
  383. Procedure TestClass_OverloadConstructor;
  384. Procedure TestClass_OverloadDelphiOverride;
  385. Procedure TestClass_ReintroducedVar;
  386. Procedure TestClass_RaiseDescendant;
  387. Procedure TestClass_ExternalMethod;
  388. Procedure TestClass_ExternalVirtualNameMismatchFail;
  389. Procedure TestClass_ExternalOverrideFail;
  390. Procedure TestClass_ExternalVar;
  391. Procedure TestClass_Const;
  392. Procedure TestClass_LocalVarSelfFail;
  393. Procedure TestClass_ArgSelfFail;
  394. Procedure TestClass_NestedProcSelf;
  395. Procedure TestClass_NestedProcSelf2;
  396. Procedure TestClass_NestedProcClassSelf;
  397. Procedure TestClass_NestedProcCallInherited;
  398. Procedure TestClass_TObjectFree;
  399. Procedure TestClass_TObjectFreeNewInstance;
  400. Procedure TestClass_TObjectFreeLowerCase;
  401. Procedure TestClass_TObjectFreeFunctionFail;
  402. Procedure TestClass_TObjectFreePropertyFail;
  403. Procedure TestClass_ForIn;
  404. // class of
  405. Procedure TestClassOf_Create;
  406. Procedure TestClassOf_Call;
  407. Procedure TestClassOf_Assign;
  408. Procedure TestClassOf_Is;
  409. Procedure TestClassOf_Compare;
  410. Procedure TestClassOf_ClassVar;
  411. Procedure TestClassOf_ClassMethod;
  412. Procedure TestClassOf_ClassProperty;
  413. Procedure TestClassOf_ClassMethodSelf;
  414. Procedure TestClassOf_TypeCast;
  415. Procedure TestClassOf_ImplicitFunctionCall;
  416. Procedure TestClassOf_Const;
  417. // nested class
  418. Procedure TestNestedClass_Alias;
  419. Procedure TestNestedClass_Record;
  420. Procedure TestNestedClass_Class;
  421. // external class
  422. Procedure TestExternalClass_Var;
  423. Procedure TestExternalClass_Const;
  424. Procedure TestExternalClass_Dollar;
  425. Procedure TestExternalClass_DuplicateVarFail;
  426. Procedure TestExternalClass_Method;
  427. Procedure TestExternalClass_ClassMethod;
  428. Procedure TestExternalClass_NonExternalOverride;
  429. Procedure TestExternalClass_Property;
  430. Procedure TestExternalClass_ClassProperty;
  431. Procedure TestExternalClass_ClassOf;
  432. Procedure TestExternalClass_ClassOtherUnit;
  433. Procedure TestExternalClass_Is;
  434. Procedure TestExternalClass_As;
  435. Procedure TestExternalClass_DestructorFail;
  436. Procedure TestExternalClass_New;
  437. Procedure TestExternalClass_ClassOf_New;
  438. Procedure TestExternalClass_FuncClassOf_New;
  439. Procedure TestExternalClass_LocalConstSameName;
  440. Procedure TestExternalClass_ReintroduceOverload;
  441. Procedure TestExternalClass_Inherited;
  442. Procedure TestExternalClass_PascalAncestorFail;
  443. Procedure TestExternalClass_NewInstance;
  444. Procedure TestExternalClass_NewInstance_NonVirtualFail;
  445. Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
  446. Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail;
  447. Procedure TestExternalClass_PascalProperty;
  448. Procedure TestExternalClass_TypeCastToRootClass;
  449. Procedure TestExternalClass_TypeCastToJSObject;
  450. Procedure TestExternalClass_TypeCastStringToExternalString;
  451. Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
  452. Procedure TestExternalClass_BracketAccessor;
  453. Procedure TestExternalClass_BracketAccessor_2ParamsFail;
  454. Procedure TestExternalClass_BracketAccessor_ReadOnly;
  455. Procedure TestExternalClass_BracketAccessor_WriteOnly;
  456. Procedure TestExternalClass_BracketAccessor_MultiType;
  457. Procedure TestExternalClass_BracketAccessor_Index;
  458. Procedure TestExternalClass_ForInJSObject;
  459. // class interfaces
  460. Procedure TestClassInterface_Corba;
  461. Procedure TestClassInterface_ProcExternalFail;
  462. Procedure TestClassInterface_Overloads;
  463. Procedure TestClassInterface_DuplicateGUIInIntfListFail;
  464. Procedure TestClassInterface_DuplicateGUIInAncestorFail;
  465. Procedure TestClassInterface_AncestorImpl;
  466. Procedure TestClassInterface_ImplReintroduce;
  467. Procedure TestClassInterface_MethodResolution;
  468. Procedure TestClassInterface_AncestorMoreInterfaces;
  469. Procedure TestClassInterface_Corba_Delegation;
  470. Procedure TestClassInterface_Corba_DelegationStatic;
  471. Procedure TestClassInterface_Corba_Operators;
  472. Procedure TestClassInterface_Corba_Args;
  473. Procedure TestClassInterface_Corba_ForIn;
  474. Procedure TestClassInterface_COM_AssignVar;
  475. Procedure TestClassInterface_COM_AssignArg;
  476. Procedure TestClassInterface_COM_FunctionResult;
  477. Procedure TestClassInterface_COM_InheritedFuncResult;
  478. Procedure TestClassInterface_COM_IsAsTypeCasts;
  479. Procedure TestClassInterface_COM_PassAsArg;
  480. Procedure TestClassInterface_COM_PassToUntypedParam;
  481. Procedure TestClassInterface_COM_FunctionInExpr;
  482. Procedure TestClassInterface_COM_Property;
  483. Procedure TestClassInterface_COM_IntfProperty;
  484. Procedure TestClassInterface_COM_Delegation;
  485. Procedure TestClassInterface_COM_With;
  486. Procedure TestClassInterface_COM_ForIn;
  487. Procedure TestClassInterface_COM_ArrayOfIntfFail;
  488. Procedure TestClassInterface_COM_RecordIntfFail;
  489. Procedure TestClassInterface_COM_UnitInitialization;
  490. Procedure TestClassInterface_GUID;
  491. Procedure TestClassInterface_GUIDProperty;
  492. // proc types
  493. Procedure TestProcType;
  494. Procedure TestProcType_Arg;
  495. Procedure TestProcType_FunctionFPC;
  496. Procedure TestProcType_FunctionDelphi;
  497. Procedure TestProcType_ProcedureDelphi;
  498. Procedure TestProcType_AsParam;
  499. Procedure TestProcType_MethodFPC;
  500. Procedure TestProcType_MethodDelphi;
  501. Procedure TestProcType_PropertyFPC;
  502. Procedure TestProcType_PropertyDelphi;
  503. Procedure TestProcType_WithClassInstDoPropertyFPC;
  504. Procedure TestProcType_Nested;
  505. Procedure TestProcType_NestedOfObject;
  506. Procedure TestProcType_ReferenceToProc;
  507. Procedure TestProcType_ReferenceToMethod;
  508. Procedure TestProcType_Typecast;
  509. Procedure TestProcType_PassProcToUntyped;
  510. Procedure TestProcType_PassProcToArray;
  511. // pointer
  512. Procedure TestPointer;
  513. Procedure TestPointer_Proc;
  514. Procedure TestPointer_AssignRecordFail;
  515. Procedure TestPointer_AssignStaticArrayFail;
  516. Procedure TestPointer_TypeCastJSValueToPointer;
  517. Procedure TestPointer_NonRecordFail;
  518. Procedure TestPointer_AnonymousArgTypeFail;
  519. Procedure TestPointer_AnonymousVarTypeFail;
  520. Procedure TestPointer_AnonymousResultTypeFail;
  521. Procedure TestPointer_AddrOperatorFail;
  522. Procedure TestPointer_ArrayParamsFail;
  523. Procedure TestPointer_PointerAddFail;
  524. Procedure TestPointer_IncPointerFail;
  525. Procedure TestPointer_Record;
  526. Procedure TestPointer_RecordArg;
  527. // jsvalue
  528. Procedure TestJSValue_AssignToJSValue;
  529. Procedure TestJSValue_TypeCastToBaseType;
  530. Procedure TestJSValue_Equal;
  531. Procedure TestJSValue_If;
  532. Procedure TestJSValue_Not;
  533. Procedure TestJSValue_Enum;
  534. Procedure TestJSValue_ClassInstance;
  535. Procedure TestJSValue_ClassOf;
  536. Procedure TestJSValue_ArrayOfJSValue;
  537. Procedure TestJSValue_Params;
  538. Procedure TestJSValue_UntypedParam;
  539. Procedure TestJSValue_FuncResultType;
  540. Procedure TestJSValue_ProcType_Assign;
  541. Procedure TestJSValue_ProcType_Equal;
  542. Procedure TestJSValue_ProcType_Param;
  543. Procedure TestJSValue_AssignToPointerFail;
  544. Procedure TestJSValue_OverloadDouble;
  545. Procedure TestJSValue_OverloadNativeInt;
  546. Procedure TestJSValue_OverloadWord;
  547. Procedure TestJSValue_OverloadString;
  548. Procedure TestJSValue_OverloadChar;
  549. Procedure TestJSValue_OverloadPointer;
  550. Procedure TestJSValue_ForIn;
  551. // RTTI
  552. Procedure TestRTTI_ProcType;
  553. Procedure TestRTTI_ProcType_ArgFromOtherUnit;
  554. Procedure TestRTTI_EnumAndSetType;
  555. Procedure TestRTTI_EnumRange;
  556. Procedure TestRTTI_AnonymousEnumType;
  557. Procedure TestRTTI_StaticArray;
  558. Procedure TestRTTI_DynArray;
  559. Procedure TestRTTI_ArrayNestedAnonymous;
  560. Procedure TestRTTI_PublishedMethodOverloadFail;
  561. Procedure TestRTTI_PublishedMethodExternalFail;
  562. Procedure TestRTTI_PublishedClassPropertyFail;
  563. Procedure TestRTTI_PublishedClassFieldFail;
  564. Procedure TestRTTI_PublishedFieldExternalFail;
  565. Procedure TestRTTI_IndexModifier;
  566. Procedure TestRTTI_StoredModifier;
  567. Procedure TestRTTI_DefaultValue;
  568. Procedure TestRTTI_DefaultValueSet;
  569. Procedure TestRTTI_DefaultValueRangeType;
  570. Procedure TestRTTI_DefaultValueInherit;
  571. Procedure TestRTTI_Class_Field;
  572. Procedure TestRTTI_Class_Method;
  573. Procedure TestRTTI_Class_MethodArgFlags;
  574. Procedure TestRTTI_Class_Property;
  575. Procedure TestRTTI_Class_PropertyParams;
  576. Procedure TestRTTI_OverrideMethod;
  577. Procedure TestRTTI_OverloadProperty;
  578. // ToDo: array argument
  579. Procedure TestRTTI_ClassForward;
  580. Procedure TestRTTI_ClassOf;
  581. Procedure TestRTTI_Record;
  582. Procedure TestRTTI_RecordAnonymousArray;
  583. Procedure TestRTTI_LocalTypes;
  584. Procedure TestRTTI_TypeInfo_BaseTypes;
  585. Procedure TestRTTI_TypeInfo_Type_BaseTypes;
  586. Procedure TestRTTI_TypeInfo_LocalFail;
  587. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  588. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  589. Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  590. Procedure TestRTTI_TypeInfo_FunctionClassType;
  591. Procedure TestRTTI_Interface_Corba;
  592. Procedure TestRTTI_Interface_COM;
  593. // Resourcestring
  594. Procedure TestResourcestringProgram;
  595. Procedure TestResourcestringUnit;
  596. Procedure TestResourcestringImplementation;
  597. // Attributes
  598. Procedure TestAtributes_Ignore;
  599. // Assertions, checks
  600. procedure TestAssert;
  601. procedure TestAssert_SysUtils;
  602. procedure TestObjectChecks;
  603. procedure TestRangeChecks_AssignInt;
  604. procedure TestRangeChecks_AssignIntRange;
  605. procedure TestRangeChecks_AssignEnum;
  606. procedure TestRangeChecks_AssignEnumRange;
  607. procedure TestRangeChecks_AssignChar;
  608. procedure TestRangeChecks_AssignCharRange;
  609. procedure TestRangeChecks_ArrayIndex;
  610. procedure TestRangeChecks_StringIndex;
  611. procedure TestRangeChecks_TypecastInt;
  612. end;
  613. function LinesToStr(Args: array of const): string;
  614. function ExtractFileUnitName(aFilename: string): string;
  615. function JSToStr(El: TJSElement): string;
  616. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  617. implementation
  618. function LinesToStr(Args: array of const): string;
  619. var
  620. s: String;
  621. i: Integer;
  622. begin
  623. s:='';
  624. for i:=Low(Args) to High(Args) do
  625. case Args[i].VType of
  626. vtChar: s += Args[i].VChar+LineEnding;
  627. vtString: s += Args[i].VString^+LineEnding;
  628. vtPChar: s += Args[i].VPChar+LineEnding;
  629. vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
  630. vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
  631. vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
  632. vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
  633. vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
  634. end;
  635. Result:=s;
  636. end;
  637. function ExtractFileUnitName(aFilename: string): string;
  638. var
  639. p: Integer;
  640. begin
  641. Result:=ExtractFileName(aFilename);
  642. if Result='' then exit;
  643. for p:=length(Result) downto 1 do
  644. case Result[p] of
  645. '/','\': exit;
  646. '.':
  647. begin
  648. Delete(Result,p,length(Result));
  649. exit;
  650. end;
  651. end;
  652. end;
  653. function JSToStr(El: TJSElement): string;
  654. var
  655. aWriter: TBufferWriter;
  656. aJSWriter: TJSWriter;
  657. begin
  658. aJSWriter:=nil;
  659. aWriter:=TBufferWriter.Create(1000);
  660. try
  661. aJSWriter:=TJSWriter.Create(aWriter);
  662. aJSWriter.IndentSize:=2;
  663. aJSWriter.WriteJS(El);
  664. Result:=aWriter.AsAnsistring;
  665. finally
  666. aJSWriter.Free;
  667. aWriter.Free;
  668. end;
  669. end;
  670. function CheckSrcDiff(Expected, Actual: string; out Msg: string): boolean;
  671. // search diff, ignore changes in spaces
  672. const
  673. SpaceChars = [#9,#10,#13,' '];
  674. var
  675. ExpectedP, ActualP: PChar;
  676. function FindLineEnd(p: PChar): PChar;
  677. begin
  678. Result:=p;
  679. while not (Result^ in [#0,#10,#13]) do inc(Result);
  680. end;
  681. function FindLineStart(p, MinP: PChar): PChar;
  682. begin
  683. while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
  684. Result:=p;
  685. end;
  686. procedure SkipLineEnd(var p: PChar);
  687. begin
  688. if p^ in [#10,#13] then
  689. begin
  690. if (p[1] in [#10,#13]) and (p^<>p[1]) then
  691. inc(p,2)
  692. else
  693. inc(p);
  694. end;
  695. end;
  696. procedure DiffFound;
  697. var
  698. ActLineStartP, ActLineEndP, p, StartPos: PChar;
  699. ExpLine, ActLine: String;
  700. i, LineNo, DiffLineNo: Integer;
  701. begin
  702. writeln('Diff found "',Msg,'". Lines:');
  703. // write correct lines
  704. p:=PChar(Expected);
  705. LineNo:=0;
  706. DiffLineNo:=0;
  707. repeat
  708. StartPos:=p;
  709. while not (p^ in [#0,#10,#13]) do inc(p);
  710. ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
  711. SkipLineEnd(p);
  712. inc(LineNo);
  713. if (p<=ExpectedP) and (p^<>#0) then
  714. begin
  715. writeln('= ',ExpLine);
  716. end else begin
  717. // diff line
  718. if DiffLineNo=0 then DiffLineNo:=LineNo;
  719. // write actual line
  720. ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
  721. ActLineEndP:=FindLineEnd(ActualP);
  722. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  723. writeln('- ',ActLine);
  724. // write expected line
  725. writeln('+ ',ExpLine);
  726. // write empty line with pointer ^
  727. for i:=1 to 2+ExpectedP-StartPos do write(' ');
  728. writeln('^');
  729. Msg:='expected "'+ExpLine+'", but got "'+ActLine+'".';
  730. CheckSrcDiff:=false;
  731. // write up to three following actual lines to get some context
  732. for i:=1 to 3 do begin
  733. ActLineStartP:=ActLineEndP;
  734. SkipLineEnd(ActLineStartP);
  735. if ActLineStartP^=#0 then break;
  736. ActLineEndP:=FindLineEnd(ActLineStartP);
  737. ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
  738. writeln('~ ',ActLine);
  739. end;
  740. exit;
  741. end;
  742. until p^=#0;
  743. writeln('DiffFound Actual:-----------------------');
  744. writeln(Actual);
  745. writeln('DiffFound Expected:---------------------');
  746. writeln(Expected);
  747. writeln('DiffFound ------------------------------');
  748. Msg:='diff found, but lines are the same, internal error';
  749. CheckSrcDiff:=false;
  750. end;
  751. var
  752. IsSpaceNeeded: Boolean;
  753. LastChar, Quote: Char;
  754. begin
  755. Result:=true;
  756. Msg:='';
  757. if Expected='' then Expected:=' ';
  758. if Actual='' then Actual:=' ';
  759. ExpectedP:=PChar(Expected);
  760. ActualP:=PChar(Actual);
  761. repeat
  762. //writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
  763. case ExpectedP^ of
  764. #0:
  765. begin
  766. // check that rest of Actual has only spaces
  767. while ActualP^ in SpaceChars do inc(ActualP);
  768. if ActualP^<>#0 then
  769. begin
  770. DiffFound;
  771. exit;
  772. end;
  773. exit(true);
  774. end;
  775. ' ',#9,#10,#13:
  776. begin
  777. // skip space in Expected
  778. IsSpaceNeeded:=false;
  779. if ExpectedP>PChar(Expected) then
  780. LastChar:=ExpectedP[-1]
  781. else
  782. LastChar:=#0;
  783. while ExpectedP^ in SpaceChars do inc(ExpectedP);
  784. if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
  785. and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
  786. IsSpaceNeeded:=true;
  787. if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
  788. begin
  789. DiffFound;
  790. exit;
  791. end;
  792. while ActualP^ in SpaceChars do inc(ActualP);
  793. end;
  794. '''','"':
  795. begin
  796. while ActualP^ in SpaceChars do inc(ActualP);
  797. if ExpectedP^<>ActualP^ then
  798. begin
  799. DiffFound;
  800. exit;
  801. end;
  802. Quote:=ExpectedP^;
  803. repeat
  804. inc(ExpectedP);
  805. inc(ActualP);
  806. if ExpectedP^<>ActualP^ then
  807. begin
  808. DiffFound;
  809. exit;
  810. end;
  811. if (ExpectedP^ in [#0,#10,#13]) then
  812. break
  813. else if (ExpectedP^=Quote) then
  814. begin
  815. inc(ExpectedP);
  816. inc(ActualP);
  817. break;
  818. end;
  819. until false;
  820. end;
  821. else
  822. while ActualP^ in SpaceChars do inc(ActualP);
  823. if ExpectedP^<>ActualP^ then
  824. begin
  825. DiffFound;
  826. exit;
  827. end;
  828. inc(ExpectedP);
  829. inc(ActualP);
  830. end;
  831. until false;
  832. end;
  833. { TTestEnginePasResolver }
  834. procedure TTestEnginePasResolver.SetModule(AValue: TPasModule);
  835. begin
  836. if FModule=AValue then Exit;
  837. if Module<>nil then
  838. Module.Release;
  839. FModule:=AValue;
  840. if Module<>nil then
  841. Module.AddRef;
  842. end;
  843. destructor TTestEnginePasResolver.Destroy;
  844. begin
  845. FreeAndNil(FStreamResolver);
  846. Module:=nil;
  847. FreeAndNil(FParser);
  848. FreeAndNil(FScanner);
  849. FreeAndNil(FStreamResolver);
  850. inherited Destroy;
  851. end;
  852. function TTestEnginePasResolver.FindUnit(const AName, InFilename: String;
  853. NameExpr, InFileExpr: TPasExpr): TPasModule;
  854. begin
  855. Result:=nil;
  856. if InFilename<>'' then
  857. RaiseNotYetImplemented(20180224101926,InFileExpr,'Use testcase tcunitsearch instead');
  858. if Assigned(OnFindUnit) then
  859. Result:=OnFindUnit(AName);
  860. if NameExpr=nil then ;
  861. end;
  862. procedure TTestEnginePasResolver.UsedInterfacesFinished(Section: TPasSection);
  863. begin
  864. // do not parse recursively
  865. // parse via the queue
  866. if Section=nil then ;
  867. end;
  868. { TCustomTestModule }
  869. function TCustomTestModule.GetResolverCount: integer;
  870. begin
  871. Result:=FModules.Count;
  872. end;
  873. function TCustomTestModule.GetResolvers(Index: integer
  874. ): TTestEnginePasResolver;
  875. begin
  876. Result:=TTestEnginePasResolver(FModules[Index]);
  877. end;
  878. function TCustomTestModule.OnPasResolverFindUnit(const aUnitName: String
  879. ): TPasModule;
  880. var
  881. DefNamespace: String;
  882. begin
  883. //writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
  884. if (Pos('.',aUnitName)<1) then
  885. begin
  886. DefNamespace:=GetDefaultNamespace;
  887. if DefNamespace<>'' then
  888. begin
  889. Result:=LoadUnit(DefNamespace+'.'+aUnitName);
  890. if Result<>nil then exit;
  891. end;
  892. end;
  893. Result:=LoadUnit(aUnitName);
  894. if Result<>nil then exit;
  895. writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
  896. Fail('can''t find unit "'+aUnitName+'"');
  897. end;
  898. function TCustomTestModule.LoadUnit(const aUnitName: String): TPasModule;
  899. var
  900. i: Integer;
  901. CurEngine: TTestEnginePasResolver;
  902. CurUnitName: String;
  903. begin
  904. //writeln('TTestModule.FindUnit START Unit="',aUnitName,'"');
  905. Result:=nil;
  906. if (Module.ClassType=TPasModule)
  907. and (CompareText(Module.Name,aUnitName)=0) then
  908. exit(Module);
  909. for i:=0 to ResolverCount-1 do
  910. begin
  911. CurEngine:=Resolvers[i];
  912. CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
  913. //writeln('TTestModule.FindUnit Checking ',i,'/',ResolverCount,' ',CurEngine.Filename,' ',CurUnitName);
  914. if CompareText(aUnitName,CurUnitName)=0 then
  915. begin
  916. Result:=CurEngine.Module;
  917. if Result<>nil then exit;
  918. //writeln('TTestModule.FindUnit PARSING unit "',CurEngine.Filename,'"');
  919. FileResolver.FindSourceFile(aUnitName);
  920. CurEngine.StreamResolver:=TStreamResolver.Create;
  921. CurEngine.StreamResolver.OwnsStreams:=True;
  922. //writeln('TTestModule.FindUnit SOURCE=',CurEngine.Source);
  923. CurEngine.StreamResolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
  924. CurEngine.Scanner:=TPascalScanner.Create(CurEngine.StreamResolver);
  925. InitScanner(CurEngine.Scanner);
  926. CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.StreamResolver,CurEngine);
  927. CurEngine.Parser.Options:=po_tcmodules;
  928. if CompareText(CurUnitName,'System')=0 then
  929. CurEngine.Parser.ImplicitUses.Clear;
  930. CurEngine.Scanner.OpenFile(CurEngine.Filename);
  931. try
  932. CurEngine.Parser.NextToken;
  933. CurEngine.Parser.ParseUnit(CurEngine.FModule);
  934. except
  935. on E: Exception do
  936. HandleException(E);
  937. end;
  938. //writeln('TTestModule.FindUnit END ',CurUnitName);
  939. Result:=CurEngine.Module;
  940. exit;
  941. end;
  942. end;
  943. end;
  944. procedure TCustomTestModule.SetUp;
  945. begin
  946. inherited SetUp;
  947. FSkipTests:=false;
  948. FSource:=TStringList.Create;
  949. FModules:=TObjectList.Create(true);
  950. FFilename:='test1.pp';
  951. FFileResolver:=TStreamResolver.Create;
  952. FFileResolver.OwnsStreams:=True;
  953. FScanner:=TPascalScanner.Create(FFileResolver);
  954. InitScanner(FScanner);
  955. FEngine:=AddModule(Filename);
  956. FEngine.Scanner:=FScanner;
  957. FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
  958. FEngine.Parser:=FParser;
  959. Parser.Options:=po_tcmodules;
  960. FModule:=Nil;
  961. FConverter:=CreateConverter;
  962. FExpectedErrorClass:=nil;
  963. end;
  964. function TCustomTestModule.CreateConverter: TPasToJSConverter;
  965. begin
  966. Result:=TPasToJSConverter.Create;
  967. Result.Options:=co_tcmodules;
  968. end;
  969. procedure TCustomTestModule.InitScanner(aScanner: TPascalScanner);
  970. begin
  971. aScanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
  972. aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
  973. aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
  974. aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
  975. aScanner.CurrentBoolSwitches:=[bsHints,bsNotes,bsWarnings,bsWriteableConst];
  976. end;
  977. procedure TCustomTestModule.TearDown;
  978. begin
  979. FSkipTests:=false;
  980. FJSModule:=nil;
  981. FJSRegModuleCall:=nil;
  982. FJSModuleCallArgs:=nil;
  983. FJSImplentationUses:=nil;
  984. FJSInterfaceUses:=nil;
  985. FJSModuleSrc:=nil;
  986. FJSInitBody:=nil;
  987. FreeAndNil(FJSSource);
  988. FreeAndNil(FJSModule);
  989. FreeAndNil(FConverter);
  990. Engine.Clear;
  991. if Assigned(FModule) then
  992. begin
  993. FModule.Release;
  994. FModule:=nil;
  995. end;
  996. FreeAndNil(FSource);
  997. FreeAndNil(FFileResolver);
  998. if FModules<>nil then
  999. begin
  1000. FreeAndNil(FModules);
  1001. FEngine:=nil;
  1002. end;
  1003. inherited TearDown;
  1004. end;
  1005. procedure TCustomTestModule.Add(Line: string);
  1006. begin
  1007. Source.Add(Line);
  1008. end;
  1009. procedure TCustomTestModule.Add(const Lines: array of string);
  1010. var
  1011. i: Integer;
  1012. begin
  1013. for i:=low(Lines) to high(Lines) do
  1014. Add(Lines[i]);
  1015. end;
  1016. procedure TCustomTestModule.StartParsing;
  1017. var
  1018. Src: String;
  1019. begin
  1020. Src:=Source.Text;
  1021. FEngine.Source:=Src;
  1022. FileResolver.AddStream(FileName,TStringStream.Create(Src));
  1023. Scanner.OpenFile(FileName);
  1024. Writeln('// Test : ',Self.TestName);
  1025. Writeln(Src);
  1026. end;
  1027. procedure TCustomTestModule.ParseModuleQueue;
  1028. var
  1029. i: Integer;
  1030. CurResolver: TTestEnginePasResolver;
  1031. Found: Boolean;
  1032. Section: TPasSection;
  1033. begin
  1034. // parse til exception or all modules finished
  1035. while not SkipTests do
  1036. begin
  1037. Found:=false;
  1038. for i:=0 to ResolverCount-1 do
  1039. begin
  1040. CurResolver:=Resolvers[i];
  1041. if CurResolver.CurrentParser=nil then continue;
  1042. if not CurResolver.CurrentParser.CanParseContinue(Section) then
  1043. continue;
  1044. CurResolver.Parser.ParseContinue;
  1045. Found:=true;
  1046. break;
  1047. end;
  1048. if not Found then break;
  1049. end;
  1050. for i:=0 to ResolverCount-1 do
  1051. begin
  1052. CurResolver:=Resolvers[i];
  1053. if CurResolver.Parser=nil then
  1054. begin
  1055. if CurResolver.CurrentParser<>nil then
  1056. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' '+GetObjName(CurResolver.Parser)+'=Parser<>CurrentParser='+GetObjName(CurResolver.CurrentParser));
  1057. continue;
  1058. end;
  1059. if CurResolver.Parser.CurModule<>nil then
  1060. Fail('TCustomTestModule.ParseModuleQueue '+CurResolver.Filename+' NOT FINISHED CurModule='+GetObjName(CurResolver.Parser.CurModule));
  1061. end;
  1062. end;
  1063. procedure TCustomTestModule.ParseModule;
  1064. begin
  1065. if SkipTests then exit;
  1066. FFirstPasStatement:=nil;
  1067. try
  1068. StartParsing;
  1069. Parser.ParseMain(FModule);
  1070. ParseModuleQueue;
  1071. except
  1072. on E: Exception do
  1073. HandleException(E);
  1074. end;
  1075. if SkipTests then exit;
  1076. AssertNotNull('Module resulted in Module',FModule);
  1077. AssertEquals('modulename',lowercase(ChangeFileExt(FFileName,'')),lowercase(Module.Name));
  1078. TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
  1079. end;
  1080. procedure TCustomTestModule.ParseProgram;
  1081. begin
  1082. if SkipTests then exit;
  1083. ParseModule;
  1084. if SkipTests then exit;
  1085. AssertEquals('Has program',TPasProgram,Module.ClassType);
  1086. FPasProgram:=TPasProgram(Module);
  1087. AssertNotNull('Has program section',PasProgram.ProgramSection);
  1088. AssertNotNull('Has initialization section',PasProgram.InitializationSection);
  1089. if (PasProgram.InitializationSection.Elements.Count>0) then
  1090. if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
  1091. FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
  1092. end;
  1093. procedure TCustomTestModule.ParseUnit;
  1094. begin
  1095. if SkipTests then exit;
  1096. ParseModule;
  1097. if SkipTests then exit;
  1098. AssertEquals('Has unit (TPasModule)',TPasModule,Module.ClassType);
  1099. AssertNotNull('Has interface section',Module.InterfaceSection);
  1100. AssertNotNull('Has implementation section',Module.ImplementationSection);
  1101. if (Module.InitializationSection<>nil)
  1102. and (Module.InitializationSection.Elements.Count>0)
  1103. and (TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock) then
  1104. FFirstPasStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]);
  1105. end;
  1106. function TCustomTestModule.FindModuleWithFilename(aFilename: string
  1107. ): TTestEnginePasResolver;
  1108. var
  1109. i: Integer;
  1110. begin
  1111. for i:=0 to ResolverCount-1 do
  1112. if CompareText(Resolvers[i].Filename,aFilename)=0 then
  1113. exit(Resolvers[i]);
  1114. Result:=nil;
  1115. end;
  1116. function TCustomTestModule.AddModule(aFilename: string
  1117. ): TTestEnginePasResolver;
  1118. begin
  1119. //writeln('TTestModuleConverter.AddModule ',aFilename);
  1120. if FindModuleWithFilename(aFilename)<>nil then
  1121. Fail('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
  1122. Result:=TTestEnginePasResolver.Create;
  1123. Result.Filename:=aFilename;
  1124. Result.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs);
  1125. Result.OnFindUnit:=@OnPasResolverFindUnit;
  1126. FModules.Add(Result);
  1127. end;
  1128. function TCustomTestModule.AddModuleWithSrc(aFilename, Src: string
  1129. ): TTestEnginePasResolver;
  1130. begin
  1131. Result:=AddModule(aFilename);
  1132. Result.Source:=Src;
  1133. end;
  1134. function TCustomTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
  1135. ImplementationSrc: string): TTestEnginePasResolver;
  1136. var
  1137. Src: String;
  1138. begin
  1139. Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
  1140. Src+=LineEnding;
  1141. Src+='interface'+LineEnding;
  1142. Src+=LineEnding;
  1143. Src+=InterfaceSrc;
  1144. Src+='implementation'+LineEnding;
  1145. Src+=LineEnding;
  1146. Src+=ImplementationSrc;
  1147. Src+='end.'+LineEnding;
  1148. Result:=AddModuleWithSrc(aFilename,Src);
  1149. end;
  1150. procedure TCustomTestModule.AddSystemUnit;
  1151. begin
  1152. AddModuleWithIntfImplSrc('system.pp',
  1153. // interface
  1154. LinesToStr([
  1155. 'type',
  1156. ' integer=longint;',
  1157. 'var',
  1158. ' ExitCode: Longint;',
  1159. ''
  1160. // implementation
  1161. ]),LinesToStr([
  1162. ''
  1163. ]));
  1164. end;
  1165. procedure TCustomTestModule.StartProgram(NeedSystemUnit: boolean);
  1166. begin
  1167. if NeedSystemUnit then
  1168. AddSystemUnit
  1169. else
  1170. Parser.ImplicitUses.Clear;
  1171. Add('program '+ExtractFileUnitName(Filename)+';');
  1172. Add('');
  1173. end;
  1174. procedure TCustomTestModule.StartUnit(NeedSystemUnit: boolean);
  1175. begin
  1176. if NeedSystemUnit then
  1177. AddSystemUnit
  1178. else
  1179. Parser.ImplicitUses.Clear;
  1180. Add('unit Test1;');
  1181. Add('');
  1182. end;
  1183. procedure TCustomTestModule.ConvertModule;
  1184. procedure CheckUsesList(UsesName: String; Arg: TJSArrayLiteralElement;
  1185. out UsesLit: TJSArrayLiteral);
  1186. var
  1187. i: Integer;
  1188. Item: TJSElement;
  1189. Lit: TJSLiteral;
  1190. begin
  1191. UsesLit:=nil;
  1192. AssertNotNull(UsesName+' uses section',Arg.Expr);
  1193. if (Arg.Expr.ClassType=TJSLiteral) and TJSLiteral(Arg.Expr).Value.IsNull then
  1194. exit; // null is ok
  1195. AssertEquals(UsesName+' uses section param is array',TJSArrayLiteral,Arg.Expr.ClassType);
  1196. FJSInterfaceUses:=TJSArrayLiteral(Arg.Expr);
  1197. for i:=0 to FJSInterfaceUses.Elements.Count-1 do
  1198. begin
  1199. Item:=FJSInterfaceUses.Elements.Elements[i].Expr;
  1200. AssertNotNull(UsesName+' uses section item['+IntToStr(i)+'].Expr',Item);
  1201. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is lit',TJSLiteral,Item.ClassType);
  1202. Lit:=TJSLiteral(Item);
  1203. AssertEquals(UsesName+' uses section item['+IntToStr(i)+'] is string lit',
  1204. ord(jsbase.jstString),ord(Lit.Value.ValueType));
  1205. end;
  1206. end;
  1207. procedure CheckFunctionParam(ParamName: string; Arg: TJSArrayLiteralElement;
  1208. out Src: TJSSourceElements);
  1209. var
  1210. FunDecl: TJSFunctionDeclarationStatement;
  1211. FunDef: TJSFuncDef;
  1212. FunBody: TJSFunctionBody;
  1213. begin
  1214. Src:=nil;
  1215. AssertNotNull(ParamName,Arg.Expr);
  1216. AssertEquals(ParamName+' Arg.Expr type',TJSFunctionDeclarationStatement,Arg.Expr.ClassType);
  1217. FunDecl:=Arg.Expr as TJSFunctionDeclarationStatement;
  1218. AssertNotNull(ParamName+' FunDecl.AFunction',FunDecl.AFunction);
  1219. AssertEquals(ParamName+' FunDecl.AFunction type',TJSFuncDef,FunDecl.AFunction.ClassType);
  1220. FunDef:=FunDecl.AFunction as TJSFuncDef;
  1221. AssertEquals(ParamName+' name empty','',String(FunDef.Name));
  1222. AssertNotNull(ParamName+' body',FunDef.Body);
  1223. AssertEquals(ParamName+' body type',TJSFunctionBody,FunDef.Body.ClassType);
  1224. FunBody:=FunDef.Body as TJSFunctionBody;
  1225. AssertNotNull(ParamName+' body.A',FunBody.A);
  1226. AssertEquals(ParamName+' body.A type',TJSSourceElements,FunBody.A.ClassType);
  1227. Src:=FunBody.A as TJSSourceElements;
  1228. end;
  1229. var
  1230. ModuleNameExpr: TJSLiteral;
  1231. InitFunction: TJSFunctionDeclarationStatement;
  1232. InitAssign: TJSSimpleAssignStatement;
  1233. InitName: String;
  1234. LastNode: TJSElement;
  1235. Arg: TJSArrayLiteralElement;
  1236. begin
  1237. if SkipTests then exit;
  1238. try
  1239. FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements;
  1240. except
  1241. on E: Exception do
  1242. HandleException(E);
  1243. end;
  1244. if SkipTests then exit;
  1245. if ExpectedErrorClass<>nil then
  1246. Fail('Missing '+ExpectedErrorClass.ClassName+' error {'+ExpectedErrorMsg+'} ('+IntToStr(ExpectedErrorNumber)+')');
  1247. FJSSource:=TStringList.Create;
  1248. FJSSource.Text:=ConvertJSModuleToString(JSModule);
  1249. {$IFDEF VerbosePas2JS}
  1250. writeln('TTestModule.ConvertModule JS:');
  1251. write(FJSSource.Text);
  1252. {$ENDIF}
  1253. // rtl.module(...
  1254. AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
  1255. AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
  1256. AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
  1257. FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
  1258. AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
  1259. AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
  1260. AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
  1261. FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
  1262. // parameter 'unitname'
  1263. if JSModuleCallArgs.Elements.Count<1 then
  1264. Fail('rtl.module first param unit missing');
  1265. Arg:=JSModuleCallArgs.Elements.Elements[0];
  1266. AssertNotNull('module name param',Arg.Expr);
  1267. ModuleNameExpr:=Arg.Expr as TJSLiteral;
  1268. AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
  1269. if Module is TPasProgram then
  1270. AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString))
  1271. else
  1272. AssertEquals('module name',Module.Name,String(ModuleNameExpr.Value.AsString));
  1273. // main uses section
  1274. if JSModuleCallArgs.Elements.Count<2 then
  1275. Fail('rtl.module second param main uses missing');
  1276. Arg:=JSModuleCallArgs.Elements.Elements[1];
  1277. CheckUsesList('interface',Arg,FJSInterfaceUses);
  1278. // program/library/interface function()
  1279. if JSModuleCallArgs.Elements.Count<3 then
  1280. Fail('rtl.module third param intf-function missing');
  1281. Arg:=JSModuleCallArgs.Elements.Elements[2];
  1282. CheckFunctionParam('module intf-function',Arg,FJSModuleSrc);
  1283. // search for $mod.$init or $mod.$main - the last statement
  1284. if Module is TPasProgram then
  1285. begin
  1286. InitName:='$main';
  1287. AssertEquals('$mod.'+InitName+' function 1',true,JSModuleSrc.Statements.Count>0);
  1288. end
  1289. else
  1290. InitName:='$init';
  1291. FJSInitBody:=nil;
  1292. if JSModuleSrc.Statements.Count>0 then
  1293. begin
  1294. LastNode:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node;
  1295. if LastNode is TJSSimpleAssignStatement then
  1296. begin
  1297. InitAssign:=LastNode as TJSSimpleAssignStatement;
  1298. if GetDottedIdentifier(InitAssign.LHS)='$mod.'+InitName then
  1299. begin
  1300. InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
  1301. FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
  1302. end
  1303. else if Module is TPasProgram then
  1304. CheckDottedIdentifier('init function',InitAssign.LHS,'$mod.'+InitName);
  1305. end;
  1306. end;
  1307. // optional: implementation uses section
  1308. if JSModuleCallArgs.Elements.Count<4 then
  1309. exit;
  1310. Arg:=JSModuleCallArgs.Elements.Elements[3];
  1311. CheckUsesList('implementation',Arg,FJSImplentationUses);
  1312. // optional: implementation function()
  1313. if JSModuleCallArgs.Elements.Count<5 then
  1314. exit;
  1315. Arg:=JSModuleCallArgs.Elements.Elements[4];
  1316. CheckFunctionParam('module impl-function',Arg,FJSImplementationSrc);
  1317. end;
  1318. procedure TCustomTestModule.ConvertProgram;
  1319. begin
  1320. Add('end.');
  1321. ParseProgram;
  1322. ConvertModule;
  1323. end;
  1324. procedure TCustomTestModule.ConvertUnit;
  1325. begin
  1326. Add('end.');
  1327. ParseUnit;
  1328. ConvertModule;
  1329. end;
  1330. function TCustomTestModule.ConvertJSModuleToString(El: TJSElement): string;
  1331. begin
  1332. Result:=tcmodules.JSToStr(El);
  1333. end;
  1334. procedure TCustomTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
  1335. DottedName: string);
  1336. begin
  1337. if DottedName='' then
  1338. begin
  1339. AssertNull(Msg,El);
  1340. end
  1341. else
  1342. begin
  1343. AssertNotNull(Msg,El);
  1344. AssertEquals(Msg,DottedName,GetDottedIdentifier(El));
  1345. end;
  1346. end;
  1347. function TCustomTestModule.GetDottedIdentifier(El: TJSElement): string;
  1348. begin
  1349. if El=nil then
  1350. Result:=''
  1351. else if El is TJSPrimaryExpressionIdent then
  1352. Result:=String(TJSPrimaryExpressionIdent(El).Name)
  1353. else if El is TJSDotMemberExpression then
  1354. Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
  1355. else
  1356. AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
  1357. end;
  1358. procedure TCustomTestModule.CheckSource(Msg, Statements: String;
  1359. InitStatements: string; ImplStatements: string);
  1360. var
  1361. ActualSrc, ExpectedSrc, InitName: String;
  1362. begin
  1363. ActualSrc:=JSToStr(JSModuleSrc);
  1364. ExpectedSrc:=
  1365. 'var $mod = this;'+LineEnding
  1366. +Statements;
  1367. if coUseStrict in Converter.Options then
  1368. ExpectedSrc:='"use strict";'+LineEnding+ExpectedSrc;
  1369. if Module is TPasProgram then
  1370. InitName:='$main'
  1371. else
  1372. InitName:='$init';
  1373. if (Module is TPasProgram) or (Trim(InitStatements)<>'') then
  1374. ExpectedSrc:=ExpectedSrc+LineEnding
  1375. +'$mod.'+InitName+' = function () {'+LineEnding
  1376. +InitStatements
  1377. +'};'+LineEnding;
  1378. //writeln('TCustomTestModule.CheckSource ExpectedIntf="',ExpectedSrc,'"');
  1379. //writeln('TTestModule.CheckSource InitStatements="',Trim(InitStatements),'"');
  1380. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1381. if (JSImplementationSrc<>nil) then
  1382. begin
  1383. ActualSrc:=JSToStr(JSImplementationSrc);
  1384. ExpectedSrc:=
  1385. 'var $mod = this;'+LineEnding
  1386. +'var $impl = $mod.$impl;'+LineEnding
  1387. +ImplStatements;
  1388. end
  1389. else
  1390. begin
  1391. ActualSrc:='';
  1392. ExpectedSrc:=ImplStatements;
  1393. end;
  1394. //writeln('TTestModule.CheckSource InitStatements="',InitStatements,'"');
  1395. //writeln('TCustomTestModule.CheckSource Expected: ',ExpectedSrc);
  1396. CheckDiff(Msg,ExpectedSrc,ActualSrc);
  1397. end;
  1398. procedure TCustomTestModule.CheckDiff(Msg, Expected, Actual: string);
  1399. // search diff, ignore changes in spaces
  1400. var
  1401. s: string;
  1402. begin
  1403. if CheckSrcDiff(Expected,Actual,s) then exit;
  1404. Fail(Msg+': '+s);
  1405. end;
  1406. procedure TCustomTestModule.CheckUnit(Filename, ExpectedSrc: string);
  1407. var
  1408. aResolver: TTestEnginePasResolver;
  1409. aConverter: TPasToJSConverter;
  1410. aJSModule: TJSSourceElements;
  1411. ActualSrc: String;
  1412. begin
  1413. aResolver:=GetResolver(Filename);
  1414. AssertNotNull('missing resolver of unit '+Filename,aResolver);
  1415. {$IFDEF VerbosePas2JS}
  1416. writeln('CheckUnit '+Filename+' converting ...');
  1417. {$ENDIF}
  1418. aConverter:=CreateConverter;
  1419. try
  1420. try
  1421. aJSModule:=aConverter.ConvertPasElement(aResolver.Module,aResolver) as TJSSourceElements;
  1422. except
  1423. on E: Exception do
  1424. HandleException(E);
  1425. end;
  1426. ActualSrc:=ConvertJSModuleToString(aJSModule);
  1427. {$IFDEF VerbosePas2JS}
  1428. writeln('TTestModule.CheckUnit ',Filename,' Pas:');
  1429. write(aResolver.Source);
  1430. writeln('TTestModule.CheckUnit ',Filename,' JS:');
  1431. write(ActualSrc);
  1432. {$ENDIF}
  1433. CheckDiff('Converted unit: "'+ChangeFileExt(Filename,'.js')+'"',ExpectedSrc,ActualSrc);
  1434. finally
  1435. aConverter.Free;
  1436. end;
  1437. end;
  1438. procedure TCustomTestModule.SetExpectedScannerError(Msg: string;
  1439. MsgNumber: integer);
  1440. begin
  1441. ExpectedErrorClass:=EScannerError;
  1442. ExpectedErrorMsg:=Msg;
  1443. ExpectedErrorNumber:=MsgNumber;
  1444. end;
  1445. procedure TCustomTestModule.SetExpectedParserError(Msg: string;
  1446. MsgNumber: integer);
  1447. begin
  1448. ExpectedErrorClass:=EParserError;
  1449. ExpectedErrorMsg:=Msg;
  1450. ExpectedErrorNumber:=MsgNumber;
  1451. end;
  1452. procedure TCustomTestModule.SetExpectedPasResolverError(Msg: string;
  1453. MsgNumber: integer);
  1454. begin
  1455. ExpectedErrorClass:=EPasResolve;
  1456. ExpectedErrorMsg:=Msg;
  1457. ExpectedErrorNumber:=MsgNumber;
  1458. end;
  1459. procedure TCustomTestModule.SetExpectedConverterError(Msg: string;
  1460. MsgNumber: integer);
  1461. begin
  1462. ExpectedErrorClass:=EPas2JS;
  1463. ExpectedErrorMsg:=Msg;
  1464. ExpectedErrorNumber:=MsgNumber;
  1465. end;
  1466. function TCustomTestModule.IsErrorExpected(E: Exception): boolean;
  1467. var
  1468. MsgNumber: Integer;
  1469. Msg: String;
  1470. begin
  1471. Result:=false;
  1472. if (ExpectedErrorClass=nil) or (ExpectedErrorClass<>E.ClassType) then exit;
  1473. Msg:=E.Message;
  1474. if E is EPas2JS then
  1475. MsgNumber:=EPas2JS(E).MsgNumber
  1476. else if E is EPasResolve then
  1477. MsgNumber:=EPasResolve(E).MsgNumber
  1478. else if E is EParserError then
  1479. MsgNumber:=Parser.LastMsgNumber
  1480. else if E is EScannerError then
  1481. begin
  1482. MsgNumber:=Scanner.LastMsgNumber;
  1483. Msg:=Scanner.LastMsg;
  1484. end
  1485. else
  1486. MsgNumber:=0;
  1487. Result:=(MsgNumber=ExpectedErrorNumber) and (Msg=ExpectedErrorMsg);
  1488. if Result then
  1489. SkipTests:=true;
  1490. end;
  1491. procedure TCustomTestModule.HandleScannerError(E: EScannerError);
  1492. begin
  1493. if IsErrorExpected(E) then exit;
  1494. WriteSources(Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn);
  1495. writeln('ERROR: TCustomTestModule.HandleScannerError '+E.ClassName+':'+E.Message
  1496. +' '+Scanner.CurFilename
  1497. +'('+IntToStr(Scanner.CurRow)+','+IntToStr(Scanner.CurColumn)+')');
  1498. FailException(E);
  1499. end;
  1500. procedure TCustomTestModule.HandleParserError(E: EParserError);
  1501. begin
  1502. if IsErrorExpected(E) then exit;
  1503. WriteSources(E.Filename,E.Row,E.Column);
  1504. writeln('ERROR: TCustomTestModule.HandleParserError '+E.ClassName+':'+E.Message
  1505. +' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')'
  1506. +' MainModuleScannerLine="'+Scanner.CurLine+'"'
  1507. );
  1508. FailException(E);
  1509. end;
  1510. procedure TCustomTestModule.HandlePasResolveError(E: EPasResolve);
  1511. var
  1512. P: TPasSourcePos;
  1513. begin
  1514. if IsErrorExpected(E) then exit;
  1515. P:=E.SourcePos;
  1516. WriteSources(P.FileName,P.Row,P.Column);
  1517. writeln('ERROR: TCustomTestModule.HandlePasResolveError '+E.ClassName+':'+E.Message
  1518. +' '+P.FileName+'('+IntToStr(P.Row)+','+IntToStr(P.Column)+')');
  1519. FailException(E);
  1520. end;
  1521. procedure TCustomTestModule.HandlePas2JSError(E: EPas2JS);
  1522. var
  1523. Row, Col: integer;
  1524. begin
  1525. if IsErrorExpected(E) then exit;
  1526. Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col);
  1527. WriteSources(E.PasElement.SourceFilename,Row,Col);
  1528. writeln('ERROR: TCustomTestModule.HandlePas2JSError '+E.ClassName+':'+E.Message
  1529. +' '+E.PasElement.SourceFilename
  1530. +'('+IntToStr(Row)+','+IntToStr(Col)+')');
  1531. FailException(E);
  1532. end;
  1533. procedure TCustomTestModule.HandleException(E: Exception);
  1534. begin
  1535. if E is EScannerError then
  1536. HandleScannerError(EScannerError(E))
  1537. else if E is EParserError then
  1538. HandleParserError(EParserError(E))
  1539. else if E is EPasResolve then
  1540. HandlePasResolveError(EPasResolve(E))
  1541. else if E is EPas2JS then
  1542. HandlePas2JSError(EPas2JS(E))
  1543. else
  1544. begin
  1545. if IsErrorExpected(E) then exit;
  1546. if not (E is EAssertionFailedError) then
  1547. begin
  1548. WriteSources('',0,0);
  1549. writeln('ERROR: TCustomTestModule.HandleException '+E.ClassName+':'+E.Message);
  1550. end;
  1551. FailException(E);
  1552. end;
  1553. end;
  1554. procedure TCustomTestModule.FailException(E: Exception);
  1555. var
  1556. MsgNumber: Integer;
  1557. begin
  1558. if ExpectedErrorClass<>nil then
  1559. begin
  1560. if FExpectedErrorClass=E.ClassType then
  1561. begin
  1562. if E is EPas2JS then
  1563. MsgNumber:=EPas2JS(E).MsgNumber
  1564. else if E is EPasResolve then
  1565. MsgNumber:=EPasResolve(E).MsgNumber
  1566. else if E is EParserError then
  1567. MsgNumber:=Parser.LastMsgNumber
  1568. else if E is EScannerError then
  1569. MsgNumber:=Scanner.LastMsgNumber
  1570. else
  1571. MsgNumber:=0;
  1572. AssertEquals('Expected error message ('+IntToStr(ExpectedErrorNumber)+')','{'+ExpectedErrorMsg+'}','{'+E.Message+'}');
  1573. AssertEquals('Expected {'+ExpectedErrorMsg+'}, but got msg {'+E.Message+'} number',
  1574. ExpectedErrorNumber,MsgNumber);
  1575. end else begin
  1576. AssertEquals('Wrong exception class',ExpectedErrorClass.ClassName,E.ClassName);
  1577. end;
  1578. end;
  1579. Fail(E.Message);
  1580. end;
  1581. procedure TCustomTestModule.WriteSources(const aFilename: string; aRow,
  1582. aCol: integer);
  1583. var
  1584. IsSrc: Boolean;
  1585. i, j: Integer;
  1586. SrcLines: TStringList;
  1587. Line: string;
  1588. aModule: TTestEnginePasResolver;
  1589. begin
  1590. writeln('TCustomTestModule.WriteSources File="',aFilename,'" Row=',aRow,' Col=',aCol);
  1591. for i:=0 to ResolverCount-1 do
  1592. begin
  1593. aModule:=Resolvers[i];
  1594. SrcLines:=TStringList.Create;
  1595. try
  1596. SrcLines.Text:=aModule.Source;
  1597. IsSrc:=ExtractFilename(aModule.Filename)=ExtractFileName(aFilename);
  1598. writeln('Testcode:-File="',aModule.Filename,'"----------------------------------:');
  1599. for j:=1 to SrcLines.Count do
  1600. begin
  1601. Line:=SrcLines[j-1];
  1602. if IsSrc and (j=aRow) then
  1603. begin
  1604. write('*');
  1605. Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line));
  1606. end;
  1607. writeln(Format('%:4d: ',[j]),Line);
  1608. end;
  1609. finally
  1610. SrcLines.Free;
  1611. end;
  1612. end;
  1613. end;
  1614. function TCustomTestModule.IndexOfResolver(const Filename: string): integer;
  1615. var
  1616. i: Integer;
  1617. begin
  1618. for i:=0 to ResolverCount-1 do
  1619. if Filename=Resolvers[i].Filename then exit(i);
  1620. Result:=-1;
  1621. end;
  1622. function TCustomTestModule.GetResolver(const Filename: string
  1623. ): TTestEnginePasResolver;
  1624. var
  1625. i: Integer;
  1626. begin
  1627. i:=IndexOfResolver(Filename);
  1628. if i<0 then exit(nil);
  1629. Result:=Resolvers[i];
  1630. end;
  1631. function TCustomTestModule.GetDefaultNamespace: string;
  1632. var
  1633. C: TClass;
  1634. begin
  1635. Result:='';
  1636. if FModule=nil then exit;
  1637. C:=FModule.ClassType;
  1638. if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then
  1639. Result:=Engine.DefaultNameSpace;
  1640. end;
  1641. { TTestModule }
  1642. procedure TTestModule.TestEmptyProgram;
  1643. begin
  1644. StartProgram(false);
  1645. Add('begin');
  1646. ConvertProgram;
  1647. CheckSource('TestEmptyProgram','','');
  1648. end;
  1649. procedure TTestModule.TestEmptyProgramUseStrict;
  1650. begin
  1651. Converter.Options:=Converter.Options+[coUseStrict];
  1652. StartProgram(false);
  1653. Add('begin');
  1654. ConvertProgram;
  1655. CheckSource('TestEmptyProgramUseStrict','','');
  1656. end;
  1657. procedure TTestModule.TestEmptyUnit;
  1658. begin
  1659. StartUnit(false);
  1660. Add('interface');
  1661. Add('implementation');
  1662. ConvertUnit;
  1663. CheckSource('TestEmptyUnit',
  1664. LinesToStr([
  1665. ]),
  1666. '');
  1667. end;
  1668. procedure TTestModule.TestEmptyUnitUseStrict;
  1669. begin
  1670. Converter.Options:=Converter.Options+[coUseStrict];
  1671. StartUnit(false);
  1672. Add('interface');
  1673. Add('implementation');
  1674. ConvertUnit;
  1675. CheckSource('TestEmptyUnitUseStrict',
  1676. LinesToStr([
  1677. ''
  1678. ]),
  1679. '');
  1680. end;
  1681. procedure TTestModule.TestDottedUnitNames;
  1682. begin
  1683. AddModuleWithIntfImplSrc('NS1.Unit2.pas',
  1684. LinesToStr([
  1685. 'var iV: longint;'
  1686. ]),
  1687. '');
  1688. FFilename:='ns1.test1.pp';
  1689. StartProgram(true);
  1690. Add('uses unIt2;');
  1691. Add('implementation');
  1692. Add('var');
  1693. Add(' i: longint;');
  1694. Add('begin');
  1695. Add(' i:=iv;');
  1696. Add(' i:=uNit2.iv;');
  1697. Add(' i:=Ns1.TEst1.i;');
  1698. ConvertProgram;
  1699. CheckSource('TestDottedUnitNames',
  1700. LinesToStr([
  1701. 'this.i = 0;',
  1702. '']),
  1703. LinesToStr([ // this.$init
  1704. '$mod.i = pas["NS1.Unit2"].iV;',
  1705. '$mod.i = pas["NS1.Unit2"].iV;',
  1706. '$mod.i = $mod.i;',
  1707. '']) );
  1708. end;
  1709. procedure TTestModule.TestDottedUnitNameImpl;
  1710. begin
  1711. AddModuleWithIntfImplSrc('TEST.UnitA.pas',
  1712. LinesToStr([
  1713. 'type',
  1714. ' TObject = class end;',
  1715. ' TTestA = class',
  1716. ' end;'
  1717. ]),
  1718. LinesToStr(['uses TEST.UnitB;'])
  1719. );
  1720. AddModuleWithIntfImplSrc('TEST.UnitB.pas',
  1721. LinesToStr([
  1722. 'uses TEST.UnitA;',
  1723. 'type TTestB = class(TTestA);'
  1724. ]),
  1725. ''
  1726. );
  1727. StartProgram(true);
  1728. Add('uses TEST.UnitA;');
  1729. Add('begin');
  1730. ConvertProgram;
  1731. CheckSource('TestDottedUnitNameImpl',
  1732. LinesToStr([
  1733. '']),
  1734. LinesToStr([ // this.$init
  1735. '']) );
  1736. CheckUnit('TEST.UnitA.pas',
  1737. LinesToStr([
  1738. 'rtl.module("TEST.UnitA", ["system"], function () {',
  1739. ' var $mod = this;',
  1740. ' rtl.createClass($mod, "TObject", null, function () {',
  1741. ' this.$init = function () {',
  1742. ' };',
  1743. ' this.$final = function () {',
  1744. ' };',
  1745. ' });',
  1746. ' rtl.createClass($mod, "TTestA", $mod.TObject, function () {',
  1747. ' });',
  1748. '}, ["TEST.UnitB"]);'
  1749. ]));
  1750. CheckUnit('TEST.UnitB.pas',
  1751. LinesToStr([
  1752. 'rtl.module("TEST.UnitB", ["system","TEST.UnitA"], function () {',
  1753. ' var $mod = this;',
  1754. ' rtl.createClass($mod, "TTestB", pas["TEST.UnitA"].TTestA, function () {',
  1755. ' });',
  1756. '});'
  1757. ]));
  1758. end;
  1759. procedure TTestModule.TestDottedUnitExpr;
  1760. begin
  1761. AddModuleWithIntfImplSrc('NS2.SubNs2.Unit2.pas',
  1762. LinesToStr([
  1763. 'procedure DoIt;'
  1764. ]),
  1765. 'procedure DoIt; begin end;');
  1766. FFilename:='Ns1.SubNs1.Test1.pp';
  1767. StartProgram(true);
  1768. Add('uses Ns2.sUbnS2.unIt2;');
  1769. Add('implementation');
  1770. Add('var');
  1771. Add(' i: longint;');
  1772. Add('begin');
  1773. Add(' ns2.subns2.unit2.doit;');
  1774. Add(' i:=Ns1.SubNS1.TEst1.i;');
  1775. ConvertProgram;
  1776. CheckSource('TestDottedUnitExpr',
  1777. LinesToStr([
  1778. 'this.i = 0;',
  1779. '']),
  1780. LinesToStr([ // this.$init
  1781. 'pas["NS2.SubNs2.Unit2"].DoIt();',
  1782. '$mod.i = $mod.i;',
  1783. '']) );
  1784. end;
  1785. procedure TTestModule.Test_ModeFPCFail;
  1786. begin
  1787. StartProgram(false);
  1788. Add('{$mode FPC}');
  1789. Add('begin');
  1790. SetExpectedScannerError('Invalid mode: "FPC"',nErrInvalidMode);
  1791. ConvertProgram;
  1792. end;
  1793. procedure TTestModule.Test_ModeSwitchCBlocksFail;
  1794. begin
  1795. StartProgram(false);
  1796. Add('{$modeswitch cblocks-}');
  1797. Add('begin');
  1798. SetExpectedScannerError('Invalid mode switch: "cblocks-"',nErrInvalidModeSwitch);
  1799. ConvertProgram;
  1800. end;
  1801. procedure TTestModule.TestUnit_Intf1Impl2Intf1;
  1802. begin
  1803. AddModuleWithIntfImplSrc('unit1.pp',
  1804. LinesToStr([
  1805. 'type number = longint;']),
  1806. LinesToStr([
  1807. 'uses test1;',
  1808. 'procedure DoIt;',
  1809. 'begin',
  1810. ' i:=3;',
  1811. 'end;']));
  1812. StartUnit(true);
  1813. Add([
  1814. 'interface',
  1815. 'uses unit1;',
  1816. 'var i: number;',
  1817. 'implementation']);
  1818. ConvertUnit;
  1819. CheckSource('TestUnit_Intf1Impl2Intf1',
  1820. LinesToStr([
  1821. 'this.i = 0;',
  1822. '']),
  1823. LinesToStr([
  1824. '']) );
  1825. end;
  1826. procedure TTestModule.TestVarInt;
  1827. begin
  1828. StartProgram(false);
  1829. Add('var MyI: longint;');
  1830. Add('begin');
  1831. ConvertProgram;
  1832. CheckSource('TestVarInt','this.MyI=0;','');
  1833. end;
  1834. procedure TTestModule.TestVarBaseTypes;
  1835. begin
  1836. StartProgram(false);
  1837. Add('var');
  1838. Add(' i: longint;');
  1839. Add(' s: string;');
  1840. Add(' c: char;');
  1841. Add(' b: boolean;');
  1842. Add(' d: double;');
  1843. Add(' i2: longint = 3;');
  1844. Add(' s2: string = ''foo'';');
  1845. Add(' c2: char = ''4'';');
  1846. Add(' b2: boolean = true;');
  1847. Add(' d2: double = 5.6;');
  1848. Add(' i3: longint = $707;');
  1849. Add(' i4: nativeint = 4503599627370495;');
  1850. Add(' i5: nativeint = -4503599627370496;');
  1851. Add(' i6: nativeint = $fffffffffffff;');
  1852. Add(' i7: nativeint = -$10000000000000;');
  1853. Add(' i8: byte = 00;');
  1854. Add(' u8: nativeuint = $fffffffffffff;');
  1855. Add(' u9: nativeuint = $0000000000000;');
  1856. Add('begin');
  1857. ConvertProgram;
  1858. CheckSource('TestVarBaseTypes',
  1859. LinesToStr([
  1860. 'this.i = 0;',
  1861. 'this.s = "";',
  1862. 'this.c = "";',
  1863. 'this.b = false;',
  1864. 'this.d = 0.0;',
  1865. 'this.i2 = 3;',
  1866. 'this.s2 = "foo";',
  1867. 'this.c2 = "4";',
  1868. 'this.b2 = true;',
  1869. 'this.d2 = 5.6;',
  1870. 'this.i3 = 0x707;',
  1871. 'this.i4 = 4503599627370495;',
  1872. 'this.i5 = -4503599627370496;',
  1873. 'this.i6 = 0xfffffffffffff;',
  1874. 'this.i7 =-0x10000000000000;',
  1875. 'this.i8 = 0;',
  1876. 'this.u8 = 0xfffffffffffff;',
  1877. 'this.u9 = 0x0;'
  1878. ]),
  1879. '');
  1880. end;
  1881. procedure TTestModule.TestBaseTypeSingleFail;
  1882. begin
  1883. StartProgram(false);
  1884. Add('var s: single;');
  1885. SetExpectedPasResolverError('identifier not found "single"',PasResolveEval.nIdentifierNotFound);
  1886. ConvertProgram;
  1887. end;
  1888. procedure TTestModule.TestBaseTypeExtendedFail;
  1889. begin
  1890. StartProgram(false);
  1891. Add('var e: extended;');
  1892. SetExpectedPasResolverError('identifier not found "extended"',PasResolveEval.nIdentifierNotFound);
  1893. ConvertProgram;
  1894. end;
  1895. procedure TTestModule.TestConstBaseTypes;
  1896. begin
  1897. StartProgram(false);
  1898. Add('const');
  1899. Add(' i: longint = 3;');
  1900. Add(' s: string = ''foo'';');
  1901. Add(' c: char = ''4'';');
  1902. Add(' b: boolean = true;');
  1903. Add(' d: double = 5.6;');
  1904. Add(' e = low(word);');
  1905. Add(' f = high(word);');
  1906. Add('begin');
  1907. ConvertProgram;
  1908. CheckSource('TestVarBaseTypes',
  1909. LinesToStr([
  1910. 'this.i=3;',
  1911. 'this.s="foo";',
  1912. 'this.c="4";',
  1913. 'this.b=true;',
  1914. 'this.d=5.6;',
  1915. 'this.e = 0;',
  1916. 'this.f = 65535;'
  1917. ]),
  1918. '');
  1919. end;
  1920. procedure TTestModule.TestAliasTypeRef;
  1921. begin
  1922. StartProgram(false);
  1923. Add('type');
  1924. Add(' a=longint;');
  1925. Add(' b=a;');
  1926. Add('var');
  1927. Add(' c: A;');
  1928. Add(' d: B;');
  1929. Add('begin');
  1930. ConvertProgram;
  1931. CheckSource('TestAliasTypeRef',
  1932. LinesToStr([ // statements
  1933. 'this.c = 0;',
  1934. 'this.d = 0;'
  1935. ]),
  1936. LinesToStr([ // this.$main
  1937. ''
  1938. ]));
  1939. end;
  1940. procedure TTestModule.TestTypeCast_BaseTypes;
  1941. begin
  1942. StartProgram(false);
  1943. Add([
  1944. 'var',
  1945. ' i: longint;',
  1946. ' b: boolean;',
  1947. ' d: double;',
  1948. ' s: string;',
  1949. ' c: char;',
  1950. 'begin',
  1951. ' i:=longint(i);',
  1952. ' i:=longint(b);',
  1953. ' b:=boolean(b);',
  1954. ' b:=boolean(i);',
  1955. ' d:=double(d);',
  1956. ' d:=double(i);',
  1957. ' s:=string(s);',
  1958. ' s:=string(c);',
  1959. ' c:=char(c);',
  1960. ' c:=char(i);',
  1961. ' c:=char(65);',
  1962. '']);
  1963. ConvertProgram;
  1964. CheckSource('TestAliasTypeRef',
  1965. LinesToStr([ // statements
  1966. 'this.i = 0;',
  1967. 'this.b = false;',
  1968. 'this.d = 0.0;',
  1969. 'this.s = "";',
  1970. 'this.c = "";',
  1971. '']),
  1972. LinesToStr([ // this.$main
  1973. '$mod.i = $mod.i;',
  1974. '$mod.i = ($mod.b ? 1 : 0);',
  1975. '$mod.b = $mod.b;',
  1976. '$mod.b = $mod.i != 0;',
  1977. '$mod.d = $mod.d;',
  1978. '$mod.d = $mod.i;',
  1979. '$mod.s = $mod.s;',
  1980. '$mod.s = $mod.c;',
  1981. '$mod.c = $mod.c;',
  1982. '$mod.c = String.fromCharCode($mod.i);',
  1983. '$mod.c = "A";',
  1984. '']));
  1985. end;
  1986. procedure TTestModule.TestTypeCast_AliasBaseTypes;
  1987. begin
  1988. StartProgram(false);
  1989. Add('type');
  1990. Add(' integer = longint;');
  1991. Add(' TYesNo = boolean;');
  1992. Add(' TFloat = double;');
  1993. Add(' TCaption = string;');
  1994. Add(' TChar = char;');
  1995. Add('var');
  1996. Add(' i: integer;');
  1997. Add(' b: TYesNo;');
  1998. Add(' d: TFloat;');
  1999. Add(' s: TCaption;');
  2000. Add(' c: TChar;');
  2001. Add('begin');
  2002. Add(' i:=integer(i);');
  2003. Add(' i:=integer(b);');
  2004. Add(' b:=TYesNo(b);');
  2005. Add(' b:=TYesNo(i);');
  2006. Add(' d:=TFloat(d);');
  2007. Add(' d:=TFloat(i);');
  2008. Add(' s:=TCaption(s);');
  2009. Add(' s:=TCaption(c);');
  2010. Add(' c:=TChar(c);');
  2011. ConvertProgram;
  2012. CheckSource('TestAliasTypeRef',
  2013. LinesToStr([ // statements
  2014. 'this.i = 0;',
  2015. 'this.b = false;',
  2016. 'this.d = 0.0;',
  2017. 'this.s = "";',
  2018. 'this.c = "";',
  2019. '']),
  2020. LinesToStr([ // this.$main
  2021. '$mod.i = $mod.i;',
  2022. '$mod.i = ($mod.b ? 1 : 0);',
  2023. '$mod.b = $mod.b;',
  2024. '$mod.b = $mod.i != 0;',
  2025. '$mod.d = $mod.d;',
  2026. '$mod.d = $mod.i;',
  2027. '$mod.s = $mod.s;',
  2028. '$mod.s = $mod.c;',
  2029. '$mod.c = $mod.c;',
  2030. '']));
  2031. end;
  2032. procedure TTestModule.TestEmptyProc;
  2033. begin
  2034. StartProgram(false);
  2035. Add('procedure Test;');
  2036. Add('begin');
  2037. Add('end;');
  2038. Add('begin');
  2039. ConvertProgram;
  2040. CheckSource('TestEmptyProc',
  2041. LinesToStr([ // statements
  2042. 'this.Test = function () {',
  2043. '};'
  2044. ]),
  2045. LinesToStr([ // this.$main
  2046. ''
  2047. ]));
  2048. end;
  2049. procedure TTestModule.TestProcOneParam;
  2050. begin
  2051. StartProgram(false);
  2052. Add('procedure ProcA(i: longint);');
  2053. Add('begin');
  2054. Add('end;');
  2055. Add('begin');
  2056. Add(' PROCA(3);');
  2057. ConvertProgram;
  2058. CheckSource('TestProcOneParam',
  2059. LinesToStr([ // statements
  2060. 'this.ProcA = function (i) {',
  2061. '};'
  2062. ]),
  2063. LinesToStr([ // this.$main
  2064. '$mod.ProcA(3);'
  2065. ]));
  2066. end;
  2067. procedure TTestModule.TestFunctionWithoutParams;
  2068. begin
  2069. StartProgram(false);
  2070. Add('function FuncA: longint;');
  2071. Add('begin');
  2072. Add('end;');
  2073. Add('var i: longint;');
  2074. Add('begin');
  2075. Add(' I:=FUNCA();');
  2076. Add(' I:=FUNCA;');
  2077. Add(' FUNCA();');
  2078. Add(' FUNCA;');
  2079. ConvertProgram;
  2080. CheckSource('TestProcWithoutParams',
  2081. LinesToStr([ // statements
  2082. 'this.FuncA = function () {',
  2083. ' var Result = 0;',
  2084. ' return Result;',
  2085. '};',
  2086. 'this.i=0;'
  2087. ]),
  2088. LinesToStr([ // this.$main
  2089. '$mod.i=$mod.FuncA();',
  2090. '$mod.i=$mod.FuncA();',
  2091. '$mod.FuncA();',
  2092. '$mod.FuncA();'
  2093. ]));
  2094. end;
  2095. procedure TTestModule.TestProcedureWithoutParams;
  2096. begin
  2097. StartProgram(false);
  2098. Add('procedure ProcA;');
  2099. Add('begin');
  2100. Add('end;');
  2101. Add('begin');
  2102. Add(' PROCA();');
  2103. Add(' PROCA;');
  2104. ConvertProgram;
  2105. CheckSource('TestProcWithoutParams',
  2106. LinesToStr([ // statements
  2107. 'this.ProcA = function () {',
  2108. '};'
  2109. ]),
  2110. LinesToStr([ // this.$main
  2111. '$mod.ProcA();',
  2112. '$mod.ProcA();'
  2113. ]));
  2114. end;
  2115. procedure TTestModule.TestIncDec;
  2116. begin
  2117. StartProgram(false);
  2118. Add([
  2119. 'procedure DoIt(var i: longint);',
  2120. 'begin',
  2121. ' inc(i);',
  2122. ' inc(i,2);',
  2123. 'end;',
  2124. 'var',
  2125. ' Bar: longint;',
  2126. 'begin',
  2127. ' inc(bar);',
  2128. ' inc(bar,2);',
  2129. ' dec(bar);',
  2130. ' dec(bar,3);',
  2131. '']);
  2132. ConvertProgram;
  2133. CheckSource('TestIncDec',
  2134. LinesToStr([ // statements
  2135. 'this.DoIt = function (i) {',
  2136. ' i.set(i.get()+1);',
  2137. ' i.set(i.get()+2);',
  2138. '};',
  2139. 'this.Bar = 0;'
  2140. ]),
  2141. LinesToStr([ // this.$main
  2142. '$mod.Bar+=1;',
  2143. '$mod.Bar+=2;',
  2144. '$mod.Bar-=1;',
  2145. '$mod.Bar-=3;'
  2146. ]));
  2147. end;
  2148. procedure TTestModule.TestAssignments;
  2149. begin
  2150. StartProgram(false);
  2151. Parser.Options:=Parser.Options+[po_cassignments];
  2152. Add('var');
  2153. Add(' Bar:longint;');
  2154. Add('begin');
  2155. Add(' bar:=3;');
  2156. Add(' bar+=4;');
  2157. Add(' bar-=5;');
  2158. Add(' bar*=6;');
  2159. ConvertProgram;
  2160. CheckSource('TestAssignments',
  2161. LinesToStr([ // statements
  2162. 'this.Bar = 0;'
  2163. ]),
  2164. LinesToStr([ // this.$main
  2165. '$mod.Bar=3;',
  2166. '$mod.Bar+=4;',
  2167. '$mod.Bar-=5;',
  2168. '$mod.Bar*=6;'
  2169. ]));
  2170. end;
  2171. procedure TTestModule.TestArithmeticOperators1;
  2172. begin
  2173. StartProgram(false);
  2174. Add('var');
  2175. Add(' vA,vB,vC:longint;');
  2176. Add('begin');
  2177. Add(' va:=1;');
  2178. Add(' vb:=va+va;');
  2179. Add(' vb:=va div vb;');
  2180. Add(' vb:=va mod vb;');
  2181. Add(' vb:=va+va*vb+va div vb;');
  2182. Add(' vc:=-va;');
  2183. Add(' va:=va-vb;');
  2184. Add(' vb:=va;');
  2185. Add(' if va<vb then vc:=va else vc:=vb;');
  2186. ConvertProgram;
  2187. CheckSource('TestArithmeticOperators1',
  2188. LinesToStr([ // statements
  2189. 'this.vA = 0;',
  2190. 'this.vB = 0;',
  2191. 'this.vC = 0;'
  2192. ]),
  2193. LinesToStr([ // this.$main
  2194. '$mod.vA = 1;',
  2195. '$mod.vB = $mod.vA + $mod.vA;',
  2196. '$mod.vB = Math.floor($mod.vA / $mod.vB);',
  2197. '$mod.vB = $mod.vA % $mod.vB;',
  2198. '$mod.vB = ($mod.vA + ($mod.vA * $mod.vB)) + Math.floor($mod.vA / $mod.vB);',
  2199. '$mod.vC = -$mod.vA;',
  2200. '$mod.vA = $mod.vA - $mod.vB;',
  2201. '$mod.vB = $mod.vA;',
  2202. 'if ($mod.vA < $mod.vB){ $mod.vC = $mod.vA } else $mod.vC = $mod.vB;'
  2203. ]));
  2204. end;
  2205. procedure TTestModule.TestLogicalOperators;
  2206. begin
  2207. StartProgram(false);
  2208. Add('var');
  2209. Add(' vA,vB,vC:boolean;');
  2210. Add('begin');
  2211. Add(' va:=vb and vc;');
  2212. Add(' va:=vb or vc;');
  2213. Add(' va:=vb xor vc;');
  2214. Add(' va:=true and vc;');
  2215. Add(' va:=(vb and vc) or (va and vb);');
  2216. Add(' va:=not vb;');
  2217. ConvertProgram;
  2218. CheckSource('TestLogicalOperators',
  2219. LinesToStr([ // statements
  2220. 'this.vA = false;',
  2221. 'this.vB = false;',
  2222. 'this.vC = false;'
  2223. ]),
  2224. LinesToStr([ // this.$main
  2225. '$mod.vA = $mod.vB && $mod.vC;',
  2226. '$mod.vA = $mod.vB || $mod.vC;',
  2227. '$mod.vA = $mod.vB ^ $mod.vC;',
  2228. '$mod.vA = true && $mod.vC;',
  2229. '$mod.vA = ($mod.vB && $mod.vC) || ($mod.vA && $mod.vB);',
  2230. '$mod.vA = !$mod.vB;'
  2231. ]));
  2232. end;
  2233. procedure TTestModule.TestBitwiseOperators;
  2234. begin
  2235. StartProgram(false);
  2236. Add('var');
  2237. Add(' vA,vB,vC:longint;');
  2238. Add('begin');
  2239. Add(' va:=vb and vc;');
  2240. Add(' va:=vb or vc;');
  2241. Add(' va:=vb xor vc;');
  2242. Add(' va:=vb shl vc;');
  2243. Add(' va:=vb shr vc;');
  2244. Add(' va:=3 and vc;');
  2245. Add(' va:=(vb and vc) or (va and vb);');
  2246. Add(' va:=not vb;');
  2247. ConvertProgram;
  2248. CheckSource('TestBitwiseOperators',
  2249. LinesToStr([ // statements
  2250. 'this.vA = 0;',
  2251. 'this.vB = 0;',
  2252. 'this.vC = 0;'
  2253. ]),
  2254. LinesToStr([ // this.$main
  2255. '$mod.vA = $mod.vB & $mod.vC;',
  2256. '$mod.vA = $mod.vB | $mod.vC;',
  2257. '$mod.vA = $mod.vB ^ $mod.vC;',
  2258. '$mod.vA = $mod.vB << $mod.vC;',
  2259. '$mod.vA = $mod.vB >>> $mod.vC;',
  2260. '$mod.vA = 3 & $mod.vC;',
  2261. '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);',
  2262. '$mod.vA = ~$mod.vB;'
  2263. ]));
  2264. end;
  2265. procedure TTestModule.TestPrgProcVar;
  2266. begin
  2267. StartProgram(false);
  2268. Add('procedure Proc1;');
  2269. Add('type');
  2270. Add(' t1=longint;');
  2271. Add('var');
  2272. Add(' vA:t1;');
  2273. Add('begin');
  2274. Add('end;');
  2275. Add('begin');
  2276. ConvertProgram;
  2277. CheckSource('TestPrgProcVar',
  2278. LinesToStr([ // statements
  2279. 'this.Proc1 = function () {',
  2280. ' var vA=0;',
  2281. '};'
  2282. ]),
  2283. LinesToStr([ // this.$main
  2284. ''
  2285. ]));
  2286. end;
  2287. procedure TTestModule.TestUnitProcVar;
  2288. begin
  2289. StartUnit(false);
  2290. Add('interface');
  2291. Add('');
  2292. Add('type tA=string; // unit scope');
  2293. Add('procedure Proc1;');
  2294. Add('');
  2295. Add('implementation');
  2296. Add('');
  2297. Add('procedure Proc1;');
  2298. Add('type tA=longint; // local proc scope');
  2299. Add('var v1:tA; // using local tA');
  2300. Add('begin');
  2301. Add('end;');
  2302. Add('var v2:tA; // using interface tA');
  2303. ConvertUnit;
  2304. CheckSource('TestUnitProcVar',
  2305. LinesToStr([ // statements
  2306. 'var $impl = $mod.$impl;',
  2307. 'this.Proc1 = function () {',
  2308. ' var v1 = 0;',
  2309. '};',
  2310. '']),
  2311. // this.$init
  2312. '',
  2313. // implementation
  2314. LinesToStr([
  2315. '$impl.v2 = "";',
  2316. '']));
  2317. end;
  2318. procedure TTestModule.TestImplProc;
  2319. begin
  2320. StartUnit(false);
  2321. Add('interface');
  2322. Add('');
  2323. Add('procedure Proc1;');
  2324. Add('');
  2325. Add('implementation');
  2326. Add('');
  2327. Add('procedure Proc1; begin end;');
  2328. Add('procedure Proc2; begin end;');
  2329. Add('initialization');
  2330. Add(' Proc1;');
  2331. Add(' Proc2;');
  2332. ConvertUnit;
  2333. CheckSource('TestImplProc',
  2334. LinesToStr([ // statements
  2335. 'var $impl = $mod.$impl;',
  2336. 'this.Proc1 = function () {',
  2337. '};',
  2338. '']),
  2339. LinesToStr([ // this.$init
  2340. '$mod.Proc1();',
  2341. '$impl.Proc2();',
  2342. '']),
  2343. LinesToStr([ // implementation
  2344. '$impl.Proc2 = function () {',
  2345. '};',
  2346. ''])
  2347. );
  2348. end;
  2349. procedure TTestModule.TestFunctionResult;
  2350. begin
  2351. StartProgram(false);
  2352. Add('function Func1: longint;');
  2353. Add('begin');
  2354. Add(' Result:=3;');
  2355. Add(' Func1:=4;');
  2356. Add('end;');
  2357. Add('begin');
  2358. ConvertProgram;
  2359. CheckSource('TestFunctionResult',
  2360. LinesToStr([ // statements
  2361. 'this.Func1 = function () {',
  2362. ' var Result = 0;',
  2363. ' Result = 3;',
  2364. ' Result = 4;',
  2365. ' return Result;',
  2366. '};'
  2367. ]),
  2368. '');
  2369. end;
  2370. procedure TTestModule.TestNestedProc;
  2371. begin
  2372. StartProgram(false);
  2373. Add([
  2374. 'var vInUnit: longint;',
  2375. 'function DoIt(pA,pD: longint): longint;',
  2376. 'var',
  2377. ' vB: longint;',
  2378. ' vC: longint;',
  2379. ' function Nesty(pA: longint): longint; ',
  2380. ' var vB: longint;',
  2381. ' begin',
  2382. ' Result:=pa+vb+vc+pd+vInUnit;',
  2383. ' nesty:=3;',
  2384. ' doit:=4;',
  2385. ' exit;',
  2386. ' end;',
  2387. 'begin',
  2388. ' Result:=pa+vb+vc;',
  2389. ' doit:=6;',
  2390. ' exit;',
  2391. 'end;',
  2392. 'begin']);
  2393. ConvertProgram;
  2394. CheckSource('TestNestedProc',
  2395. LinesToStr([ // statements
  2396. 'this.vInUnit = 0;',
  2397. 'this.DoIt = function (pA, pD) {',
  2398. ' var Result = 0;',
  2399. ' var vB = 0;',
  2400. ' var vC = 0;',
  2401. ' function Nesty(pA) {',
  2402. ' var Result$1 = 0;',
  2403. ' var vB = 0;',
  2404. ' Result$1 = (((pA + vB) + vC) + pD) + $mod.vInUnit;',
  2405. ' Result$1 = 3;',
  2406. ' Result = 4;',
  2407. ' return Result$1;',
  2408. ' return Result$1;',
  2409. ' };',
  2410. ' Result = (pA + vB) + vC;',
  2411. ' Result = 6;',
  2412. ' return Result;',
  2413. ' return Result;',
  2414. '};'
  2415. ]),
  2416. '');
  2417. end;
  2418. procedure TTestModule.TestNestedProc_ResultString;
  2419. begin
  2420. StartProgram(false);
  2421. Add([
  2422. 'function DoIt: string;',
  2423. ' function Nesty: string; ',
  2424. ' begin',
  2425. ' nesty:=#65#66;',
  2426. ' nesty[1]:=#67;',
  2427. ' doit:=#68;',
  2428. ' doit[2]:=#69;',
  2429. ' end;',
  2430. 'begin',
  2431. ' doit:=#70;',
  2432. ' doit[3]:=#71;',
  2433. 'end;',
  2434. 'begin']);
  2435. ConvertProgram;
  2436. CheckSource('TestNestedProc_ResultString',
  2437. LinesToStr([ // statements
  2438. 'this.DoIt = function () {',
  2439. ' var Result = "";',
  2440. ' function Nesty() {',
  2441. ' var Result$1 = "";',
  2442. ' Result$1 = "AB";',
  2443. ' Result$1 = rtl.setCharAt(Result$1, 0, "C");',
  2444. ' Result = "D";',
  2445. ' Result = rtl.setCharAt(Result, 1, "E");',
  2446. ' return Result$1;',
  2447. ' };',
  2448. ' Result = "F";',
  2449. ' Result = rtl.setCharAt(Result, 2, "G");',
  2450. ' return Result;',
  2451. '};'
  2452. ]),
  2453. '');
  2454. end;
  2455. procedure TTestModule.TestForwardProc;
  2456. begin
  2457. StartProgram(false);
  2458. Add('procedure FuncA(Bar: longint); forward;');
  2459. Add('procedure FuncB(Bar: longint);');
  2460. Add('begin');
  2461. Add(' funca(bar);');
  2462. Add('end;');
  2463. Add('procedure funca(bar: longint);');
  2464. Add('begin');
  2465. Add(' if bar=3 then ;');
  2466. Add('end;');
  2467. Add('begin');
  2468. Add(' funca(4);');
  2469. Add(' funcb(5);');
  2470. ConvertProgram;
  2471. CheckSource('TestForwardProc',
  2472. LinesToStr([ // statements'
  2473. 'this.FuncB = function (Bar) {',
  2474. ' $mod.FuncA(Bar);',
  2475. '};',
  2476. 'this.FuncA = function (Bar) {',
  2477. ' if (Bar === 3);',
  2478. '};'
  2479. ]),
  2480. LinesToStr([
  2481. '$mod.FuncA(4);',
  2482. '$mod.FuncB(5);'
  2483. ])
  2484. );
  2485. end;
  2486. procedure TTestModule.TestNestedForwardProc;
  2487. begin
  2488. StartProgram(false);
  2489. Add('procedure FuncA;');
  2490. Add(' procedure FuncB(i: longint); forward;');
  2491. Add(' procedure FuncC(i: longint);');
  2492. Add(' begin');
  2493. Add(' funcb(i);');
  2494. Add(' end;');
  2495. Add(' procedure FuncB(i: longint);');
  2496. Add(' begin');
  2497. Add(' if i=3 then ;');
  2498. Add(' end;');
  2499. Add('begin');
  2500. Add(' funcc(4)');
  2501. Add('end;');
  2502. Add('begin');
  2503. Add(' funca;');
  2504. ConvertProgram;
  2505. CheckSource('TestNestedForwardProc',
  2506. LinesToStr([ // statements'
  2507. 'this.FuncA = function () {',
  2508. ' function FuncC(i) {',
  2509. ' FuncB(i);',
  2510. ' };',
  2511. ' function FuncB(i) {',
  2512. ' if (i === 3);',
  2513. ' };',
  2514. ' FuncC(4);',
  2515. '};'
  2516. ]),
  2517. LinesToStr([
  2518. '$mod.FuncA();'
  2519. ])
  2520. );
  2521. end;
  2522. procedure TTestModule.TestAssignFunctionResult;
  2523. begin
  2524. StartProgram(false);
  2525. Add('function Func1: longint;');
  2526. Add('begin');
  2527. Add('end;');
  2528. Add('var i: longint;');
  2529. Add('begin');
  2530. Add(' i:=func1();');
  2531. Add(' i:=func1()+func1();');
  2532. ConvertProgram;
  2533. CheckSource('TestAssignFunctionResult',
  2534. LinesToStr([ // statements
  2535. 'this.Func1 = function () {',
  2536. ' var Result = 0;',
  2537. ' return Result;',
  2538. '};',
  2539. 'this.i = 0;'
  2540. ]),
  2541. LinesToStr([
  2542. '$mod.i = $mod.Func1();',
  2543. '$mod.i = $mod.Func1() + $mod.Func1();'
  2544. ]));
  2545. end;
  2546. procedure TTestModule.TestFunctionResultInCondition;
  2547. begin
  2548. StartProgram(false);
  2549. Add('function Func1: longint;');
  2550. Add('begin');
  2551. Add('end;');
  2552. Add('function Func2: boolean;');
  2553. Add('begin');
  2554. Add('end;');
  2555. Add('var i: longint;');
  2556. Add('begin');
  2557. Add(' if func2 then ;');
  2558. Add(' if i=func1() then ;');
  2559. Add(' if i=func1 then ;');
  2560. ConvertProgram;
  2561. CheckSource('TestFunctionResultInCondition',
  2562. LinesToStr([ // statements
  2563. 'this.Func1 = function () {',
  2564. ' var Result = 0;',
  2565. ' return Result;',
  2566. '};',
  2567. 'this.Func2 = function () {',
  2568. ' var Result = false;',
  2569. ' return Result;',
  2570. '};',
  2571. 'this.i = 0;'
  2572. ]),
  2573. LinesToStr([
  2574. 'if ($mod.Func2());',
  2575. 'if ($mod.i === $mod.Func1());',
  2576. 'if ($mod.i === $mod.Func1());'
  2577. ]));
  2578. end;
  2579. procedure TTestModule.TestFunctionResultInForLoop;
  2580. begin
  2581. StartProgram(false);
  2582. Add([
  2583. 'function Func1(a: array of longint): longint;',
  2584. 'begin',
  2585. ' for Result:=High(a) downto Low(a) do if a[Result]=0 then exit;',
  2586. ' for Result in a do if a[Result]=0 then exit;',
  2587. 'end;',
  2588. 'begin',
  2589. ' Func1([1,2,3])']);
  2590. ConvertProgram;
  2591. CheckSource('TestFunctionResultInForLoop',
  2592. LinesToStr([ // statements
  2593. 'this.Func1 = function (a) {',
  2594. ' var Result = 0;',
  2595. ' for (var $l1 = rtl.length(a) - 1; $l1 >= 0; $l1--) {',
  2596. ' Result = $l1;',
  2597. ' if (a[Result] === 0) return Result;',
  2598. ' };',
  2599. ' for (var $in2 = a, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) {',
  2600. ' Result = $in2[$l3];',
  2601. ' if (a[Result] === 0) return Result;',
  2602. ' };',
  2603. ' return Result;',
  2604. '};',
  2605. '']),
  2606. LinesToStr([
  2607. '$mod.Func1([1, 2, 3]);'
  2608. ]));
  2609. end;
  2610. procedure TTestModule.TestExit;
  2611. begin
  2612. StartProgram(false);
  2613. Add('procedure ProcA;');
  2614. Add('begin');
  2615. Add(' exit;');
  2616. Add('end;');
  2617. Add('function FuncB: longint;');
  2618. Add('begin');
  2619. Add(' exit;');
  2620. Add(' exit(3);');
  2621. Add('end;');
  2622. Add('function FuncC: string;');
  2623. Add('begin');
  2624. Add(' exit;');
  2625. Add(' exit(''a'');');
  2626. Add(' exit(''abc'');');
  2627. Add('end;');
  2628. Add('begin');
  2629. Add(' exit;');
  2630. Add(' exit(1);');
  2631. ConvertProgram;
  2632. CheckSource('TestExit',
  2633. LinesToStr([ // statements
  2634. 'this.ProcA = function () {',
  2635. ' return;',
  2636. '};',
  2637. 'this.FuncB = function () {',
  2638. ' var Result = 0;',
  2639. ' return Result;',
  2640. ' return 3;',
  2641. ' return Result;',
  2642. '};',
  2643. 'this.FuncC = function () {',
  2644. ' var Result = "";',
  2645. ' return Result;',
  2646. ' return "a";',
  2647. ' return "abc";',
  2648. ' return Result;',
  2649. '};'
  2650. ]),
  2651. LinesToStr([
  2652. 'return;',
  2653. 'return 1;',
  2654. '']));
  2655. end;
  2656. procedure TTestModule.TestBreak;
  2657. begin
  2658. StartProgram(false);
  2659. Add([
  2660. 'var',
  2661. ' i: longint;',
  2662. 'begin',
  2663. ' repeat',
  2664. ' break;',
  2665. ' until true;',
  2666. ' while true do',
  2667. ' break;',
  2668. ' for i:=1 to 2 do',
  2669. ' break;']);
  2670. ConvertProgram;
  2671. CheckSource('TestBreak',
  2672. LinesToStr([ // statements
  2673. 'this.i = 0;'
  2674. ]),
  2675. LinesToStr([
  2676. 'do {',
  2677. ' break;',
  2678. '} while (!true);',
  2679. 'while (true) break;',
  2680. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) break;',
  2681. '']));
  2682. end;
  2683. procedure TTestModule.TestBreakAsVar;
  2684. begin
  2685. StartProgram(false);
  2686. Add([
  2687. 'procedure DoIt(break: boolean);',
  2688. 'begin',
  2689. ' if break then ;',
  2690. 'end;',
  2691. 'var',
  2692. ' break: boolean;',
  2693. 'begin',
  2694. ' if break then ;']);
  2695. ConvertProgram;
  2696. CheckSource('TestBreakAsVar',
  2697. LinesToStr([ // statements
  2698. 'this.DoIt = function (Break) {',
  2699. ' if (Break) ;',
  2700. '};',
  2701. 'this.Break = false;',
  2702. '']),
  2703. LinesToStr([
  2704. 'if($mod.Break) ;',
  2705. '']));
  2706. end;
  2707. procedure TTestModule.TestContinue;
  2708. begin
  2709. StartProgram(false);
  2710. Add('var i: longint;');
  2711. Add('begin');
  2712. Add(' repeat');
  2713. Add(' continue;');
  2714. Add(' until true;');
  2715. Add(' while true do');
  2716. Add(' continue;');
  2717. Add(' for i:=1 to 2 do');
  2718. Add(' continue;');
  2719. ConvertProgram;
  2720. CheckSource('TestContinue',
  2721. LinesToStr([ // statements
  2722. 'this.i = 0;'
  2723. ]),
  2724. LinesToStr([
  2725. 'do {',
  2726. ' continue;',
  2727. '} while (!true);',
  2728. 'while (true) continue;',
  2729. 'for ($mod.i = 1; $mod.i <= 2; $mod.i++) continue;',
  2730. '']));
  2731. end;
  2732. procedure TTestModule.TestProc_External;
  2733. begin
  2734. StartProgram(false);
  2735. Add('procedure Foo; external name ''console.log'';');
  2736. Add('function Bar: longint; external name ''get.item'';');
  2737. Add('function Bla(s: string): longint; external name ''apply.something'';');
  2738. Add('var');
  2739. Add(' i: longint;');
  2740. Add('begin');
  2741. Add(' Foo;');
  2742. Add(' i:=Bar;');
  2743. Add(' i:=Bla(''abc'');');
  2744. ConvertProgram;
  2745. CheckSource('TestProc_External',
  2746. LinesToStr([ // statements
  2747. 'this.i = 0;'
  2748. ]),
  2749. LinesToStr([
  2750. 'console.log();',
  2751. '$mod.i = get.item();',
  2752. '$mod.i = apply.something("abc");'
  2753. ]));
  2754. end;
  2755. procedure TTestModule.TestProc_ExternalOtherUnit;
  2756. begin
  2757. AddModuleWithIntfImplSrc('unit2.pas',
  2758. LinesToStr([
  2759. 'procedure Now; external name ''Date.now'';',
  2760. 'procedure DoIt;'
  2761. ]),
  2762. 'procedure doit; begin end;');
  2763. StartUnit(true);
  2764. Add('interface');
  2765. Add('uses unit2;');
  2766. Add('implementation');
  2767. Add('begin');
  2768. Add(' now;');
  2769. Add(' now();');
  2770. Add(' uNit2.now;');
  2771. Add(' uNit2.now();');
  2772. Add(' doit;');
  2773. Add(' uNit2.doit;');
  2774. ConvertUnit;
  2775. CheckSource('TestProc_ExternalOtherUnit',
  2776. LinesToStr([
  2777. '']),
  2778. LinesToStr([
  2779. 'Date.now();',
  2780. 'Date.now();',
  2781. 'Date.now();',
  2782. 'Date.now();',
  2783. 'pas.unit2.DoIt();',
  2784. 'pas.unit2.DoIt();',
  2785. '']));
  2786. end;
  2787. procedure TTestModule.TestProc_Asm;
  2788. begin
  2789. StartProgram(false);
  2790. Add([
  2791. 'function DoIt: longint;',
  2792. 'begin;',
  2793. ' asm',
  2794. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2795. ' end;',
  2796. ' asm console.log(); end;',
  2797. 'end;',
  2798. 'begin']);
  2799. ConvertProgram;
  2800. CheckSource('TestProc_Asm',
  2801. LinesToStr([ // statements
  2802. 'this.DoIt = function () {',
  2803. ' var Result = 0;',
  2804. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2805. ' console.log();',
  2806. ' return Result;',
  2807. '};'
  2808. ]),
  2809. LinesToStr([
  2810. ''
  2811. ]));
  2812. end;
  2813. procedure TTestModule.TestProc_Assembler;
  2814. begin
  2815. StartProgram(false);
  2816. Add('function DoIt: longint; assembler;');
  2817. Add('asm');
  2818. Add('{ a:{ b:{}, c:[]}, d:''1'' };');
  2819. Add('end;');
  2820. Add('begin');
  2821. ConvertProgram;
  2822. CheckSource('TestProc_Assembler',
  2823. LinesToStr([ // statements
  2824. 'this.DoIt = function () {',
  2825. ' { a:{ b:{}, c:[]}, d:''1'' };',
  2826. '};'
  2827. ]),
  2828. LinesToStr([
  2829. ''
  2830. ]));
  2831. end;
  2832. procedure TTestModule.TestProc_VarParam;
  2833. begin
  2834. StartProgram(false);
  2835. Add('type integer = longint;');
  2836. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  2837. Add('var vJ: integer;');
  2838. Add('begin');
  2839. Add(' vg:=vg+1;');
  2840. Add(' vj:=vh+2;');
  2841. Add(' vi:=vi+3;');
  2842. Add(' doit(vg,vg,vg);');
  2843. Add(' doit(vh,vh,vj);');
  2844. Add(' doit(vi,vi,vi);');
  2845. Add(' doit(vj,vj,vj);');
  2846. Add('end;');
  2847. Add('var i: integer;');
  2848. Add('begin');
  2849. Add(' doit(i,i,i);');
  2850. ConvertProgram;
  2851. CheckSource('TestProc_VarParam',
  2852. LinesToStr([ // statements
  2853. 'this.DoIt = function (vG,vH,vI) {',
  2854. ' var vJ = 0;',
  2855. ' vG = vG + 1;',
  2856. ' vJ = vH + 2;',
  2857. ' vI.set(vI.get()+3);',
  2858. ' $mod.DoIt(vG, vG, {',
  2859. ' get: function () {',
  2860. ' return vG;',
  2861. ' },',
  2862. ' set: function (v) {',
  2863. ' vG = v;',
  2864. ' }',
  2865. ' });',
  2866. ' $mod.DoIt(vH, vH, {',
  2867. ' get: function () {',
  2868. ' return vJ;',
  2869. ' },',
  2870. ' set: function (v) {',
  2871. ' vJ = v;',
  2872. ' }',
  2873. ' });',
  2874. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  2875. ' $mod.DoIt(vJ, vJ, {',
  2876. ' get: function () {',
  2877. ' return vJ;',
  2878. ' },',
  2879. ' set: function (v) {',
  2880. ' vJ = v;',
  2881. ' }',
  2882. ' });',
  2883. '};',
  2884. 'this.i = 0;'
  2885. ]),
  2886. LinesToStr([
  2887. '$mod.DoIt($mod.i,$mod.i,{',
  2888. ' p: $mod,',
  2889. ' get: function () {',
  2890. ' return this.p.i;',
  2891. ' },',
  2892. ' set: function (v) {',
  2893. ' this.p.i = v;',
  2894. ' }',
  2895. '});'
  2896. ]));
  2897. end;
  2898. procedure TTestModule.TestProc_VarParamString;
  2899. begin
  2900. StartProgram(false);
  2901. Add(['type TCaption = string;',
  2902. 'procedure DoIt(vA: TCaption; var vB: TCaption; out vC: TCaption);',
  2903. 'var c: char;',
  2904. 'begin',
  2905. ' va[1]:=c;',
  2906. ' vb[2]:=c;',
  2907. ' vc[3]:=c;',
  2908. 'end;',
  2909. 'begin']);
  2910. ConvertProgram;
  2911. CheckSource('TestProc_VarParamString',
  2912. LinesToStr([ // statements
  2913. 'this.DoIt = function (vA,vB,vC) {',
  2914. ' var c = "";',
  2915. ' vA = rtl.setCharAt(vA, 0, c);',
  2916. ' vB.set(rtl.setCharAt(vB.get(), 1, c));',
  2917. ' vC.set(rtl.setCharAt(vC.get(), 2, c));',
  2918. '};',
  2919. '']),
  2920. LinesToStr([
  2921. ]));
  2922. end;
  2923. procedure TTestModule.TestProc_VarParamV;
  2924. begin
  2925. StartProgram(false);
  2926. Add([
  2927. 'procedure Inc2(var i: longint);',
  2928. 'begin',
  2929. ' i:=i+2;',
  2930. 'end;',
  2931. 'procedure DoIt(v: longint);',
  2932. 'var p: array of longint;',
  2933. 'begin',
  2934. ' Inc2(v);',
  2935. ' Inc2(p[v]);',
  2936. 'end;',
  2937. 'begin']);
  2938. ConvertProgram;
  2939. CheckSource('TestProc_VarParamV',
  2940. LinesToStr([ // statements
  2941. 'this.Inc2 = function (i) {',
  2942. ' i.set(i.get()+2);',
  2943. '};',
  2944. 'this.DoIt = function (v) {',
  2945. ' var p = [];',
  2946. ' $mod.Inc2({get: function () {',
  2947. ' return v;',
  2948. ' }, set: function (w) {',
  2949. ' v = w;',
  2950. ' }});',
  2951. ' $mod.Inc2({',
  2952. ' a: v,',
  2953. ' p: p,',
  2954. ' get: function () {',
  2955. ' return this.p[this.a];',
  2956. ' },',
  2957. ' set: function (v) {',
  2958. ' this.p[this.a] = v;',
  2959. ' }',
  2960. ' });',
  2961. '};',
  2962. '']),
  2963. LinesToStr([
  2964. '']));
  2965. end;
  2966. procedure TTestModule.TestProc_Overload;
  2967. begin
  2968. StartProgram(false);
  2969. Add('procedure DoIt(vI: longint); begin end;');
  2970. Add('procedure DoIt(vI, vJ: longint); begin end;');
  2971. Add('procedure DoIt(vD: double); begin end;');
  2972. Add('begin');
  2973. Add(' DoIt(1);');
  2974. Add(' DoIt(2,3);');
  2975. Add(' DoIt(4.5);');
  2976. ConvertProgram;
  2977. CheckSource('TestProcedureOverload',
  2978. LinesToStr([ // statements
  2979. 'this.DoIt = function (vI) {',
  2980. '};',
  2981. 'this.DoIt$1 = function (vI, vJ) {',
  2982. '};',
  2983. 'this.DoIt$2 = function (vD) {',
  2984. '};',
  2985. '']),
  2986. LinesToStr([
  2987. '$mod.DoIt(1);',
  2988. '$mod.DoIt$1(2, 3);',
  2989. '$mod.DoIt$2(4.5);',
  2990. '']));
  2991. end;
  2992. procedure TTestModule.TestProc_OverloadForward;
  2993. begin
  2994. StartProgram(false);
  2995. Add('procedure DoIt(vI: longint); forward;');
  2996. Add('procedure DoIt(vI, vJ: longint); begin end;');
  2997. Add('procedure doit(vi: longint); begin end;');
  2998. Add('begin');
  2999. Add(' doit(1);');
  3000. Add(' doit(2,3);');
  3001. ConvertProgram;
  3002. CheckSource('TestProcedureOverloadForward',
  3003. LinesToStr([ // statements
  3004. 'this.DoIt$1 = function (vI, vJ) {',
  3005. '};',
  3006. 'this.DoIt = function (vI) {',
  3007. '};',
  3008. '']),
  3009. LinesToStr([
  3010. '$mod.DoIt(1);',
  3011. '$mod.DoIt$1(2, 3);',
  3012. '']));
  3013. end;
  3014. procedure TTestModule.TestProc_OverloadIntfImpl;
  3015. begin
  3016. StartUnit(false);
  3017. Add('interface');
  3018. Add('procedure DoIt(vI: longint);');
  3019. Add('procedure DoIt(vI, vJ: longint);');
  3020. Add('implementation');
  3021. Add('procedure DoIt(vI, vJ, vK, vL, vM: longint); forward;');
  3022. Add('procedure DoIt(vI, vJ, vK: longint); begin end;');
  3023. Add('procedure DoIt(vi: longint); begin end;');
  3024. Add('procedure DoIt(vI, vJ, vK, vL: longint); begin end;');
  3025. Add('procedure DoIt(vi, vj: longint); begin end;');
  3026. Add('procedure DoIt(vi, vj, vk, vl, vm: longint); begin end;');
  3027. Add('begin');
  3028. Add(' doit(1);');
  3029. Add(' doit(2,3);');
  3030. Add(' doit(4,5,6);');
  3031. Add(' doit(7,8,9,10);');
  3032. Add(' doit(11,12,13,14,15);');
  3033. ConvertUnit;
  3034. CheckSource('TestProcedureOverloadUnit',
  3035. LinesToStr([ // statements
  3036. 'var $impl = $mod.$impl;',
  3037. 'this.DoIt = function (vI) {',
  3038. '};',
  3039. 'this.DoIt$1 = function (vI, vJ) {',
  3040. '};',
  3041. '']),
  3042. LinesToStr([ // this.$init
  3043. '$mod.DoIt(1);',
  3044. '$mod.DoIt$1(2, 3);',
  3045. '$impl.DoIt$3(4,5,6);',
  3046. '$impl.DoIt$4(7,8,9,10);',
  3047. '$impl.DoIt$2(11,12,13,14,15);',
  3048. '']),
  3049. LinesToStr([ // implementation
  3050. '$impl.DoIt$3 = function (vI, vJ, vK) {',
  3051. '};',
  3052. '$impl.DoIt$4 = function (vI, vJ, vK, vL) {',
  3053. '};',
  3054. '$impl.DoIt$2 = function (vI, vJ, vK, vL, vM) {',
  3055. '};',
  3056. '']));
  3057. end;
  3058. procedure TTestModule.TestProc_OverloadNested;
  3059. begin
  3060. StartProgram(false);
  3061. Add([
  3062. 'procedure DoIt(vA: longint); overload; forward;',
  3063. 'procedure DoIt(vB, vC: longint); overload;',
  3064. 'begin // 2 param overload',
  3065. ' doit(1);',
  3066. ' doit(1,2);',
  3067. 'end;',
  3068. 'procedure doit(vA: longint);',
  3069. ' procedure DoIt(vA, vB, vC: longint); overload; forward;',
  3070. ' procedure DoIt(vA, vB, vC, vD: longint); overload;',
  3071. ' begin // 4 param overload',
  3072. ' doit(1);',
  3073. ' doit(1,2);',
  3074. ' doit(1,2,3);',
  3075. ' doit(1,2,3,4);',
  3076. ' end;',
  3077. ' procedure doit(vA, vB, vC: longint);',
  3078. ' procedure DoIt(vA, vB, vC, vD, vE: longint); overload; forward;',
  3079. ' procedure DoIt(vA, vB, vC, vD, vE, vF: longint); overload;',
  3080. ' begin // 6 param overload',
  3081. ' doit(1);',
  3082. ' doit(1,2);',
  3083. ' doit(1,2,3);',
  3084. ' doit(1,2,3,4);',
  3085. ' doit(1,2,3,4,5);',
  3086. ' doit(1,2,3,4,5,6);',
  3087. ' end;',
  3088. ' procedure doit(vA, vB, vC, vD, vE: longint);',
  3089. ' begin // 5 param overload',
  3090. ' doit(1);',
  3091. ' doit(1,2);',
  3092. ' doit(1,2,3);',
  3093. ' doit(1,2,3,4);',
  3094. ' doit(1,2,3,4,5);',
  3095. ' doit(1,2,3,4,5,6);',
  3096. ' end;',
  3097. ' begin // 3 param overload',
  3098. ' doit(1);',
  3099. ' doit(1,2);',
  3100. ' doit(1,2,3);',
  3101. ' doit(1,2,3,4);',
  3102. ' doit(1,2,3,4,5);',
  3103. ' doit(1,2,3,4,5,6);',
  3104. ' end;',
  3105. 'begin // 1 param overload',
  3106. ' doit(1);',
  3107. ' doit(1,2);',
  3108. ' doit(1,2,3);',
  3109. ' doit(1,2,3,4);',
  3110. 'end;',
  3111. 'begin // main',
  3112. ' doit(1);',
  3113. ' doit(1,2);']);
  3114. ConvertProgram;
  3115. CheckSource('TestProcedureOverloadNested',
  3116. LinesToStr([ // statements
  3117. 'this.DoIt$1 = function (vB, vC) {',
  3118. ' $mod.DoIt(1);',
  3119. ' $mod.DoIt$1(1, 2);',
  3120. '};',
  3121. 'this.DoIt = function (vA) {',
  3122. ' function DoIt$3(vA, vB, vC, vD) {',
  3123. ' $mod.DoIt(1);',
  3124. ' $mod.DoIt$1(1, 2);',
  3125. ' DoIt$2(1, 2, 3);',
  3126. ' DoIt$3(1, 2, 3, 4);',
  3127. ' };',
  3128. ' function DoIt$2(vA, vB, vC) {',
  3129. ' function DoIt$5(vA, vB, vC, vD, vE, vF) {',
  3130. ' $mod.DoIt(1);',
  3131. ' $mod.DoIt$1(1, 2);',
  3132. ' DoIt$2(1, 2, 3);',
  3133. ' DoIt$3(1, 2, 3, 4);',
  3134. ' DoIt$4(1, 2, 3, 4, 5);',
  3135. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3136. ' };',
  3137. ' function DoIt$4(vA, vB, vC, vD, vE) {',
  3138. ' $mod.DoIt(1);',
  3139. ' $mod.DoIt$1(1, 2);',
  3140. ' DoIt$2(1, 2, 3);',
  3141. ' DoIt$3(1, 2, 3, 4);',
  3142. ' DoIt$4(1, 2, 3, 4, 5);',
  3143. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3144. ' };',
  3145. ' $mod.DoIt(1);',
  3146. ' $mod.DoIt$1(1, 2);',
  3147. ' DoIt$2(1, 2, 3);',
  3148. ' DoIt$3(1, 2, 3, 4);',
  3149. ' DoIt$4(1, 2, 3, 4, 5);',
  3150. ' DoIt$5(1, 2, 3, 4, 5, 6);',
  3151. ' };',
  3152. ' $mod.DoIt(1);',
  3153. ' $mod.DoIt$1(1, 2);',
  3154. ' DoIt$2(1, 2, 3);',
  3155. ' DoIt$3(1, 2, 3, 4);',
  3156. '};',
  3157. '']),
  3158. LinesToStr([
  3159. '$mod.DoIt(1);',
  3160. '$mod.DoIt$1(1, 2);',
  3161. '']));
  3162. end;
  3163. procedure TTestModule.TestProc_OverloadUnitCycle;
  3164. begin
  3165. AddModuleWithIntfImplSrc('Unit2.pas',
  3166. LinesToStr([
  3167. 'type',
  3168. ' TObject = class',
  3169. ' procedure DoIt(b: boolean); virtual; abstract;',
  3170. ' procedure DoIt(i: longint); virtual; abstract;',
  3171. ' end;',
  3172. '']),
  3173. 'uses test1;');
  3174. StartUnit(true);
  3175. Add([
  3176. 'interface',
  3177. 'uses unit2;',
  3178. 'type',
  3179. ' TEagle = class(TObject)',
  3180. ' procedure DoIt(b: boolean); override;',
  3181. ' procedure DoIt(i: longint); override;',
  3182. ' end;',
  3183. 'implementation',
  3184. 'procedure TEagle.DoIt(b: boolean); begin end;',
  3185. 'procedure TEagle.DoIt(i: longint); begin end;',
  3186. '']);
  3187. ConvertUnit;
  3188. CheckSource('TestProc_OverloadUnitCycle',
  3189. LinesToStr([ // statements
  3190. 'rtl.createClass($mod, "TEagle", pas.Unit2.TObject, function () {',
  3191. ' this.DoIt = function (b) {',
  3192. ' };',
  3193. ' this.DoIt$1 = function (i) {',
  3194. ' };',
  3195. '});',
  3196. '']),
  3197. '',
  3198. LinesToStr([
  3199. '']));
  3200. end;
  3201. procedure TTestModule.TestProc_Varargs;
  3202. begin
  3203. StartProgram(false);
  3204. Add([
  3205. 'procedure ProcA(i:longint); varargs; external name ''ProcA'';',
  3206. 'procedure ProcB; varargs; external name ''ProcB'';',
  3207. 'procedure ProcC(i: longint = 17); varargs; external name ''ProcC'';',
  3208. 'function GetIt: longint; begin end;',
  3209. 'begin',
  3210. ' ProcA(1);',
  3211. ' ProcA(1,2);',
  3212. ' ProcA(1,2.0);',
  3213. ' ProcA(1,2,3);',
  3214. ' ProcA(1,''2'');',
  3215. ' ProcA(2,'''');',
  3216. ' ProcA(3,false);',
  3217. ' ProcB;',
  3218. ' ProcB();',
  3219. ' ProcB(4);',
  3220. ' ProcB(''foo'');',
  3221. ' ProcC;',
  3222. ' ProcC();',
  3223. ' ProcC(4);',
  3224. ' ProcC(5,''foo'');',
  3225. ' ProcB(GetIt);',
  3226. ' ProcB(GetIt());',
  3227. ' ProcB(GetIt,GetIt());']);
  3228. ConvertProgram;
  3229. CheckSource('TestProc_Varargs',
  3230. LinesToStr([ // statements
  3231. 'this.GetIt = function () {',
  3232. ' var Result = 0;',
  3233. ' return Result;',
  3234. '};',
  3235. '']),
  3236. LinesToStr([
  3237. 'ProcA(1);',
  3238. 'ProcA(1, 2);',
  3239. 'ProcA(1, 2.0);',
  3240. 'ProcA(1, 2, 3);',
  3241. 'ProcA(1, "2");',
  3242. 'ProcA(2, "");',
  3243. 'ProcA(3, false);',
  3244. 'ProcB();',
  3245. 'ProcB();',
  3246. 'ProcB(4);',
  3247. 'ProcB("foo");',
  3248. 'ProcC(17);',
  3249. 'ProcC(17);',
  3250. 'ProcC(4);',
  3251. 'ProcC(5, "foo");',
  3252. 'ProcB($mod.GetIt());',
  3253. 'ProcB($mod.GetIt());',
  3254. 'ProcB($mod.GetIt(), $mod.GetIt());',
  3255. '']));
  3256. end;
  3257. procedure TTestModule.TestProc_ConstOrder;
  3258. begin
  3259. StartProgram(false);
  3260. Add([
  3261. 'const A = 3;',
  3262. 'const B = A+1;',
  3263. 'procedure DoIt;',
  3264. 'const C = A+1;',
  3265. 'const D = B+1;',
  3266. 'const E = D+C+B+A;',
  3267. 'begin',
  3268. 'end;',
  3269. 'begin'
  3270. ]);
  3271. ConvertProgram;
  3272. CheckSource('TestProc_ConstOrder',
  3273. LinesToStr([ // statements
  3274. 'this.A = 3;',
  3275. 'this.B = 3 + 1;',
  3276. 'var C = 3 + 1;',
  3277. 'var D = 4 + 1;',
  3278. 'var E = ((5 + 4) + 4) + 3;',
  3279. 'this.DoIt = function () {',
  3280. '};',
  3281. '']),
  3282. LinesToStr([
  3283. ''
  3284. ]));
  3285. end;
  3286. procedure TTestModule.TestProc_DuplicateConst;
  3287. begin
  3288. StartProgram(false);
  3289. Add([
  3290. 'const A = 1;',
  3291. 'procedure DoIt;',
  3292. 'const A = 2;',
  3293. ' procedure SubIt;',
  3294. ' const A = 21;',
  3295. ' begin',
  3296. ' end;',
  3297. 'begin',
  3298. 'end;',
  3299. 'procedure DoSome;',
  3300. 'const A = 3;',
  3301. 'begin',
  3302. 'end;',
  3303. 'begin'
  3304. ]);
  3305. ConvertProgram;
  3306. CheckSource('TestProc_DuplicateConst',
  3307. LinesToStr([ // statements
  3308. 'this.A = 1;',
  3309. 'var A$1 = 2;',
  3310. 'var A$2 = 21;',
  3311. 'this.DoIt = function () {',
  3312. ' function SubIt() {',
  3313. ' };',
  3314. '};',
  3315. 'var A$3 = 3;',
  3316. 'this.DoSome = function () {',
  3317. '};',
  3318. '']),
  3319. LinesToStr([
  3320. ''
  3321. ]));
  3322. end;
  3323. procedure TTestModule.TestProc_LocalVarAbsolute;
  3324. begin
  3325. StartProgram(false);
  3326. Add([
  3327. 'type',
  3328. ' TObject = class',
  3329. ' Index: longint;',
  3330. ' end;',
  3331. 'procedure DoIt(i: longint);',
  3332. 'var',
  3333. ' d: double absolute i;',
  3334. ' s: string absolute d;',
  3335. ' o: TObject absolute i;',
  3336. 'begin',
  3337. ' if d=d then d:=d;',
  3338. ' if s=s then s:=s;',
  3339. ' if o.Index<o.Index then o.Index:=o.Index;',
  3340. 'end;',
  3341. 'begin']);
  3342. ConvertProgram;
  3343. CheckSource('TestProc_LocalVarAbsolute',
  3344. LinesToStr([ // statements
  3345. 'rtl.createClass($mod, "TObject", null, function () {',
  3346. ' this.$init = function () {',
  3347. ' this.Index = 0;',
  3348. ' };',
  3349. ' this.$final = function () {',
  3350. ' };',
  3351. '});',
  3352. 'this.DoIt = function (i) {',
  3353. ' if (i === i) i = i;',
  3354. ' if (i === i) i = i;',
  3355. ' if (i.Index < i.Index) i.Index = i.Index;',
  3356. '};'
  3357. ]),
  3358. LinesToStr([
  3359. ]));
  3360. end;
  3361. procedure TTestModule.TestEnum_Name;
  3362. begin
  3363. StartProgram(false);
  3364. Add('type TMyEnum = (Red, Green, Blue);');
  3365. Add('var e: TMyEnum;');
  3366. Add('var f: TMyEnum = Blue;');
  3367. Add('begin');
  3368. Add(' e:=green;');
  3369. Add(' e:=default(TMyEnum);');
  3370. ConvertProgram;
  3371. CheckSource('TestEnumName',
  3372. LinesToStr([ // statements
  3373. 'this.TMyEnum = {',
  3374. ' "0":"Red",',
  3375. ' Red:0,',
  3376. ' "1":"Green",',
  3377. ' Green:1,',
  3378. ' "2":"Blue",',
  3379. ' Blue:2',
  3380. ' };',
  3381. 'this.e = 0;',
  3382. 'this.f = $mod.TMyEnum.Blue;'
  3383. ]),
  3384. LinesToStr([
  3385. '$mod.e=$mod.TMyEnum.Green;',
  3386. '$mod.e=$mod.TMyEnum.Red;'
  3387. ]));
  3388. end;
  3389. procedure TTestModule.TestEnum_Number;
  3390. begin
  3391. Converter.Options:=Converter.Options+[coEnumNumbers];
  3392. StartProgram(false);
  3393. Add('type TMyEnum = (Red, Green);');
  3394. Add('var');
  3395. Add(' e: TMyEnum;');
  3396. Add(' f: TMyEnum = Green;');
  3397. Add(' i: longint;');
  3398. Add('begin');
  3399. Add(' e:=green;');
  3400. Add(' i:=longint(e);');
  3401. ConvertProgram;
  3402. CheckSource('TestEnumNumber',
  3403. LinesToStr([ // statements
  3404. 'this.TMyEnum = {',
  3405. ' "0":"Red",',
  3406. ' Red:0,',
  3407. ' "1":"Green",',
  3408. ' Green:1',
  3409. ' };',
  3410. 'this.e = 0;',
  3411. 'this.f = 1;',
  3412. 'this.i = 0;'
  3413. ]),
  3414. LinesToStr([
  3415. '$mod.e=1;',
  3416. '$mod.i=$mod.e;'
  3417. ]));
  3418. end;
  3419. procedure TTestModule.TestEnum_ConstFail;
  3420. begin
  3421. StartProgram(false);
  3422. Add([
  3423. 'type TMyEnum = (Red = 100, Green = 101);',
  3424. 'var',
  3425. ' e: TMyEnum;',
  3426. ' f: TMyEnum = Green;',
  3427. 'begin',
  3428. ' e:=green;']);
  3429. SetExpectedPasResolverError('not yet implemented: Red:TPasEnumValue [20180126202434] enum const',3002);
  3430. ConvertProgram;
  3431. end;
  3432. procedure TTestModule.TestEnum_Functions;
  3433. begin
  3434. StartProgram(false);
  3435. Add('type TMyEnum = (Red, Green);');
  3436. Add('var');
  3437. Add(' e: TMyEnum;');
  3438. Add(' i: longint;');
  3439. Add(' s: string;');
  3440. Add(' b: boolean;');
  3441. Add('begin');
  3442. Add(' i:=ord(red);');
  3443. Add(' i:=ord(green);');
  3444. Add(' i:=ord(e);');
  3445. Add(' i:=ord(b);');
  3446. Add(' e:=low(tmyenum);');
  3447. Add(' e:=low(e);');
  3448. Add(' b:=low(boolean);');
  3449. Add(' e:=high(tmyenum);');
  3450. Add(' e:=high(e);');
  3451. Add(' b:=high(boolean);');
  3452. Add(' e:=pred(green);');
  3453. Add(' e:=pred(e);');
  3454. Add(' b:=pred(b);');
  3455. Add(' e:=succ(red);');
  3456. Add(' e:=succ(e);');
  3457. Add(' b:=succ(b);');
  3458. Add(' e:=tmyenum(1);');
  3459. Add(' e:=tmyenum(i);');
  3460. Add(' s:=str(e);');
  3461. Add(' str(e,s);');
  3462. Add(' s:=str(e:3);');
  3463. Add(' e:=TMyEnum(i);');
  3464. Add(' i:=longint(e);');
  3465. ConvertProgram;
  3466. CheckSource('TestEnum_Functions',
  3467. LinesToStr([ // statements
  3468. 'this.TMyEnum = {',
  3469. ' "0":"Red",',
  3470. ' Red:0,',
  3471. ' "1":"Green",',
  3472. ' Green:1',
  3473. ' };',
  3474. 'this.e = 0;',
  3475. 'this.i = 0;',
  3476. 'this.s = "";',
  3477. 'this.b = false;',
  3478. '']),
  3479. LinesToStr([
  3480. '$mod.i=$mod.TMyEnum.Red;',
  3481. '$mod.i=$mod.TMyEnum.Green;',
  3482. '$mod.i=$mod.e;',
  3483. '$mod.i=$mod.b+0;',
  3484. '$mod.e=$mod.TMyEnum.Red;',
  3485. '$mod.e=$mod.TMyEnum.Red;',
  3486. '$mod.b=false;',
  3487. '$mod.e=$mod.TMyEnum.Green;',
  3488. '$mod.e=$mod.TMyEnum.Green;',
  3489. '$mod.b=true;',
  3490. '$mod.e=$mod.TMyEnum.Green-1;',
  3491. '$mod.e=$mod.e-1;',
  3492. '$mod.b=false;',
  3493. '$mod.e=$mod.TMyEnum.Red+1;',
  3494. '$mod.e=$mod.e+1;',
  3495. '$mod.b=true;',
  3496. '$mod.e=1;',
  3497. '$mod.e=$mod.i;',
  3498. '$mod.s = $mod.TMyEnum[$mod.e];',
  3499. '$mod.s = $mod.TMyEnum[$mod.e];',
  3500. '$mod.s = rtl.spaceLeft($mod.TMyEnum[$mod.e], 3);',
  3501. '$mod.e=$mod.i;',
  3502. '$mod.i=$mod.e;',
  3503. '']));
  3504. end;
  3505. procedure TTestModule.TestEnum_AsParams;
  3506. begin
  3507. StartProgram(false);
  3508. Add('type TEnum = (Red,Blue);');
  3509. Add('procedure DoIt(vG: TEnum; const vH: TEnum; var vI: TEnum);');
  3510. Add('var vJ: TEnum;');
  3511. Add('begin');
  3512. Add(' vg:=vg;');
  3513. Add(' vj:=vh;');
  3514. Add(' vi:=vi;');
  3515. Add(' doit(vg,vg,vg);');
  3516. Add(' doit(vh,vh,vj);');
  3517. Add(' doit(vi,vi,vi);');
  3518. Add(' doit(vj,vj,vj);');
  3519. Add('end;');
  3520. Add('var i: TEnum;');
  3521. Add('begin');
  3522. Add(' doit(i,i,i);');
  3523. ConvertProgram;
  3524. CheckSource('TestEnum_AsParams',
  3525. LinesToStr([ // statements
  3526. 'this.TEnum = {',
  3527. ' "0": "Red",',
  3528. ' Red: 0,',
  3529. ' "1": "Blue",',
  3530. ' Blue: 1',
  3531. '};',
  3532. 'this.DoIt = function (vG,vH,vI) {',
  3533. ' var vJ = 0;',
  3534. ' vG = vG;',
  3535. ' vJ = vH;',
  3536. ' vI.set(vI.get());',
  3537. ' $mod.DoIt(vG, vG, {',
  3538. ' get: function () {',
  3539. ' return vG;',
  3540. ' },',
  3541. ' set: function (v) {',
  3542. ' vG = v;',
  3543. ' }',
  3544. ' });',
  3545. ' $mod.DoIt(vH, vH, {',
  3546. ' get: function () {',
  3547. ' return vJ;',
  3548. ' },',
  3549. ' set: function (v) {',
  3550. ' vJ = v;',
  3551. ' }',
  3552. ' });',
  3553. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  3554. ' $mod.DoIt(vJ, vJ, {',
  3555. ' get: function () {',
  3556. ' return vJ;',
  3557. ' },',
  3558. ' set: function (v) {',
  3559. ' vJ = v;',
  3560. ' }',
  3561. ' });',
  3562. '};',
  3563. 'this.i = 0;'
  3564. ]),
  3565. LinesToStr([
  3566. '$mod.DoIt($mod.i,$mod.i,{',
  3567. ' p: $mod,',
  3568. ' get: function () {',
  3569. ' return this.p.i;',
  3570. ' },',
  3571. ' set: function (v) {',
  3572. ' this.p.i = v;',
  3573. ' }',
  3574. '});'
  3575. ]));
  3576. end;
  3577. procedure TTestModule.TestEnumRange_Array;
  3578. begin
  3579. StartProgram(false);
  3580. Add([
  3581. 'type',
  3582. ' TEnum = (Red, Green, Blue);',
  3583. ' TEnumRg = green..blue;',
  3584. ' TArr = array[TEnumRg] of byte;',
  3585. ' TArr2 = array[green..blue] of byte;',
  3586. 'var',
  3587. ' a: TArr;',
  3588. ' b: TArr = (3,4);',
  3589. ' c: TArr2 = (5,6);',
  3590. 'begin',
  3591. ' a[green] := b[blue];',
  3592. ' c[green] := c[blue];',
  3593. '']);
  3594. ConvertProgram;
  3595. CheckSource('TestEnumRange_Array',
  3596. LinesToStr([ // statements
  3597. 'this.TEnum = {',
  3598. ' "0": "Red",',
  3599. ' Red: 0,',
  3600. ' "1": "Green",',
  3601. ' Green: 1,',
  3602. ' "2": "Blue",',
  3603. ' Blue: 2',
  3604. '};',
  3605. 'this.a = rtl.arraySetLength(null, 0, 2);',
  3606. 'this.b = [3, 4];',
  3607. 'this.c = [5, 6];',
  3608. '']),
  3609. LinesToStr([
  3610. ' $mod.a[$mod.TEnum.Green - 1] = $mod.b[$mod.TEnum.Blue - 1];',
  3611. ' $mod.c[$mod.TEnum.Green - 1] = $mod.c[$mod.TEnum.Blue - 1];',
  3612. '']));
  3613. end;
  3614. procedure TTestModule.TestEnum_ForIn;
  3615. begin
  3616. StartProgram(false);
  3617. Add([
  3618. 'type',
  3619. ' TEnum = (Red, Green, Blue);',
  3620. ' TEnumRg = green..blue;',
  3621. ' TArr = array[TEnum] of byte;',
  3622. ' TArrRg = array[TEnumRg] of byte;',
  3623. 'var',
  3624. ' e: TEnum;',
  3625. ' a1: TArr = (3,4,5);',
  3626. ' a2: TArrRg = (11,12);',
  3627. ' b: byte;',
  3628. 'begin',
  3629. ' for e in TEnum do ;',
  3630. ' for e in TEnumRg do ;',
  3631. ' for e in TArr do ;',
  3632. ' for e in TArrRg do ;',
  3633. ' for b in a1 do ;',
  3634. ' for b in a2 do ;',
  3635. '']);
  3636. ConvertProgram;
  3637. CheckSource('TestEnum_ForIn',
  3638. LinesToStr([ // statements
  3639. 'this.TEnum = {',
  3640. ' "0": "Red",',
  3641. ' Red: 0,',
  3642. ' "1": "Green",',
  3643. ' Green: 1,',
  3644. ' "2": "Blue",',
  3645. ' Blue: 2',
  3646. '};',
  3647. 'this.e = 0;',
  3648. 'this.a1 = [3, 4, 5];',
  3649. 'this.a2 = [11, 12];',
  3650. 'this.b = 0;',
  3651. '']),
  3652. LinesToStr([
  3653. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  3654. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  3655. ' for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  3656. ' for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  3657. ' for (var $in1 = $mod.a1, $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.b = $in1[$l2];',
  3658. ' for (var $in4 = $mod.a2, $l5 = 0, $end6 = rtl.length($in4) - 1; $l5 <= $end6; $l5++) $mod.b = $in4[$l5];',
  3659. '']));
  3660. end;
  3661. procedure TTestModule.TestEnum_ScopedNumber;
  3662. begin
  3663. Converter.Options:=Converter.Options+[coEnumNumbers];
  3664. StartProgram(false);
  3665. Add([
  3666. 'type',
  3667. ' TEnum = (Red, Green);',
  3668. 'var',
  3669. ' e: TEnum;',
  3670. 'begin',
  3671. ' e:=TEnum.Green;',
  3672. '']);
  3673. ConvertProgram;
  3674. CheckSource('TestEnum_ScopedNumber',
  3675. LinesToStr([ // statements
  3676. 'this.TEnum = {',
  3677. ' "0": "Red",',
  3678. ' Red: 0,',
  3679. ' "1": "Green",',
  3680. ' Green: 1',
  3681. '};',
  3682. 'this.e = 0;',
  3683. '']),
  3684. LinesToStr([
  3685. '$mod.e = 1;']));
  3686. end;
  3687. procedure TTestModule.TestSet;
  3688. begin
  3689. StartProgram(false);
  3690. Add([
  3691. 'type',
  3692. ' TColor = (Red, Green, Blue);',
  3693. ' TColors = set of TColor;',
  3694. 'var',
  3695. ' c: TColor;',
  3696. ' s: TColors;',
  3697. ' t: TColors = [];',
  3698. ' u: TColors = [Red];',
  3699. 'begin',
  3700. ' s:=[];',
  3701. ' s:=[Green];',
  3702. ' s:=[Green,Blue];',
  3703. ' s:=[Red..Blue];',
  3704. ' s:=[Red,Green..Blue];',
  3705. ' s:=[Red,c];',
  3706. ' s:=t;',
  3707. ' s:=default(TColors);',
  3708. '']);
  3709. ConvertProgram;
  3710. CheckSource('TestSet',
  3711. LinesToStr([ // statements
  3712. 'this.TColor = {',
  3713. ' "0":"Red",',
  3714. ' Red:0,',
  3715. ' "1":"Green",',
  3716. ' Green:1,',
  3717. ' "2":"Blue",',
  3718. ' Blue:2',
  3719. ' };',
  3720. 'this.c = 0;',
  3721. 'this.s = {};',
  3722. 'this.t = {};',
  3723. 'this.u = rtl.createSet($mod.TColor.Red);'
  3724. ]),
  3725. LinesToStr([
  3726. '$mod.s={};',
  3727. '$mod.s=rtl.createSet($mod.TColor.Green);',
  3728. '$mod.s=rtl.createSet($mod.TColor.Green,$mod.TColor.Blue);',
  3729. '$mod.s=rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);',
  3730. '$mod.s=rtl.createSet($mod.TColor.Red,null,$mod.TColor.Green,$mod.TColor.Blue);',
  3731. '$mod.s=rtl.createSet($mod.TColor.Red,$mod.c);',
  3732. '$mod.s=rtl.refSet($mod.t);',
  3733. '$mod.s={};',
  3734. '']));
  3735. end;
  3736. procedure TTestModule.TestSet_Operators;
  3737. begin
  3738. StartProgram(false);
  3739. Add('type');
  3740. Add(' TColor = (Red, Green, Blue);');
  3741. Add(' TColors = set of tcolor;');
  3742. Add('var');
  3743. Add(' vC: TColor;');
  3744. Add(' vS: TColors;');
  3745. Add(' vT: TColors;');
  3746. Add(' vU: TColors;');
  3747. Add(' B: boolean;');
  3748. Add('begin');
  3749. Add(' include(vs,green);');
  3750. Add(' exclude(vs,vc);');
  3751. Add(' vs:=vt+vu;');
  3752. Add(' vs:=vt+[red];');
  3753. Add(' vs:=[red]+vt;');
  3754. Add(' vs:=[red]+[green];');
  3755. Add(' vs:=vt-vu;');
  3756. Add(' vs:=vt-[red];');
  3757. Add(' vs:=[red]-vt;');
  3758. Add(' vs:=[red]-[green];');
  3759. Add(' vs:=vt*vu;');
  3760. Add(' vs:=vt*[red];');
  3761. Add(' vs:=[red]*vt;');
  3762. Add(' vs:=[red]*[green];');
  3763. Add(' vs:=vt><vu;');
  3764. Add(' vs:=vt><[red];');
  3765. Add(' vs:=[red]><vt;');
  3766. Add(' vs:=[red]><[green];');
  3767. Add(' b:=vt=vu;');
  3768. Add(' b:=vt=[red];');
  3769. Add(' b:=[red]=vt;');
  3770. Add(' b:=[red]=[green];');
  3771. Add(' b:=vt<>vu;');
  3772. Add(' b:=vt<>[red];');
  3773. Add(' b:=[red]<>vt;');
  3774. Add(' b:=[red]<>[green];');
  3775. Add(' b:=vt<=vu;');
  3776. Add(' b:=vt<=[red];');
  3777. Add(' b:=[red]<=vt;');
  3778. Add(' b:=[red]<=[green];');
  3779. Add(' b:=vt>=vu;');
  3780. Add(' b:=vt>=[red];');
  3781. Add(' b:=[red]>=vt;');
  3782. Add(' b:=[red]>=[green];');
  3783. ConvertProgram;
  3784. CheckSource('TestSet_Operators',
  3785. LinesToStr([ // statements
  3786. 'this.TColor = {',
  3787. ' "0":"Red",',
  3788. ' Red:0,',
  3789. ' "1":"Green",',
  3790. ' Green:1,',
  3791. ' "2":"Blue",',
  3792. ' Blue:2',
  3793. ' };',
  3794. 'this.vC = 0;',
  3795. 'this.vS = {};',
  3796. 'this.vT = {};',
  3797. 'this.vU = {};',
  3798. 'this.B = false;'
  3799. ]),
  3800. LinesToStr([
  3801. '$mod.vS = rtl.includeSet($mod.vS,$mod.TColor.Green);',
  3802. '$mod.vS = rtl.excludeSet($mod.vS,$mod.vC);',
  3803. '$mod.vS = rtl.unionSet($mod.vT, $mod.vU);',
  3804. '$mod.vS = rtl.unionSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3805. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3806. '$mod.vS = rtl.unionSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3807. '$mod.vS = rtl.diffSet($mod.vT, $mod.vU);',
  3808. '$mod.vS = rtl.diffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3809. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3810. '$mod.vS = rtl.diffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3811. '$mod.vS = rtl.intersectSet($mod.vT, $mod.vU);',
  3812. '$mod.vS = rtl.intersectSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3813. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3814. '$mod.vS = rtl.intersectSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3815. '$mod.vS = rtl.symDiffSet($mod.vT, $mod.vU);',
  3816. '$mod.vS = rtl.symDiffSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3817. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3818. '$mod.vS = rtl.symDiffSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3819. '$mod.B = rtl.eqSet($mod.vT, $mod.vU);',
  3820. '$mod.B = rtl.eqSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3821. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3822. '$mod.B = rtl.eqSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3823. '$mod.B = rtl.neSet($mod.vT, $mod.vU);',
  3824. '$mod.B = rtl.neSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3825. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3826. '$mod.B = rtl.neSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3827. '$mod.B = rtl.leSet($mod.vT, $mod.vU);',
  3828. '$mod.B = rtl.leSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3829. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3830. '$mod.B = rtl.leSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3831. '$mod.B = rtl.geSet($mod.vT, $mod.vU);',
  3832. '$mod.B = rtl.geSet($mod.vT, rtl.createSet($mod.TColor.Red));',
  3833. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), $mod.vT);',
  3834. '$mod.B = rtl.geSet(rtl.createSet($mod.TColor.Red), rtl.createSet($mod.TColor.Green));',
  3835. '']));
  3836. end;
  3837. procedure TTestModule.TestSet_Operator_In;
  3838. begin
  3839. StartProgram(false);
  3840. Add('type');
  3841. Add(' TColor = (Red, Green, Blue);');
  3842. Add(' TColors = set of tcolor;');
  3843. Add('var');
  3844. Add(' vC: tcolor;');
  3845. Add(' vT: tcolors;');
  3846. Add(' B: boolean;');
  3847. Add('begin');
  3848. Add(' b:=red in vt;');
  3849. Add(' b:=vc in vt;');
  3850. Add(' b:=green in [red..blue];');
  3851. Add(' b:=vc in [red..blue];');
  3852. Add(' ');
  3853. Add(' if red in vt then ;');
  3854. Add(' while vC in vt do ;');
  3855. Add(' repeat');
  3856. Add(' until vC in vt;');
  3857. ConvertProgram;
  3858. CheckSource('TestSet_Operator_In',
  3859. LinesToStr([ // statements
  3860. 'this.TColor = {',
  3861. ' "0":"Red",',
  3862. ' Red:0,',
  3863. ' "1":"Green",',
  3864. ' Green:1,',
  3865. ' "2":"Blue",',
  3866. ' Blue:2',
  3867. ' };',
  3868. 'this.vC = 0;',
  3869. 'this.vT = {};',
  3870. 'this.B = false;'
  3871. ]),
  3872. LinesToStr([
  3873. '$mod.B = $mod.TColor.Red in $mod.vT;',
  3874. '$mod.B = $mod.vC in $mod.vT;',
  3875. '$mod.B = $mod.TColor.Green in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  3876. '$mod.B = $mod.vC in rtl.createSet(null, $mod.TColor.Red, $mod.TColor.Blue);',
  3877. 'if ($mod.TColor.Red in $mod.vT) ;',
  3878. 'while ($mod.vC in $mod.vT) {',
  3879. '};',
  3880. 'do {',
  3881. '} while (!($mod.vC in $mod.vT));',
  3882. '']));
  3883. end;
  3884. procedure TTestModule.TestSet_Functions;
  3885. begin
  3886. StartProgram(false);
  3887. Add('type');
  3888. Add(' TMyEnum = (Red, Green);');
  3889. Add(' TMyEnums = set of TMyEnum;');
  3890. Add('var');
  3891. Add(' e: TMyEnum;');
  3892. Add(' s: TMyEnums;');
  3893. Add('begin');
  3894. Add(' e:=Low(TMyEnums);');
  3895. Add(' e:=Low(s);');
  3896. Add(' e:=High(TMyEnums);');
  3897. Add(' e:=High(s);');
  3898. ConvertProgram;
  3899. CheckSource('TestSetFunctions',
  3900. LinesToStr([ // statements
  3901. 'this.TMyEnum = {',
  3902. ' "0":"Red",',
  3903. ' Red:0,',
  3904. ' "1":"Green",',
  3905. ' Green:1',
  3906. ' };',
  3907. 'this.e = 0;',
  3908. 'this.s = {};'
  3909. ]),
  3910. LinesToStr([
  3911. '$mod.e=$mod.TMyEnum.Red;',
  3912. '$mod.e=$mod.TMyEnum.Red;',
  3913. '$mod.e=$mod.TMyEnum.Green;',
  3914. '$mod.e=$mod.TMyEnum.Green;',
  3915. '']));
  3916. end;
  3917. procedure TTestModule.TestSet_PassAsArgClone;
  3918. begin
  3919. StartProgram(false);
  3920. Add('type');
  3921. Add(' TMyEnum = (Red, Green);');
  3922. Add(' TMyEnums = set of TMyEnum;');
  3923. Add('procedure DoDefault(s: tmyenums); begin end;');
  3924. Add('procedure DoConst(const s: tmyenums); begin end;');
  3925. Add('var');
  3926. Add(' aSet: tmyenums;');
  3927. Add('begin');
  3928. Add(' dodefault(aset);');
  3929. Add(' doconst(aset);');
  3930. ConvertProgram;
  3931. CheckSource('TestSetFunctions',
  3932. LinesToStr([ // statements
  3933. 'this.TMyEnum = {',
  3934. ' "0":"Red",',
  3935. ' Red:0,',
  3936. ' "1":"Green",',
  3937. ' Green:1',
  3938. ' };',
  3939. 'this.DoDefault = function (s) {',
  3940. '};',
  3941. 'this.DoConst = function (s) {',
  3942. '};',
  3943. 'this.aSet = {};'
  3944. ]),
  3945. LinesToStr([
  3946. '$mod.DoDefault(rtl.refSet($mod.aSet));',
  3947. '$mod.DoConst($mod.aSet);',
  3948. '']));
  3949. end;
  3950. procedure TTestModule.TestSet_AsParams;
  3951. begin
  3952. StartProgram(false);
  3953. Add('type TEnum = (Red,Blue);');
  3954. Add('type TEnums = set of TEnum;');
  3955. Add('procedure DoIt(vG: TEnums; const vH: TEnums; var vI: TEnums);');
  3956. Add('var vJ: TEnums;');
  3957. Add('begin');
  3958. Add(' vg:=vg;');
  3959. Add(' vj:=vh;');
  3960. Add(' vi:=vi;');
  3961. Add(' doit(vg,vg,vg);');
  3962. Add(' doit(vh,vh,vj);');
  3963. Add(' doit(vi,vi,vi);');
  3964. Add(' doit(vj,vj,vj);');
  3965. Add('end;');
  3966. Add('var i: TEnums;');
  3967. Add('begin');
  3968. Add(' doit(i,i,i);');
  3969. ConvertProgram;
  3970. CheckSource('TestSet_AsParams',
  3971. LinesToStr([ // statements
  3972. 'this.TEnum = {',
  3973. ' "0": "Red",',
  3974. ' Red: 0,',
  3975. ' "1": "Blue",',
  3976. ' Blue: 1',
  3977. '};',
  3978. 'this.DoIt = function (vG,vH,vI) {',
  3979. ' var vJ = {};',
  3980. ' vG = rtl.refSet(vG);',
  3981. ' vJ = rtl.refSet(vH);',
  3982. ' vI.set(rtl.refSet(vI.get()));',
  3983. ' $mod.DoIt(rtl.refSet(vG), vG, {',
  3984. ' get: function () {',
  3985. ' return vG;',
  3986. ' },',
  3987. ' set: function (v) {',
  3988. ' vG = v;',
  3989. ' }',
  3990. ' });',
  3991. ' $mod.DoIt(rtl.refSet(vH), vH, {',
  3992. ' get: function () {',
  3993. ' return vJ;',
  3994. ' },',
  3995. ' set: function (v) {',
  3996. ' vJ = v;',
  3997. ' }',
  3998. ' });',
  3999. ' $mod.DoIt(rtl.refSet(vI.get()), vI.get(), vI);',
  4000. ' $mod.DoIt(rtl.refSet(vJ), vJ, {',
  4001. ' get: function () {',
  4002. ' return vJ;',
  4003. ' },',
  4004. ' set: function (v) {',
  4005. ' vJ = v;',
  4006. ' }',
  4007. ' });',
  4008. '};',
  4009. 'this.i = {};'
  4010. ]),
  4011. LinesToStr([
  4012. '$mod.DoIt(rtl.refSet($mod.i),$mod.i,{',
  4013. ' p: $mod,',
  4014. ' get: function () {',
  4015. ' return this.p.i;',
  4016. ' },',
  4017. ' set: function (v) {',
  4018. ' this.p.i = v;',
  4019. ' }',
  4020. '});'
  4021. ]));
  4022. end;
  4023. procedure TTestModule.TestSet_Property;
  4024. begin
  4025. StartProgram(false);
  4026. Add('type');
  4027. Add(' TEnum = (Red,Blue);');
  4028. Add(' TEnums = set of TEnum;');
  4029. Add(' TObject = class');
  4030. Add(' function GetColors: TEnums; external name ''GetColors'';');
  4031. Add(' procedure SetColors(const Value: TEnums); external name ''SetColors'';');
  4032. Add(' property Colors: TEnums read GetColors write SetColors;');
  4033. Add(' end;');
  4034. Add('procedure DoIt(i: TEnums; const j: TEnums; var k: TEnums; out l: TEnums);');
  4035. Add('begin end;');
  4036. Add('var Obj: TObject;');
  4037. Add('begin');
  4038. Add(' Include(Obj.Colors,Red);');
  4039. Add(' Exclude(Obj.Colors,Red);');
  4040. //Add(' DoIt(Obj.Colors,Obj.Colors,Obj.Colors,Obj.Colors);');
  4041. ConvertProgram;
  4042. CheckSource('TestSet_Property',
  4043. LinesToStr([ // statements
  4044. 'this.TEnum = {',
  4045. ' "0": "Red",',
  4046. ' Red: 0,',
  4047. ' "1": "Blue",',
  4048. ' Blue: 1',
  4049. '};',
  4050. 'rtl.createClass($mod, "TObject", null, function () {',
  4051. ' this.$init = function () {',
  4052. ' };',
  4053. ' this.$final = function () {',
  4054. ' };',
  4055. '});',
  4056. 'this.DoIt = function (i, j, k, l) {',
  4057. '};',
  4058. 'this.Obj = null;',
  4059. '']),
  4060. LinesToStr([
  4061. '$mod.Obj.SetColors(rtl.includeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  4062. '$mod.Obj.SetColors(rtl.excludeSet($mod.Obj.GetColors(), $mod.TEnum.Red));',
  4063. '']));
  4064. end;
  4065. procedure TTestModule.TestSet_EnumConst;
  4066. begin
  4067. StartProgram(false);
  4068. Add('type');
  4069. Add(' TEnum = (Red,Blue);');
  4070. Add(' TEnums = set of TEnum;');
  4071. Add('const');
  4072. Add(' Orange = red;');
  4073. Add('var');
  4074. Add(' Enum: tenum;');
  4075. Add(' Enums: tenums;');
  4076. Add('begin');
  4077. Add(' Include(enums,orange);');
  4078. Add(' Exclude(enums,orange);');
  4079. Add(' if orange in enums then;');
  4080. Add(' if orange in [orange,red] then;');
  4081. ConvertProgram;
  4082. CheckSource('TestEnumConst',
  4083. LinesToStr([ // statements
  4084. 'this.TEnum = {',
  4085. ' "0": "Red",',
  4086. ' Red: 0,',
  4087. ' "1": "Blue",',
  4088. ' Blue: 1',
  4089. '};',
  4090. 'this.Orange = $mod.TEnum.Red;',
  4091. 'this.Enum = 0;',
  4092. 'this.Enums = {};',
  4093. '']),
  4094. LinesToStr([
  4095. '$mod.Enums = rtl.includeSet($mod.Enums, $mod.TEnum.Red);',
  4096. '$mod.Enums = rtl.excludeSet($mod.Enums, $mod.TEnum.Red);',
  4097. 'if ($mod.TEnum.Red in $mod.Enums) ;',
  4098. 'if ($mod.TEnum.Red in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Red)) ;',
  4099. '']));
  4100. end;
  4101. procedure TTestModule.TestSet_AnonymousEnumType;
  4102. begin
  4103. StartProgram(false);
  4104. Add('type');
  4105. Add(' TFlags = set of (red, green);');
  4106. Add('const');
  4107. Add(' favorite = red;');
  4108. Add('var');
  4109. Add(' f: TFlags;');
  4110. Add(' i: longint;');
  4111. Add('begin');
  4112. Add(' Include(f,red);');
  4113. Add(' Include(f,favorite);');
  4114. Add(' i:=ord(red);');
  4115. Add(' i:=ord(favorite);');
  4116. Add(' i:=ord(low(TFlags));');
  4117. Add(' i:=ord(low(f));');
  4118. Add(' i:=ord(low(favorite));');
  4119. Add(' i:=ord(high(TFlags));');
  4120. Add(' i:=ord(high(f));');
  4121. Add(' i:=ord(high(favorite));');
  4122. Add(' f:=[green,favorite];');
  4123. ConvertProgram;
  4124. CheckSource('TestSet_AnonymousEnumType',
  4125. LinesToStr([ // statements
  4126. 'this.TFlags$a = {',
  4127. ' "0": "red",',
  4128. ' red: 0,',
  4129. ' "1": "green",',
  4130. ' green: 1',
  4131. '};',
  4132. 'this.favorite = $mod.TFlags$a.red;',
  4133. 'this.f = {};',
  4134. 'this.i = 0;',
  4135. '']),
  4136. LinesToStr([
  4137. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  4138. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  4139. '$mod.i = $mod.TFlags$a.red;',
  4140. '$mod.i = $mod.TFlags$a.red;',
  4141. '$mod.i = $mod.TFlags$a.red;',
  4142. '$mod.i = $mod.TFlags$a.red;',
  4143. '$mod.i = $mod.TFlags$a.red;',
  4144. '$mod.i = $mod.TFlags$a.green;',
  4145. '$mod.i = $mod.TFlags$a.green;',
  4146. '$mod.i = $mod.TFlags$a.green;',
  4147. '$mod.f = rtl.createSet($mod.TFlags$a.green, $mod.TFlags$a.red);',
  4148. '']));
  4149. end;
  4150. procedure TTestModule.TestSet_AnonymousEnumTypeChar;
  4151. begin
  4152. exit;
  4153. StartProgram(false);
  4154. Add([
  4155. 'type',
  4156. ' TAtoZ = ''A''..''Z'';',
  4157. ' TSetOfAZ = set of TAtoZ;',
  4158. 'var',
  4159. ' c: char;',
  4160. ' a: TAtoZ;',
  4161. ' s: TSetOfAZ = [''P'',''A''];',
  4162. ' i: longint;',
  4163. 'begin',
  4164. ' Include(s,''S'');',
  4165. ' Include(s,c);',
  4166. ' Include(s,a);',
  4167. ' c:=low(TAtoZ);',
  4168. ' i:=ord(low(TAtoZ));',
  4169. ' a:=high(TAtoZ);',
  4170. ' a:=high(TSetOfAtoZ);',
  4171. ' s:=[a,c,''M''];',
  4172. '']);
  4173. ConvertProgram;
  4174. CheckSource('TestSet_AnonymousEnumTypeChar',
  4175. LinesToStr([ // statements
  4176. '']),
  4177. LinesToStr([
  4178. '']));
  4179. end;
  4180. procedure TTestModule.TestSet_ConstEnum;
  4181. begin
  4182. StartProgram(false);
  4183. Add([
  4184. 'type',
  4185. ' TEnum = (red,blue,green);',
  4186. ' TEnums = set of TEnum;',
  4187. 'const',
  4188. ' teAny = [low(TEnum)..high(TEnum)];',
  4189. ' teRedBlue = [low(TEnum)..pred(high(TEnum))];',
  4190. 'var',
  4191. ' e: TEnum;',
  4192. ' s: TEnums;',
  4193. 'begin',
  4194. ' if blue in teAny then;',
  4195. ' if blue in teAny+[e] then;',
  4196. ' if blue in teAny+teRedBlue then;',
  4197. ' if e in [red,blue] then;',
  4198. ' s:=teAny;',
  4199. ' s:=teAny+[e];',
  4200. ' s:=[e]+teAny;',
  4201. ' s:=teAny+teRedBlue;',
  4202. ' s:=teAny+teRedBlue+[e];',
  4203. '']);
  4204. ConvertProgram;
  4205. CheckSource('TestSet_ConstEnum',
  4206. LinesToStr([ // statements
  4207. 'this.TEnum = {',
  4208. ' "0": "red",',
  4209. ' red: 0,',
  4210. ' "1": "blue",',
  4211. ' blue: 1,',
  4212. ' "2": "green",',
  4213. ' green: 2',
  4214. '};',
  4215. 'this.teAny = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green);',
  4216. 'this.teRedBlue = rtl.createSet(null, $mod.TEnum.red, $mod.TEnum.green - 1);',
  4217. 'this.e = 0;',
  4218. 'this.s = {};',
  4219. '']),
  4220. LinesToStr([
  4221. 'if ($mod.TEnum.blue in $mod.teAny) ;',
  4222. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, rtl.createSet($mod.e))) ;',
  4223. 'if ($mod.TEnum.blue in rtl.unionSet($mod.teAny, $mod.teRedBlue)) ;',
  4224. 'if ($mod.e in rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)) ;',
  4225. '$mod.s = rtl.refSet($mod.teAny);',
  4226. '$mod.s = rtl.unionSet($mod.teAny, rtl.createSet($mod.e));',
  4227. '$mod.s = rtl.unionSet(rtl.createSet($mod.e), $mod.teAny);',
  4228. '$mod.s = rtl.unionSet($mod.teAny, $mod.teRedBlue);',
  4229. '$mod.s = rtl.unionSet(rtl.unionSet($mod.teAny, $mod.teRedBlue), rtl.createSet($mod.e));',
  4230. '']));
  4231. end;
  4232. procedure TTestModule.TestSet_ConstChar;
  4233. begin
  4234. StartProgram(false);
  4235. Add([
  4236. 'const',
  4237. ' LowChars = [''a''..''z''];',
  4238. ' Chars = LowChars+[''A''..''Z''];',
  4239. 'var',
  4240. ' c: char;',
  4241. ' s: string;',
  4242. 'begin',
  4243. ' if c in lowchars then ;',
  4244. ' if ''a'' in lowchars then ;',
  4245. ' if s[1] in lowchars then ;',
  4246. ' if c in chars then ;',
  4247. ' if c in [''a''..''z'',''_''] then ;',
  4248. ' if ''b'' in [''a''..''z'',''_''] then ;',
  4249. '']);
  4250. ConvertProgram;
  4251. CheckSource('TestSet_ConstChar',
  4252. LinesToStr([ // statements
  4253. 'this.LowChars = rtl.createSet(null, 97, 122);',
  4254. 'this.Chars = rtl.unionSet($mod.LowChars, rtl.createSet(null, 65, 90));',
  4255. 'this.c = "";',
  4256. 'this.s = "";',
  4257. '']),
  4258. LinesToStr([
  4259. 'if ($mod.c.charCodeAt() in $mod.LowChars) ;',
  4260. 'if (97 in $mod.LowChars) ;',
  4261. 'if ($mod.s.charCodeAt(0) in $mod.LowChars) ;',
  4262. 'if ($mod.c.charCodeAt() in $mod.Chars) ;',
  4263. 'if ($mod.c.charCodeAt() in rtl.createSet(null, 97, 122, 95)) ;',
  4264. 'if (98 in rtl.createSet(null, 97, 122, 95)) ;',
  4265. '']));
  4266. end;
  4267. procedure TTestModule.TestSet_ConstInt;
  4268. begin
  4269. StartProgram(false);
  4270. Add([
  4271. 'const',
  4272. ' Months = [1..12];',
  4273. ' Mirror = [-12..-1]+Months;',
  4274. 'var',
  4275. ' i: smallint;',
  4276. 'begin',
  4277. ' if 3 in Months then;',
  4278. ' if i in Months+[i] then;',
  4279. ' if i in Months+Mirror then;',
  4280. ' if i in [4..6,8] then;',
  4281. '']);
  4282. ConvertProgram;
  4283. CheckSource('TestSet_ConstInt',
  4284. LinesToStr([ // statements
  4285. 'this.Months = rtl.createSet(null, 1, 12);',
  4286. 'this.Mirror = rtl.unionSet(rtl.createSet(null, -12, -1), $mod.Months);',
  4287. 'this.i = 0;',
  4288. '']),
  4289. LinesToStr([
  4290. 'if (3 in $mod.Months) ;',
  4291. 'if ($mod.i in rtl.unionSet($mod.Months, rtl.createSet($mod.i))) ;',
  4292. 'if ($mod.i in rtl.unionSet($mod.Months, $mod.Mirror)) ;',
  4293. 'if ($mod.i in rtl.createSet(null, 4, 6, 8)) ;',
  4294. '']));
  4295. end;
  4296. procedure TTestModule.TestSet_ForIn;
  4297. begin
  4298. StartProgram(false);
  4299. Add([
  4300. 'type',
  4301. ' TEnum = (Red, Green, Blue);',
  4302. ' TEnumRg = green..blue;',
  4303. ' TSetOfEnum = set of TEnum;',
  4304. ' TSetOfEnumRg = set of TEnumRg;',
  4305. 'var',
  4306. ' e, e2: TEnum;',
  4307. ' er: TEnum;',
  4308. ' s: TSetOfEnum;',
  4309. 'begin',
  4310. ' for e in TSetOfEnum do ;',
  4311. ' for e in TSetOfEnumRg do ;',
  4312. ' for e in [] do e2:=e;',
  4313. ' for e in [red..green] do e2:=e;',
  4314. ' for e in [green,blue] do e2:=e;',
  4315. ' for e in [red,blue] do e2:=e;',
  4316. ' for e in s do e2:=e;',
  4317. ' for er in TSetOfEnumRg do ;',
  4318. '']);
  4319. ConvertProgram;
  4320. CheckSource('TestEnumName',
  4321. LinesToStr([ // statements
  4322. 'this.TEnum = {',
  4323. ' "0":"Red",',
  4324. ' Red:0,',
  4325. ' "1":"Green",',
  4326. ' Green:1,',
  4327. ' "2":"Blue",',
  4328. ' Blue:2',
  4329. ' };',
  4330. 'this.e = 0;',
  4331. 'this.e2 = 0;',
  4332. 'this.er = 0;',
  4333. 'this.s = {};',
  4334. '']),
  4335. LinesToStr([
  4336. 'for ($mod.e = 0; $mod.e <= 2; $mod.e++) ;',
  4337. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) ;',
  4338. 'for ($mod.e = 0; $mod.e <= 1; $mod.e++) $mod.e2 = $mod.e;',
  4339. 'for ($mod.e = 1; $mod.e <= 2; $mod.e++) $mod.e2 = $mod.e;',
  4340. 'for ($mod.e in rtl.createSet($mod.TEnum.Red, $mod.TEnum.Blue)) $mod.e2 = $mod.e;',
  4341. 'for ($mod.e in $mod.s) $mod.e2 = $mod.e;',
  4342. 'for ($mod.er = 1; $mod.er <= 2; $mod.er++) ;',
  4343. '']));
  4344. end;
  4345. procedure TTestModule.TestNestBegin;
  4346. begin
  4347. StartProgram(false);
  4348. Add('begin');
  4349. Add(' begin');
  4350. Add(' begin');
  4351. Add(' end;');
  4352. Add(' begin');
  4353. Add(' if true then ;');
  4354. Add(' end;');
  4355. Add(' end;');
  4356. ConvertProgram;
  4357. CheckSource('TestNestBegin',
  4358. '',
  4359. 'if (true) ;');
  4360. end;
  4361. procedure TTestModule.TestUnitImplVars;
  4362. begin
  4363. StartUnit(false);
  4364. Add('interface');
  4365. Add('implementation');
  4366. Add('var');
  4367. Add(' V1:longint;');
  4368. Add(' V2:longint = 3;');
  4369. Add(' V3:string = ''abc'';');
  4370. ConvertUnit;
  4371. CheckSource('TestUnitImplVars',
  4372. LinesToStr([ // statements
  4373. 'var $impl = $mod.$impl;',
  4374. '']),
  4375. '', // this.$init
  4376. LinesToStr([ // implementation
  4377. '$impl.V1 = 0;',
  4378. '$impl.V2 = 3;',
  4379. '$impl.V3 = "abc";',
  4380. '']) );
  4381. end;
  4382. procedure TTestModule.TestUnitImplConsts;
  4383. begin
  4384. StartUnit(false);
  4385. Add('interface');
  4386. Add('implementation');
  4387. Add('const');
  4388. Add(' v1 = 3;');
  4389. Add(' v2:longint = 4;');
  4390. Add(' v3:string = ''abc'';');
  4391. ConvertUnit;
  4392. CheckSource('TestUnitImplConsts',
  4393. LinesToStr([ // statements
  4394. 'var $impl = $mod.$impl;',
  4395. '']),
  4396. '', // this.$init
  4397. LinesToStr([ // implementation
  4398. '$impl.v1 = 3;',
  4399. '$impl.v2 = 4;',
  4400. '$impl.v3 = "abc";',
  4401. '']) );
  4402. end;
  4403. procedure TTestModule.TestUnitImplRecord;
  4404. begin
  4405. StartUnit(false);
  4406. Add('interface');
  4407. Add('implementation');
  4408. Add('type');
  4409. Add(' TMyRecord = record');
  4410. Add(' i: longint;');
  4411. Add(' end;');
  4412. Add('var aRec: TMyRecord;');
  4413. Add('initialization');
  4414. Add(' arec.i:=3;');
  4415. ConvertUnit;
  4416. CheckSource('TestUnitImplRecord',
  4417. LinesToStr([ // statements
  4418. 'var $impl = $mod.$impl;',
  4419. '']),
  4420. // this.$init
  4421. '$impl.aRec.i = 3;',
  4422. LinesToStr([ // implementation
  4423. '$impl.TMyRecord = function (s) {',
  4424. ' if (s) {',
  4425. ' this.i = s.i;',
  4426. ' } else {',
  4427. ' this.i = 0;',
  4428. ' };',
  4429. ' this.$equal = function (b) {',
  4430. ' return this.i === b.i;',
  4431. ' };',
  4432. '};',
  4433. '$impl.aRec = new $impl.TMyRecord();',
  4434. '']) );
  4435. end;
  4436. procedure TTestModule.TestRenameJSNameConflict;
  4437. begin
  4438. StartProgram(false);
  4439. Add('var apply: longint;');
  4440. Add('var bind: longint;');
  4441. Add('var call: longint;');
  4442. Add('begin');
  4443. ConvertProgram;
  4444. CheckSource('TestRenameJSNameConflict',
  4445. LinesToStr([ // statements
  4446. 'this.Apply = 0;',
  4447. 'this.Bind = 0;',
  4448. 'this.Call = 0;'
  4449. ]),
  4450. LinesToStr([ // this.$main
  4451. ''
  4452. ]));
  4453. end;
  4454. procedure TTestModule.TestLocalConst;
  4455. begin
  4456. StartProgram(false);
  4457. Add('procedure DoIt;');
  4458. Add('const');
  4459. Add(' cA: longint = 1;');
  4460. Add(' cB = 2;');
  4461. Add(' procedure Sub;');
  4462. Add(' const');
  4463. Add(' csA = 3;');
  4464. Add(' cB: double = 4;');
  4465. Add(' begin');
  4466. Add(' cb:=cb+csa;');
  4467. Add(' ca:=ca+csa+5;');
  4468. Add(' end;');
  4469. Add('begin');
  4470. Add(' ca:=ca+cb+6;');
  4471. Add('end;');
  4472. Add('begin');
  4473. ConvertProgram;
  4474. CheckSource('TestLocalConst',
  4475. LinesToStr([
  4476. 'var cA = 1;',
  4477. 'var cB = 2;',
  4478. 'var csA = 3;',
  4479. 'var cB$1 = 4;',
  4480. 'this.DoIt = function () {',
  4481. ' function Sub() {',
  4482. ' cB$1 = cB$1 + 3;',
  4483. ' cA = (cA + 3) + 5;',
  4484. ' };',
  4485. ' cA = (cA + 2) + 6;',
  4486. '};'
  4487. ]),
  4488. LinesToStr([
  4489. ]));
  4490. end;
  4491. procedure TTestModule.TestVarExternal;
  4492. begin
  4493. StartProgram(false);
  4494. Add('var');
  4495. Add(' NaN: double; external name ''Global.NaN'';');
  4496. Add(' d: double;');
  4497. Add('begin');
  4498. Add(' d:=NaN;');
  4499. ConvertProgram;
  4500. CheckSource('TestVarExternal',
  4501. LinesToStr([
  4502. 'this.d = 0.0;'
  4503. ]),
  4504. LinesToStr([
  4505. '$mod.d = Global.NaN;'
  4506. ]));
  4507. end;
  4508. procedure TTestModule.TestVarExternalOtherUnit;
  4509. begin
  4510. AddModuleWithIntfImplSrc('unit2.pas',
  4511. LinesToStr([
  4512. 'var NaN: double; external name ''Global.NaN'';',
  4513. 'var iV: longint;'
  4514. ]),
  4515. '');
  4516. StartUnit(true);
  4517. Add('interface');
  4518. Add('uses unit2;');
  4519. Add('implementation');
  4520. Add('var');
  4521. Add(' d: double;');
  4522. Add(' i: longint; external name ''$i'';');
  4523. Add('begin');
  4524. Add(' d:=nan;');
  4525. Add(' d:=uNit2.nan;');
  4526. Add(' d:=test1.d;');
  4527. Add(' i:=iv;');
  4528. Add(' i:=uNit2.iv;');
  4529. Add(' i:=test1.i;');
  4530. ConvertUnit;
  4531. CheckSource('TestVarExternalOtherUnit',
  4532. LinesToStr([
  4533. 'var $impl = $mod.$impl;',
  4534. '']),
  4535. LinesToStr([ // this.$init
  4536. '$impl.d = Global.NaN;',
  4537. '$impl.d = Global.NaN;',
  4538. '$impl.d = $impl.d;',
  4539. '$i = pas.unit2.iV;',
  4540. '$i = pas.unit2.iV;',
  4541. '$i = $i;',
  4542. '']),
  4543. LinesToStr([ // implementation
  4544. '$impl.d = 0.0;',
  4545. '']) );
  4546. end;
  4547. procedure TTestModule.TestVarAbsoluteFail;
  4548. begin
  4549. StartProgram(false);
  4550. Add([
  4551. 'var',
  4552. ' a: longint;',
  4553. ' b: longword absolute a;',
  4554. 'begin']);
  4555. SetExpectedPasResolverError('Invalid variable modifier "absolute"',nInvalidVariableModifier);
  4556. ConvertProgram;
  4557. end;
  4558. procedure TTestModule.TestConstExternal;
  4559. begin
  4560. StartProgram(false);
  4561. Add([
  4562. 'const',
  4563. ' NaN: double; external name ''Global.NaN'';',
  4564. 'var d: double;',
  4565. 'begin',
  4566. ' d:=NaN;']);
  4567. ConvertProgram;
  4568. CheckSource('TestConstExternal',
  4569. LinesToStr([
  4570. 'this.d = 0.0;'
  4571. ]),
  4572. LinesToStr([
  4573. '$mod.d = Global.NaN;'
  4574. ]));
  4575. end;
  4576. procedure TTestModule.TestDouble;
  4577. begin
  4578. StartProgram(false);
  4579. Add([
  4580. 'type',
  4581. ' TDateTime = double;',
  4582. 'const',
  4583. ' a = TDateTime(2.7);',
  4584. ' b = a + TDateTime(1.7);',
  4585. ' c = 0.9 + 0.1;',
  4586. ' f0_1 = 0.1;',
  4587. ' f0_3 = 0.3;',
  4588. ' fn0_1 = -0.1;',
  4589. ' fn0_3 = -0.3;',
  4590. ' fn0_003 = -0.003;',
  4591. ' fn0_123456789 = -0.123456789;',
  4592. ' fn300_0 = -300.0;',
  4593. ' fn123456_0 = -123456.0;',
  4594. ' fn1234567_8 = -1234567.8;',
  4595. ' fn12345678_9 = -12345678.9;',
  4596. ' f1_0En12 = 1E-12;',
  4597. ' fn1_0En12 = -1E-12;',
  4598. ' maxdouble = 1.7e+308;',
  4599. ' mindouble = -1.7e+308;',
  4600. ' MinSafeIntDouble = -$10000000000000;',
  4601. ' MaxSafeIntDouble = $fffffffffffff;',
  4602. 'var',
  4603. ' d: double = b;',
  4604. 'begin',
  4605. ' d:=1.0;',
  4606. ' d:=1.0/3.0;',
  4607. ' d:=1/3;',
  4608. ' d:=5.0E-324;',
  4609. ' d:=1.7E308;',
  4610. ' d:=001.00E00;',
  4611. ' d:=002.00E001;',
  4612. ' d:=-003.00E-00;',
  4613. ' d:=-004.00E-001;',
  4614. ' d:=10**3;',
  4615. ' d:=10 mod 3;',
  4616. ' d:=10 div 3;',
  4617. ' d:=c;',
  4618. ' d:=f0_1;',
  4619. ' d:=f0_3;',
  4620. ' d:=fn0_1;',
  4621. ' d:=fn0_3;',
  4622. ' d:=fn0_003;',
  4623. ' d:=fn0_123456789;',
  4624. ' d:=fn300_0;',
  4625. ' d:=fn123456_0;',
  4626. ' d:=fn1234567_8;',
  4627. ' d:=fn12345678_9;',
  4628. ' d:=f1_0En12;',
  4629. ' d:=fn1_0En12;',
  4630. ' d:=maxdouble;',
  4631. ' d:=mindouble;',
  4632. ' d:=MinSafeIntDouble;',
  4633. ' d:=MaxSafeIntDouble;',
  4634. ' d:=default(double);',
  4635. '']);
  4636. ConvertProgram;
  4637. CheckSource('TestDouble',
  4638. LinesToStr([
  4639. 'this.a = 2.7;',
  4640. 'this.b = 2.7 + 1.7;',
  4641. 'this.c = 0.9 + 0.1;',
  4642. 'this.f0_1 = 0.1;',
  4643. 'this.f0_3 = 0.3;',
  4644. 'this.fn0_1 = -0.1;',
  4645. 'this.fn0_3 = -0.3;',
  4646. 'this.fn0_003 = -0.003;',
  4647. 'this.fn0_123456789 = -0.123456789;',
  4648. 'this.fn300_0 = -300.0;',
  4649. 'this.fn123456_0 = -123456.0;',
  4650. 'this.fn1234567_8 = -1234567.8;',
  4651. 'this.fn12345678_9 = -12345678.9;',
  4652. 'this.f1_0En12 = 1E-12;',
  4653. 'this.fn1_0En12 = -1E-12;',
  4654. 'this.maxdouble = 1.7e+308;',
  4655. 'this.mindouble = -1.7e+308;',
  4656. 'this.MinSafeIntDouble = -0x10000000000000;',
  4657. 'this.MaxSafeIntDouble = 0xfffffffffffff;',
  4658. 'this.d = 4.4;'
  4659. ]),
  4660. LinesToStr([
  4661. '$mod.d = 1.0;',
  4662. '$mod.d = 1.0 / 3.0;',
  4663. '$mod.d = 1 / 3;',
  4664. '$mod.d = 5.0E-324;',
  4665. '$mod.d = 1.7E308;',
  4666. '$mod.d = 1.00E0;',
  4667. '$mod.d = 2.00E1;',
  4668. '$mod.d = -3.00E-0;',
  4669. '$mod.d = -4.00E-1;',
  4670. '$mod.d = Math.pow(10, 3);',
  4671. '$mod.d = 10 % 3;',
  4672. '$mod.d = Math.floor(10 / 3);',
  4673. '$mod.d = 1;',
  4674. '$mod.d = 0.1;',
  4675. '$mod.d = 0.3;',
  4676. '$mod.d = -0.1;',
  4677. '$mod.d = -0.3;',
  4678. '$mod.d = -0.003;',
  4679. '$mod.d = -0.123456789;',
  4680. '$mod.d = -300;',
  4681. '$mod.d = -123456;',
  4682. '$mod.d = -1234567.8;',
  4683. '$mod.d = -1.23456789E7;',
  4684. '$mod.d = 1E-12;',
  4685. '$mod.d = -1E-12;',
  4686. '$mod.d = 1.7E308;',
  4687. '$mod.d = -1.7E308;',
  4688. '$mod.d = -4503599627370496;',
  4689. '$mod.d = 4503599627370495;',
  4690. '$mod.d = 0.0;',
  4691. '']));
  4692. end;
  4693. procedure TTestModule.TestInteger;
  4694. begin
  4695. StartProgram(false);
  4696. Add([
  4697. 'const',
  4698. ' MinInt = low(NativeInt);',
  4699. ' MaxInt = high(NativeInt);',
  4700. 'type',
  4701. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  4702. 'const',
  4703. ' a = low(TMyInt)+High(TMyInt);',
  4704. 'var',
  4705. ' i: TMyInt;',
  4706. 'begin',
  4707. ' i:=-MinInt;',
  4708. ' i:=default(TMyInt);']);
  4709. ConvertProgram;
  4710. CheckSource('TestIntegerRange',
  4711. LinesToStr([
  4712. 'this.MinInt = -4503599627370496;',
  4713. 'this.MaxInt = 4503599627370495;',
  4714. 'this.a = -4503599627370496 + 4503599627370495;',
  4715. 'this.i = -4503599627370496;',
  4716. '']),
  4717. LinesToStr([
  4718. '$mod.i = - -4503599627370496;',
  4719. '$mod.i = -4503599627370496;',
  4720. '']));
  4721. end;
  4722. procedure TTestModule.TestIntegerRange;
  4723. begin
  4724. StartProgram(false);
  4725. Add([
  4726. 'const',
  4727. ' MinInt = -1;',
  4728. ' MaxInt = +1;',
  4729. 'type',
  4730. ' {#TMyInt}TMyInt = MinInt..MaxInt;',
  4731. ' TInt2 = 1..3;',
  4732. 'const',
  4733. ' a = low(TMyInt)+High(TMyInt);',
  4734. ' b = low(TInt2)+High(TInt2);',
  4735. ' s1 = [1];',
  4736. ' s2 = [1,2];',
  4737. ' s3 = [1..3];',
  4738. ' s4 = [low(shortint)..high(shortint)];',
  4739. ' s5 = [succ(low(shortint))..pred(high(shortint))];',
  4740. ' s6 = 1 in s2;',
  4741. 'var',
  4742. ' i: TMyInt;',
  4743. ' i2: TInt2;',
  4744. 'begin',
  4745. ' i:=i2;',
  4746. ' i:=default(TMyInt);',
  4747. ' if i=i2 then ;']);
  4748. ConvertProgram;
  4749. CheckSource('TestIntegerRange',
  4750. LinesToStr([
  4751. 'this.MinInt = -1;',
  4752. 'this.MaxInt = +1;',
  4753. 'this.a = -1 + 1;',
  4754. 'this.b = 1 + 3;',
  4755. 'this.s1 = rtl.createSet(1);',
  4756. 'this.s2 = rtl.createSet(1, 2);',
  4757. 'this.s3 = rtl.createSet(null, 1, 3);',
  4758. 'this.s4 = rtl.createSet(null, -128, 127);',
  4759. 'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
  4760. 'this.s6 = 1 in $mod.s2;',
  4761. 'this.i = -1;',
  4762. 'this.i2 = 1;',
  4763. '']),
  4764. LinesToStr([
  4765. '$mod.i = $mod.i2;',
  4766. '$mod.i = -1;',
  4767. 'if ($mod.i === $mod.i2) ;',
  4768. '']));
  4769. end;
  4770. procedure TTestModule.TestIntegerTypecasts;
  4771. begin
  4772. StartProgram(false);
  4773. Add([
  4774. 'var',
  4775. ' i: nativeint;',
  4776. ' b: byte;',
  4777. ' sh: shortint;',
  4778. ' w: word;',
  4779. ' sm: smallint;',
  4780. ' lw: longword;',
  4781. ' li: longint;',
  4782. 'begin',
  4783. ' b:=byte(i);',
  4784. ' sh:=shortint(i);',
  4785. ' w:=word(i);',
  4786. ' sm:=smallint(i);',
  4787. ' lw:=longword(i);',
  4788. ' li:=longint(i);',
  4789. '']);
  4790. ConvertProgram;
  4791. CheckSource('TestIntegerTypecasts',
  4792. LinesToStr([
  4793. 'this.i = 0;',
  4794. 'this.b = 0;',
  4795. 'this.sh = 0;',
  4796. 'this.w = 0;',
  4797. 'this.sm = 0;',
  4798. 'this.lw = 0;',
  4799. 'this.li = 0;',
  4800. '']),
  4801. LinesToStr([
  4802. '$mod.b = $mod.i & 255;',
  4803. '$mod.sh = (($mod.i & 255) << 24) >> 24;',
  4804. '$mod.w = $mod.i & 65535;',
  4805. '$mod.sm = (($mod.i & 65535) << 16) >> 16;',
  4806. '$mod.lw = $mod.i >>> 0;',
  4807. '$mod.li = $mod.i & 0xFFFFFFFF;',
  4808. '']));
  4809. end;
  4810. procedure TTestModule.TestCurrency;
  4811. begin
  4812. StartProgram(false);
  4813. Add([
  4814. 'type',
  4815. ' TCoin = currency;',
  4816. 'const',
  4817. ' a = TCoin(2.7);',
  4818. ' b = a + TCoin(1.7);',
  4819. ' MinSafeIntCurrency: TCoin = -92233720368.5477;',
  4820. ' MaxSafeIntCurrency: TCoin = 92233720368.5477;',
  4821. 'var',
  4822. ' c: TCoin = b;',
  4823. ' i: nativeint;',
  4824. ' d: double;',
  4825. ' j: jsvalue;',
  4826. 'function DoIt(c: currency): currency; begin end;',
  4827. 'function GetIt(d: double): double; begin end;',
  4828. 'procedure Write(v: jsvalue); begin end;',
  4829. 'begin',
  4830. ' c:=1.0;',
  4831. ' c:=0.1;',
  4832. ' c:=1.0/3.0;',
  4833. ' c:=1/3;',
  4834. ' c:=a;',
  4835. ' d:=c;',
  4836. ' c:=d;',
  4837. ' c:=currency(d);',
  4838. ' d:=double(c);',
  4839. ' c:=c+a;',
  4840. ' c:=-c-a;',
  4841. ' c:=d+c;',
  4842. ' c:=c+d;',
  4843. ' c:=d-c;',
  4844. ' c:=c-d;',
  4845. ' c:=c*a;',
  4846. ' c:=a*c;',
  4847. ' c:=d*c;',
  4848. ' c:=c*d;',
  4849. ' c:=c/a;',
  4850. ' c:=a/c;',
  4851. ' c:=d/c;',
  4852. ' c:=c/d;',
  4853. ' c:=c**a;',
  4854. ' c:=a**c;',
  4855. ' c:=d**c;',
  4856. ' c:=c**d;',
  4857. ' if c=c then ;',
  4858. ' if c=a then ;',
  4859. ' if a=c then ;',
  4860. ' if d=c then ;',
  4861. ' if c=d then ;',
  4862. ' c:=DoIt(c);',
  4863. ' c:=DoIt(i);',
  4864. ' c:=DoIt(d);',
  4865. ' c:=GetIt(c);',
  4866. ' j:=c;',
  4867. ' Write(c);',
  4868. ' c:=default(currency);',
  4869. '']);
  4870. ConvertProgram;
  4871. CheckSource('TestCurrency',
  4872. LinesToStr([
  4873. 'this.a = 27000;',
  4874. 'this.b = $mod.a + 17000;',
  4875. 'this.MinSafeIntCurrency = -92233720368.5477;',
  4876. 'this.MaxSafeIntCurrency = 92233720368.5477;',
  4877. 'this.c = $mod.b;',
  4878. 'this.i = 0;',
  4879. 'this.d = 0.0;',
  4880. 'this.j = undefined;',
  4881. 'this.DoIt = function (c) {',
  4882. ' var Result = 0;',
  4883. ' return Result;',
  4884. '};',
  4885. 'this.GetIt = function (d) {',
  4886. ' var Result = 0.0;',
  4887. ' return Result;',
  4888. '};',
  4889. 'this.Write = function (v) {',
  4890. '};',
  4891. '']),
  4892. LinesToStr([
  4893. '$mod.c = 10000;',
  4894. '$mod.c = 1000;',
  4895. '$mod.c = Math.floor((1.0 / 3.0) * 10000);',
  4896. '$mod.c = Math.floor((1 / 3) * 10000);',
  4897. '$mod.c = $mod.a;',
  4898. '$mod.d = $mod.c / 10000;',
  4899. '$mod.c = Math.floor($mod.d * 10000);',
  4900. '$mod.c = $mod.d * 10000;',
  4901. '$mod.d = $mod.c / 10000;',
  4902. '$mod.c = $mod.c + $mod.a;',
  4903. '$mod.c = -$mod.c - $mod.a;',
  4904. '$mod.c = ($mod.d * 10000) + $mod.c;',
  4905. '$mod.c = $mod.c + ($mod.d * 10000);',
  4906. '$mod.c = ($mod.d * 10000) - $mod.c;',
  4907. '$mod.c = $mod.c - ($mod.d * 10000);',
  4908. '$mod.c = ($mod.c * $mod.a) / 10000;',
  4909. '$mod.c = ($mod.a * $mod.c) / 10000;',
  4910. '$mod.c = $mod.d * $mod.c;',
  4911. '$mod.c = $mod.c * $mod.d;',
  4912. '$mod.c = Math.floor(($mod.c / $mod.a) * 10000);',
  4913. '$mod.c = Math.floor(($mod.a / $mod.c) * 10000);',
  4914. '$mod.c = Math.floor($mod.d / $mod.c);',
  4915. '$mod.c = Math.floor($mod.c / $mod.d);',
  4916. '$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.a / 10000) * 10000);',
  4917. '$mod.c = Math.floor(Math.pow($mod.a / 10000, $mod.c / 10000) * 10000);',
  4918. '$mod.c = Math.floor(Math.pow($mod.d, $mod.c / 10000) * 10000);',
  4919. '$mod.c = Math.floor(Math.pow($mod.c / 10000, $mod.d) * 10000);',
  4920. 'if ($mod.c === $mod.c) ;',
  4921. 'if ($mod.c === $mod.a) ;',
  4922. 'if ($mod.a === $mod.c) ;',
  4923. 'if (($mod.d * 10000) === $mod.c) ;',
  4924. 'if ($mod.c === ($mod.d * 10000)) ;',
  4925. '$mod.c = $mod.DoIt($mod.c);',
  4926. '$mod.c = $mod.DoIt($mod.i * 10000);',
  4927. '$mod.c = $mod.DoIt($mod.d * 10000);',
  4928. '$mod.c = Math.floor($mod.GetIt($mod.c / 10000) * 10000);',
  4929. '$mod.j = $mod.c / 10000;',
  4930. '$mod.Write($mod.c / 10000);',
  4931. '$mod.c = 0;',
  4932. '']));
  4933. end;
  4934. procedure TTestModule.TestForBoolDo;
  4935. begin
  4936. StartProgram(false);
  4937. Add([
  4938. 'var b: boolean;',
  4939. 'begin',
  4940. ' for b:=false to true do ;',
  4941. ' for b:=b downto false do ;',
  4942. ' for b in boolean do ;',
  4943. '']);
  4944. ConvertProgram;
  4945. CheckSource('TestForBoolDo',
  4946. LinesToStr([ // statements
  4947. 'this.b = false;']),
  4948. LinesToStr([ // this.$main
  4949. 'for (var $l1 = 0; $l1 <= 1; $l1++) $mod.b = $l1 !== 0;',
  4950. 'for (var $l2 = +$mod.b; $l2 >= 0; $l2--) $mod.b = $l2 !== 0;',
  4951. 'for (var $l3 = 0; $l3 <= 1; $l3++) $mod.b = $l3 !== 0;',
  4952. '']));
  4953. end;
  4954. procedure TTestModule.TestForIntDo;
  4955. begin
  4956. StartProgram(false);
  4957. Add([
  4958. 'var i: longint;',
  4959. 'begin',
  4960. ' for i:=3 to 5 do ;',
  4961. ' for i:=i downto 2 do ;',
  4962. ' for i in byte do ;',
  4963. '']);
  4964. ConvertProgram;
  4965. CheckSource('TestForIntDo',
  4966. LinesToStr([ // statements
  4967. 'this.i = 0;']),
  4968. LinesToStr([ // this.$main
  4969. 'for ($mod.i = 3; $mod.i <= 5; $mod.i++) ;',
  4970. 'for (var $l1 = $mod.i; $l1 >= 2; $l1--) $mod.i = $l1;',
  4971. 'for (var $l2 = 0; $l2 <= 255; $l2++) $mod.i = $l2;',
  4972. '']));
  4973. end;
  4974. procedure TTestModule.TestForIntInDo;
  4975. begin
  4976. StartProgram(false);
  4977. Add([
  4978. 'type',
  4979. ' TSetOfInt = set of byte;',
  4980. ' TIntRg = 3..7;',
  4981. ' TSetOfIntRg = set of TIntRg;',
  4982. 'var',
  4983. ' i,i2: longint;',
  4984. ' a1: array of byte;',
  4985. ' a2: array[1..3] of byte;',
  4986. ' soi: TSetOfInt;',
  4987. ' soir: TSetOfIntRg;',
  4988. ' ir: TIntRg;',
  4989. 'begin',
  4990. ' for i in byte do ;',
  4991. ' for i in a1 do ;',
  4992. ' for i in a2 do ;',
  4993. ' for i in [11..13] do ;',
  4994. ' for i in TSetOfInt do ;',
  4995. ' for i in TIntRg do ;',
  4996. ' for i in soi do i2:=i;',
  4997. ' for i in TSetOfIntRg do ;',
  4998. ' for i in soir do ;',
  4999. ' for ir in TIntRg do ;',
  5000. ' for ir in TSetOfIntRg do ;',
  5001. ' for ir in soir do ;',
  5002. '']);
  5003. ConvertProgram;
  5004. CheckSource('TestForIntInDo',
  5005. LinesToStr([ // statements
  5006. 'this.i = 0;',
  5007. 'this.i2 = 0;',
  5008. 'this.a1 = [];',
  5009. 'this.a2 = rtl.arraySetLength(null, 0, 3);',
  5010. 'this.soi = {};',
  5011. 'this.soir = {};',
  5012. 'this.ir = 3;',
  5013. '']),
  5014. LinesToStr([ // this.$main
  5015. 'for (var $l1 = 0; $l1 <= 255; $l1++) $mod.i = $l1;',
  5016. 'for (var $in2 = $mod.a1, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) $mod.i = $in2[$l3];',
  5017. 'for (var $in5 = $mod.a2, $l6 = 0, $end7 = rtl.length($in5) - 1; $l6 <= $end7; $l6++) $mod.i = $in5[$l6];',
  5018. 'for (var $l8 = 11; $l8 <= 13; $l8++) $mod.i = $l8;',
  5019. 'for (var $l9 = 0; $l9 <= 255; $l9++) $mod.i = $l9;',
  5020. 'for (var $l10 = 3; $l10 <= 7; $l10++) $mod.i = $l10;',
  5021. 'for ($mod.i in $mod.soi) $mod.i2 = $mod.i;',
  5022. 'for (var $l11 = 3; $l11 <= 7; $l11++) $mod.i = $l11;',
  5023. 'for ($mod.i in $mod.soir) ;',
  5024. 'for (var $l12 = 3; $l12 <= 7; $l12++) $mod.ir = $l12;',
  5025. 'for (var $l13 = 3; $l13 <= 7; $l13++) $mod.ir = $l13;',
  5026. 'for ($mod.ir in $mod.soir) ;',
  5027. '']));
  5028. end;
  5029. procedure TTestModule.TestCharConst;
  5030. begin
  5031. StartProgram(false);
  5032. Add('const');
  5033. Add(' c: char = ''1'';');
  5034. Add('begin');
  5035. Add(' c:=#0;');
  5036. Add(' c:=#1;');
  5037. Add(' c:=#9;');
  5038. Add(' c:=#10;');
  5039. Add(' c:=#13;');
  5040. Add(' c:=#31;');
  5041. Add(' c:=#32;');
  5042. Add(' c:=#$A;');
  5043. Add(' c:=#$0A;');
  5044. Add(' c:=#$b;');
  5045. Add(' c:=#$0b;');
  5046. Add(' c:=^A;');
  5047. Add(' c:=''"'';');
  5048. Add(' c:=default(char);');
  5049. ConvertProgram;
  5050. CheckSource('TestCharConst',
  5051. LinesToStr([
  5052. 'this.c="1";'
  5053. ]),
  5054. LinesToStr([
  5055. '$mod.c="\x00";',
  5056. '$mod.c="\x01";',
  5057. '$mod.c="\t";',
  5058. '$mod.c="\n";',
  5059. '$mod.c="\r";',
  5060. '$mod.c="\x1F";',
  5061. '$mod.c=" ";',
  5062. '$mod.c="\n";',
  5063. '$mod.c="\n";',
  5064. '$mod.c="\x0B";',
  5065. '$mod.c="\x0B";',
  5066. '$mod.c="\x01";',
  5067. '$mod.c=''"'';',
  5068. '$mod.c="\x00";'
  5069. ]));
  5070. end;
  5071. procedure TTestModule.TestChar_Compare;
  5072. begin
  5073. StartProgram(false);
  5074. Add('var');
  5075. Add(' c: char;');
  5076. Add(' b: boolean;');
  5077. Add('begin');
  5078. Add(' b:=c=''1'';');
  5079. Add(' b:=''2''=c;');
  5080. Add(' b:=''3''=''4'';');
  5081. Add(' b:=c<>''5'';');
  5082. Add(' b:=''6''<>c;');
  5083. Add(' b:=c>''7'';');
  5084. Add(' b:=''8''>c;');
  5085. Add(' b:=c>=''9'';');
  5086. Add(' b:=''A''>=c;');
  5087. Add(' b:=c<''B'';');
  5088. Add(' b:=''C''<c;');
  5089. Add(' b:=c<=''D'';');
  5090. Add(' b:=''E''<=c;');
  5091. ConvertProgram;
  5092. CheckSource('TestChar_Compare',
  5093. LinesToStr([
  5094. 'this.c="";',
  5095. 'this.b = false;'
  5096. ]),
  5097. LinesToStr([
  5098. '$mod.b = $mod.c === "1";',
  5099. '$mod.b = "2" === $mod.c;',
  5100. '$mod.b = "3" === "4";',
  5101. '$mod.b = $mod.c !== "5";',
  5102. '$mod.b = "6" !== $mod.c;',
  5103. '$mod.b = $mod.c > "7";',
  5104. '$mod.b = "8" > $mod.c;',
  5105. '$mod.b = $mod.c >= "9";',
  5106. '$mod.b = "A" >= $mod.c;',
  5107. '$mod.b = $mod.c < "B";',
  5108. '$mod.b = "C" < $mod.c;',
  5109. '$mod.b = $mod.c <= "D";',
  5110. '$mod.b = "E" <= $mod.c;',
  5111. '']));
  5112. end;
  5113. procedure TTestModule.TestChar_Ord;
  5114. begin
  5115. StartProgram(false);
  5116. Add('var');
  5117. Add(' c: char;');
  5118. Add(' i: longint;');
  5119. Add(' s: string;');
  5120. Add('begin');
  5121. Add(' i:=ord(c);');
  5122. Add(' i:=ord(s[i]);');
  5123. ConvertProgram;
  5124. CheckSource('TestChar_Ord',
  5125. LinesToStr([
  5126. 'this.c = "";',
  5127. 'this.i = 0;',
  5128. 'this.s = "";'
  5129. ]),
  5130. LinesToStr([
  5131. '$mod.i = $mod.c.charCodeAt();',
  5132. '$mod.i = $mod.s.charCodeAt($mod.i-1);',
  5133. '']));
  5134. end;
  5135. procedure TTestModule.TestChar_Chr;
  5136. begin
  5137. StartProgram(false);
  5138. Add('var');
  5139. Add(' c: char;');
  5140. Add(' i: longint;');
  5141. Add('begin');
  5142. Add(' c:=chr(i);');
  5143. ConvertProgram;
  5144. CheckSource('TestChar_Chr',
  5145. LinesToStr([
  5146. 'this.c = "";',
  5147. 'this.i = 0;'
  5148. ]),
  5149. LinesToStr([
  5150. '$mod.c = String.fromCharCode($mod.i);',
  5151. '']));
  5152. end;
  5153. procedure TTestModule.TestStringConst;
  5154. begin
  5155. StartProgram(false);
  5156. Add([
  5157. 'var',
  5158. ' s: string = ''abc'';',
  5159. 'begin',
  5160. ' s:='''';',
  5161. ' s:=#13#10;',
  5162. ' s:=#9''foo'';',
  5163. ' s:=#$A9;',
  5164. ' s:=''foo''#13''bar'';',
  5165. ' s:=''"'';',
  5166. ' s:=''"''''"'';',
  5167. ' s:=default(string);',
  5168. '']);
  5169. ConvertProgram;
  5170. CheckSource('TestStringConst',
  5171. LinesToStr([
  5172. 'this.s="abc";'
  5173. ]),
  5174. LinesToStr([
  5175. '$mod.s="";',
  5176. '$mod.s="\r\n";',
  5177. '$mod.s="\tfoo";',
  5178. '$mod.s="©";',
  5179. '$mod.s="foo\rbar";',
  5180. '$mod.s=''"'';',
  5181. '$mod.s=''"\''"'';',
  5182. '$mod.s="";'
  5183. ]));
  5184. end;
  5185. procedure TTestModule.TestStringConstSurrogate;
  5186. begin
  5187. StartProgram(false);
  5188. Add([
  5189. 'var',
  5190. ' s: string;',
  5191. 'begin',
  5192. ' s:=''😊'';', // 1F60A
  5193. '']);
  5194. ConvertProgram;
  5195. CheckSource('TestStringConstSurrogate',
  5196. LinesToStr([
  5197. 'this.s="";'
  5198. ]),
  5199. LinesToStr([
  5200. '$mod.s="😊";'
  5201. ]));
  5202. end;
  5203. procedure TTestModule.TestString_Length;
  5204. begin
  5205. StartProgram(false);
  5206. Add('const c = ''foo'';');
  5207. Add('var');
  5208. Add(' s: string;');
  5209. Add(' i: longint;');
  5210. Add('begin');
  5211. Add(' i:=length(s);');
  5212. Add(' i:=length(s+s);');
  5213. Add(' i:=length(''abc'');');
  5214. Add(' i:=length(c);');
  5215. ConvertProgram;
  5216. CheckSource('TestString_Length',
  5217. LinesToStr([
  5218. 'this.c = "foo";',
  5219. 'this.s = "";',
  5220. 'this.i = 0;',
  5221. '']),
  5222. LinesToStr([
  5223. '$mod.i = $mod.s.length;',
  5224. '$mod.i = ($mod.s+$mod.s).length;',
  5225. '$mod.i = "abc".length;',
  5226. '$mod.i = $mod.c.length;',
  5227. '']));
  5228. end;
  5229. procedure TTestModule.TestString_Compare;
  5230. begin
  5231. StartProgram(false);
  5232. Add('var');
  5233. Add(' s, t: string;');
  5234. Add(' b: boolean;');
  5235. Add('begin');
  5236. Add(' b:=s=t;');
  5237. Add(' b:=s<>t;');
  5238. Add(' b:=s>t;');
  5239. Add(' b:=s>=t;');
  5240. Add(' b:=s<t;');
  5241. Add(' b:=s<=t;');
  5242. ConvertProgram;
  5243. CheckSource('TestString_Compare',
  5244. LinesToStr([ // statements
  5245. 'this.s = "";',
  5246. 'this.t = "";',
  5247. 'this.b =false;'
  5248. ]),
  5249. LinesToStr([ // this.$main
  5250. '$mod.b = $mod.s === $mod.t;',
  5251. '$mod.b = $mod.s !== $mod.t;',
  5252. '$mod.b = $mod.s > $mod.t;',
  5253. '$mod.b = $mod.s >= $mod.t;',
  5254. '$mod.b = $mod.s < $mod.t;',
  5255. '$mod.b = $mod.s <= $mod.t;',
  5256. '']));
  5257. end;
  5258. procedure TTestModule.TestString_SetLength;
  5259. begin
  5260. StartProgram(false);
  5261. Add([
  5262. 'procedure DoIt(var s: string);',
  5263. 'begin',
  5264. ' SetLength(s,2);',
  5265. 'end;',
  5266. 'var s: string;',
  5267. 'begin',
  5268. ' SetLength(s,3);',
  5269. '']);
  5270. ConvertProgram;
  5271. CheckSource('TestString_SetLength',
  5272. LinesToStr([ // statements
  5273. 'this.DoIt = function (s) {',
  5274. ' s.set(rtl.strSetLength(s.get(), 2));',
  5275. '};',
  5276. 'this.s = "";',
  5277. '']),
  5278. LinesToStr([ // this.$main
  5279. '$mod.s = rtl.strSetLength($mod.s, 3);'
  5280. ]));
  5281. end;
  5282. procedure TTestModule.TestString_CharAt;
  5283. begin
  5284. StartProgram(false);
  5285. Add([
  5286. 'var',
  5287. ' s: string;',
  5288. ' c: char;',
  5289. ' b: boolean;',
  5290. 'begin',
  5291. ' b:= s[1] = c;',
  5292. ' b:= c = s[1];',
  5293. ' b:= c <> s[1];',
  5294. ' b:= c > s[1];',
  5295. ' b:= c >= s[1];',
  5296. ' b:= c < s[2];',
  5297. ' b:= c <= s[1];',
  5298. ' s[1] := c;',
  5299. ' s[2+3] := c;']);
  5300. ConvertProgram;
  5301. CheckSource('TestString_CharAt',
  5302. LinesToStr([ // statements
  5303. 'this.s = "";',
  5304. 'this.c = "";',
  5305. 'this.b = false;'
  5306. ]),
  5307. LinesToStr([ // this.$main
  5308. '$mod.b = $mod.s.charAt(0) === $mod.c;',
  5309. '$mod.b = $mod.c === $mod.s.charAt(0);',
  5310. '$mod.b = $mod.c !== $mod.s.charAt(0);',
  5311. '$mod.b = $mod.c > $mod.s.charAt(0);',
  5312. '$mod.b = $mod.c >= $mod.s.charAt(0);',
  5313. '$mod.b = $mod.c < $mod.s.charAt(1);',
  5314. '$mod.b = $mod.c <= $mod.s.charAt(0);',
  5315. '$mod.s = rtl.setCharAt($mod.s, 0, $mod.c);',
  5316. '$mod.s = rtl.setCharAt($mod.s, (2 + 3) - 1, $mod.c);',
  5317. '']));
  5318. end;
  5319. procedure TTestModule.TestStr;
  5320. begin
  5321. StartProgram(false);
  5322. Add('var');
  5323. Add(' b: boolean;');
  5324. Add(' i: longint;');
  5325. Add(' d: double;');
  5326. Add(' s: string;');
  5327. Add('begin');
  5328. Add(' str(b,s);');
  5329. Add(' str(i,s);');
  5330. Add(' str(d,s);');
  5331. Add(' str(i:3,s);');
  5332. Add(' str(d:3:2,s);');
  5333. Add(' Str(12.456:12:1,s);');
  5334. Add(' Str(12.456:12,s);');
  5335. Add(' s:=str(b);');
  5336. Add(' s:=str(i);');
  5337. Add(' s:=str(d);');
  5338. Add(' s:=str(i,i);');
  5339. Add(' s:=str(i:3);');
  5340. Add(' s:=str(d:3:2);');
  5341. Add(' s:=str(i:4,i);');
  5342. Add(' s:=str(i,i:5);');
  5343. Add(' s:=str(i:4,i:5);');
  5344. Add(' s:=str(s,s);');
  5345. Add(' s:=str(s,''foo'');');
  5346. ConvertProgram;
  5347. CheckSource('TestStr',
  5348. LinesToStr([ // statements
  5349. 'this.b = false;',
  5350. 'this.i = 0;',
  5351. 'this.d = 0.0;',
  5352. 'this.s = "";',
  5353. '']),
  5354. LinesToStr([ // this.$main
  5355. '$mod.s = ""+$mod.b;',
  5356. '$mod.s = ""+$mod.i;',
  5357. '$mod.s = rtl.floatToStr($mod.d);',
  5358. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  5359. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  5360. '$mod.s = rtl.floatToStr(12.456,12,1);',
  5361. '$mod.s = rtl.floatToStr(12.456,12);',
  5362. '$mod.s = ""+$mod.b;',
  5363. '$mod.s = ""+$mod.i;',
  5364. '$mod.s = rtl.floatToStr($mod.d);',
  5365. '$mod.s = (""+$mod.i)+$mod.i;',
  5366. '$mod.s = rtl.spaceLeft(""+$mod.i,3);',
  5367. '$mod.s = rtl.floatToStr($mod.d,3,2);',
  5368. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + $mod.i;',
  5369. '$mod.s = ("" + $mod.i) + rtl.spaceLeft("" + $mod.i, 5);',
  5370. '$mod.s = rtl.spaceLeft("" + $mod.i, 4) + rtl.spaceLeft("" + $mod.i, 5);',
  5371. '$mod.s = $mod.s + $mod.s;',
  5372. '$mod.s = $mod.s + "foo";',
  5373. '']));
  5374. end;
  5375. procedure TTestModule.TestBaseType_AnsiStringFail;
  5376. begin
  5377. StartProgram(false);
  5378. Add('var s: AnsiString');
  5379. SetExpectedPasResolverError('identifier not found "AnsiString"',PasResolveEval.nIdentifierNotFound);
  5380. ConvertProgram;
  5381. end;
  5382. procedure TTestModule.TestBaseType_WideStringFail;
  5383. begin
  5384. StartProgram(false);
  5385. Add('var s: WideString');
  5386. SetExpectedPasResolverError('identifier not found "WideString"',PasResolveEval.nIdentifierNotFound);
  5387. ConvertProgram;
  5388. end;
  5389. procedure TTestModule.TestBaseType_ShortStringFail;
  5390. begin
  5391. StartProgram(false);
  5392. Add('var s: ShortString');
  5393. SetExpectedPasResolverError('identifier not found "ShortString"',PasResolveEval.nIdentifierNotFound);
  5394. ConvertProgram;
  5395. end;
  5396. procedure TTestModule.TestBaseType_RawByteStringFail;
  5397. begin
  5398. StartProgram(false);
  5399. Add('var s: RawByteString');
  5400. SetExpectedPasResolverError('identifier not found "RawByteString"',PasResolveEval.nIdentifierNotFound);
  5401. ConvertProgram;
  5402. end;
  5403. procedure TTestModule.TestTypeShortstring_Fail;
  5404. begin
  5405. StartProgram(false);
  5406. Add('type t = string[12];');
  5407. Add('var s: t;');
  5408. Add('begin');
  5409. SetExpectedPasResolverError('illegal qualifier "["',nIllegalQualifier);
  5410. ConvertProgram;
  5411. end;
  5412. procedure TTestModule.TestCharSet_Custom;
  5413. begin
  5414. StartProgram(false);
  5415. Add([
  5416. 'type',
  5417. ' TCharRg = ''a''..''z'';',
  5418. ' TSetOfCharRg = set of TCharRg;',
  5419. ' TCharRg2 = ''m''..''p'';',
  5420. 'const',
  5421. ' crg: TCharRg = ''b'';',
  5422. 'var',
  5423. ' c: char;',
  5424. ' crg2: TCharRg2;',
  5425. ' s: TSetOfCharRg;',
  5426. 'begin',
  5427. ' c:=crg;',
  5428. ' crg:=c;',
  5429. ' crg2:=crg;',
  5430. ' if c=crg then ;',
  5431. ' if crg=c then ;',
  5432. ' if crg=crg2 then ;',
  5433. ' if c in s then ;',
  5434. ' if crg2 in s then ;',
  5435. ' c:=default(TCharRg);',
  5436. '']);
  5437. ConvertProgram;
  5438. CheckSource('TestCharSet_Custom',
  5439. LinesToStr([ // statements
  5440. 'this.crg = "b";',
  5441. 'this.c = "";',
  5442. 'this.crg2 = "m";',
  5443. 'this.s = {};',
  5444. '']),
  5445. LinesToStr([ // this.$main
  5446. '$mod.c = $mod.crg;',
  5447. '$mod.crg = $mod.c;',
  5448. '$mod.crg2 = $mod.crg;',
  5449. 'if ($mod.c === $mod.crg) ;',
  5450. 'if ($mod.crg === $mod.c) ;',
  5451. 'if ($mod.crg === $mod.crg2) ;',
  5452. 'if ($mod.c.charCodeAt() in $mod.s) ;',
  5453. 'if ($mod.crg2.charCodeAt() in $mod.s) ;',
  5454. '$mod.c = "a";',
  5455. '']));
  5456. end;
  5457. procedure TTestModule.TestForCharDo;
  5458. begin
  5459. StartProgram(false);
  5460. Add([
  5461. 'var c: char;',
  5462. 'begin',
  5463. ' for c:=''a'' to ''c'' do ;',
  5464. ' for c:=c downto ''a'' do ;',
  5465. '']);
  5466. ConvertProgram;
  5467. CheckSource('TestForCharDo',
  5468. LinesToStr([ // statements
  5469. 'this.c = "";']),
  5470. LinesToStr([ // this.$main
  5471. 'for (var $l1 = 97; $l1 <= 99; $l1++) $mod.c = String.fromCharCode($l1);',
  5472. 'for (var $l2 = $mod.c.charCodeAt(); $l2 >= 97; $l2--) $mod.c = String.fromCharCode($l2);',
  5473. '']));
  5474. end;
  5475. procedure TTestModule.TestForCharInDo;
  5476. begin
  5477. StartProgram(false);
  5478. Add([
  5479. 'type',
  5480. ' TSetOfChar = set of char;',
  5481. ' TCharRg = ''a''..''z'';',
  5482. ' TSetOfCharRg = set of TCharRg;',
  5483. 'const Foo = ''foo'';',
  5484. 'var',
  5485. ' c,c2: char;',
  5486. ' s: string;',
  5487. ' a1: array of char;',
  5488. ' a2: array[1..3] of char;',
  5489. ' soc: TSetOfChar;',
  5490. ' socr: TSetOfCharRg;',
  5491. ' cr: TCharRg;',
  5492. 'begin',
  5493. ' for c in foo do ;',
  5494. ' for c in s do ;',
  5495. ' for c in char do ;',
  5496. ' for c in a1 do ;',
  5497. ' for c in a2 do ;',
  5498. ' for c in [''1''..''3''] do ;',
  5499. ' for c in TSetOfChar do ;',
  5500. ' for c in TCharRg do ;',
  5501. ' for c in soc do c2:=c;',
  5502. ' for c in TSetOfCharRg do ;',
  5503. ' for c in socr do ;',
  5504. ' for cr in TCharRg do ;',
  5505. ' for cr in TSetOfCharRg do ;',
  5506. ' for cr in socr do ;',
  5507. '']);
  5508. ConvertProgram;
  5509. CheckSource('TestForCharInDo',
  5510. LinesToStr([ // statements
  5511. 'this.Foo = "foo";',
  5512. 'this.c = "";',
  5513. 'this.c2 = "";',
  5514. 'this.s = "";',
  5515. 'this.a1 = [];',
  5516. 'this.a2 = rtl.arraySetLength(null, "", 3);',
  5517. 'this.soc = {};',
  5518. 'this.socr = {};',
  5519. 'this.cr = "a";',
  5520. '']),
  5521. LinesToStr([ // this.$main
  5522. 'for (var $in1 = $mod.Foo, $l2 = 0, $end3 = $in1.length - 1; $l2 <= $end3; $l2++) $mod.c = $in1.charAt($l2);',
  5523. 'for (var $in4 = $mod.s, $l5 = 0, $end6 = $in4.length - 1; $l5 <= $end6; $l5++) $mod.c = $in4.charAt($l5);',
  5524. 'for (var $l7 = 0; $l7 <= 65535; $l7++) $mod.c = String.fromCharCode($l7);',
  5525. 'for (var $in8 = $mod.a1, $l9 = 0, $end10 = rtl.length($in8) - 1; $l9 <= $end10; $l9++) $mod.c = $in8[$l9];',
  5526. 'for (var $in11 = $mod.a2, $l12 = 0, $end13 = rtl.length($in11) - 1; $l12 <= $end13; $l12++) $mod.c = $in11[$l12];',
  5527. 'for (var $l14 = 49; $l14 <= 51; $l14++) $mod.c = String.fromCharCode($l14);',
  5528. 'for (var $l15 = 0; $l15 <= 65535; $l15++) $mod.c = String.fromCharCode($l15);',
  5529. 'for (var $l16 = 97; $l16 <= 122; $l16++) $mod.c = String.fromCharCode($l16);',
  5530. 'for (var $l17 in $mod.soc) {',
  5531. ' $mod.c = String.fromCharCode($l17);',
  5532. ' $mod.c2 = $mod.c;',
  5533. '};',
  5534. 'for (var $l18 = 97; $l18 <= 122; $l18++) $mod.c = String.fromCharCode($l18);',
  5535. 'for (var $l19 in $mod.socr) $mod.c = String.fromCharCode($l19);',
  5536. 'for (var $l20 = 97; $l20 <= 122; $l20++) $mod.cr = String.fromCharCode($l20);',
  5537. 'for (var $l21 = 97; $l21 <= 122; $l21++) $mod.cr = String.fromCharCode($l21);',
  5538. 'for (var $l22 in $mod.socr) $mod.cr = String.fromCharCode($l22);',
  5539. '']));
  5540. end;
  5541. procedure TTestModule.TestProcTwoArgs;
  5542. begin
  5543. StartProgram(false);
  5544. Add('procedure Test(a,b: longint);');
  5545. Add('begin');
  5546. Add('end;');
  5547. Add('begin');
  5548. ConvertProgram;
  5549. CheckSource('TestProcTwoArgs',
  5550. LinesToStr([ // statements
  5551. 'this.Test = function (a,b) {',
  5552. '};'
  5553. ]),
  5554. LinesToStr([ // this.$main
  5555. ''
  5556. ]));
  5557. end;
  5558. procedure TTestModule.TestProc_DefaultValue;
  5559. begin
  5560. StartProgram(false);
  5561. Add('procedure p1(i: longint = 1);');
  5562. Add('begin');
  5563. Add('end;');
  5564. Add('procedure p2(i: longint = 1; c: char = ''a'');');
  5565. Add('begin');
  5566. Add('end;');
  5567. Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');');
  5568. Add('begin');
  5569. Add('end;');
  5570. Add('begin');
  5571. Add(' p1;');
  5572. Add(' p1();');
  5573. Add(' p1(11);');
  5574. Add(' p2;');
  5575. Add(' p2();');
  5576. Add(' p2(12);');
  5577. Add(' p2(13,''b'');');
  5578. Add(' p3();');
  5579. ConvertProgram;
  5580. CheckSource('TestProc_DefaultValue',
  5581. LinesToStr([ // statements
  5582. 'this.p1 = function (i) {',
  5583. '};',
  5584. 'this.p2 = function (i,c) {',
  5585. '};',
  5586. 'this.p3 = function (d,b,s) {',
  5587. '};'
  5588. ]),
  5589. LinesToStr([ // this.$main
  5590. ' $mod.p1(1);',
  5591. ' $mod.p1(1);',
  5592. ' $mod.p1(11);',
  5593. ' $mod.p2(1,"a");',
  5594. ' $mod.p2(1,"a");',
  5595. ' $mod.p2(12,"a");',
  5596. ' $mod.p2(13,"b");',
  5597. ' $mod.p3(1.0,false,"abc");'
  5598. ]));
  5599. end;
  5600. procedure TTestModule.TestFunctionInt;
  5601. begin
  5602. StartProgram(false);
  5603. Add('function MyTest(Bar: longint): longint;');
  5604. Add('begin');
  5605. Add(' Result:=2*bar');
  5606. Add('end;');
  5607. Add('begin');
  5608. ConvertProgram;
  5609. CheckSource('TestFunctionInt',
  5610. LinesToStr([ // statements
  5611. 'this.MyTest = function (Bar) {',
  5612. ' var Result = 0;',
  5613. ' Result = 2*Bar;',
  5614. ' return Result;',
  5615. '};'
  5616. ]),
  5617. LinesToStr([ // this.$main
  5618. ''
  5619. ]));
  5620. end;
  5621. procedure TTestModule.TestFunctionString;
  5622. begin
  5623. StartProgram(false);
  5624. Add('function Test(Bar: string): string;');
  5625. Add('begin');
  5626. Add(' Result:=bar+BAR');
  5627. Add('end;');
  5628. Add('begin');
  5629. ConvertProgram;
  5630. CheckSource('TestFunctionString',
  5631. LinesToStr([ // statements
  5632. 'this.Test = function (Bar) {',
  5633. ' var Result = "";',
  5634. ' Result = Bar+Bar;',
  5635. ' return Result;',
  5636. '};'
  5637. ]),
  5638. LinesToStr([ // this.$main
  5639. ''
  5640. ]));
  5641. end;
  5642. procedure TTestModule.TestForLoop;
  5643. begin
  5644. StartProgram(false);
  5645. Add('var');
  5646. Add(' vI, vJ, vN: longint;');
  5647. Add('begin');
  5648. Add(' VJ:=0;');
  5649. Add(' VN:=3;');
  5650. Add(' for VI:=1 to VN do');
  5651. Add(' begin');
  5652. Add(' VJ:=VJ+VI;');
  5653. Add(' end;');
  5654. ConvertProgram;
  5655. CheckSource('TestForLoop',
  5656. LinesToStr([ // statements
  5657. 'this.vI = 0;',
  5658. 'this.vJ = 0;',
  5659. 'this.vN = 0;'
  5660. ]),
  5661. LinesToStr([ // this.$main
  5662. ' $mod.vJ = 0;',
  5663. ' $mod.vN = 3;',
  5664. ' for (var $l1 = 1, $end2 = $mod.vN; $l1 <= $end2; $l1++) {',
  5665. ' $mod.vI = $l1;',
  5666. ' $mod.vJ = $mod.vJ + $mod.vI;',
  5667. ' };',
  5668. '']));
  5669. end;
  5670. procedure TTestModule.TestForLoopInsideFunction;
  5671. begin
  5672. StartProgram(false);
  5673. Add('function SumNumbers(Count: longint): longint;');
  5674. Add('var');
  5675. Add(' vI, vJ: longint;');
  5676. Add('begin');
  5677. Add(' vj:=0;');
  5678. Add(' for vi:=1 to count do');
  5679. Add(' begin');
  5680. Add(' vj:=vj+vi;');
  5681. Add(' end;');
  5682. Add('end;');
  5683. Add('begin');
  5684. Add(' sumnumbers(3);');
  5685. ConvertProgram;
  5686. CheckSource('TestForLoopInsideFunction',
  5687. LinesToStr([ // statements
  5688. 'this.SumNumbers = function (Count) {',
  5689. ' var Result = 0;',
  5690. ' var vI = 0;',
  5691. ' var vJ = 0;',
  5692. ' vJ = 0;',
  5693. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  5694. ' vI = $l1;',
  5695. ' vJ = vJ + vI;',
  5696. ' };',
  5697. ' return Result;',
  5698. '};'
  5699. ]),
  5700. LinesToStr([ // $mod.$main
  5701. ' $mod.SumNumbers(3);'
  5702. ]));
  5703. end;
  5704. procedure TTestModule.TestForLoop_ReadVarAfter;
  5705. begin
  5706. StartProgram(false);
  5707. Add('var');
  5708. Add(' vI: longint;');
  5709. Add('begin');
  5710. Add(' for vi:=1 to 2 do ;');
  5711. Add(' if vi=3 then ;');
  5712. ConvertProgram;
  5713. CheckSource('TestForLoop',
  5714. LinesToStr([ // statements
  5715. 'this.vI = 0;'
  5716. ]),
  5717. LinesToStr([ // this.$main
  5718. ' for ($mod.vI = 1; $mod.vI <= 2; $mod.vI++) ;',
  5719. ' if ($mod.vI===3) ;'
  5720. ]));
  5721. end;
  5722. procedure TTestModule.TestForLoop_Nested;
  5723. begin
  5724. StartProgram(false);
  5725. Add('function SumNumbers(Count: longint): longint;');
  5726. Add('var');
  5727. Add(' vI, vJ, vK: longint;');
  5728. Add('begin');
  5729. Add(' VK:=0;');
  5730. Add(' for VI:=1 to count do');
  5731. Add(' begin');
  5732. Add(' for vj:=1 to vi do');
  5733. Add(' begin');
  5734. Add(' vk:=VK+VI;');
  5735. Add(' end;');
  5736. Add(' end;');
  5737. Add('end;');
  5738. Add('begin');
  5739. Add(' sumnumbers(3);');
  5740. ConvertProgram;
  5741. CheckSource('TestForLoopInFunction',
  5742. LinesToStr([ // statements
  5743. 'this.SumNumbers = function (Count) {',
  5744. ' var Result = 0;',
  5745. ' var vI = 0;',
  5746. ' var vJ = 0;',
  5747. ' var vK = 0;',
  5748. ' vK = 0;',
  5749. ' for (var $l1 = 1, $end2 = Count; $l1 <= $end2; $l1++) {',
  5750. ' vI = $l1;',
  5751. ' for (var $l3 = 1, $end4 = vI; $l3 <= $end4; $l3++) {',
  5752. ' vJ = $l3;',
  5753. ' vK = vK + vI;',
  5754. ' };',
  5755. ' };',
  5756. ' return Result;',
  5757. '};'
  5758. ]),
  5759. LinesToStr([ // $mod.$main
  5760. ' $mod.SumNumbers(3);'
  5761. ]));
  5762. end;
  5763. procedure TTestModule.TestRepeatUntil;
  5764. begin
  5765. StartProgram(false);
  5766. Add('var');
  5767. Add(' vI, vJ, vN: longint;');
  5768. Add('begin');
  5769. Add(' vn:=3;');
  5770. Add(' vj:=0;');
  5771. Add(' VI:=0;');
  5772. Add(' repeat');
  5773. Add(' VI:=vi+1;');
  5774. Add(' vj:=VJ+vI;');
  5775. Add(' until vi>=vn');
  5776. ConvertProgram;
  5777. CheckSource('TestRepeatUntil',
  5778. LinesToStr([ // statements
  5779. 'this.vI = 0;',
  5780. 'this.vJ = 0;',
  5781. 'this.vN = 0;'
  5782. ]),
  5783. LinesToStr([ // $mod.$main
  5784. ' $mod.vN = 3;',
  5785. ' $mod.vJ = 0;',
  5786. ' $mod.vI = 0;',
  5787. ' do{',
  5788. ' $mod.vI = $mod.vI + 1;',
  5789. ' $mod.vJ = $mod.vJ + $mod.vI;',
  5790. ' }while(!($mod.vI>=$mod.vN));'
  5791. ]));
  5792. end;
  5793. procedure TTestModule.TestAsmBlock;
  5794. begin
  5795. StartProgram(false);
  5796. Add([
  5797. 'var',
  5798. ' vI: longint;',
  5799. 'begin',
  5800. ' vi:=1;',
  5801. ' asm',
  5802. ' if (vI===1) {',
  5803. ' vI=2;',
  5804. //' console.log(''end;'');', ToDo
  5805. ' }',
  5806. ' if (vI===2){ vI=3; }',
  5807. ' end;',
  5808. ' VI:=4;']);
  5809. ConvertProgram;
  5810. CheckSource('TestAsmBlock',
  5811. LinesToStr([ // statements
  5812. 'this.vI = 0;'
  5813. ]),
  5814. LinesToStr([ // $mod.$main
  5815. '$mod.vI = 1;',
  5816. 'if (vI===1) {',
  5817. ' vI=2;',
  5818. '}',
  5819. 'if (vI===2){ vI=3; }',
  5820. ';',
  5821. '$mod.vI = 4;'
  5822. ]));
  5823. end;
  5824. procedure TTestModule.TestAsmPas_Impl;
  5825. begin
  5826. StartUnit(false);
  5827. Add('interface');
  5828. Add('const cIntf: longint = 1;');
  5829. Add('var vIntf: longint;');
  5830. Add('implementation');
  5831. Add('const cImpl: longint = 2;');
  5832. Add('var vImpl: longint;');
  5833. Add('procedure DoIt;');
  5834. Add('const cLoc: longint = 3;');
  5835. Add('var vLoc: longint;');
  5836. Add('begin;');
  5837. Add(' asm');
  5838. //Add(' pas(vIntf)=pas(cIntf);');
  5839. //Add(' pas(vImpl)=pas(cImpl);');
  5840. //Add(' pas(vLoc)=pas(cLoc);');
  5841. Add(' end;');
  5842. Add('end;');
  5843. ConvertUnit;
  5844. CheckSource('TestAsmPas_Impl',
  5845. LinesToStr([
  5846. 'var $impl = $mod.$impl;',
  5847. 'this.cIntf = 1;',
  5848. 'this.vIntf = 0;',
  5849. '']),
  5850. '', // this.$init
  5851. LinesToStr([ // implementation
  5852. '$impl.cImpl = 2;',
  5853. '$impl.vImpl = 0;',
  5854. 'var cLoc = 3;',
  5855. '$impl.DoIt = function () {',
  5856. ' var vLoc = 0;',
  5857. '};',
  5858. '']) );
  5859. end;
  5860. procedure TTestModule.TestTryFinally;
  5861. begin
  5862. StartProgram(false);
  5863. Add('var i: longint;');
  5864. Add('begin');
  5865. Add(' try');
  5866. Add(' i:=0; i:=2 div i;');
  5867. Add(' finally');
  5868. Add(' i:=3');
  5869. Add(' end;');
  5870. ConvertProgram;
  5871. CheckSource('TestTryFinally',
  5872. LinesToStr([ // statements
  5873. 'this.i = 0;'
  5874. ]),
  5875. LinesToStr([ // $mod.$main
  5876. 'try {',
  5877. ' $mod.i = 0;',
  5878. ' $mod.i = Math.floor(2 / $mod.i);',
  5879. '} finally {',
  5880. ' $mod.i = 3;',
  5881. '};'
  5882. ]));
  5883. end;
  5884. procedure TTestModule.TestTryExcept;
  5885. begin
  5886. StartProgram(false);
  5887. Add('type');
  5888. Add(' TObject = class end;');
  5889. Add(' Exception = class Msg: string; end;');
  5890. Add(' EInvalidCast = class(Exception) end;');
  5891. Add('var vI: longint;');
  5892. Add('begin');
  5893. Add(' try');
  5894. Add(' vi:=1;');
  5895. Add(' except');
  5896. Add(' vi:=2');
  5897. Add(' end;');
  5898. Add(' try');
  5899. Add(' vi:=3;');
  5900. Add(' except');
  5901. Add(' raise;');
  5902. Add(' end;');
  5903. Add(' try');
  5904. Add(' VI:=4;');
  5905. Add(' except');
  5906. Add(' on einvalidcast do');
  5907. Add(' raise;');
  5908. Add(' on E: exception do');
  5909. Add(' if e.msg='''' then');
  5910. Add(' raise e;');
  5911. Add(' else');
  5912. Add(' vi:=5');
  5913. Add(' end;');
  5914. Add(' try');
  5915. Add(' VI:=6;');
  5916. Add(' except');
  5917. Add(' on einvalidcast do ;');
  5918. Add(' end;');
  5919. ConvertProgram;
  5920. CheckSource('TestTryExcept',
  5921. LinesToStr([ // statements
  5922. 'rtl.createClass($mod, "TObject", null, function () {',
  5923. ' this.$init = function () {',
  5924. ' };',
  5925. ' this.$final = function () {',
  5926. ' };',
  5927. '});',
  5928. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  5929. ' this.$init = function () {',
  5930. ' $mod.TObject.$init.call(this);',
  5931. ' this.Msg = "";',
  5932. ' };',
  5933. '});',
  5934. 'rtl.createClass($mod, "EInvalidCast", $mod.Exception, function () {',
  5935. '});',
  5936. 'this.vI = 0;'
  5937. ]),
  5938. LinesToStr([ // $mod.$main
  5939. 'try {',
  5940. ' $mod.vI = 1;',
  5941. '} catch ($e) {',
  5942. ' $mod.vI = 2;',
  5943. '};',
  5944. 'try {',
  5945. ' $mod.vI = 3;',
  5946. '} catch ($e) {',
  5947. ' throw $e;',
  5948. '};',
  5949. 'try {',
  5950. ' $mod.vI = 4;',
  5951. '} catch ($e) {',
  5952. ' if ($mod.EInvalidCast.isPrototypeOf($e)){',
  5953. ' throw $e',
  5954. ' } else if ($mod.Exception.isPrototypeOf($e)) {',
  5955. ' var E = $e;',
  5956. ' if (E.Msg === "") throw E;',
  5957. ' } else {',
  5958. ' $mod.vI = 5;',
  5959. ' }',
  5960. '};',
  5961. 'try {',
  5962. ' $mod.vI = 6;',
  5963. '} catch ($e) {',
  5964. ' if ($mod.EInvalidCast.isPrototypeOf($e)){' ,
  5965. ' } else throw $e',
  5966. '};',
  5967. '']));
  5968. end;
  5969. procedure TTestModule.TestCaseOf;
  5970. begin
  5971. StartProgram(false);
  5972. Add('var vI: longint;');
  5973. Add('begin');
  5974. Add(' case vi of');
  5975. Add(' 1: ;');
  5976. Add(' 2: vi:=3;');
  5977. Add(' else');
  5978. Add(' VI:=4');
  5979. Add(' end;');
  5980. ConvertProgram;
  5981. CheckSource('TestCaseOf',
  5982. LinesToStr([ // statements
  5983. 'this.vI = 0;'
  5984. ]),
  5985. LinesToStr([ // $mod.$main
  5986. 'var $tmp1 = $mod.vI;',
  5987. 'if ($tmp1 === 1) {} else if ($tmp1 === 2){ $mod.vI = 3 }else {',
  5988. ' $mod.vI = 4;',
  5989. '};'
  5990. ]));
  5991. end;
  5992. procedure TTestModule.TestCaseOf_UseSwitch;
  5993. begin
  5994. StartProgram(false);
  5995. Converter.UseSwitchStatement:=true;
  5996. Add('var Vi: longint;');
  5997. Add('begin');
  5998. Add(' case vi of');
  5999. Add(' 1: ;');
  6000. Add(' 2: VI:=3;');
  6001. Add(' else');
  6002. Add(' vi:=4');
  6003. Add(' end;');
  6004. ConvertProgram;
  6005. CheckSource('TestCaseOf_UseSwitch',
  6006. LinesToStr([ // statements
  6007. 'this.Vi = 0;'
  6008. ]),
  6009. LinesToStr([ // $mod.$main
  6010. 'switch ($mod.Vi) {',
  6011. 'case 1:',
  6012. ' break;',
  6013. 'case 2:',
  6014. ' $mod.Vi = 3;',
  6015. ' break;',
  6016. 'default:',
  6017. ' $mod.Vi = 4;',
  6018. '};'
  6019. ]));
  6020. end;
  6021. procedure TTestModule.TestCaseOfNoElse;
  6022. begin
  6023. StartProgram(false);
  6024. Add('var Vi: longint;');
  6025. Add('begin');
  6026. Add(' case vi of');
  6027. Add(' 1: begin vi:=2; VI:=3; end;');
  6028. Add(' end;');
  6029. ConvertProgram;
  6030. CheckSource('TestCaseOfNoElse',
  6031. LinesToStr([ // statements
  6032. 'this.Vi = 0;'
  6033. ]),
  6034. LinesToStr([ // $mod.$main
  6035. 'var $tmp1 = $mod.Vi;',
  6036. 'if ($tmp1 === 1) {',
  6037. ' $mod.Vi = 2;',
  6038. ' $mod.Vi = 3;',
  6039. '};'
  6040. ]));
  6041. end;
  6042. procedure TTestModule.TestCaseOfNoElse_UseSwitch;
  6043. begin
  6044. StartProgram(false);
  6045. Converter.UseSwitchStatement:=true;
  6046. Add('var vI: longint;');
  6047. Add('begin');
  6048. Add(' case vi of');
  6049. Add(' 1: begin VI:=2; vi:=3; end;');
  6050. Add(' end;');
  6051. ConvertProgram;
  6052. CheckSource('TestCaseOfNoElse_UseSwitch',
  6053. LinesToStr([ // statements
  6054. 'this.vI = 0;'
  6055. ]),
  6056. LinesToStr([ // $mod.$main
  6057. 'switch ($mod.vI) {',
  6058. 'case 1:',
  6059. ' $mod.vI = 2;',
  6060. ' $mod.vI = 3;',
  6061. ' break;',
  6062. '};'
  6063. ]));
  6064. end;
  6065. procedure TTestModule.TestCaseOfRange;
  6066. begin
  6067. StartProgram(false);
  6068. Add('var vI: longint;');
  6069. Add('begin');
  6070. Add(' case vi of');
  6071. Add(' 1..3: vi:=14;');
  6072. Add(' 4,5: vi:=16;');
  6073. Add(' 6..7,9..10: ;');
  6074. Add(' else ;');
  6075. Add(' end;');
  6076. ConvertProgram;
  6077. CheckSource('TestCaseOfRange',
  6078. LinesToStr([ // statements
  6079. 'this.vI = 0;'
  6080. ]),
  6081. LinesToStr([ // $mod.$main
  6082. 'var $tmp1 = $mod.vI;',
  6083. 'if (($tmp1 >= 1) && ($tmp1 <= 3)){',
  6084. ' $mod.vI = 14',
  6085. '} else if (($tmp1 === 4) || ($tmp1 === 5)){',
  6086. ' $mod.vI = 16',
  6087. '} else if ((($tmp1 >= 6) && ($tmp1 <= 7)) || (($tmp1 >= 9) && ($tmp1 <= 10))) ;'
  6088. ]));
  6089. end;
  6090. procedure TTestModule.TestCaseOfString;
  6091. begin
  6092. StartProgram(false);
  6093. Add([
  6094. 'var s,h: string;',
  6095. 'begin',
  6096. ' case s of',
  6097. ' ''foo'': s:=h;',
  6098. ' ''a''..''z'': h:=s;',
  6099. ' end;',
  6100. '']);
  6101. ConvertProgram;
  6102. CheckSource('TestCaseOfString',
  6103. LinesToStr([ // statements
  6104. 'this.s = "";',
  6105. 'this.h = "";',
  6106. '']),
  6107. LinesToStr([ // $mod.$main
  6108. 'var $tmp1 = $mod.s;',
  6109. 'if ($tmp1 === "foo") {',
  6110. ' $mod.s = $mod.h}',
  6111. ' else if (($tmp1.length === 1) && (($tmp1 >= "a") && ($tmp1 <= "z"))) $mod.h = $mod.s;',
  6112. '']));
  6113. end;
  6114. procedure TTestModule.TestArray_Dynamic;
  6115. begin
  6116. StartProgram(false);
  6117. Add('type');
  6118. Add(' TArrayInt = array of longint;');
  6119. Add('var');
  6120. Add(' Arr: TArrayInt;');
  6121. Add(' i: longint;');
  6122. Add(' b: boolean;');
  6123. Add('begin');
  6124. Add(' SetLength(arr,3);');
  6125. Add(' arr[0]:=4;');
  6126. Add(' arr[1]:=length(arr)+arr[0];');
  6127. Add(' arr[i]:=5;');
  6128. Add(' arr[arr[i]]:=arr[6];');
  6129. Add(' i:=low(arr);');
  6130. Add(' i:=high(arr);');
  6131. Add(' b:=Assigned(arr);');
  6132. Add(' Arr:=default(TArrayInt);');
  6133. ConvertProgram;
  6134. CheckSource('TestArray_Dynamic',
  6135. LinesToStr([ // statements
  6136. 'this.Arr = [];',
  6137. 'this.i = 0;',
  6138. 'this.b = false;'
  6139. ]),
  6140. LinesToStr([ // $mod.$main
  6141. '$mod.Arr = rtl.arraySetLength($mod.Arr,0,3);',
  6142. '$mod.Arr[0] = 4;',
  6143. '$mod.Arr[1] = rtl.length($mod.Arr) + $mod.Arr[0];',
  6144. '$mod.Arr[$mod.i] = 5;',
  6145. '$mod.Arr[$mod.Arr[$mod.i]] = $mod.Arr[6];',
  6146. '$mod.i = 0;',
  6147. '$mod.i = rtl.length($mod.Arr) - 1;',
  6148. '$mod.b = rtl.length($mod.Arr) > 0;',
  6149. '$mod.Arr = [];',
  6150. '']));
  6151. end;
  6152. procedure TTestModule.TestArray_Dynamic_Nil;
  6153. begin
  6154. StartProgram(false);
  6155. Add('type');
  6156. Add(' TArrayInt = array of longint;');
  6157. Add('var');
  6158. Add(' Arr: TArrayInt;');
  6159. Add('procedure DoIt(const i: TArrayInt; j: TArrayInt); begin end;');
  6160. Add('begin');
  6161. Add(' arr:=nil;');
  6162. Add(' if arr=nil then;');
  6163. Add(' if nil=arr then;');
  6164. Add(' if arr<>nil then;');
  6165. Add(' if nil<>arr then;');
  6166. Add(' DoIt(nil,nil);');
  6167. ConvertProgram;
  6168. CheckSource('TestArray_Dynamic',
  6169. LinesToStr([ // statements
  6170. 'this.Arr = [];',
  6171. 'this.DoIt = function(i,j){',
  6172. '};'
  6173. ]),
  6174. LinesToStr([ // $mod.$main
  6175. '$mod.Arr = [];',
  6176. 'if (rtl.length($mod.Arr) === 0) ;',
  6177. 'if (rtl.length($mod.Arr) === 0) ;',
  6178. 'if (rtl.length($mod.Arr) > 0) ;',
  6179. 'if (rtl.length($mod.Arr) > 0) ;',
  6180. '$mod.DoIt([],[]);',
  6181. '']));
  6182. end;
  6183. procedure TTestModule.TestArray_DynMultiDimensional;
  6184. begin
  6185. StartProgram(false);
  6186. Add('type');
  6187. Add(' TArrayInt = array of longint;');
  6188. Add(' TArrayArrayInt = array of TArrayInt;');
  6189. Add('var');
  6190. Add(' Arr: TArrayInt;');
  6191. Add(' Arr2: TArrayArrayInt;');
  6192. Add(' i: longint;');
  6193. Add('begin');
  6194. Add(' arr2:=nil;');
  6195. Add(' if arr2=nil then;');
  6196. Add(' if nil=arr2 then;');
  6197. Add(' i:=low(arr2);');
  6198. Add(' i:=low(arr2[1]);');
  6199. Add(' i:=high(arr2);');
  6200. Add(' i:=high(arr2[2]);');
  6201. Add(' arr2[3]:=arr;');
  6202. Add(' arr2[4][5]:=i;');
  6203. Add(' i:=arr2[6][7];');
  6204. Add(' arr2[8,9]:=i;');
  6205. Add(' i:=arr2[10,11];');
  6206. Add(' SetLength(arr2,14);');
  6207. Add(' SetLength(arr2[15],16);');
  6208. ConvertProgram;
  6209. CheckSource('TestArray_Dynamic',
  6210. LinesToStr([ // statements
  6211. 'this.Arr = [];',
  6212. 'this.Arr2 = [];',
  6213. 'this.i = 0;'
  6214. ]),
  6215. LinesToStr([ // $mod.$main
  6216. '$mod.Arr2 = [];',
  6217. 'if (rtl.length($mod.Arr2) === 0) ;',
  6218. 'if (rtl.length($mod.Arr2) === 0) ;',
  6219. '$mod.i = 0;',
  6220. '$mod.i = 0;',
  6221. '$mod.i = rtl.length($mod.Arr2) - 1;',
  6222. '$mod.i = rtl.length($mod.Arr2[2]) - 1;',
  6223. '$mod.Arr2[3] = $mod.Arr;',
  6224. '$mod.Arr2[4][5] = $mod.i;',
  6225. '$mod.i = $mod.Arr2[6][7];',
  6226. '$mod.Arr2[8][9] = $mod.i;',
  6227. '$mod.i = $mod.Arr2[10][11];',
  6228. '$mod.Arr2 = rtl.arraySetLength($mod.Arr2, [], 14);',
  6229. '$mod.Arr2[15] = rtl.arraySetLength($mod.Arr2[15], 0, 16);',
  6230. '']));
  6231. end;
  6232. procedure TTestModule.TestArray_StaticInt;
  6233. begin
  6234. StartProgram(false);
  6235. Add('type');
  6236. Add(' TArrayInt = array[2..4] of longint;');
  6237. Add('var');
  6238. Add(' Arr: TArrayInt;');
  6239. Add(' Arr2: TArrayInt = (5,6,7);');
  6240. Add(' i: longint;');
  6241. Add(' b: boolean;');
  6242. Add('begin');
  6243. Add(' arr[2]:=4;');
  6244. Add(' arr[3]:=arr[2]+arr[3];');
  6245. Add(' arr[i]:=5;');
  6246. Add(' arr[arr[i]]:=arr[high(arr)];');
  6247. Add(' i:=low(arr);');
  6248. Add(' i:=high(arr);');
  6249. Add(' b:=arr[2]=arr[3];');
  6250. Add(' arr:=default(TArrayInt);');
  6251. ConvertProgram;
  6252. CheckSource('TestArray_StaticInt',
  6253. LinesToStr([ // statements
  6254. 'this.Arr = rtl.arraySetLength(null,0,3);',
  6255. 'this.Arr2 = [5, 6, 7];',
  6256. 'this.i = 0;',
  6257. 'this.b = false;'
  6258. ]),
  6259. LinesToStr([ // $mod.$main
  6260. '$mod.Arr[0] = 4;',
  6261. '$mod.Arr[1] = $mod.Arr[0] + $mod.Arr[1];',
  6262. '$mod.Arr[$mod.i-2] = 5;',
  6263. '$mod.Arr[$mod.Arr[$mod.i-2]-2] = $mod.Arr[2];',
  6264. '$mod.i = 2;',
  6265. '$mod.i = 4;',
  6266. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  6267. '$mod.Arr = rtl.arraySetLength(null,0,3).slice(0);',
  6268. '']));
  6269. end;
  6270. procedure TTestModule.TestArray_StaticBool;
  6271. begin
  6272. StartProgram(false);
  6273. Add('type');
  6274. Add(' TBools = array[boolean] of boolean;');
  6275. Add(' TBool2 = array[true..true] of boolean;');
  6276. Add('var');
  6277. Add(' Arr: TBools;');
  6278. Add(' Arr2: TBool2;');
  6279. Add(' Arr3: TBools = (true,false);');
  6280. Add(' b: boolean;');
  6281. Add('begin');
  6282. Add(' b:=low(arr);');
  6283. Add(' b:=high(arr);');
  6284. Add(' arr[true]:=false;');
  6285. Add(' arr[false]:=arr[b] or arr[true];');
  6286. Add(' arr[b]:=true;');
  6287. Add(' arr[arr[b]]:=arr[high(arr)];');
  6288. Add(' b:=arr[false]=arr[true];');
  6289. Add(' b:=low(arr2);');
  6290. Add(' b:=high(arr2);');
  6291. Add(' arr2[true]:=true;');
  6292. Add(' arr2[true]:=arr2[true] and arr2[b];');
  6293. Add(' arr2[b]:=false;');
  6294. ConvertProgram;
  6295. CheckSource('TestArray_StaticBool',
  6296. LinesToStr([ // statements
  6297. 'this.Arr = rtl.arraySetLength(null,false,2);',
  6298. 'this.Arr2 = rtl.arraySetLength(null,false,1);',
  6299. 'this.Arr3 = [true, false];',
  6300. 'this.b = false;'
  6301. ]),
  6302. LinesToStr([ // $mod.$main
  6303. '$mod.b = false;',
  6304. '$mod.b = true;',
  6305. '$mod.Arr[1] = false;',
  6306. '$mod.Arr[0] = $mod.Arr[+$mod.b] || $mod.Arr[1];',
  6307. '$mod.Arr[+$mod.b] = true;',
  6308. '$mod.Arr[+$mod.Arr[+$mod.b]] = $mod.Arr[1];',
  6309. '$mod.b = $mod.Arr[0] === $mod.Arr[1];',
  6310. '$mod.b = true;',
  6311. '$mod.b = true;',
  6312. '$mod.Arr2[0] = true;',
  6313. '$mod.Arr2[0] = $mod.Arr2[0] && $mod.Arr2[1-$mod.b];',
  6314. '$mod.Arr2[1-$mod.b] = false;',
  6315. '']));
  6316. end;
  6317. procedure TTestModule.TestArray_StaticChar;
  6318. begin
  6319. StartProgram(false);
  6320. Add('type');
  6321. Add(' TChars = array[char] of char;');
  6322. Add(' TChars2 = array[''a''..''z''] of char;');
  6323. Add('var');
  6324. Add(' Arr: TChars;');
  6325. Add(' Arr2: TChars2;');
  6326. Add(' Arr3: array[2..4] of char = (''p'',''a'',''s'');');
  6327. Add(' Arr4: array[11..13] of char = ''pas'';');
  6328. Add(' Arr5: array[21..22] of char = ''äö'';');
  6329. Add(' c: char;');
  6330. Add(' b: boolean;');
  6331. Add('begin');
  6332. Add(' c:=low(arr);');
  6333. Add(' c:=high(arr);');
  6334. Add(' arr[''B'']:=''a'';');
  6335. Add(' arr[''D'']:=arr[c];');
  6336. Add(' arr[c]:=arr[''d''];');
  6337. Add(' arr[arr[c]]:=arr[high(arr)];');
  6338. Add(' b:=arr[low(arr)]=arr[''e''];');
  6339. Add(' c:=low(arr2);');
  6340. Add(' c:=high(arr2);');
  6341. Add(' arr2[''b'']:=''f'';');
  6342. Add(' arr2[''a'']:=arr2[c];');
  6343. Add(' arr2[c]:=arr2[''g''];');
  6344. ConvertProgram;
  6345. CheckSource('TestArray_StaticChar',
  6346. LinesToStr([ // statements
  6347. 'this.Arr = rtl.arraySetLength(null, "", 65536);',
  6348. 'this.Arr2 = rtl.arraySetLength(null, "", 26);',
  6349. 'this.Arr3 = ["p", "a", "s"];',
  6350. 'this.Arr4 = ["p", "a", "s"];',
  6351. 'this.Arr5 = ["ä", "ö"];',
  6352. 'this.c = "";',
  6353. 'this.b = false;',
  6354. '']),
  6355. LinesToStr([ // $mod.$main
  6356. '$mod.c = "\x00";',
  6357. '$mod.c = "'#$EF#$BF#$BF'";',
  6358. '$mod.Arr[66] = "a";',
  6359. '$mod.Arr[68] = $mod.Arr[$mod.c.charCodeAt()];',
  6360. '$mod.Arr[$mod.c.charCodeAt()] = $mod.Arr[100];',
  6361. '$mod.Arr[$mod.Arr[$mod.c.charCodeAt()].charCodeAt()] = $mod.Arr[65535];',
  6362. '$mod.b = $mod.Arr[0] === $mod.Arr[101];',
  6363. '$mod.c = "a";',
  6364. '$mod.c = "z";',
  6365. '$mod.Arr2[1] = "f";',
  6366. '$mod.Arr2[0] = $mod.Arr2[$mod.c.charCodeAt() - 97];',
  6367. '$mod.Arr2[$mod.c.charCodeAt() - 97] = $mod.Arr2[6];',
  6368. '']));
  6369. end;
  6370. procedure TTestModule.TestArray_StaticMultiDim;
  6371. begin
  6372. StartProgram(false);
  6373. Add([
  6374. 'type',
  6375. ' TArrayInt = array[1..3] of longint;',
  6376. ' TArrayArrayInt = array[5..6] of TArrayInt;',
  6377. 'var',
  6378. ' Arr: TArrayInt;',
  6379. ' Arr2: TArrayArrayInt;',
  6380. ' Arr3: array[boolean] of TArrayInt = ((11,12,13),(21,22,23));',
  6381. ' i: longint;',
  6382. 'begin',
  6383. ' i:=low(arr);',
  6384. ' i:=low(arr2);',
  6385. ' i:=low(arr2[5]);',
  6386. ' i:=high(arr);',
  6387. ' i:=high(arr2);',
  6388. ' i:=high(arr2[6]);',
  6389. ' arr2[5]:=arr;',
  6390. ' arr2[6][2]:=i;',
  6391. ' i:=arr2[6][3];',
  6392. ' arr2[6,3]:=i;',
  6393. ' i:=arr2[5,2];',
  6394. ' arr2:=arr2;',// clone multi dim static array
  6395. //' arr3:=arr3;',// clone anonymous multi dim static array
  6396. '']);
  6397. ConvertProgram;
  6398. CheckSource('TestArray_StaticMultiDim',
  6399. LinesToStr([ // statements
  6400. 'this.TArrayArrayInt$clone = function (a) {',
  6401. ' var r = [];',
  6402. ' for (var i = 0; i < 2; i++) r.push(a[i].slice(0));',
  6403. ' return r;',
  6404. '};',
  6405. 'this.Arr = rtl.arraySetLength(null, 0, 3);',
  6406. 'this.Arr2 = rtl.arraySetLength(null, 0, 2, 3);',
  6407. 'this.Arr3 = [[11, 12, 13], [21, 22, 23]];',
  6408. 'this.i = 0;'
  6409. ]),
  6410. LinesToStr([ // $mod.$main
  6411. '$mod.i = 1;',
  6412. '$mod.i = 5;',
  6413. '$mod.i = 1;',
  6414. '$mod.i = 3;',
  6415. '$mod.i = 6;',
  6416. '$mod.i = 3;',
  6417. '$mod.Arr2[0] = $mod.Arr.slice(0);',
  6418. '$mod.Arr2[1][1] = $mod.i;',
  6419. '$mod.i = $mod.Arr2[1][2];',
  6420. '$mod.Arr2[1][2] = $mod.i;',
  6421. '$mod.i = $mod.Arr2[0][1];',
  6422. '$mod.Arr2 = $mod.TArrayArrayInt$clone($mod.Arr2);',
  6423. '']));
  6424. end;
  6425. procedure TTestModule.TestArrayOfRecord;
  6426. begin
  6427. StartProgram(false);
  6428. Add('type');
  6429. Add(' TRec = record');
  6430. Add(' Int: longint;');
  6431. Add(' end;');
  6432. Add(' TArrayRec = array of TRec;');
  6433. Add('var');
  6434. Add(' Arr: TArrayRec;');
  6435. Add(' r: TRec;');
  6436. Add(' i: longint;');
  6437. Add('begin');
  6438. Add(' SetLength(arr,3);');
  6439. Add(' arr[0].int:=4;');
  6440. Add(' arr[1].int:=length(arr)+arr[2].int;');
  6441. Add(' arr[arr[i].int].int:=arr[5].int;');
  6442. Add(' arr[7]:=r;');
  6443. Add(' r:=arr[8];');
  6444. Add(' i:=low(arr);');
  6445. Add(' i:=high(arr);');
  6446. ConvertProgram;
  6447. CheckSource('TestArrayOfRecord',
  6448. LinesToStr([ // statements
  6449. 'this.TRec = function (s) {',
  6450. ' if (s) {',
  6451. ' this.Int = s.Int;',
  6452. ' } else {',
  6453. ' this.Int = 0;',
  6454. ' };',
  6455. ' this.$equal = function (b) {',
  6456. ' return this.Int === b.Int;',
  6457. ' };',
  6458. '};',
  6459. 'this.Arr = [];',
  6460. 'this.r = new $mod.TRec();',
  6461. 'this.i = 0;'
  6462. ]),
  6463. LinesToStr([ // $mod.$main
  6464. '$mod.Arr = rtl.arraySetLength($mod.Arr,$mod.TRec,3);',
  6465. '$mod.Arr[0].Int = 4;',
  6466. '$mod.Arr[1].Int = rtl.length($mod.Arr)+$mod.Arr[2].Int;',
  6467. '$mod.Arr[$mod.Arr[$mod.i].Int].Int = $mod.Arr[5].Int;',
  6468. '$mod.Arr[7] = new $mod.TRec($mod.r);',
  6469. '$mod.r = new $mod.TRec($mod.Arr[8]);',
  6470. '$mod.i = 0;',
  6471. '$mod.i = rtl.length($mod.Arr)-1;',
  6472. '']));
  6473. end;
  6474. procedure TTestModule.TestArray_DynAsParam;
  6475. begin
  6476. StartProgram(false);
  6477. Add([
  6478. 'type integer = longint;',
  6479. 'type TArrInt = array of integer;',
  6480. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  6481. 'var vJ: TArrInt;',
  6482. 'begin',
  6483. ' vg:=vg;',
  6484. ' vj:=vh;',
  6485. ' vi:=vi;',
  6486. ' doit(vg,vg,vg);',
  6487. ' doit(vh,vh,vj);',
  6488. ' doit(vi,vi,vi);',
  6489. ' doit(vj,vj,vj);',
  6490. 'end;',
  6491. 'var i: TArrInt;',
  6492. 'begin',
  6493. ' doit(i,i,i);']);
  6494. ConvertProgram;
  6495. CheckSource('TestArray_DynAsParams',
  6496. LinesToStr([ // statements
  6497. 'this.DoIt = function (vG,vH,vI) {',
  6498. ' var vJ = [];',
  6499. ' vG = vG;',
  6500. ' vJ = vH;',
  6501. ' vI.set(vI.get());',
  6502. ' $mod.DoIt(vG, vG, {',
  6503. ' get: function () {',
  6504. ' return vG;',
  6505. ' },',
  6506. ' set: function (v) {',
  6507. ' vG = v;',
  6508. ' }',
  6509. ' });',
  6510. ' $mod.DoIt(vH, vH, {',
  6511. ' get: function () {',
  6512. ' return vJ;',
  6513. ' },',
  6514. ' set: function (v) {',
  6515. ' vJ = v;',
  6516. ' }',
  6517. ' });',
  6518. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  6519. ' $mod.DoIt(vJ, vJ, {',
  6520. ' get: function () {',
  6521. ' return vJ;',
  6522. ' },',
  6523. ' set: function (v) {',
  6524. ' vJ = v;',
  6525. ' }',
  6526. ' });',
  6527. '};',
  6528. 'this.i = [];'
  6529. ]),
  6530. LinesToStr([
  6531. '$mod.DoIt($mod.i,$mod.i,{',
  6532. ' p: $mod,',
  6533. ' get: function () {',
  6534. ' return this.p.i;',
  6535. ' },',
  6536. ' set: function (v) {',
  6537. ' this.p.i = v;',
  6538. ' }',
  6539. '});'
  6540. ]));
  6541. end;
  6542. procedure TTestModule.TestArray_StaticAsParam;
  6543. begin
  6544. StartProgram(false);
  6545. Add([
  6546. 'type integer = longint;',
  6547. 'type TArrInt = array[1..2] of integer;',
  6548. 'procedure DoIt(vG: TArrInt; const vH: TArrInt; var vI: TArrInt);',
  6549. 'var vJ: TArrInt;',
  6550. 'begin',
  6551. ' vg:=vg;',
  6552. ' vj:=vh;',
  6553. ' vi:=vi;',
  6554. ' doit(vg,vg,vg);',
  6555. ' doit(vh,vh,vj);',
  6556. ' doit(vi,vi,vi);',
  6557. ' doit(vj,vj,vj);',
  6558. 'end;',
  6559. 'var i: TArrInt;',
  6560. 'begin',
  6561. ' doit(i,i,i);']);
  6562. ConvertProgram;
  6563. CheckSource('TestArray_StaticAsParams',
  6564. LinesToStr([ // statements
  6565. 'this.DoIt = function (vG,vH,vI) {',
  6566. ' var vJ = rtl.arraySetLength(null, 0, 2);',
  6567. ' vG = vG.slice(0);',
  6568. ' vJ = vH.slice(0);',
  6569. ' vI.set(vI.get().slice(0));',
  6570. ' $mod.DoIt(vG.slice(0), vG, {',
  6571. ' get: function () {',
  6572. ' return vG;',
  6573. ' },',
  6574. ' set: function (v) {',
  6575. ' vG = v;',
  6576. ' }',
  6577. ' });',
  6578. ' $mod.DoIt(vH.slice(0), vH, {',
  6579. ' get: function () {',
  6580. ' return vJ;',
  6581. ' },',
  6582. ' set: function (v) {',
  6583. ' vJ = v;',
  6584. ' }',
  6585. ' });',
  6586. ' $mod.DoIt(vI.get().slice(0), vI.get(), vI);',
  6587. ' $mod.DoIt(vJ.slice(0), vJ, {',
  6588. ' get: function () {',
  6589. ' return vJ;',
  6590. ' },',
  6591. ' set: function (v) {',
  6592. ' vJ = v;',
  6593. ' }',
  6594. ' });',
  6595. '};',
  6596. 'this.i = rtl.arraySetLength(null, 0, 2);'
  6597. ]),
  6598. LinesToStr([
  6599. '$mod.DoIt($mod.i.slice(0),$mod.i,{',
  6600. ' p: $mod,',
  6601. ' get: function () {',
  6602. ' return this.p.i;',
  6603. ' },',
  6604. ' set: function (v) {',
  6605. ' this.p.i = v;',
  6606. ' }',
  6607. '});'
  6608. ]));
  6609. end;
  6610. procedure TTestModule.TestArrayElement_AsParams;
  6611. begin
  6612. StartProgram(false);
  6613. Add('type integer = longint;');
  6614. Add('type TArrayInt = array of integer;');
  6615. Add('procedure DoIt(vG: Integer; const vH: Integer; var vI: Integer);');
  6616. Add('var vJ: tarrayint;');
  6617. Add('begin');
  6618. Add(' vi:=vi;');
  6619. Add(' doit(vi,vi,vi);');
  6620. Add(' doit(vj[1+1],vj[1+2],vj[1+3]);');
  6621. Add('end;');
  6622. Add('var a: TArrayInt;');
  6623. Add('begin');
  6624. Add(' doit(a[1+4],a[1+5],a[1+6]);');
  6625. ConvertProgram;
  6626. CheckSource('TestArrayElement_AsParams',
  6627. LinesToStr([ // statements
  6628. 'this.DoIt = function (vG,vH,vI) {',
  6629. ' var vJ = [];',
  6630. ' vI.set(vI.get());',
  6631. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  6632. ' $mod.DoIt(vJ[1+1], vJ[1+2], {',
  6633. ' a:1+3,',
  6634. ' p:vJ,',
  6635. ' get: function () {',
  6636. ' return this.p[this.a];',
  6637. ' },',
  6638. ' set: function (v) {',
  6639. ' this.p[this.a] = v;',
  6640. ' }',
  6641. ' });',
  6642. '};',
  6643. 'this.a = [];'
  6644. ]),
  6645. LinesToStr([
  6646. '$mod.DoIt($mod.a[1+4],$mod.a[1+5],{',
  6647. ' a: 1+6,',
  6648. ' p: $mod.a,',
  6649. ' get: function () {',
  6650. ' return this.p[this.a];',
  6651. ' },',
  6652. ' set: function (v) {',
  6653. ' this.p[this.a] = v;',
  6654. ' }',
  6655. '});'
  6656. ]));
  6657. end;
  6658. procedure TTestModule.TestArrayElementFromFuncResult_AsParams;
  6659. begin
  6660. StartProgram(false);
  6661. Add('type Integer = longint;');
  6662. Add('type TArrayInt = array of integer;');
  6663. Add('function GetArr(vB: integer = 0): tarrayint;');
  6664. Add('begin');
  6665. Add('end;');
  6666. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  6667. Add('begin');
  6668. Add('end;');
  6669. Add('begin');
  6670. Add(' doit(getarr[1+1],getarr[1+2],getarr[1+3]);');
  6671. Add(' doit(getarr()[2+1],getarr()[2+2],getarr()[2+3]);');
  6672. Add(' doit(getarr(7)[3+1],getarr(8)[3+2],getarr(9)[3+3]);');
  6673. ConvertProgram;
  6674. CheckSource('TestArrayElementFromFuncResult_AsParams',
  6675. LinesToStr([ // statements
  6676. 'this.GetArr = function (vB) {',
  6677. ' var Result = [];',
  6678. ' return Result;',
  6679. '};',
  6680. 'this.DoIt = function (vG,vH,vI) {',
  6681. '};'
  6682. ]),
  6683. LinesToStr([
  6684. '$mod.DoIt($mod.GetArr(0)[1+1],$mod.GetArr(0)[1+2],{',
  6685. ' a: 1+3,',
  6686. ' p: $mod.GetArr(0),',
  6687. ' get: function () {',
  6688. ' return this.p[this.a];',
  6689. ' },',
  6690. ' set: function (v) {',
  6691. ' this.p[this.a] = v;',
  6692. ' }',
  6693. '});',
  6694. '$mod.DoIt($mod.GetArr(0)[2+1],$mod.GetArr(0)[2+2],{',
  6695. ' a: 2+3,',
  6696. ' p: $mod.GetArr(0),',
  6697. ' get: function () {',
  6698. ' return this.p[this.a];',
  6699. ' },',
  6700. ' set: function (v) {',
  6701. ' this.p[this.a] = v;',
  6702. ' }',
  6703. '});',
  6704. '$mod.DoIt($mod.GetArr(7)[3+1],$mod.GetArr(8)[3+2],{',
  6705. ' a: 3+3,',
  6706. ' p: $mod.GetArr(9),',
  6707. ' get: function () {',
  6708. ' return this.p[this.a];',
  6709. ' },',
  6710. ' set: function (v) {',
  6711. ' this.p[this.a] = v;',
  6712. ' }',
  6713. '});',
  6714. '']));
  6715. end;
  6716. procedure TTestModule.TestArrayEnumTypeRange;
  6717. begin
  6718. StartProgram(false);
  6719. Add([
  6720. 'type',
  6721. ' TEnum = (red,blue);',
  6722. ' TEnumArray = array[TEnum] of longint;',
  6723. 'var',
  6724. ' e: TEnum;',
  6725. ' i: longint;',
  6726. ' a: TEnumArray;',
  6727. ' numbers: TEnumArray = (1,2);',
  6728. ' names: array[TEnum] of string = (''red'',''blue'');',
  6729. 'begin',
  6730. ' e:=low(a);',
  6731. ' e:=high(a);',
  6732. ' i:=a[red];',
  6733. ' a[e]:=a[e];']);
  6734. ConvertProgram;
  6735. CheckSource('TestArrayEnumTypeRange',
  6736. LinesToStr([ // statements
  6737. ' this.TEnum = {',
  6738. ' "0": "red",',
  6739. ' red: 0,',
  6740. ' "1": "blue",',
  6741. ' blue: 1',
  6742. '};',
  6743. 'this.e = 0;',
  6744. 'this.i = 0;',
  6745. 'this.a = rtl.arraySetLength(null,0,2);',
  6746. 'this.numbers = [1, 2];',
  6747. 'this.names = ["red", "blue"];',
  6748. '']),
  6749. LinesToStr([ // $mod.$main
  6750. '$mod.e = $mod.TEnum.red;',
  6751. '$mod.e = $mod.TEnum.blue;',
  6752. '$mod.i = $mod.a[$mod.TEnum.red];',
  6753. '$mod.a[$mod.e] = $mod.a[$mod.e];',
  6754. '']));
  6755. end;
  6756. procedure TTestModule.TestArray_SetLengthOutArg;
  6757. begin
  6758. StartProgram(false);
  6759. Add([
  6760. 'type TArrInt = array of longint;',
  6761. 'procedure DoIt(out a: TArrInt);',
  6762. 'begin',
  6763. ' SetLength(a,2);',
  6764. 'end;',
  6765. 'begin',
  6766. '']);
  6767. ConvertProgram;
  6768. CheckSource('TestArray_SetLengthOutArg',
  6769. LinesToStr([ // statements
  6770. 'this.DoIt = function (a) {',
  6771. ' a.set(rtl.arraySetLength(a.get(), 0, 2));',
  6772. '};',
  6773. '']),
  6774. LinesToStr([
  6775. '']));
  6776. end;
  6777. procedure TTestModule.TestArray_SetLengthProperty;
  6778. begin
  6779. StartProgram(false);
  6780. Add('type');
  6781. Add(' TArrInt = array of longint;');
  6782. Add(' TObject = class');
  6783. Add(' function GetColors: TArrInt; external name ''GetColors'';');
  6784. Add(' procedure SetColors(const Value: TArrInt); external name ''SetColors'';');
  6785. Add(' property Colors: TArrInt read GetColors write SetColors;');
  6786. Add(' end;');
  6787. Add('var Obj: TObject;');
  6788. Add('begin');
  6789. Add(' SetLength(Obj.Colors,2);');
  6790. ConvertProgram;
  6791. CheckSource('TestArray_SetLengthProperty',
  6792. LinesToStr([ // statements
  6793. 'rtl.createClass($mod, "TObject", null, function () {',
  6794. ' this.$init = function () {',
  6795. ' };',
  6796. ' this.$final = function () {',
  6797. ' };',
  6798. '});',
  6799. 'this.Obj = null;',
  6800. '']),
  6801. LinesToStr([
  6802. '$mod.Obj.SetColors(rtl.arraySetLength($mod.Obj.GetColors(), 0, 2));',
  6803. '']));
  6804. end;
  6805. procedure TTestModule.TestArray_SetLengthMultiDim;
  6806. begin
  6807. StartProgram(false);
  6808. Add([
  6809. 'type',
  6810. ' TArrArrInt = array of array of longint;',
  6811. 'var',
  6812. ' a: TArrArrInt;',
  6813. 'begin',
  6814. ' SetLength(a,2);',
  6815. ' SetLength(a,3,4);',
  6816. '']);
  6817. ConvertProgram;
  6818. CheckSource('TestArray_SetLengthMultiDim',
  6819. LinesToStr([ // statements
  6820. 'this.a = [];']),
  6821. LinesToStr([
  6822. '$mod.a = rtl.arraySetLength($mod.a, [], 2);',
  6823. '$mod.a = rtl.arraySetLength($mod.a, 0, 3, 4);',
  6824. '']));
  6825. end;
  6826. procedure TTestModule.TestArray_OpenArrayOfString;
  6827. begin
  6828. StartProgram(false);
  6829. Add('procedure DoIt(const a: array of String);');
  6830. Add('var');
  6831. Add(' i: longint;');
  6832. Add(' s: string;');
  6833. Add('begin');
  6834. Add(' for i:=low(a) to high(a) do s:=a[length(a)-i-1];');
  6835. Add('end;');
  6836. Add('var s: string;');
  6837. Add('begin');
  6838. Add(' DoIt([]);');
  6839. Add(' DoIt([s,''foo'','''',s+s]);');
  6840. ConvertProgram;
  6841. CheckSource('TestArray_OpenArrayOfString',
  6842. LinesToStr([ // statements
  6843. 'this.DoIt = function (a) {',
  6844. ' var i = 0;',
  6845. ' var s = "";',
  6846. ' for (var $l1 = 0, $end2 = rtl.length(a) - 1; $l1 <= $end2; $l1++) {',
  6847. ' i = $l1;',
  6848. ' s = a[(rtl.length(a) - i) - 1];',
  6849. ' };',
  6850. '};',
  6851. 'this.s = "";',
  6852. '']),
  6853. LinesToStr([
  6854. '$mod.DoIt([]);',
  6855. '$mod.DoIt([$mod.s, "foo", "", $mod.s + $mod.s]);',
  6856. '']));
  6857. end;
  6858. procedure TTestModule.TestArray_Concat;
  6859. begin
  6860. StartProgram(false);
  6861. Add('type');
  6862. Add(' integer = longint;');
  6863. Add(' TFlag = (big,small);');
  6864. Add(' TFlags = set of TFlag;');
  6865. Add(' TRec = record');
  6866. Add(' i: integer;');
  6867. Add(' end;');
  6868. Add(' TArrInt = array of integer;');
  6869. Add(' TArrRec = array of TRec;');
  6870. Add(' TArrSet = array of TFlags;');
  6871. Add(' TArrJSValue = array of jsvalue;');
  6872. Add('var');
  6873. Add(' ArrInt: tarrint;');
  6874. Add(' ArrRec: tarrrec;');
  6875. Add(' ArrSet: tarrset;');
  6876. Add(' ArrJSValue: tarrjsvalue;');
  6877. Add('begin');
  6878. Add(' arrint:=concat(arrint);');
  6879. Add(' arrint:=concat(arrint,arrint);');
  6880. Add(' arrint:=concat(arrint,arrint,arrint);');
  6881. Add(' arrrec:=concat(arrrec);');
  6882. Add(' arrrec:=concat(arrrec,arrrec);');
  6883. Add(' arrrec:=concat(arrrec,arrrec,arrrec);');
  6884. Add(' arrset:=concat(arrset);');
  6885. Add(' arrset:=concat(arrset,arrset);');
  6886. Add(' arrset:=concat(arrset,arrset,arrset);');
  6887. Add(' arrjsvalue:=concat(arrjsvalue);');
  6888. Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue);');
  6889. Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);');
  6890. ConvertProgram;
  6891. CheckSource('TestArray_Concat',
  6892. LinesToStr([ // statements
  6893. 'this.TFlag = {',
  6894. ' "0": "big",',
  6895. ' big: 0,',
  6896. ' "1": "small",',
  6897. ' small: 1',
  6898. '};',
  6899. 'this.TRec = function (s) {',
  6900. ' if (s) {',
  6901. ' this.i = s.i;',
  6902. ' } else {',
  6903. ' this.i = 0;',
  6904. ' };',
  6905. ' this.$equal = function (b) {',
  6906. ' return this.i === b.i;',
  6907. ' };',
  6908. '};',
  6909. 'this.ArrInt = [];',
  6910. 'this.ArrRec = [];',
  6911. 'this.ArrSet = [];',
  6912. 'this.ArrJSValue = [];',
  6913. '']),
  6914. LinesToStr([ // $mod.$main
  6915. '$mod.ArrInt = $mod.ArrInt;',
  6916. '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt);',
  6917. '$mod.ArrInt = $mod.ArrInt.concat($mod.ArrInt,$mod.ArrInt);',
  6918. '$mod.ArrRec = $mod.ArrRec;',
  6919. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec);',
  6920. '$mod.ArrRec = rtl.arrayConcat($mod.TRec, $mod.ArrRec, $mod.ArrRec);',
  6921. '$mod.ArrSet = $mod.ArrSet;',
  6922. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet);',
  6923. '$mod.ArrSet = rtl.arrayConcat("refSet", $mod.ArrSet, $mod.ArrSet);',
  6924. '$mod.ArrJSValue = $mod.ArrJSValue;',
  6925. '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue);',
  6926. '$mod.ArrJSValue = $mod.ArrJSValue.concat($mod.ArrJSValue, $mod.ArrJSValue);',
  6927. '']));
  6928. end;
  6929. procedure TTestModule.TestArray_Copy;
  6930. begin
  6931. StartProgram(false);
  6932. Add('type');
  6933. Add(' integer = longint;');
  6934. Add(' TFlag = (big,small);');
  6935. Add(' TFlags = set of TFlag;');
  6936. Add(' TRec = record');
  6937. Add(' i: integer;');
  6938. Add(' end;');
  6939. Add(' TArrInt = array of integer;');
  6940. Add(' TArrRec = array of TRec;');
  6941. Add(' TArrSet = array of TFlags;');
  6942. Add(' TArrJSValue = array of jsvalue;');
  6943. Add('var');
  6944. Add(' ArrInt: tarrint;');
  6945. Add(' ArrRec: tarrrec;');
  6946. Add(' ArrSet: tarrset;');
  6947. Add(' ArrJSValue: tarrjsvalue;');
  6948. Add('begin');
  6949. Add(' arrint:=copy(arrint);');
  6950. Add(' arrint:=copy(arrint,2);');
  6951. Add(' arrint:=copy(arrint,3,4);');
  6952. Add(' arrrec:=copy(arrrec);');
  6953. Add(' arrrec:=copy(arrrec,5);');
  6954. Add(' arrrec:=copy(arrrec,6,7);');
  6955. Add(' arrset:=copy(arrset);');
  6956. Add(' arrset:=copy(arrset,8);');
  6957. Add(' arrset:=copy(arrset,9,10);');
  6958. Add(' arrjsvalue:=copy(arrjsvalue);');
  6959. Add(' arrjsvalue:=copy(arrjsvalue,11);');
  6960. Add(' arrjsvalue:=copy(arrjsvalue,12,13);');
  6961. ConvertProgram;
  6962. CheckSource('TestArray_Copy',
  6963. LinesToStr([ // statements
  6964. 'this.TFlag = {',
  6965. ' "0": "big",',
  6966. ' big: 0,',
  6967. ' "1": "small",',
  6968. ' small: 1',
  6969. '};',
  6970. 'this.TRec = function (s) {',
  6971. ' if (s) {',
  6972. ' this.i = s.i;',
  6973. ' } else {',
  6974. ' this.i = 0;',
  6975. ' };',
  6976. ' this.$equal = function (b) {',
  6977. ' return this.i === b.i;',
  6978. ' };',
  6979. '};',
  6980. 'this.ArrInt = [];',
  6981. 'this.ArrRec = [];',
  6982. 'this.ArrSet = [];',
  6983. 'this.ArrJSValue = [];',
  6984. '']),
  6985. LinesToStr([ // $mod.$main
  6986. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 0);',
  6987. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 2);',
  6988. '$mod.ArrInt = rtl.arrayCopy(0, $mod.ArrInt, 3, 4);',
  6989. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 0);',
  6990. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 5);',
  6991. '$mod.ArrRec = rtl.arrayCopy($mod.TRec, $mod.ArrRec, 6, 7);',
  6992. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 0);',
  6993. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 8);',
  6994. '$mod.ArrSet = rtl.arrayCopy("refSet", $mod.ArrSet, 9, 10);',
  6995. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 0);',
  6996. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 11);',
  6997. '$mod.ArrJSValue = rtl.arrayCopy(0, $mod.ArrJSValue, 12, 13);',
  6998. '']));
  6999. end;
  7000. procedure TTestModule.TestArray_InsertDelete;
  7001. begin
  7002. StartProgram(false);
  7003. Add('type');
  7004. Add(' integer = longint;');
  7005. Add(' TFlag = (big,small);');
  7006. Add(' TFlags = set of TFlag;');
  7007. Add(' TRec = record');
  7008. Add(' i: integer;');
  7009. Add(' end;');
  7010. Add(' TArrInt = array of integer;');
  7011. Add(' TArrRec = array of TRec;');
  7012. Add(' TArrSet = array of TFlags;');
  7013. Add(' TArrJSValue = array of jsvalue;');
  7014. Add('var');
  7015. Add(' ArrInt: tarrint;');
  7016. Add(' ArrRec: tarrrec;');
  7017. Add(' ArrSet: tarrset;');
  7018. Add(' ArrJSValue: tarrjsvalue;');
  7019. Add('begin');
  7020. Add(' Insert(1,arrint,2);');
  7021. Add(' Insert(arrint[3],arrint,4);');
  7022. Add(' Insert(arrrec[5],arrrec,6);');
  7023. Add(' Insert(arrset[7],arrset,7);');
  7024. Add(' Insert(arrjsvalue[8],arrjsvalue,9);');
  7025. Add(' Insert(10,arrjsvalue,11);');
  7026. Add(' Delete(arrint,12,13);');
  7027. Add(' Delete(arrrec,14,15);');
  7028. Add(' Delete(arrset,17,18);');
  7029. Add(' Delete(arrjsvalue,19,10);');
  7030. ConvertProgram;
  7031. CheckSource('TestArray_InsertDelete',
  7032. LinesToStr([ // statements
  7033. 'this.TFlag = {',
  7034. ' "0": "big",',
  7035. ' big: 0,',
  7036. ' "1": "small",',
  7037. ' small: 1',
  7038. '};',
  7039. 'this.TRec = function (s) {',
  7040. ' if (s) {',
  7041. ' this.i = s.i;',
  7042. ' } else {',
  7043. ' this.i = 0;',
  7044. ' };',
  7045. ' this.$equal = function (b) {',
  7046. ' return this.i === b.i;',
  7047. ' };',
  7048. '};',
  7049. 'this.ArrInt = [];',
  7050. 'this.ArrRec = [];',
  7051. 'this.ArrSet = [];',
  7052. 'this.ArrJSValue = [];',
  7053. '']),
  7054. LinesToStr([ // $mod.$main
  7055. '$mod.ArrInt.splice(2, 0, 1);',
  7056. '$mod.ArrInt.splice(4, 0, $mod.ArrInt[3]);',
  7057. '$mod.ArrRec.splice(6, 0, $mod.ArrRec[5]);',
  7058. '$mod.ArrSet.splice(7, 0, $mod.ArrSet[7]);',
  7059. '$mod.ArrJSValue.splice(9, 0, $mod.ArrJSValue[8]);',
  7060. '$mod.ArrJSValue.splice(11, 0, 10);',
  7061. '$mod.ArrInt.splice(12, 13);',
  7062. '$mod.ArrRec.splice(14, 15);',
  7063. '$mod.ArrSet.splice(17, 18);',
  7064. '$mod.ArrJSValue.splice(19, 10);',
  7065. '']));
  7066. end;
  7067. procedure TTestModule.TestArray_DynArrayConst;
  7068. begin
  7069. StartProgram(false);
  7070. Add([
  7071. 'type',
  7072. ' integer = longint;',
  7073. ' TArrInt = array of integer;',
  7074. ' TArrStr = array of string;',
  7075. 'const',
  7076. ' Ints: TArrInt = (1,2,3);',
  7077. ' Names: array of string = (''a'',''foo'');',
  7078. ' Aliases: TarrStr = (''foo'',''b'');',
  7079. ' OneInt: TArrInt = (7);',
  7080. ' OneStr: array of integer = (7);',
  7081. //' Chars: array of char = ''aoc'';',
  7082. ' NameCount = low(Names)+high(Names)+length(Names);',
  7083. 'begin',
  7084. '']);
  7085. ConvertProgram;
  7086. CheckSource('TestArray_DynArrayConst',
  7087. LinesToStr([ // statements
  7088. 'this.Ints = [1, 2, 3];',
  7089. 'this.Names = ["a", "foo"];',
  7090. 'this.Aliases = ["foo", "b"];',
  7091. 'this.OneInt = [7];',
  7092. 'this.OneStr = [7];',
  7093. 'this.NameCount = (0 + (rtl.length($mod.Names) - 1)) + rtl.length($mod.Names);',
  7094. '']),
  7095. LinesToStr([ // $mod.$main
  7096. '']));
  7097. end;
  7098. procedure TTestModule.TestArray_ForInArrOfString;
  7099. begin
  7100. StartProgram(false);
  7101. Add([
  7102. 'type',
  7103. 'type',
  7104. ' TMonthNameArray = array [1..12] of string;',
  7105. ' TMonthNames = TMonthNameArray;',
  7106. ' TObject = class',
  7107. ' private',
  7108. ' function GetLongMonthNames: TMonthNames; virtual; abstract;',
  7109. ' public',
  7110. ' Property LongMonthNames : TMonthNames Read GetLongMonthNames;',
  7111. ' end;',
  7112. 'var f: TObject;',
  7113. ' Month: string;',
  7114. 'begin',
  7115. ' for Month in f.LongMonthNames do ;',
  7116. '']);
  7117. ConvertProgram;
  7118. CheckSource('TestArray_ForInArrOfString',
  7119. LinesToStr([ // statements
  7120. 'rtl.createClass($mod, "TObject", null, function () {',
  7121. ' this.$init = function () {',
  7122. ' };',
  7123. ' this.$final = function () {',
  7124. ' };',
  7125. '});',
  7126. 'this.f = null;',
  7127. 'this.Month = "";',
  7128. '']),
  7129. LinesToStr([ // $mod.$main
  7130. 'for (var $in1 = $mod.f.GetLongMonthNames(), $l2 = 0, $end3 = rtl.length($in1) - 1; $l2 <= $end3; $l2++) $mod.Month = $in1[$l2];',
  7131. '']));
  7132. end;
  7133. procedure TTestModule.TestExternalClass_TypeCastArrayToExternalArray;
  7134. begin
  7135. StartProgram(false);
  7136. Add([
  7137. '{$modeswitch externalclass}',
  7138. 'type',
  7139. ' TJSArray = class external name ''Array''',
  7140. ' class function isArray(Value: JSValue) : boolean;',
  7141. ' function concat() : TJSArray; varargs;',
  7142. ' end;',
  7143. 'var',
  7144. ' aObj: TJSArray;',
  7145. ' a: array of longint;',
  7146. 'begin',
  7147. ' if TJSArray.isArray(65) then ;',
  7148. ' aObj:=TJSArray(a).concat(a);']);
  7149. ConvertProgram;
  7150. CheckSource('TestExternalClass_TypeCastArrayToExternalArray',
  7151. LinesToStr([ // statements
  7152. 'this.aObj = null;',
  7153. 'this.a = [];',
  7154. '']),
  7155. LinesToStr([ // $mod.$main
  7156. 'if (Array.isArray(65)) ;',
  7157. '$mod.aObj = $mod.a.concat($mod.a);',
  7158. '']));
  7159. end;
  7160. procedure TTestModule.TestExternalClass_TypeCastArrayFromExternalArray;
  7161. begin
  7162. StartProgram(false);
  7163. Add('{$modeswitch externalclass}');
  7164. Add('type');
  7165. Add(' TArrStr = array of string;');
  7166. Add(' TJSArray = class external name ''Array''');
  7167. Add(' end;');
  7168. Add('var');
  7169. Add(' aObj: TJSArray;');
  7170. Add(' a: TArrStr;');
  7171. Add('begin');
  7172. Add(' a:=TArrStr(aObj);');
  7173. Add(' TArrStr(aObj)[1]:=TArrStr(aObj)[2];');
  7174. ConvertProgram;
  7175. CheckSource('TestExternalClass_TypeCastArrayFromExternalArray',
  7176. LinesToStr([ // statements
  7177. 'this.aObj = null;',
  7178. 'this.a = [];',
  7179. '']),
  7180. LinesToStr([ // $mod.$main
  7181. '$mod.a = $mod.aObj;',
  7182. '$mod.aObj[1] = $mod.aObj[2];',
  7183. '']));
  7184. end;
  7185. procedure TTestModule.TestRecord_Empty;
  7186. begin
  7187. StartProgram(false);
  7188. Add(['type',
  7189. ' TRecA = record',
  7190. ' end;',
  7191. 'var a,b: TRecA;',
  7192. 'begin',
  7193. ' if a=b then ;']);
  7194. ConvertProgram;
  7195. CheckSource('TestRecord_Empty',
  7196. LinesToStr([ // statements
  7197. 'this.TRecA = function (s) {',
  7198. ' this.$equal = function (b) {',
  7199. ' return true;',
  7200. ' };',
  7201. '};',
  7202. 'this.a = new $mod.TRecA();',
  7203. 'this.b = new $mod.TRecA();'
  7204. ]),
  7205. LinesToStr([ // $mod.$main
  7206. 'if ($mod.a.$equal($mod.b)) ;'
  7207. ]));
  7208. end;
  7209. procedure TTestModule.TestRecord_Var;
  7210. begin
  7211. StartProgram(false);
  7212. Add('type');
  7213. Add(' TRecA = record');
  7214. Add(' Bold: longint;');
  7215. Add(' end;');
  7216. Add('var Rec: TRecA;');
  7217. Add('begin');
  7218. Add(' rec.bold:=123');
  7219. ConvertProgram;
  7220. CheckSource('TestRecord_Var',
  7221. LinesToStr([ // statements
  7222. 'this.TRecA = function (s) {',
  7223. ' if (s) {',
  7224. ' this.Bold = s.Bold;',
  7225. ' } else {',
  7226. ' this.Bold = 0;',
  7227. ' };',
  7228. ' this.$equal = function (b) {',
  7229. ' return this.Bold === b.Bold;',
  7230. ' };',
  7231. '};',
  7232. 'this.Rec = new $mod.TRecA();'
  7233. ]),
  7234. LinesToStr([ // $mod.$main
  7235. '$mod.Rec.Bold = 123;'
  7236. ]));
  7237. end;
  7238. procedure TTestModule.TestWithRecordDo;
  7239. begin
  7240. StartProgram(false);
  7241. Add('type');
  7242. Add(' TRec = record');
  7243. Add(' vI: longint;');
  7244. Add(' end;');
  7245. Add('var');
  7246. Add(' Int: longint;');
  7247. Add(' r: TRec;');
  7248. Add('begin');
  7249. Add(' with r do');
  7250. Add(' int:=vi;');
  7251. Add(' with r do begin');
  7252. Add(' int:=vi;');
  7253. Add(' vi:=int;');
  7254. Add(' end;');
  7255. ConvertProgram;
  7256. CheckSource('TestWithRecordDo',
  7257. LinesToStr([ // statements
  7258. 'this.TRec = function (s) {',
  7259. ' if (s) {',
  7260. ' this.vI = s.vI;',
  7261. ' } else {',
  7262. ' this.vI = 0;',
  7263. ' };',
  7264. ' this.$equal = function (b) {',
  7265. ' return this.vI === b.vI;',
  7266. ' };',
  7267. '};',
  7268. 'this.Int = 0;',
  7269. 'this.r = new $mod.TRec();'
  7270. ]),
  7271. LinesToStr([ // $mod.$main
  7272. 'var $with1 = $mod.r;',
  7273. '$mod.Int = $with1.vI;',
  7274. 'var $with2 = $mod.r;',
  7275. '$mod.Int = $with2.vI;',
  7276. '$with2.vI = $mod.Int;'
  7277. ]));
  7278. end;
  7279. procedure TTestModule.TestRecord_Assign;
  7280. begin
  7281. StartProgram(false);
  7282. Add('type');
  7283. Add(' TEnum = (red,green);');
  7284. Add(' TEnums = set of TEnum;');
  7285. Add(' TSmallRec = record');
  7286. Add(' N: longint;');
  7287. Add(' end;');
  7288. Add(' TBigRec = record');
  7289. Add(' Int: longint;');
  7290. Add(' D: double;');
  7291. Add(' Arr: array of longint;');
  7292. Add(' Arr2: array[1..2] of longint;');
  7293. Add(' Small: TSmallRec;');
  7294. Add(' Enums: TEnums;');
  7295. Add(' end;');
  7296. Add('var');
  7297. Add(' r, s: TBigRec;');
  7298. Add('begin');
  7299. Add(' r:=s;');
  7300. Add(' r:=default(TBigRec);');
  7301. Add(' r:=default(s);');
  7302. ConvertProgram;
  7303. CheckSource('TestRecord_Assign',
  7304. LinesToStr([ // statements
  7305. 'this.TEnum = {',
  7306. ' "0": "red",',
  7307. ' red: 0,',
  7308. ' "1": "green",',
  7309. ' green: 1',
  7310. '};',
  7311. 'this.TSmallRec = function (s) {',
  7312. ' if(s){',
  7313. ' this.N = s.N;',
  7314. ' } else {',
  7315. ' this.N = 0;',
  7316. ' };',
  7317. ' this.$equal = function (b) {',
  7318. ' return this.N === b.N;',
  7319. ' };',
  7320. '};',
  7321. 'this.TBigRec = function (s) {',
  7322. ' if(s){',
  7323. ' this.Int = s.Int;',
  7324. ' this.D = s.D;',
  7325. ' this.Arr = s.Arr;',
  7326. ' this.Arr2 = s.Arr2.slice(0);',
  7327. ' this.Small = new $mod.TSmallRec(s.Small);',
  7328. ' this.Enums = rtl.refSet(s.Enums);',
  7329. ' } else {',
  7330. ' this.Int = 0;',
  7331. ' this.D = 0.0;',
  7332. ' this.Arr = [];',
  7333. ' this.Arr2 = rtl.arraySetLength(null, 0, 2);',
  7334. ' this.Small = new $mod.TSmallRec();',
  7335. ' this.Enums = {};',
  7336. ' };',
  7337. ' this.$equal = function (b) {',
  7338. ' return (this.Int === b.Int) && ((this.D === b.D) && ((this.Arr === b.Arr)',
  7339. ' && (rtl.arrayEq(this.Arr2, b.Arr2)',
  7340. ' && (this.Small.$equal(b.Small) && rtl.eqSet(this.Enums, b.Enums)))));',
  7341. ' };',
  7342. '};',
  7343. 'this.r = new $mod.TBigRec();',
  7344. 'this.s = new $mod.TBigRec();'
  7345. ]),
  7346. LinesToStr([ // $mod.$main
  7347. '$mod.r = new $mod.TBigRec($mod.s);',
  7348. '$mod.r = new $mod.TBigRec();',
  7349. '$mod.r = new $mod.TBigRec();',
  7350. '']));
  7351. end;
  7352. procedure TTestModule.TestRecord_PassAsArgClone;
  7353. begin
  7354. StartProgram(false);
  7355. Add('type');
  7356. Add(' TRecA = record');
  7357. Add(' Bold: longint;');
  7358. Add(' end;');
  7359. Add('procedure DoDefault(r: treca); begin end;');
  7360. Add('procedure DoConst(const r: treca); begin end;');
  7361. Add('var Rec: treca;');
  7362. Add('begin');
  7363. Add(' dodefault(rec);');
  7364. Add(' doconst(rec);');
  7365. ConvertProgram;
  7366. CheckSource('TestRecord_PassAsArgClone',
  7367. LinesToStr([ // statements
  7368. 'this.TRecA = function (s) {',
  7369. ' if (s) {',
  7370. ' this.Bold = s.Bold;',
  7371. ' } else {',
  7372. ' this.Bold = 0;',
  7373. ' };',
  7374. ' this.$equal = function (b) {',
  7375. ' return this.Bold === b.Bold;',
  7376. ' };',
  7377. '};',
  7378. 'this.DoDefault = function (r) {',
  7379. '};',
  7380. 'this.DoConst = function (r) {',
  7381. '};',
  7382. 'this.Rec = new $mod.TRecA();'
  7383. ]),
  7384. LinesToStr([ // $mod.$main
  7385. '$mod.DoDefault(new $mod.TRecA($mod.Rec));',
  7386. '$mod.DoConst($mod.Rec);',
  7387. '']));
  7388. end;
  7389. procedure TTestModule.TestRecord_AsParams;
  7390. begin
  7391. StartProgram(false);
  7392. Add('type');
  7393. Add(' integer = longint;');
  7394. Add(' TRecord = record');
  7395. Add(' i: integer;');
  7396. Add(' end;');
  7397. Add('procedure DoIt(vG: TRecord; const vH: TRecord; var vI: TRecord);');
  7398. Add('var vJ: TRecord;');
  7399. Add('begin');
  7400. Add(' vg:=vg;');
  7401. Add(' vj:=vh;');
  7402. Add(' vi:=vi;');
  7403. Add(' doit(vg,vg,vg);');
  7404. Add(' doit(vh,vh,vj);');
  7405. Add(' doit(vi,vi,vi);');
  7406. Add(' doit(vj,vj,vj);');
  7407. Add('end;');
  7408. Add('var i: TRecord;');
  7409. Add('begin');
  7410. Add(' doit(i,i,i);');
  7411. ConvertProgram;
  7412. CheckSource('TestRecord_AsParams',
  7413. LinesToStr([ // statements
  7414. 'this.TRecord = function (s) {',
  7415. ' if (s) {',
  7416. ' this.i = s.i;',
  7417. ' } else {',
  7418. ' this.i = 0;',
  7419. ' };',
  7420. ' this.$equal = function (b) {',
  7421. ' return this.i === b.i;',
  7422. ' };',
  7423. '};',
  7424. 'this.DoIt = function (vG,vH,vI) {',
  7425. ' var vJ = new $mod.TRecord();',
  7426. ' vG = new $mod.TRecord(vG);',
  7427. ' vJ = new $mod.TRecord(vH);',
  7428. ' vI.set(new $mod.TRecord(vI.get()));',
  7429. ' $mod.DoIt(new $mod.TRecord(vG), vG, {',
  7430. ' get: function () {',
  7431. ' return vG;',
  7432. ' },',
  7433. ' set: function (v) {',
  7434. ' vG = v;',
  7435. ' }',
  7436. ' });',
  7437. ' $mod.DoIt(new $mod.TRecord(vH), vH, {',
  7438. ' get: function () {',
  7439. ' return vJ;',
  7440. ' },',
  7441. ' set: function (v) {',
  7442. ' vJ = v;',
  7443. ' }',
  7444. ' });',
  7445. ' $mod.DoIt(new $mod.TRecord(vI.get()), vI.get(), vI);',
  7446. ' $mod.DoIt(new $mod.TRecord(vJ), vJ, {',
  7447. ' get: function () {',
  7448. ' return vJ;',
  7449. ' },',
  7450. ' set: function (v) {',
  7451. ' vJ = v;',
  7452. ' }',
  7453. ' });',
  7454. '};',
  7455. 'this.i = new $mod.TRecord();'
  7456. ]),
  7457. LinesToStr([
  7458. '$mod.DoIt(new $mod.TRecord($mod.i),$mod.i,{',
  7459. ' p: $mod,',
  7460. ' get: function () {',
  7461. ' return this.p.i;',
  7462. ' },',
  7463. ' set: function (v) {',
  7464. ' this.p.i = v;',
  7465. ' }',
  7466. '});'
  7467. ]));
  7468. end;
  7469. procedure TTestModule.TestRecordElement_AsParams;
  7470. begin
  7471. StartProgram(false);
  7472. Add('type');
  7473. Add(' integer = longint;');
  7474. Add(' TRecord = record');
  7475. Add(' i: integer;');
  7476. Add(' end;');
  7477. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  7478. Add('var vJ: TRecord;');
  7479. Add('begin');
  7480. Add(' doit(vj.i,vj.i,vj.i);');
  7481. Add('end;');
  7482. Add('var r: TRecord;');
  7483. Add('begin');
  7484. Add(' doit(r.i,r.i,r.i);');
  7485. ConvertProgram;
  7486. CheckSource('TestRecordElement_AsParams',
  7487. LinesToStr([ // statements
  7488. 'this.TRecord = function (s) {',
  7489. ' if (s) {',
  7490. ' this.i = s.i;',
  7491. ' } else {',
  7492. ' this.i = 0;',
  7493. ' };',
  7494. ' this.$equal = function (b) {',
  7495. ' return this.i === b.i;',
  7496. ' };',
  7497. '};',
  7498. 'this.DoIt = function (vG,vH,vI) {',
  7499. ' var vJ = new $mod.TRecord();',
  7500. ' $mod.DoIt(vJ.i, vJ.i, {',
  7501. ' p: vJ,',
  7502. ' get: function () {',
  7503. ' return this.p.i;',
  7504. ' },',
  7505. ' set: function (v) {',
  7506. ' this.p.i = v;',
  7507. ' }',
  7508. ' });',
  7509. '};',
  7510. 'this.r = new $mod.TRecord();'
  7511. ]),
  7512. LinesToStr([
  7513. '$mod.DoIt($mod.r.i,$mod.r.i,{',
  7514. ' p: $mod.r,',
  7515. ' get: function () {',
  7516. ' return this.p.i;',
  7517. ' },',
  7518. ' set: function (v) {',
  7519. ' this.p.i = v;',
  7520. ' }',
  7521. '});'
  7522. ]));
  7523. end;
  7524. procedure TTestModule.TestRecordElementFromFuncResult_AsParams;
  7525. begin
  7526. StartProgram(false);
  7527. Add('type');
  7528. Add(' integer = longint;');
  7529. Add(' TRecord = record');
  7530. Add(' i: integer;');
  7531. Add(' end;');
  7532. Add('function GetRec(vB: integer = 0): TRecord;');
  7533. Add('begin');
  7534. Add('end;');
  7535. Add('procedure DoIt(vG: integer; const vH: integer);');
  7536. Add('begin');
  7537. Add('end;');
  7538. Add('begin');
  7539. Add(' doit(getrec.i,getrec.i);');
  7540. Add(' doit(getrec().i,getrec().i);');
  7541. Add(' doit(getrec(1).i,getrec(2).i);');
  7542. ConvertProgram;
  7543. CheckSource('TestRecordElementFromFuncResult_AsParams',
  7544. LinesToStr([ // statements
  7545. 'this.TRecord = function (s) {',
  7546. ' if (s) {',
  7547. ' this.i = s.i;',
  7548. ' } else {',
  7549. ' this.i = 0;',
  7550. ' };',
  7551. ' this.$equal = function (b) {',
  7552. ' return this.i === b.i;',
  7553. ' };',
  7554. '};',
  7555. 'this.GetRec = function (vB) {',
  7556. ' var Result = new $mod.TRecord();',
  7557. ' return Result;',
  7558. '};',
  7559. 'this.DoIt = function (vG,vH) {',
  7560. '};'
  7561. ]),
  7562. LinesToStr([
  7563. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  7564. '$mod.DoIt($mod.GetRec(0).i,$mod.GetRec(0).i);',
  7565. '$mod.DoIt($mod.GetRec(1).i,$mod.GetRec(2).i);',
  7566. '']));
  7567. end;
  7568. procedure TTestModule.TestRecordElementFromWith_AsParams;
  7569. begin
  7570. StartProgram(false);
  7571. Add('type');
  7572. Add(' integer = longint;');
  7573. Add(' TRecord = record');
  7574. Add(' i: integer;');
  7575. Add(' end;');
  7576. Add('procedure DoIt(vG: integer; const vH: integer; var vI: integer);');
  7577. Add('begin');
  7578. Add('end;');
  7579. Add('var r: trecord;');
  7580. Add('begin');
  7581. Add(' with r do ');
  7582. Add(' doit(i,i,i);');
  7583. ConvertProgram;
  7584. CheckSource('TestRecordElementFromWith_AsParams',
  7585. LinesToStr([ // statements
  7586. 'this.TRecord = function (s) {',
  7587. ' if (s) {',
  7588. ' this.i = s.i;',
  7589. ' } else {',
  7590. ' this.i = 0;',
  7591. ' };',
  7592. ' this.$equal = function (b) {',
  7593. ' return this.i === b.i;',
  7594. ' };',
  7595. '};',
  7596. 'this.DoIt = function (vG,vH,vI) {',
  7597. '};',
  7598. 'this.r = new $mod.TRecord();'
  7599. ]),
  7600. LinesToStr([
  7601. 'var $with1 = $mod.r;',
  7602. '$mod.DoIt($with1.i,$with1.i,{',
  7603. ' p: $with1,',
  7604. ' get: function () {',
  7605. ' return this.p.i;',
  7606. ' },',
  7607. ' set: function (v) {',
  7608. ' this.p.i = v;',
  7609. ' }',
  7610. '});',
  7611. '']));
  7612. end;
  7613. procedure TTestModule.TestRecord_Equal;
  7614. begin
  7615. StartProgram(false);
  7616. Add('type');
  7617. Add(' integer = longint;');
  7618. Add(' TFlag = (red,blue);');
  7619. Add(' TFlags = set of TFlag;');
  7620. Add(' TProc = procedure;');
  7621. Add(' TRecord = record');
  7622. Add(' i: integer;');
  7623. Add(' Event: TProc;');
  7624. Add(' f: TFlags;');
  7625. Add(' end;');
  7626. Add(' TNested = record');
  7627. Add(' r: TRecord;');
  7628. Add(' end;');
  7629. Add('var');
  7630. Add(' b: boolean;');
  7631. Add(' r,s: trecord;');
  7632. Add('begin');
  7633. Add(' b:=r=s;');
  7634. Add(' b:=r<>s;');
  7635. ConvertProgram;
  7636. CheckSource('TestRecord_Equal',
  7637. LinesToStr([ // statements
  7638. 'this.TFlag = {',
  7639. ' "0": "red",',
  7640. ' red: 0,',
  7641. ' "1": "blue",',
  7642. ' blue: 1',
  7643. '};',
  7644. 'this.TRecord = function (s) {',
  7645. ' if (s) {',
  7646. ' this.i = s.i;',
  7647. ' this.Event = s.Event;',
  7648. ' this.f = rtl.refSet(s.f);',
  7649. ' } else {',
  7650. ' this.i = 0;',
  7651. ' this.Event = null;',
  7652. ' this.f = {};',
  7653. ' };',
  7654. ' this.$equal = function (b) {',
  7655. ' return (this.i === b.i) && (rtl.eqCallback(this.Event, b.Event) && rtl.eqSet(this.f, b.f));',
  7656. ' };',
  7657. '};',
  7658. 'this.TNested = function (s) {',
  7659. ' if (s) {',
  7660. ' this.r = new $mod.TRecord(s.r);',
  7661. ' } else {',
  7662. ' this.r = new $mod.TRecord();',
  7663. ' };',
  7664. ' this.$equal = function (b) {',
  7665. ' return this.r.$equal(b.r);',
  7666. ' };',
  7667. '};',
  7668. 'this.b = false;',
  7669. 'this.r = new $mod.TRecord();',
  7670. 'this.s = new $mod.TRecord();'
  7671. ]),
  7672. LinesToStr([
  7673. '$mod.b = $mod.r.$equal($mod.s);',
  7674. '$mod.b = !$mod.r.$equal($mod.s);',
  7675. '']));
  7676. end;
  7677. procedure TTestModule.TestRecord_TypeCastJSValueToRecord;
  7678. begin
  7679. StartProgram(false);
  7680. Add('type');
  7681. Add(' TRecord = record');
  7682. Add(' i: longint;');
  7683. Add(' end;');
  7684. Add('var');
  7685. Add(' Jv: jsvalue;');
  7686. Add(' Rec: trecord;');
  7687. Add('begin');
  7688. Add(' rec:=trecord(jv);');
  7689. ConvertProgram;
  7690. CheckSource('TestRecord_TypeCastJSValueToRecord',
  7691. LinesToStr([ // statements
  7692. 'this.TRecord = function (s) {',
  7693. ' if (s) {',
  7694. ' this.i = s.i;',
  7695. ' } else {',
  7696. ' this.i = 0;',
  7697. ' };',
  7698. ' this.$equal = function (b) {',
  7699. ' return this.i === b.i;',
  7700. ' };',
  7701. '};',
  7702. 'this.Jv = undefined;',
  7703. 'this.Rec = new $mod.TRecord();'
  7704. ]),
  7705. LinesToStr([
  7706. '$mod.Rec = new $mod.TRecord(rtl.getObject($mod.Jv));',
  7707. '']));
  7708. end;
  7709. procedure TTestModule.TestRecord_VariantFail;
  7710. begin
  7711. StartProgram(false);
  7712. Add([
  7713. 'type',
  7714. ' TRec = record',
  7715. ' case word of',
  7716. ' 0: (b0, b1: Byte);',
  7717. ' 1: (i: word);',
  7718. ' end;',
  7719. 'begin']);
  7720. SetExpectedPasResolverError('variant record is not supported',
  7721. nXIsNotSupported);
  7722. ConvertProgram;
  7723. end;
  7724. procedure TTestModule.TestRecord_FieldArray;
  7725. begin
  7726. StartProgram(false);
  7727. Add([
  7728. 'type',
  7729. ' TArrInt = array[3..4] of longint;',
  7730. ' TArrArrInt = array[3..4] of longint;',
  7731. ' TRec = record',
  7732. ' a: array of longint;',
  7733. ' s: array[1..2] of longint;',
  7734. ' m: array[1..2,3..4] of longint;',
  7735. ' o: TArrArrInt;',
  7736. ' end;',
  7737. 'begin']);
  7738. ConvertProgram;
  7739. CheckSource('TestRecord_FieldArray',
  7740. LinesToStr([ // statements
  7741. 'this.TRec = function (s) {',
  7742. ' if (s) {',
  7743. ' this.a = s.a;',
  7744. ' this.s = s.s.slice(0);',
  7745. ' this.m = s.m.slice(0);',
  7746. ' this.o = s.o.slice(0);',
  7747. ' } else {',
  7748. ' this.a = [];',
  7749. ' this.s = rtl.arraySetLength(null, 0, 2);',
  7750. ' this.m = rtl.arraySetLength(null, 0, 2, 2);',
  7751. ' this.o = rtl.arraySetLength(null, 0, 2);',
  7752. ' };',
  7753. ' this.$equal = function (b) {',
  7754. ' return (this.a === b.a) && (rtl.arrayEq(this.s, b.s) && (rtl.arrayEq(this.m, b.m) && rtl.arrayEq(this.o, b.o)));',
  7755. ' };',
  7756. '};',
  7757. '']),
  7758. LinesToStr([ // $mod.$main
  7759. '']));
  7760. end;
  7761. procedure TTestModule.TestRecord_Const;
  7762. begin
  7763. StartProgram(false);
  7764. Add([
  7765. 'type',
  7766. ' TArrInt = array[3..4] of longint;',
  7767. ' TPoint = record x,y: longint; end;',
  7768. ' TRec = record',
  7769. ' i: longint;',
  7770. ' a: array of longint;',
  7771. ' s: array[1..2] of longint;',
  7772. ' m: array[1..2,3..4] of longint;',
  7773. ' p: TPoint;',
  7774. ' end;',
  7775. ' TPoints = array of TPoint;',
  7776. 'const',
  7777. ' r: TRec = (',
  7778. ' i:1;',
  7779. ' a:(2,3);',
  7780. ' s:(4,5);',
  7781. ' m:( (11,12), (13,14) );',
  7782. ' p: (x:21; y:22)',
  7783. ' );',
  7784. ' p: TPoints = ( (x:1;y:2), (x:3;y:4) );',
  7785. 'begin']);
  7786. ConvertProgram;
  7787. CheckSource('TestRecord_Const',
  7788. LinesToStr([ // statements
  7789. 'this.TPoint = function (s) {',
  7790. ' if (s) {',
  7791. ' this.x = s.x;',
  7792. ' this.y = s.y;',
  7793. ' } else {',
  7794. ' this.x = 0;',
  7795. ' this.y = 0;',
  7796. ' };',
  7797. ' this.$equal = function (b) {',
  7798. ' return (this.x === b.x) && (this.y === b.y);',
  7799. ' };',
  7800. '};',
  7801. 'this.TRec = function (s) {',
  7802. ' if (s) {',
  7803. ' this.i = s.i;',
  7804. ' this.a = s.a;',
  7805. ' this.s = s.s.slice(0);',
  7806. ' this.m = s.m.slice(0);',
  7807. ' this.p = new $mod.TPoint(s.p);',
  7808. ' } else {',
  7809. ' this.i = 0;',
  7810. ' this.a = [];',
  7811. ' this.s = rtl.arraySetLength(null, 0, 2);',
  7812. ' this.m = rtl.arraySetLength(null, 0, 2, 2);',
  7813. ' this.p = new $mod.TPoint();',
  7814. ' };',
  7815. ' this.$equal = function (b) {',
  7816. ' return (this.i === b.i) && ((this.a === b.a) && (rtl.arrayEq(this.s, b.s) && (rtl.arrayEq(this.m, b.m) && this.p.$equal(b.p))));',
  7817. ' };',
  7818. '};',
  7819. 'this.r = new $mod.TRec({',
  7820. ' i: 1,',
  7821. ' a: [2, 3],',
  7822. ' s: [4, 5],',
  7823. ' m: [[11, 12], [13, 14]],',
  7824. ' p: new $mod.TPoint({',
  7825. ' x: 21,',
  7826. ' y: 22',
  7827. ' })',
  7828. '});',
  7829. 'this.p = [new $mod.TPoint({',
  7830. ' x: 1,',
  7831. ' y: 2',
  7832. '}), new $mod.TPoint({',
  7833. ' x: 3,',
  7834. ' y: 4',
  7835. '})];',
  7836. '']),
  7837. LinesToStr([ // $mod.$main
  7838. '']));
  7839. end;
  7840. procedure TTestModule.TestRecord_TypecastFail;
  7841. begin
  7842. StartProgram(false);
  7843. Add([
  7844. 'type',
  7845. ' TPoint = record x,y: longint; end;',
  7846. ' TRec = record l: longint end;',
  7847. 'var p: TPoint;',
  7848. 'begin',
  7849. ' if TRec(p).l=2 then ;']);
  7850. SetExpectedPasResolverError('Illegal type conversion: "TPoint" to "record TRec"',
  7851. nIllegalTypeConversionTo);
  7852. ConvertProgram;
  7853. end;
  7854. procedure TTestModule.TestClass_TObjectDefaultConstructor;
  7855. begin
  7856. StartProgram(false);
  7857. Add('type');
  7858. Add(' TObject = class');
  7859. Add(' public');
  7860. Add(' constructor Create;');
  7861. Add(' destructor Destroy;');
  7862. Add(' end;');
  7863. Add(' TBird = TObject;');
  7864. Add('constructor tobject.create;');
  7865. Add('begin end;');
  7866. Add('destructor tobject.destroy;');
  7867. Add('begin end;');
  7868. Add('var Obj: tobject;');
  7869. Add('begin');
  7870. Add(' obj:=tobject.create;');
  7871. Add(' obj:=tbird.create;');
  7872. Add(' obj.destroy;');
  7873. ConvertProgram;
  7874. CheckSource('TestClass_TObjectDefaultConstructor',
  7875. LinesToStr([ // statements
  7876. 'rtl.createClass($mod,"TObject",null,function(){',
  7877. ' this.$init = function () {',
  7878. ' };',
  7879. ' this.$final = function () {',
  7880. ' };',
  7881. ' this.Create = function(){',
  7882. ' };',
  7883. ' this.Destroy = function(){',
  7884. ' };',
  7885. '});',
  7886. 'this.Obj = null;'
  7887. ]),
  7888. LinesToStr([ // $mod.$main
  7889. '$mod.Obj = $mod.TObject.$create("Create");',
  7890. '$mod.Obj = $mod.TObject.$create("Create");',
  7891. '$mod.Obj.$destroy("Destroy");',
  7892. '']));
  7893. end;
  7894. procedure TTestModule.TestClass_TObjectConstructorWithParams;
  7895. begin
  7896. StartProgram(false);
  7897. Add('type');
  7898. Add(' TObject = class');
  7899. Add(' public');
  7900. Add(' constructor Create(Par: longint);');
  7901. Add(' end;');
  7902. Add('constructor tobject.create(par: longint);');
  7903. Add('begin end;');
  7904. Add('var Obj: tobject;');
  7905. Add('begin');
  7906. Add(' obj:=tobject.create(3);');
  7907. ConvertProgram;
  7908. CheckSource('TestClass_TObjectConstructorWithParams',
  7909. LinesToStr([ // statements
  7910. 'rtl.createClass($mod,"TObject",null,function(){',
  7911. ' this.$init = function () {',
  7912. ' };',
  7913. ' this.$final = function () {',
  7914. ' };',
  7915. ' this.Create = function(Par){',
  7916. ' };',
  7917. '});',
  7918. 'this.Obj = null;'
  7919. ]),
  7920. LinesToStr([ // $mod.$main
  7921. '$mod.Obj = $mod.TObject.$create("Create",[3]);'
  7922. ]));
  7923. end;
  7924. procedure TTestModule.TestClass_TObjectConstructorWithDefaultParam;
  7925. begin
  7926. StartProgram(false);
  7927. Add('type');
  7928. Add(' TObject = class');
  7929. Add(' public');
  7930. Add(' constructor Create;');
  7931. Add(' end;');
  7932. Add(' TTest = class(TObject)');
  7933. Add(' public');
  7934. Add(' constructor Create(const Par: longint = 1);');
  7935. Add(' end;');
  7936. Add('constructor tobject.create;');
  7937. Add('begin end;');
  7938. Add('constructor ttest.create(const par: longint);');
  7939. Add('begin end;');
  7940. Add('var t: ttest;');
  7941. Add('begin');
  7942. Add(' t:=ttest.create;');
  7943. Add(' t:=ttest.create(2);');
  7944. ConvertProgram;
  7945. CheckSource('TestClass_TObjectConstructorWithDefaultParam',
  7946. LinesToStr([ // statements
  7947. 'rtl.createClass($mod,"TObject",null,function(){',
  7948. ' this.$init = function () {',
  7949. ' };',
  7950. ' this.$final = function () {',
  7951. ' };',
  7952. ' this.Create = function(){',
  7953. ' };',
  7954. '});',
  7955. 'rtl.createClass($mod, "TTest", $mod.TObject, function () {',
  7956. ' this.Create$1 = function (Par) {',
  7957. ' };',
  7958. '});',
  7959. 'this.t = null;'
  7960. ]),
  7961. LinesToStr([ // $mod.$main
  7962. '$mod.t = $mod.TTest.$create("Create$1", [1]);',
  7963. '$mod.t = $mod.TTest.$create("Create$1", [2]);'
  7964. ]));
  7965. end;
  7966. procedure TTestModule.TestClass_Var;
  7967. begin
  7968. StartProgram(false);
  7969. Add('type');
  7970. Add(' TObject = class');
  7971. Add(' public');
  7972. Add(' vI: longint;');
  7973. Add(' constructor Create(Par: longint);');
  7974. Add(' end;');
  7975. Add('constructor tobject.create(par: longint);');
  7976. Add('begin');
  7977. Add(' vi:=par+3');
  7978. Add('end;');
  7979. Add('var Obj: tobject;');
  7980. Add('begin');
  7981. Add(' obj:=tobject.create(4);');
  7982. Add(' obj.vi:=obj.VI+5;');
  7983. ConvertProgram;
  7984. CheckSource('TestClass_Var',
  7985. LinesToStr([ // statements
  7986. 'rtl.createClass($mod,"TObject",null,function(){',
  7987. ' this.$init = function () {',
  7988. ' this.vI = 0;',
  7989. ' };',
  7990. ' this.$final = function () {',
  7991. ' };',
  7992. ' this.Create = function(Par){',
  7993. ' this.vI = Par+3;',
  7994. ' };',
  7995. '});',
  7996. 'this.Obj = null;'
  7997. ]),
  7998. LinesToStr([ // $mod.$main
  7999. '$mod.Obj = $mod.TObject.$create("Create",[4]);',
  8000. '$mod.Obj.vI = $mod.Obj.vI + 5;'
  8001. ]));
  8002. end;
  8003. procedure TTestModule.TestClass_Method;
  8004. begin
  8005. StartProgram(false);
  8006. Add('type');
  8007. Add(' TObject = class');
  8008. Add(' public');
  8009. Add(' vI: longint;');
  8010. Add(' Sub: TObject;');
  8011. Add(' constructor Create;');
  8012. Add(' function GetIt(Par: longint): tobject;');
  8013. Add(' end;');
  8014. Add('constructor tobject.create; begin end;');
  8015. Add('function tobject.getit(par: longint): tobject;');
  8016. Add('begin');
  8017. Add(' Self.vi:=par+3;');
  8018. Add(' Result:=self.sub;');
  8019. Add('end;');
  8020. Add('var Obj: tobject;');
  8021. Add('begin');
  8022. Add(' obj:=tobject.create;');
  8023. Add(' obj.getit(4);');
  8024. Add(' obj.sub.sub:=nil;');
  8025. Add(' obj.sub.getit(5);');
  8026. Add(' obj.sub.getit(6).SUB:=nil;');
  8027. Add(' obj.sub.getit(7).GETIT(8);');
  8028. Add(' obj.sub.getit(9).SuB.getit(10);');
  8029. ConvertProgram;
  8030. CheckSource('TestClass_Method',
  8031. LinesToStr([ // statements
  8032. 'rtl.createClass($mod,"TObject",null,function(){',
  8033. ' this.$init = function () {',
  8034. ' this.vI = 0;',
  8035. ' this.Sub = null;',
  8036. ' };',
  8037. ' this.$final = function () {',
  8038. ' this.Sub = undefined;',
  8039. ' };',
  8040. ' this.Create = function(){',
  8041. ' };',
  8042. ' this.GetIt = function(Par){',
  8043. ' var Result = null;',
  8044. ' this.vI = Par + 3;',
  8045. ' Result = this.Sub;',
  8046. ' return Result;',
  8047. ' };',
  8048. '});',
  8049. 'this.Obj = null;'
  8050. ]),
  8051. LinesToStr([ // $mod.$main
  8052. '$mod.Obj = $mod.TObject.$create("Create");',
  8053. '$mod.Obj.GetIt(4);',
  8054. '$mod.Obj.Sub.Sub=null;',
  8055. '$mod.Obj.Sub.GetIt(5);',
  8056. '$mod.Obj.Sub.GetIt(6).Sub=null;',
  8057. '$mod.Obj.Sub.GetIt(7).GetIt(8);',
  8058. '$mod.Obj.Sub.GetIt(9).Sub.GetIt(10);'
  8059. ]));
  8060. end;
  8061. procedure TTestModule.TestClass_Implementation;
  8062. begin
  8063. StartUnit(false);
  8064. Add([
  8065. 'interface',
  8066. 'type',
  8067. ' TObject = class',
  8068. ' constructor Create;',
  8069. ' end;',
  8070. 'implementation',
  8071. 'type',
  8072. ' TIntClass = class',
  8073. ' constructor Create; reintroduce;',
  8074. ' class procedure DoGlob;',
  8075. ' end;',
  8076. 'constructor tintclass.create;',
  8077. 'begin',
  8078. ' inherited;',
  8079. ' inherited create;',
  8080. ' doglob;',
  8081. 'end;',
  8082. 'class procedure tintclass.doglob;',
  8083. 'begin',
  8084. 'end;',
  8085. 'constructor tobject.create;',
  8086. 'var',
  8087. ' iC: tintclass;',
  8088. 'begin',
  8089. ' ic:=tintclass.create;',
  8090. ' tintclass.doglob;',
  8091. ' ic.doglob;',
  8092. 'end;',
  8093. 'initialization',
  8094. ' tintclass.doglob;',
  8095. '']);
  8096. ConvertUnit;
  8097. CheckSource('TestClass_Implementation',
  8098. LinesToStr([ // statements
  8099. 'var $impl = $mod.$impl;',
  8100. 'rtl.createClass($mod, "TObject", null, function () {',
  8101. ' this.$init = function () {',
  8102. ' };',
  8103. ' this.$final = function () {',
  8104. ' };',
  8105. ' this.Create = function () {',
  8106. ' var iC = null;',
  8107. ' iC = $impl.TIntClass.$create("Create$1");',
  8108. ' $impl.TIntClass.DoGlob();',
  8109. ' iC.$class.DoGlob();',
  8110. ' };',
  8111. '});',
  8112. '']),
  8113. LinesToStr([ // $mod.$main
  8114. '$impl.TIntClass.DoGlob();',
  8115. '']),
  8116. LinesToStr([
  8117. 'rtl.createClass($impl, "TIntClass", $mod.TObject, function () {',
  8118. ' this.Create$1 = function () {',
  8119. ' $mod.TObject.Create.apply(this, arguments);',
  8120. ' $mod.TObject.Create.call(this);',
  8121. ' this.$class.DoGlob();',
  8122. ' };',
  8123. ' this.DoGlob = function () {',
  8124. ' };',
  8125. '});',
  8126. '']));
  8127. end;
  8128. procedure TTestModule.TestClass_Inheritance;
  8129. begin
  8130. StartProgram(false);
  8131. Add('type');
  8132. Add(' TObject = class');
  8133. Add(' public');
  8134. Add(' constructor Create;');
  8135. Add(' end;');
  8136. Add(' TClassA = class');
  8137. Add(' end;');
  8138. Add(' TClassB = class(TObject)');
  8139. Add(' procedure ProcB;');
  8140. Add(' end;');
  8141. Add('constructor tobject.create; begin end;');
  8142. Add('procedure tclassb.procb; begin end;');
  8143. Add('var');
  8144. Add(' oO: TObject;');
  8145. Add(' oA: TClassA;');
  8146. Add(' oB: TClassB;');
  8147. Add('begin');
  8148. Add(' oO:=tobject.Create;');
  8149. Add(' oA:=tclassa.Create;');
  8150. Add(' ob:=tclassb.Create;');
  8151. Add(' if oo is tclassa then ;');
  8152. Add(' ob:=oo as tclassb;');
  8153. Add(' (oo as tclassb).procb;');
  8154. ConvertProgram;
  8155. CheckSource('TestClass_Inheritance',
  8156. LinesToStr([ // statements
  8157. 'rtl.createClass($mod,"TObject",null,function(){',
  8158. ' this.$init = function () {',
  8159. ' };',
  8160. ' this.$final = function () {',
  8161. ' };',
  8162. ' this.Create = function () {',
  8163. ' };',
  8164. '});',
  8165. 'rtl.createClass($mod,"TClassA",$mod.TObject,function(){',
  8166. '});',
  8167. 'rtl.createClass($mod,"TClassB",$mod.TObject,function(){',
  8168. ' this.ProcB = function () {',
  8169. ' };',
  8170. '});',
  8171. 'this.oO = null;',
  8172. 'this.oA = null;',
  8173. 'this.oB = null;'
  8174. ]),
  8175. LinesToStr([ // $mod.$main
  8176. '$mod.oO = $mod.TObject.$create("Create");',
  8177. '$mod.oA = $mod.TClassA.$create("Create");',
  8178. '$mod.oB = $mod.TClassB.$create("Create");',
  8179. 'if ($mod.TClassA.isPrototypeOf($mod.oO));',
  8180. '$mod.oB = rtl.as($mod.oO, $mod.TClassB);',
  8181. 'rtl.as($mod.oO, $mod.TClassB).ProcB();'
  8182. ]));
  8183. end;
  8184. procedure TTestModule.TestClass_TypeAlias;
  8185. begin
  8186. StartProgram(false);
  8187. Add([
  8188. '{$interfaces corba}',
  8189. 'type',
  8190. ' IObject = interface',
  8191. ' end;',
  8192. ' IBird = type IObject;',
  8193. ' TObject = class',
  8194. ' end;',
  8195. ' TBird = type TObject;',
  8196. 'var',
  8197. ' oObj: TObject;',
  8198. ' oBird: TBird;',
  8199. ' IntfObj: IObject;',
  8200. ' IntfBird: IBird;',
  8201. 'begin',
  8202. ' oObj:=oBird;',
  8203. '']);
  8204. ConvertProgram;
  8205. CheckSource('TestClass_TypeAlias',
  8206. LinesToStr([ // statements
  8207. 'rtl.createInterface($mod, "IObject", "{5B8AD21A-8000-3000-8000-000000000000}", [], null);',
  8208. 'rtl.createInterface($mod, "IBird", "{48DF66C6-FD76-3B15-A738-D462ECC63074}", [], $mod.IObject);',
  8209. 'rtl.createClass($mod, "TObject", null, function () {',
  8210. ' this.$init = function () {',
  8211. ' };',
  8212. ' this.$final = function () {',
  8213. ' };',
  8214. '});',
  8215. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  8216. '});',
  8217. 'this.oObj = null;',
  8218. 'this.oBird = null;',
  8219. 'this.IntfObj = null;',
  8220. 'this.IntfBird = null;',
  8221. '']),
  8222. LinesToStr([ // $mod.$main
  8223. '$mod.oObj = $mod.oBird;',
  8224. '']));
  8225. end;
  8226. procedure TTestModule.TestClass_AbstractMethod;
  8227. begin
  8228. StartProgram(false);
  8229. Add('type');
  8230. Add(' TObject = class');
  8231. Add(' public');
  8232. Add(' procedure DoIt; virtual; abstract;');
  8233. Add(' end;');
  8234. Add('begin');
  8235. ConvertProgram;
  8236. CheckSource('TestClass_AbstractMethod',
  8237. LinesToStr([ // statements
  8238. 'rtl.createClass($mod,"TObject",null,function(){',
  8239. ' this.$init = function () {',
  8240. ' };',
  8241. ' this.$final = function () {',
  8242. ' };',
  8243. '});'
  8244. ]),
  8245. LinesToStr([ // this.$main
  8246. ''
  8247. ]));
  8248. end;
  8249. procedure TTestModule.TestClass_CallInherited_NoParams;
  8250. begin
  8251. StartProgram(false);
  8252. Add('type');
  8253. Add(' TObject = class');
  8254. Add(' procedure DoAbstract; virtual; abstract;');
  8255. Add(' procedure DoVirtual; virtual;');
  8256. Add(' procedure DoIt;');
  8257. Add(' end;');
  8258. Add(' TA = class');
  8259. Add(' procedure doabstract; override;');
  8260. Add(' procedure dovirtual; override;');
  8261. Add(' procedure DoSome;');
  8262. Add(' end;');
  8263. Add('procedure tobject.dovirtual;');
  8264. Add('begin');
  8265. Add(' inherited; // call non existing ancestor -> ignore silently');
  8266. Add('end;');
  8267. Add('procedure tobject.doit;');
  8268. Add('begin');
  8269. Add('end;');
  8270. Add('procedure ta.doabstract;');
  8271. Add('begin');
  8272. Add(' inherited dovirtual; // call TObject.DoVirtual');
  8273. Add('end;');
  8274. Add('procedure ta.dovirtual;');
  8275. Add('begin');
  8276. Add(' inherited; // call TObject.DoVirtual');
  8277. Add(' inherited dovirtual; // call TObject.DoVirtual');
  8278. Add(' inherited dovirtual(); // call TObject.DoVirtual');
  8279. Add(' doit;');
  8280. Add(' doit();');
  8281. Add('end;');
  8282. Add('procedure ta.dosome;');
  8283. Add('begin');
  8284. Add(' inherited; // call non existing ancestor method -> silently ignore');
  8285. Add('end;');
  8286. Add('begin');
  8287. ConvertProgram;
  8288. CheckSource('TestClass_CallInherited_NoParams',
  8289. LinesToStr([ // statements
  8290. 'rtl.createClass($mod,"TObject",null,function(){',
  8291. ' this.$init = function () {',
  8292. ' };',
  8293. ' this.$final = function () {',
  8294. ' };',
  8295. ' this.DoVirtual = function () {',
  8296. ' };',
  8297. ' this.DoIt = function () {',
  8298. ' };',
  8299. '});',
  8300. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  8301. ' this.DoAbstract = function () {',
  8302. ' $mod.TObject.DoVirtual.call(this);',
  8303. ' };',
  8304. ' this.DoVirtual = function () {',
  8305. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  8306. ' $mod.TObject.DoVirtual.call(this);',
  8307. ' $mod.TObject.DoVirtual.call(this);',
  8308. ' this.DoIt();',
  8309. ' this.DoIt();',
  8310. ' };',
  8311. ' this.DoSome = function () {',
  8312. ' };',
  8313. '});'
  8314. ]),
  8315. LinesToStr([ // this.$main
  8316. ''
  8317. ]));
  8318. end;
  8319. procedure TTestModule.TestClass_CallInherited_WithParams;
  8320. begin
  8321. StartProgram(false);
  8322. Add('type');
  8323. Add(' TObject = class');
  8324. Add(' procedure DoAbstract(pA: longint; pB: longint = 0); virtual; abstract;');
  8325. Add(' procedure DoVirtual(pA: longint; pB: longint = 0); virtual;');
  8326. Add(' procedure DoIt(pA: longint; pB: longint = 0);');
  8327. Add(' procedure DoIt2(pA: longint = 1; pB: longint = 2);');
  8328. Add(' end;');
  8329. Add(' TClassA = class');
  8330. Add(' procedure DoAbstract(pA: longint; pB: longint = 0); override;');
  8331. Add(' procedure DoVirtual(pA: longint; pB: longint = 0); override;');
  8332. Add(' end;');
  8333. Add('procedure tobject.dovirtual(pa: longint; pb: longint = 0);');
  8334. Add('begin');
  8335. Add('end;');
  8336. Add('procedure tobject.doit(pa: longint; pb: longint = 0);');
  8337. Add('begin');
  8338. Add('end;');
  8339. Add('procedure tobject.doit2(pa: longint; pb: longint = 0);');
  8340. Add('begin');
  8341. Add('end;');
  8342. Add('procedure tclassa.doabstract(pa: longint; pb: longint = 0);');
  8343. Add('begin');
  8344. Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
  8345. Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
  8346. Add('end;');
  8347. Add('procedure tclassa.dovirtual(pa: longint; pb: longint = 0);');
  8348. Add('begin');
  8349. Add(' inherited; // call TObject.DoVirtual(pA,pB)');
  8350. Add(' inherited dovirtual(pa,pb); // call TObject.DoVirtual(pA,pB)');
  8351. Add(' inherited dovirtual(pa); // call TObject.DoVirtual(pA,0)');
  8352. Add(' doit(pa,pb);');
  8353. Add(' doit(pa);');
  8354. Add(' doit2(pa);');
  8355. Add(' doit2;');
  8356. Add('end;');
  8357. Add('begin');
  8358. ConvertProgram;
  8359. CheckSource('TestClass_CallInherited_WithParams',
  8360. LinesToStr([ // statements
  8361. 'rtl.createClass($mod,"TObject",null,function(){',
  8362. ' this.$init = function () {',
  8363. ' };',
  8364. ' this.$final = function () {',
  8365. ' };',
  8366. ' this.DoVirtual = function (pA,pB) {',
  8367. ' };',
  8368. ' this.DoIt = function (pA,pB) {',
  8369. ' };',
  8370. ' this.DoIt2 = function (pA,pB) {',
  8371. ' };',
  8372. '});',
  8373. 'rtl.createClass($mod, "TClassA", $mod.TObject, function () {',
  8374. ' this.DoAbstract = function (pA,pB) {',
  8375. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  8376. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  8377. ' };',
  8378. ' this.DoVirtual = function (pA,pB) {',
  8379. ' $mod.TObject.DoVirtual.apply(this, arguments);',
  8380. ' $mod.TObject.DoVirtual.call(this,pA,pB);',
  8381. ' $mod.TObject.DoVirtual.call(this,pA,0);',
  8382. ' this.DoIt(pA,pB);',
  8383. ' this.DoIt(pA,0);',
  8384. ' this.DoIt2(pA,2);',
  8385. ' this.DoIt2(1,2);',
  8386. ' };',
  8387. '});'
  8388. ]),
  8389. LinesToStr([ // this.$main
  8390. ''
  8391. ]));
  8392. end;
  8393. procedure TTestModule.TestClasS_CallInheritedConstructor;
  8394. begin
  8395. StartProgram(false);
  8396. Add('type');
  8397. Add(' TObject = class');
  8398. Add(' constructor Create; virtual;');
  8399. Add(' constructor CreateWithB(b: boolean);');
  8400. Add(' end;');
  8401. Add(' TA = class');
  8402. Add(' constructor Create; override;');
  8403. Add(' constructor CreateWithC(c: char);');
  8404. Add(' procedure DoIt;');
  8405. Add(' class function DoSome: TObject;');
  8406. Add(' end;');
  8407. Add('constructor tobject.create;');
  8408. Add('begin');
  8409. Add(' inherited; // call non existing ancestor -> ignore silently');
  8410. Add('end;');
  8411. Add('constructor tobject.createwithb(b: boolean);');
  8412. Add('begin');
  8413. Add(' inherited; // call non existing ancestor -> ignore silently');
  8414. Add(' create; // normal call');
  8415. Add('end;');
  8416. Add('constructor ta.create;');
  8417. Add('begin');
  8418. Add(' inherited; // normal call TObject.Create');
  8419. Add(' inherited create; // normal call TObject.Create');
  8420. Add(' inherited createwithb(false); // normal call TObject.CreateWithB');
  8421. Add('end;');
  8422. Add('constructor ta.createwithc(c: char);');
  8423. Add('begin');
  8424. Add(' inherited create; // call TObject.Create');
  8425. Add(' inherited createwithb(true); // call TObject.CreateWithB');
  8426. Add(' doit;');
  8427. Add(' doit();');
  8428. Add(' dosome;');
  8429. Add('end;');
  8430. Add('procedure ta.doit;');
  8431. Add('begin');
  8432. Add(' create; // normal call');
  8433. Add(' createwithb(false); // normal call');
  8434. Add(' createwithc(''c''); // normal call');
  8435. Add('end;');
  8436. Add('class function ta.dosome: TObject;');
  8437. Add('begin');
  8438. Add(' Result:=create; // constructor');
  8439. Add(' Result:=createwithb(true); // constructor');
  8440. Add(' Result:=createwithc(''c''); // constructor');
  8441. Add('end;');
  8442. Add('begin');
  8443. ConvertProgram;
  8444. CheckSource('TestClass_CallInheritedConstructor',
  8445. LinesToStr([ // statements
  8446. 'rtl.createClass($mod,"TObject",null,function(){',
  8447. ' this.$init = function () {',
  8448. ' };',
  8449. ' this.$final = function () {',
  8450. ' };',
  8451. ' this.Create = function () {',
  8452. ' };',
  8453. ' this.CreateWithB = function (b) {',
  8454. ' this.Create();',
  8455. ' };',
  8456. '});',
  8457. 'rtl.createClass($mod, "TA", $mod.TObject, function () {',
  8458. ' this.Create = function () {',
  8459. ' $mod.TObject.Create.apply(this, arguments);',
  8460. ' $mod.TObject.Create.call(this);',
  8461. ' $mod.TObject.CreateWithB.call(this, false);',
  8462. ' };',
  8463. ' this.CreateWithC = function (c) {',
  8464. ' $mod.TObject.Create.call(this);',
  8465. ' $mod.TObject.CreateWithB.call(this, true);',
  8466. ' this.DoIt();',
  8467. ' this.DoIt();',
  8468. ' this.$class.DoSome();',
  8469. ' };',
  8470. ' this.DoIt = function () {',
  8471. ' this.Create();',
  8472. ' this.CreateWithB(false);',
  8473. ' this.CreateWithC("c");',
  8474. ' };',
  8475. ' this.DoSome = function () {',
  8476. ' var Result = null;',
  8477. ' Result = this.$create("Create");',
  8478. ' Result = this.$create("CreateWithB", [true]);',
  8479. ' Result = this.$create("CreateWithC", ["c"]);',
  8480. ' return Result;',
  8481. ' };',
  8482. '});'
  8483. ]),
  8484. LinesToStr([ // this.$main
  8485. ''
  8486. ]));
  8487. end;
  8488. procedure TTestModule.TestClass_ClassVar;
  8489. begin
  8490. StartProgram(false);
  8491. Add('type');
  8492. Add(' TObject = class');
  8493. Add(' public');
  8494. Add(' class var vI: longint;');
  8495. Add(' class var Sub: TObject;');
  8496. Add(' constructor Create;');
  8497. Add(' class function GetIt(Par: longint): tobject;');
  8498. Add(' end;');
  8499. Add('constructor tobject.create;');
  8500. Add('begin');
  8501. Add(' vi:=vi+1;');
  8502. Add(' Self.vi:=Self.vi+1;');
  8503. Add('end;');
  8504. Add('class function tobject.getit(par: longint): tobject;');
  8505. Add('begin');
  8506. Add(' vi:=vi+par;');
  8507. Add(' Self.vi:=Self.vi+par;');
  8508. Add(' Result:=self.sub;');
  8509. Add('end;');
  8510. Add('var Obj: tobject;');
  8511. Add('begin');
  8512. Add(' obj:=tobject.create;');
  8513. Add(' tobject.vi:=3;');
  8514. Add(' if tobject.vi=4 then ;');
  8515. Add(' tobject.sub:=nil;');
  8516. Add(' obj.sub:=nil;');
  8517. Add(' obj.sub.sub:=nil;');
  8518. ConvertProgram;
  8519. CheckSource('TestClass_ClassVar',
  8520. LinesToStr([ // statements
  8521. 'rtl.createClass($mod,"TObject",null,function(){',
  8522. ' this.vI = 0;',
  8523. ' this.Sub = null;',
  8524. ' this.$init = function () {',
  8525. ' };',
  8526. ' this.$final = function () {',
  8527. ' };',
  8528. ' this.Create = function(){',
  8529. ' this.$class.vI = this.vI+1;',
  8530. ' this.$class.vI = this.vI+1;',
  8531. ' };',
  8532. ' this.GetIt = function(Par){',
  8533. ' var Result = null;',
  8534. ' this.vI = this.vI + Par;',
  8535. ' this.vI = this.vI + Par;',
  8536. ' Result = this.Sub;',
  8537. ' return Result;',
  8538. ' };',
  8539. '});',
  8540. 'this.Obj = null;'
  8541. ]),
  8542. LinesToStr([ // $mod.$main
  8543. '$mod.Obj = $mod.TObject.$create("Create");',
  8544. '$mod.TObject.vI = 3;',
  8545. 'if ($mod.TObject.vI === 4);',
  8546. '$mod.TObject.Sub=null;',
  8547. '$mod.Obj.$class.Sub=null;',
  8548. '$mod.Obj.Sub.$class.Sub=null;',
  8549. '']));
  8550. end;
  8551. procedure TTestModule.TestClass_CallClassMethod;
  8552. begin
  8553. StartProgram(false);
  8554. Add('type');
  8555. Add(' TObject = class');
  8556. Add(' public');
  8557. Add(' class var vI: longint;');
  8558. Add(' class var Sub: TObject;');
  8559. Add(' constructor Create;');
  8560. Add(' function GetMore(Par: longint): longint;');
  8561. Add(' class function GetIt(Par: longint): tobject;');
  8562. Add(' end;');
  8563. Add('constructor tobject.create;');
  8564. Add('begin');
  8565. Add(' sub:=getit(3);');
  8566. Add(' vi:=getmore(4);');
  8567. Add(' sub:=Self.getit(5);');
  8568. Add(' vi:=Self.getmore(6);');
  8569. Add('end;');
  8570. Add('function tobject.getmore(par: longint): longint;');
  8571. Add('begin');
  8572. Add(' sub:=getit(11);');
  8573. Add(' vi:=getmore(12);');
  8574. Add(' sub:=self.getit(13);');
  8575. Add(' vi:=self.getmore(14);');
  8576. Add('end;');
  8577. Add('class function tobject.getit(par: longint): tobject;');
  8578. Add('begin');
  8579. Add(' sub:=getit(21);');
  8580. Add(' vi:=sub.getmore(22);');
  8581. Add(' sub:=self.getit(23);');
  8582. Add(' vi:=self.sub.getmore(24);');
  8583. Add('end;');
  8584. Add('var Obj: tobject;');
  8585. Add('begin');
  8586. Add(' obj:=tobject.create;');
  8587. Add(' tobject.getit(5);');
  8588. Add(' obj.getit(6);');
  8589. Add(' obj.sub.getit(7);');
  8590. Add(' obj.sub.getit(8).SUB:=nil;');
  8591. Add(' obj.sub.getit(9).GETIT(10);');
  8592. Add(' obj.sub.getit(11).SuB.getit(12);');
  8593. ConvertProgram;
  8594. CheckSource('TestClass_CallClassMethod',
  8595. LinesToStr([ // statements
  8596. 'rtl.createClass($mod,"TObject",null,function(){',
  8597. ' this.vI = 0;',
  8598. ' this.Sub = null;',
  8599. ' this.$init = function () {',
  8600. ' };',
  8601. ' this.$final = function () {',
  8602. ' };',
  8603. ' this.Create = function(){',
  8604. ' this.$class.Sub = this.$class.GetIt(3);',
  8605. ' this.$class.vI = this.GetMore(4);',
  8606. ' this.$class.Sub = this.$class.GetIt(5);',
  8607. ' this.$class.vI = this.GetMore(6);',
  8608. ' };',
  8609. ' this.GetMore = function(Par){',
  8610. ' var Result = 0;',
  8611. ' this.$class.Sub = this.$class.GetIt(11);',
  8612. ' this.$class.vI = this.GetMore(12);',
  8613. ' this.$class.Sub = this.$class.GetIt(13);',
  8614. ' this.$class.vI = this.GetMore(14);',
  8615. ' return Result;',
  8616. ' };',
  8617. ' this.GetIt = function(Par){',
  8618. ' var Result = null;',
  8619. ' this.Sub = this.GetIt(21);',
  8620. ' this.vI = this.Sub.GetMore(22);',
  8621. ' this.Sub = this.GetIt(23);',
  8622. ' this.vI = this.Sub.GetMore(24);',
  8623. ' return Result;',
  8624. ' };',
  8625. '});',
  8626. 'this.Obj = null;'
  8627. ]),
  8628. LinesToStr([ // $mod.$main
  8629. '$mod.Obj = $mod.TObject.$create("Create");',
  8630. '$mod.TObject.GetIt(5);',
  8631. '$mod.Obj.$class.GetIt(6);',
  8632. '$mod.Obj.Sub.$class.GetIt(7);',
  8633. '$mod.Obj.Sub.$class.GetIt(8).$class.Sub=null;',
  8634. '$mod.Obj.Sub.$class.GetIt(9).$class.GetIt(10);',
  8635. '$mod.Obj.Sub.$class.GetIt(11).Sub.$class.GetIt(12);',
  8636. '']));
  8637. end;
  8638. procedure TTestModule.TestClass_Property;
  8639. begin
  8640. StartProgram(false);
  8641. Add('type');
  8642. Add(' TObject = class');
  8643. Add(' Fx: longint;');
  8644. Add(' Fy: longint;');
  8645. Add(' function GetInt: longint;');
  8646. Add(' procedure SetInt(Value: longint);');
  8647. Add(' procedure DoIt;');
  8648. Add(' property IntA: longint read Fx write Fy;');
  8649. Add(' property IntB: longint read GetInt write SetInt;');
  8650. Add(' end;');
  8651. Add('function tobject.getint: longint;');
  8652. Add('begin');
  8653. Add(' result:=fx;');
  8654. Add('end;');
  8655. Add('procedure tobject.setint(value: longint);');
  8656. Add('begin');
  8657. Add(' if value=fy then exit;');
  8658. Add(' fy:=value;');
  8659. Add('end;');
  8660. Add('procedure tobject.doit;');
  8661. Add('begin');
  8662. Add(' IntA:=IntA+1;');
  8663. Add(' Self.IntA:=Self.IntA+1;');
  8664. Add(' IntB:=IntB+1;');
  8665. Add(' Self.IntB:=Self.IntB+1;');
  8666. Add('end;');
  8667. Add('var Obj: tobject;');
  8668. Add('begin');
  8669. Add(' obj.inta:=obj.inta+1;');
  8670. Add(' if obj.intb=2 then;');
  8671. Add(' obj.intb:=obj.intb+2;');
  8672. Add(' obj.setint(obj.inta);');
  8673. ConvertProgram;
  8674. CheckSource('TestClass_Property',
  8675. LinesToStr([ // statements
  8676. 'rtl.createClass($mod, "TObject", null, function () {',
  8677. ' this.$init = function () {',
  8678. ' this.Fx = 0;',
  8679. ' this.Fy = 0;',
  8680. ' };',
  8681. ' this.$final = function () {',
  8682. ' };',
  8683. ' this.GetInt = function () {',
  8684. ' var Result = 0;',
  8685. ' Result = this.Fx;',
  8686. ' return Result;',
  8687. ' };',
  8688. ' this.SetInt = function (Value) {',
  8689. ' if (Value === this.Fy) return;',
  8690. ' this.Fy = Value;',
  8691. ' };',
  8692. ' this.DoIt = function () {',
  8693. ' this.Fy = this.Fx + 1;',
  8694. ' this.Fy = this.Fx + 1;',
  8695. ' this.SetInt(this.GetInt() + 1);',
  8696. ' this.SetInt(this.GetInt() + 1);',
  8697. ' };',
  8698. '});',
  8699. 'this.Obj = null;'
  8700. ]),
  8701. LinesToStr([ // $mod.$main
  8702. '$mod.Obj.Fy = $mod.Obj.Fx + 1;',
  8703. 'if ($mod.Obj.GetInt() === 2);',
  8704. '$mod.Obj.SetInt($mod.Obj.GetInt() + 2);',
  8705. '$mod.Obj.SetInt($mod.Obj.Fx);'
  8706. ]));
  8707. end;
  8708. procedure TTestModule.TestClass_Property_ClassMethod;
  8709. begin
  8710. StartProgram(false);
  8711. Add('type');
  8712. Add(' TObject = class');
  8713. Add(' class var Fx: longint;');
  8714. Add(' class var Fy: longint;');
  8715. Add(' class function GetInt: longint;');
  8716. Add(' class procedure SetInt(Value: longint);');
  8717. Add(' class procedure DoIt;');
  8718. Add(' class property IntA: longint read Fx write Fy;');
  8719. Add(' class property IntB: longint read GetInt write SetInt;');
  8720. Add(' end;');
  8721. Add('class function tobject.getint: longint;');
  8722. Add('begin');
  8723. Add(' result:=fx;');
  8724. Add('end;');
  8725. Add('class procedure tobject.setint(value: longint);');
  8726. Add('begin');
  8727. Add('end;');
  8728. Add('class procedure tobject.doit;');
  8729. Add('begin');
  8730. Add(' IntA:=IntA+1;');
  8731. Add(' Self.IntA:=Self.IntA+1;');
  8732. Add(' IntB:=IntB+1;');
  8733. Add(' Self.IntB:=Self.IntB+1;');
  8734. Add('end;');
  8735. Add('var Obj: tobject;');
  8736. Add('begin');
  8737. Add(' tobject.inta:=tobject.inta+1;');
  8738. Add(' if tobject.intb=2 then;');
  8739. Add(' tobject.intb:=tobject.intb+2;');
  8740. Add(' tobject.setint(tobject.inta);');
  8741. Add(' obj.inta:=obj.inta+1;');
  8742. Add(' if obj.intb=2 then;');
  8743. Add(' obj.intb:=obj.intb+2;');
  8744. Add(' obj.setint(obj.inta);');
  8745. ConvertProgram;
  8746. CheckSource('TestClass_Property_ClassMethod',
  8747. LinesToStr([ // statements
  8748. 'rtl.createClass($mod, "TObject", null, function () {',
  8749. ' this.Fx = 0;',
  8750. ' this.Fy = 0;',
  8751. ' this.$init = function () {',
  8752. ' };',
  8753. ' this.$final = function () {',
  8754. ' };',
  8755. ' this.GetInt = function () {',
  8756. ' var Result = 0;',
  8757. ' Result = this.Fx;',
  8758. ' return Result;',
  8759. ' };',
  8760. ' this.SetInt = function (Value) {',
  8761. ' };',
  8762. ' this.DoIt = function () {',
  8763. ' this.Fy = this.Fx + 1;',
  8764. ' this.Fy = this.Fx + 1;',
  8765. ' this.SetInt(this.GetInt() + 1);',
  8766. ' this.SetInt(this.GetInt() + 1);',
  8767. ' };',
  8768. '});',
  8769. 'this.Obj = null;'
  8770. ]),
  8771. LinesToStr([ // $mod.$main
  8772. '$mod.TObject.Fy = $mod.TObject.Fx + 1;',
  8773. 'if ($mod.TObject.GetInt() === 2);',
  8774. '$mod.TObject.SetInt($mod.TObject.GetInt() + 2);',
  8775. '$mod.TObject.SetInt($mod.TObject.Fx);',
  8776. '$mod.Obj.$class.Fy = $mod.Obj.Fx + 1;',
  8777. 'if ($mod.Obj.$class.GetInt() === 2);',
  8778. '$mod.Obj.$class.SetInt($mod.Obj.$class.GetInt() + 2);',
  8779. '$mod.Obj.$class.SetInt($mod.Obj.Fx);'
  8780. ]));
  8781. end;
  8782. procedure TTestModule.TestClass_Property_Indexed;
  8783. begin
  8784. StartProgram(false);
  8785. Add('type');
  8786. Add(' TObject = class');
  8787. Add(' FItems: array of longint;');
  8788. Add(' function GetItems(Index: longint): longint;');
  8789. Add(' procedure SetItems(Index: longint; Value: longint);');
  8790. Add(' procedure DoIt;');
  8791. Add(' property Items[Index: longint]: longint read getitems write setitems;');
  8792. Add(' end;');
  8793. Add('function tobject.getitems(index: longint): longint;');
  8794. Add('begin');
  8795. Add(' Result:=fitems[index];');
  8796. Add('end;');
  8797. Add('procedure tobject.setitems(index: longint; value: longint);');
  8798. Add('begin');
  8799. Add(' fitems[index]:=value;');
  8800. Add('end;');
  8801. Add('procedure tobject.doit;');
  8802. Add('begin');
  8803. Add(' items[1]:=2;');
  8804. Add(' items[3]:=items[4];');
  8805. Add(' self.items[5]:=self.items[6];');
  8806. Add(' items[items[7]]:=items[items[8]];');
  8807. Add('end;');
  8808. Add('var Obj: tobject;');
  8809. Add('begin');
  8810. Add(' obj.Items[11]:=obj.Items[12];');
  8811. ConvertProgram;
  8812. CheckSource('TestClass_Property_Indexed',
  8813. LinesToStr([ // statements
  8814. 'rtl.createClass($mod, "TObject", null, function () {',
  8815. ' this.$init = function () {',
  8816. ' this.FItems = [];',
  8817. ' };',
  8818. ' this.$final = function () {',
  8819. ' this.FItems = undefined;',
  8820. ' };',
  8821. ' this.GetItems = function (Index) {',
  8822. ' var Result = 0;',
  8823. ' Result = this.FItems[Index];',
  8824. ' return Result;',
  8825. ' };',
  8826. ' this.SetItems = function (Index, Value) {',
  8827. ' this.FItems[Index] = Value;',
  8828. ' };',
  8829. ' this.DoIt = function () {',
  8830. ' this.SetItems(1, 2);',
  8831. ' this.SetItems(3,this.GetItems(4));',
  8832. ' this.SetItems(5,this.GetItems(6));',
  8833. ' this.SetItems(this.GetItems(7), this.GetItems(this.GetItems(8)));',
  8834. ' };',
  8835. '});',
  8836. 'this.Obj = null;'
  8837. ]),
  8838. LinesToStr([ // $mod.$main
  8839. '$mod.Obj.SetItems(11,$mod.Obj.GetItems(12));'
  8840. ]));
  8841. end;
  8842. procedure TTestModule.TestClass_Property_IndexSpec;
  8843. begin
  8844. StartProgram(false);
  8845. Add([
  8846. 'type',
  8847. ' TEnum = (red, blue);',
  8848. ' TObject = class',
  8849. ' function GetIntBool(Index: longint): boolean; virtual; abstract;',
  8850. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  8851. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  8852. ' procedure SetEnumBool(Index: TEnum; b: boolean); virtual; abstract;',
  8853. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  8854. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  8855. ' property B1: boolean index 1 read GetIntBool write SetIntBool;',
  8856. ' property B2: boolean index TEnum.blue read GetEnumBool write SetEnumBool;',
  8857. ' property B3: boolean index ord(red) read GetIntBool write SetIntBool;',
  8858. ' property I1[A: String]: boolean index ord(blue) read GetStrIntBool write SetStrIntBool;',
  8859. ' end;',
  8860. 'procedure DoIt(b: boolean); begin end;',
  8861. 'var',
  8862. ' o: TObject;',
  8863. 'begin',
  8864. ' o.B1:=o.B1;',
  8865. ' o.B2:=o.B2;',
  8866. ' o.B3:=o.B3;',
  8867. ' o.I1[''a'']:=o.I1[''b''];',
  8868. ' doit(o.b1);',
  8869. ' doit(o.b2);',
  8870. ' doit(o.i1[''c'']);',
  8871. '']);
  8872. ConvertProgram;
  8873. CheckSource('TestClass_Property_IndexSpec',
  8874. LinesToStr([ // statements
  8875. 'this.TEnum = {',
  8876. ' "0": "red",',
  8877. ' red: 0,',
  8878. ' "1": "blue",',
  8879. ' blue: 1',
  8880. '};',
  8881. 'rtl.createClass($mod, "TObject", null, function () {',
  8882. ' this.$init = function () {',
  8883. ' };',
  8884. ' this.$final = function () {',
  8885. ' };',
  8886. '});',
  8887. 'this.DoIt = function (b) {',
  8888. '};',
  8889. 'this.o = null;',
  8890. '']),
  8891. LinesToStr([ // $mod.$main
  8892. '$mod.o.SetIntBool(1, $mod.o.GetIntBool(1));',
  8893. '$mod.o.SetEnumBool($mod.TEnum.blue, $mod.o.GetEnumBool($mod.TEnum.blue));',
  8894. '$mod.o.SetIntBool(0, $mod.o.GetIntBool(0));',
  8895. '$mod.o.SetStrIntBool("a", 1, $mod.o.GetStrIntBool("b", 1));',
  8896. '$mod.DoIt($mod.o.GetIntBool(1));',
  8897. '$mod.DoIt($mod.o.GetEnumBool($mod.TEnum.blue));',
  8898. '$mod.DoIt($mod.o.GetStrIntBool("c", 1));',
  8899. '']));
  8900. end;
  8901. procedure TTestModule.TestClass_PropertyOfTypeArray;
  8902. begin
  8903. StartProgram(false);
  8904. Add('type');
  8905. Add(' TArray = array of longint;');
  8906. Add(' TObject = class');
  8907. Add(' FItems: TArray;');
  8908. Add(' function GetItems: tarray;');
  8909. Add(' procedure SetItems(Value: tarray);');
  8910. Add(' property Items: tarray read getitems write setitems;');
  8911. Add(' end;');
  8912. Add('function tobject.getitems: tarray;');
  8913. Add('begin');
  8914. Add(' Result:=fitems;');
  8915. Add('end;');
  8916. Add('procedure tobject.setitems(value: tarray);');
  8917. Add('begin');
  8918. Add(' fitems:=value;');
  8919. Add(' fitems:=nil;');
  8920. Add(' Items:=nil;');
  8921. Add(' Items:=Items;');
  8922. Add(' Items[1]:=2;');
  8923. Add(' fitems[3]:=Items[4];');
  8924. Add(' Items[5]:=Items[6];');
  8925. Add(' Self.Items[7]:=8;');
  8926. Add(' Self.Items[9]:=Self.Items[10];');
  8927. Add(' Items[Items[11]]:=Items[Items[12]];');
  8928. Add('end;');
  8929. Add('var Obj: tobject;');
  8930. Add('begin');
  8931. Add(' obj.items:=nil;');
  8932. Add(' obj.items:=obj.items;');
  8933. Add(' obj.items[11]:=obj.items[12];');
  8934. ConvertProgram;
  8935. CheckSource('TestClass_PropertyOfTypeArray',
  8936. LinesToStr([ // statements
  8937. 'rtl.createClass($mod, "TObject", null, function () {',
  8938. ' this.$init = function () {',
  8939. ' this.FItems = [];',
  8940. ' };',
  8941. ' this.$final = function () {',
  8942. ' this.FItems = undefined;',
  8943. ' };',
  8944. ' this.GetItems = function () {',
  8945. ' var Result = [];',
  8946. ' Result = this.FItems;',
  8947. ' return Result;',
  8948. ' };',
  8949. ' this.SetItems = function (Value) {',
  8950. ' this.FItems = Value;',
  8951. ' this.FItems = [];',
  8952. ' this.SetItems([]);',
  8953. ' this.SetItems(this.GetItems());',
  8954. ' this.GetItems()[1] = 2;',
  8955. ' this.FItems[3] = this.GetItems()[4];',
  8956. ' this.GetItems()[5] = this.GetItems()[6];',
  8957. ' this.GetItems()[7] = 8;',
  8958. ' this.GetItems()[9] = this.GetItems()[10];',
  8959. ' this.GetItems()[this.GetItems()[11]] = this.GetItems()[this.GetItems()[12]];',
  8960. ' };',
  8961. '});',
  8962. 'this.Obj = null;'
  8963. ]),
  8964. LinesToStr([ // $mod.$main
  8965. '$mod.Obj.SetItems([]);',
  8966. '$mod.Obj.SetItems($mod.Obj.GetItems());',
  8967. '$mod.Obj.GetItems()[11] = $mod.Obj.GetItems()[12];'
  8968. ]));
  8969. end;
  8970. procedure TTestModule.TestClass_PropertyDefault;
  8971. begin
  8972. StartProgram(false);
  8973. Add([
  8974. 'type',
  8975. ' TArray = array of longint;',
  8976. ' TObject = class',
  8977. ' FItems: TArray;',
  8978. ' function GetItems(Index: longint): longint;',
  8979. ' procedure SetItems(Index, Value: longint);',
  8980. ' property Items[Index: longint]: longint read getitems write setitems; default;',
  8981. ' end;',
  8982. 'function tobject.getitems(index: longint): longint;',
  8983. 'begin',
  8984. 'end;',
  8985. 'procedure tobject.setitems(index, value: longint);',
  8986. 'begin',
  8987. ' Self[1]:=2;',
  8988. ' Self[3]:=Self[index];',
  8989. ' Self[index]:=Self[Self[value]];',
  8990. ' Self[Self[4]]:=value;',
  8991. 'end;',
  8992. 'var Obj: tobject;',
  8993. 'begin',
  8994. ' obj[11]:=12;',
  8995. ' obj[13]:=obj[14];',
  8996. ' obj[obj[15]]:=obj[obj[15]];',
  8997. ' TObject(obj)[16]:=TObject(obj)[17];']);
  8998. ConvertProgram;
  8999. CheckSource('TestClass_PropertyDefault',
  9000. LinesToStr([ // statements
  9001. 'rtl.createClass($mod, "TObject", null, function () {',
  9002. ' this.$init = function () {',
  9003. ' this.FItems = [];',
  9004. ' };',
  9005. ' this.$final = function () {',
  9006. ' this.FItems = undefined;',
  9007. ' };',
  9008. ' this.GetItems = function (Index) {',
  9009. ' var Result = 0;',
  9010. ' return Result;',
  9011. ' };',
  9012. ' this.SetItems = function (Index, Value) {',
  9013. ' this.SetItems(1, 2);',
  9014. ' this.SetItems(3, this.GetItems(Index));',
  9015. ' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
  9016. ' this.SetItems(this.GetItems(4), Value);',
  9017. ' };',
  9018. '});',
  9019. 'this.Obj = null;'
  9020. ]),
  9021. LinesToStr([ // $mod.$main
  9022. '$mod.Obj.SetItems(11, 12);',
  9023. '$mod.Obj.SetItems(13, $mod.Obj.GetItems(14));',
  9024. '$mod.Obj.SetItems($mod.Obj.GetItems(15), $mod.Obj.GetItems($mod.Obj.GetItems(15)));',
  9025. '$mod.Obj.SetItems(16, $mod.Obj.GetItems(17));',
  9026. '']));
  9027. end;
  9028. procedure TTestModule.TestClass_PropertyDefault2;
  9029. begin
  9030. StartProgram(false);
  9031. Add([
  9032. 'type',
  9033. ' TObject = class end;',
  9034. ' TAlphaList = class',
  9035. ' function GetAlphas(Index: longint): Pointer; virtual; abstract;',
  9036. ' procedure SetAlphas(Index: longint; Value: Pointer); virtual; abstract;',
  9037. ' property Alphas[Index: longint]: Pointer read getAlphas write setAlphas; default;',
  9038. ' end;',
  9039. ' TBetaList = class',
  9040. ' function GetBetas(Index: longint): Pointer; virtual; abstract;',
  9041. ' procedure SetBetas(Index: longint; Value: Pointer); virtual; abstract;',
  9042. ' property Betas[Index: longint]: Pointer read getBetas write setBetas; default;',
  9043. ' end;',
  9044. ' TBird = class',
  9045. ' procedure DoIt;',
  9046. ' end;',
  9047. 'procedure TBird.DoIt;',
  9048. 'var',
  9049. ' List: TAlphaList;',
  9050. 'begin',
  9051. ' if TBetaList(List[2])[3]=nil then ;',
  9052. ' TBetaList(List[4])[5]:=nil;',
  9053. 'end;',
  9054. 'var',
  9055. ' List: TAlphaList;',
  9056. 'begin',
  9057. ' if TBetaList(List[2])[3]=nil then ;',
  9058. ' TBetaList(List[4])[5]:=nil;',
  9059. '']);
  9060. ConvertProgram;
  9061. CheckSource('TestClass_PropertyDefault2',
  9062. LinesToStr([ // statements
  9063. 'rtl.createClass($mod, "TObject", null, function () {',
  9064. ' this.$init = function () {',
  9065. ' };',
  9066. ' this.$final = function () {',
  9067. ' };',
  9068. '});',
  9069. 'rtl.createClass($mod, "TAlphaList", $mod.TObject, function () {',
  9070. '});',
  9071. 'rtl.createClass($mod, "TBetaList", $mod.TObject, function () {',
  9072. '});',
  9073. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  9074. ' this.DoIt = function () {',
  9075. ' var List = null;',
  9076. ' if (List.GetAlphas(2).GetBetas(3) === null) ;',
  9077. ' List.GetAlphas(4).SetBetas(5, null);',
  9078. ' };',
  9079. '});',
  9080. 'this.List = null;',
  9081. '']),
  9082. LinesToStr([ // $mod.$main
  9083. 'if ($mod.List.GetAlphas(2).GetBetas(3) === null) ;',
  9084. '$mod.List.GetAlphas(4).SetBetas(5, null);',
  9085. '']));
  9086. end;
  9087. procedure TTestModule.TestClass_PropertyOverride;
  9088. begin
  9089. StartProgram(false);
  9090. Add('type');
  9091. Add(' integer = longint;');
  9092. Add(' TObject = class');
  9093. Add(' FItem: integer;');
  9094. Add(' function GetItem: integer; external name ''GetItem'';');
  9095. Add(' procedure SetItem(Value: integer); external name ''SetItem'';');
  9096. Add(' property Item: integer read getitem write setitem;');
  9097. Add(' end;');
  9098. Add(' TCar = class');
  9099. Add(' FBag: integer;');
  9100. Add(' function GetBag: integer; external name ''GetBag'';');
  9101. Add(' property Item read getbag;');
  9102. Add(' end;');
  9103. Add('var');
  9104. Add(' Obj: tobject;');
  9105. Add(' Car: tcar;');
  9106. Add('begin');
  9107. Add(' Obj.Item:=Obj.Item;');
  9108. Add(' Car.Item:=Car.Item;');
  9109. ConvertProgram;
  9110. CheckSource('TestClass_PropertyOverride',
  9111. LinesToStr([ // statements
  9112. 'rtl.createClass($mod, "TObject", null, function () {',
  9113. ' this.$init = function () {',
  9114. ' this.FItem = 0;',
  9115. ' };',
  9116. ' this.$final = function () {',
  9117. ' };',
  9118. '});',
  9119. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  9120. ' this.$init = function () {',
  9121. ' $mod.TObject.$init.call(this);',
  9122. ' this.FBag = 0;',
  9123. ' };',
  9124. '});',
  9125. 'this.Obj = null;',
  9126. 'this.Car = null;',
  9127. '']),
  9128. LinesToStr([ // $mod.$main
  9129. '$mod.Obj.SetItem($mod.Obj.GetItem());',
  9130. '$mod.Car.SetItem($mod.Car.GetBag());',
  9131. '']));
  9132. end;
  9133. procedure TTestModule.TestClass_PropertyIncVisibility;
  9134. begin
  9135. AddModuleWithIntfImplSrc('unit1.pp',
  9136. LinesToStr([
  9137. 'type',
  9138. ' TNumber = longint;',
  9139. ' TInteger = longint;',
  9140. ' TObject = class',
  9141. ' private',
  9142. ' function GetItems(Index: TNumber): TInteger; virtual; abstract;',
  9143. ' procedure SetItems(Index: TInteger; Value: TNumber); virtual; abstract;',
  9144. ' protected',
  9145. ' property Items[Index: TNumber]: longint read GetItems write SetItems;',
  9146. ' end;']),
  9147. LinesToStr([
  9148. '']));
  9149. StartProgram(true);
  9150. Add([
  9151. 'uses unit1;',
  9152. 'type',
  9153. ' TBird = class',
  9154. ' public',
  9155. ' property Items;',
  9156. ' end;',
  9157. 'procedure DoIt(i: TInteger);',
  9158. 'begin',
  9159. 'end;',
  9160. 'var b: TBird;',
  9161. 'begin',
  9162. ' b.Items[1]:=2;',
  9163. ' b.Items[3]:=b.Items[4];',
  9164. ' DoIt(b.Items[5]);',
  9165. '']);
  9166. ConvertProgram;
  9167. CheckSource('TestClass_PropertyIncVisibility',
  9168. LinesToStr([ // statements
  9169. 'rtl.createClass($mod, "TBird", pas.unit1.TObject, function () {',
  9170. '});',
  9171. 'this.DoIt = function (i) {',
  9172. '};',
  9173. 'this.b = null;'
  9174. ]),
  9175. LinesToStr([ // $mod.$main
  9176. '$mod.b.SetItems(1, 2);',
  9177. '$mod.b.SetItems(3, $mod.b.GetItems(4));',
  9178. '$mod.DoIt($mod.b.GetItems(5));'
  9179. ]));
  9180. end;
  9181. procedure TTestModule.TestClass_Assigned;
  9182. begin
  9183. StartProgram(false);
  9184. Add('type');
  9185. Add(' TObject = class');
  9186. Add(' end;');
  9187. Add('var');
  9188. Add(' Obj: tobject;');
  9189. Add(' b: boolean;');
  9190. Add('begin');
  9191. Add(' if Assigned(obj) then ;');
  9192. Add(' b:=Assigned(obj) or false;');
  9193. ConvertProgram;
  9194. CheckSource('TestClass_Assigned',
  9195. LinesToStr([ // statements
  9196. 'rtl.createClass($mod, "TObject", null, function () {',
  9197. ' this.$init = function () {',
  9198. ' };',
  9199. ' this.$final = function () {',
  9200. ' };',
  9201. '});',
  9202. 'this.Obj = null;',
  9203. 'this.b = false;'
  9204. ]),
  9205. LinesToStr([ // $mod.$main
  9206. 'if ($mod.Obj != null);',
  9207. '$mod.b = ($mod.Obj != null) || false;'
  9208. ]));
  9209. end;
  9210. procedure TTestModule.TestClass_WithClassDoCreate;
  9211. begin
  9212. StartProgram(false);
  9213. Add('type');
  9214. Add(' TObject = class');
  9215. Add(' aBool: boolean;');
  9216. Add(' Arr: array of boolean;');
  9217. Add(' constructor Create;');
  9218. Add(' end;');
  9219. Add('constructor TObject.Create; begin end;');
  9220. Add('var');
  9221. Add(' Obj: tobject;');
  9222. Add(' b: boolean;');
  9223. Add('begin');
  9224. Add(' with tobject.create do begin');
  9225. Add(' b:=abool;');
  9226. Add(' abool:=b;');
  9227. Add(' b:=arr[1];');
  9228. Add(' arr[2]:=b;');
  9229. Add(' end;');
  9230. Add(' with tobject do');
  9231. Add(' obj:=create;');
  9232. Add(' with obj do begin');
  9233. Add(' create;');
  9234. Add(' b:=abool;');
  9235. Add(' abool:=b;');
  9236. Add(' b:=arr[3];');
  9237. Add(' arr[4]:=b;');
  9238. Add(' end;');
  9239. ConvertProgram;
  9240. CheckSource('TestClass_WithClassDoCreate',
  9241. LinesToStr([ // statements
  9242. 'rtl.createClass($mod, "TObject", null, function () {',
  9243. ' this.$init = function () {',
  9244. ' this.aBool = false;',
  9245. ' this.Arr = [];',
  9246. ' };',
  9247. ' this.$final = function () {',
  9248. ' this.Arr = undefined;',
  9249. ' };',
  9250. ' this.Create = function () {',
  9251. ' };',
  9252. '});',
  9253. 'this.Obj = null;',
  9254. 'this.b = false;'
  9255. ]),
  9256. LinesToStr([ // $mod.$main
  9257. 'var $with1 = $mod.TObject.$create("Create");',
  9258. '$mod.b = $with1.aBool;',
  9259. '$with1.aBool = $mod.b;',
  9260. '$mod.b = $with1.Arr[1];',
  9261. '$with1.Arr[2] = $mod.b;',
  9262. 'var $with2 = $mod.TObject;',
  9263. '$mod.Obj = $with2.$create("Create");',
  9264. 'var $with3 = $mod.Obj;',
  9265. '$with3.Create();',
  9266. '$mod.b = $with3.aBool;',
  9267. '$with3.aBool = $mod.b;',
  9268. '$mod.b = $with3.Arr[3];',
  9269. '$with3.Arr[4] = $mod.b;',
  9270. '']));
  9271. end;
  9272. procedure TTestModule.TestClass_WithClassInstDoProperty;
  9273. begin
  9274. StartProgram(false);
  9275. Add('type');
  9276. Add(' TObject = class');
  9277. Add(' FInt: longint;');
  9278. Add(' constructor Create;');
  9279. Add(' function GetSize: longint;');
  9280. Add(' procedure SetSize(Value: longint);');
  9281. Add(' property Int: longint read FInt write FInt;');
  9282. Add(' property Size: longint read GetSize write SetSize;');
  9283. Add(' end;');
  9284. Add('constructor TObject.Create; begin end;');
  9285. Add('function TObject.GetSize: longint; begin; end;');
  9286. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  9287. Add('var');
  9288. Add(' Obj: tobject;');
  9289. Add(' i: longint;');
  9290. Add('begin');
  9291. Add(' with TObject.Create do begin');
  9292. Add(' i:=int;');
  9293. Add(' int:=i;');
  9294. Add(' i:=size;');
  9295. Add(' size:=i;');
  9296. Add(' end;');
  9297. Add(' with obj do begin');
  9298. Add(' i:=int;');
  9299. Add(' int:=i;');
  9300. Add(' i:=size;');
  9301. Add(' size:=i;');
  9302. Add(' end;');
  9303. ConvertProgram;
  9304. CheckSource('TestClass_WithClassInstDoProperty',
  9305. LinesToStr([ // statements
  9306. 'rtl.createClass($mod, "TObject", null, function () {',
  9307. ' this.$init = function () {',
  9308. ' this.FInt = 0;',
  9309. ' };',
  9310. ' this.$final = function () {',
  9311. ' };',
  9312. ' this.Create = function () {',
  9313. ' };',
  9314. ' this.GetSize = function () {',
  9315. ' var Result = 0;',
  9316. ' return Result;',
  9317. ' };',
  9318. ' this.SetSize = function (Value) {',
  9319. ' };',
  9320. '});',
  9321. 'this.Obj = null;',
  9322. 'this.i = 0;'
  9323. ]),
  9324. LinesToStr([ // $mod.$main
  9325. 'var $with1 = $mod.TObject.$create("Create");',
  9326. '$mod.i = $with1.FInt;',
  9327. '$with1.FInt = $mod.i;',
  9328. '$mod.i = $with1.GetSize();',
  9329. '$with1.SetSize($mod.i);',
  9330. 'var $with2 = $mod.Obj;',
  9331. '$mod.i = $with2.FInt;',
  9332. '$with2.FInt = $mod.i;',
  9333. '$mod.i = $with2.GetSize();',
  9334. '$with2.SetSize($mod.i);',
  9335. '']));
  9336. end;
  9337. procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
  9338. begin
  9339. StartProgram(false);
  9340. Add('type');
  9341. Add(' TObject = class');
  9342. Add(' constructor Create;');
  9343. Add(' function GetItems(Index: longint): longint;');
  9344. Add(' procedure SetItems(Index, Value: longint);');
  9345. Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
  9346. Add(' end;');
  9347. Add('constructor TObject.Create; begin end;');
  9348. Add('function tobject.getitems(index: longint): longint; begin; end;');
  9349. Add('procedure tobject.setitems(index, value: longint); begin; end;');
  9350. Add('var');
  9351. Add(' Obj: tobject;');
  9352. Add(' i: longint;');
  9353. Add('begin');
  9354. Add(' with TObject.Create do begin');
  9355. Add(' i:=Items[1];');
  9356. Add(' Items[2]:=i;');
  9357. Add(' end;');
  9358. Add(' with obj do begin');
  9359. Add(' i:=Items[3];');
  9360. Add(' Items[4]:=i;');
  9361. Add(' end;');
  9362. ConvertProgram;
  9363. CheckSource('TestClass_WithClassInstDoPropertyWithParams',
  9364. LinesToStr([ // statements
  9365. 'rtl.createClass($mod, "TObject", null, function () {',
  9366. ' this.$init = function () {',
  9367. ' };',
  9368. ' this.$final = function () {',
  9369. ' };',
  9370. ' this.Create = function () {',
  9371. ' };',
  9372. ' this.GetItems = function (Index) {',
  9373. ' var Result = 0;',
  9374. ' return Result;',
  9375. ' };',
  9376. ' this.SetItems = function (Index, Value) {',
  9377. ' };',
  9378. '});',
  9379. 'this.Obj = null;',
  9380. 'this.i = 0;'
  9381. ]),
  9382. LinesToStr([ // $mod.$main
  9383. 'var $with1 = $mod.TObject.$create("Create");',
  9384. '$mod.i = $with1.GetItems(1);',
  9385. '$with1.SetItems(2, $mod.i);',
  9386. 'var $with2 = $mod.Obj;',
  9387. '$mod.i = $with2.GetItems(3);',
  9388. '$with2.SetItems(4, $mod.i);',
  9389. '']));
  9390. end;
  9391. procedure TTestModule.TestClass_WithClassInstDoFunc;
  9392. begin
  9393. StartProgram(false);
  9394. Add('type');
  9395. Add(' TObject = class');
  9396. Add(' constructor Create;');
  9397. Add(' function GetSize: longint;');
  9398. Add(' procedure SetSize(Value: longint);');
  9399. Add(' end;');
  9400. Add('constructor TObject.Create; begin end;');
  9401. Add('function TObject.GetSize: longint; begin; end;');
  9402. Add('procedure TObject.SetSize(Value: longint); begin; end;');
  9403. Add('var');
  9404. Add(' Obj: tobject;');
  9405. Add(' i: longint;');
  9406. Add('begin');
  9407. Add(' with TObject.Create do begin');
  9408. Add(' i:=GetSize;');
  9409. Add(' i:=GetSize();');
  9410. Add(' SetSize(i);');
  9411. Add(' end;');
  9412. Add(' with obj do begin');
  9413. Add(' i:=GetSize;');
  9414. Add(' i:=GetSize();');
  9415. Add(' SetSize(i);');
  9416. Add(' end;');
  9417. ConvertProgram;
  9418. CheckSource('TestClass_WithClassInstDoFunc',
  9419. LinesToStr([ // statements
  9420. 'rtl.createClass($mod, "TObject", null, function () {',
  9421. ' this.$init = function () {',
  9422. ' };',
  9423. ' this.$final = function () {',
  9424. ' };',
  9425. ' this.Create = function () {',
  9426. ' };',
  9427. ' this.GetSize = function () {',
  9428. ' var Result = 0;',
  9429. ' return Result;',
  9430. ' };',
  9431. ' this.SetSize = function (Value) {',
  9432. ' };',
  9433. '});',
  9434. 'this.Obj = null;',
  9435. 'this.i = 0;'
  9436. ]),
  9437. LinesToStr([ // $mod.$main
  9438. 'var $with1 = $mod.TObject.$create("Create");',
  9439. '$mod.i = $with1.GetSize();',
  9440. '$mod.i = $with1.GetSize();',
  9441. '$with1.SetSize($mod.i);',
  9442. 'var $with2 = $mod.Obj;',
  9443. '$mod.i = $with2.GetSize();',
  9444. '$mod.i = $with2.GetSize();',
  9445. '$with2.SetSize($mod.i);',
  9446. '']));
  9447. end;
  9448. procedure TTestModule.TestClass_TypeCast;
  9449. begin
  9450. StartProgram(false);
  9451. Add('type');
  9452. Add(' TObject = class');
  9453. Add(' Next: TObject;');
  9454. Add(' constructor Create;');
  9455. Add(' end;');
  9456. Add(' TControl = class(TObject)');
  9457. Add(' Arr: array of TObject;');
  9458. Add(' function GetIt(vI: longint = 0): TObject;');
  9459. Add(' end;');
  9460. Add('constructor tobject.create; begin end;');
  9461. Add('function tcontrol.getit(vi: longint = 0): tobject; begin end;');
  9462. Add('var');
  9463. Add(' Obj: tobject;');
  9464. Add('begin');
  9465. Add(' obj:=tcontrol(obj).next;');
  9466. Add(' tcontrol(obj):=nil;');
  9467. Add(' obj:=tcontrol(obj);');
  9468. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
  9469. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
  9470. Add(' tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
  9471. Add(' tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
  9472. ConvertProgram;
  9473. CheckSource('TestClass_TypeCast',
  9474. LinesToStr([ // statements
  9475. 'rtl.createClass($mod, "TObject", null, function () {',
  9476. ' this.$init = function () {',
  9477. ' this.Next = null;',
  9478. ' };',
  9479. ' this.$final = function () {',
  9480. ' this.Next = undefined;',
  9481. ' };',
  9482. ' this.Create = function () {',
  9483. ' };',
  9484. '});',
  9485. 'rtl.createClass($mod, "TControl", $mod.TObject, function () {',
  9486. ' this.$init = function () {',
  9487. ' $mod.TObject.$init.call(this);',
  9488. ' this.Arr = [];',
  9489. ' };',
  9490. ' this.$final = function () {',
  9491. ' this.Arr = undefined;',
  9492. ' $mod.TObject.$final.call(this);',
  9493. ' };',
  9494. ' this.GetIt = function (vI) {',
  9495. ' var Result = null;',
  9496. ' return Result;',
  9497. ' };',
  9498. '});',
  9499. 'this.Obj = null;'
  9500. ]),
  9501. LinesToStr([ // $mod.$main
  9502. '$mod.Obj = $mod.Obj.Next;',
  9503. '$mod.Obj = null;',
  9504. '$mod.Obj = $mod.Obj;',
  9505. '$mod.Obj = $mod.Obj.GetIt(0);',
  9506. '$mod.Obj = $mod.Obj.GetIt(0);',
  9507. '$mod.Obj = $mod.Obj.GetIt(1);',
  9508. '$mod.Obj = $mod.Obj.GetIt(0).Arr[2];',
  9509. '']));
  9510. end;
  9511. procedure TTestModule.TestClass_TypeCastUntypedParam;
  9512. begin
  9513. StartProgram(false);
  9514. Add('type');
  9515. Add(' TObject = class end;');
  9516. Add('procedure ProcA(var A);');
  9517. Add('begin');
  9518. Add(' TObject(A):=nil;');
  9519. Add(' TObject(A):=TObject(A);');
  9520. Add(' if TObject(A)=nil then ;');
  9521. Add(' if nil=TObject(A) then ;');
  9522. Add('end;');
  9523. Add('procedure ProcB(out A);');
  9524. Add('begin');
  9525. Add(' TObject(A):=nil;');
  9526. Add(' TObject(A):=TObject(A);');
  9527. Add(' if TObject(A)=nil then ;');
  9528. Add(' if nil=TObject(A) then ;');
  9529. Add('end;');
  9530. Add('procedure ProcC(const A);');
  9531. Add('begin');
  9532. Add(' if TObject(A)=nil then ;');
  9533. Add(' if nil=TObject(A) then ;');
  9534. Add('end;');
  9535. Add('var o: TObject;');
  9536. Add('begin');
  9537. Add(' ProcA(o);');
  9538. Add(' ProcB(o);');
  9539. Add(' ProcC(o);');
  9540. ConvertProgram;
  9541. CheckSource('TestClass_TypeCastUntypedParam',
  9542. LinesToStr([ // statements
  9543. 'rtl.createClass($mod, "TObject", null, function () {',
  9544. ' this.$init = function () {',
  9545. ' };',
  9546. ' this.$final = function () {',
  9547. ' };',
  9548. '});',
  9549. 'this.ProcA = function (A) {',
  9550. ' A.set(null);',
  9551. ' A.set(A.get());',
  9552. ' if (A.get() === null);',
  9553. ' if (null === A.get());',
  9554. '};',
  9555. 'this.ProcB = function (A) {',
  9556. ' A.set(null);',
  9557. ' A.set(A.get());',
  9558. ' if (A.get() === null);',
  9559. ' if (null === A.get());',
  9560. '};',
  9561. 'this.ProcC = function (A) {',
  9562. ' if (A === null);',
  9563. ' if (null === A);',
  9564. '};',
  9565. 'this.o = null;',
  9566. '']),
  9567. LinesToStr([ // $mod.$main
  9568. '$mod.ProcA({',
  9569. ' p: $mod,',
  9570. ' get: function () {',
  9571. ' return this.p.o;',
  9572. ' },',
  9573. ' set: function (v) {',
  9574. ' this.p.o = v;',
  9575. ' }',
  9576. '});',
  9577. '$mod.ProcB({',
  9578. ' p: $mod,',
  9579. ' get: function () {',
  9580. ' return this.p.o;',
  9581. ' },',
  9582. ' set: function (v) {',
  9583. ' this.p.o = v;',
  9584. ' }',
  9585. '});',
  9586. '$mod.ProcC($mod.o);',
  9587. '']));
  9588. end;
  9589. procedure TTestModule.TestClass_Overloads;
  9590. begin
  9591. StartProgram(false);
  9592. Add('type');
  9593. Add(' TObject = class');
  9594. Add(' procedure DoIt;');
  9595. Add(' procedure DoIt(vI: longint);');
  9596. Add(' end;');
  9597. Add('procedure TObject.DoIt;');
  9598. Add('begin');
  9599. Add(' DoIt;');
  9600. Add(' DoIt(1);');
  9601. Add('end;');
  9602. Add('procedure TObject.DoIt(vI: longint); begin end;');
  9603. Add('begin');
  9604. ConvertProgram;
  9605. CheckSource('TestClass_Overloads',
  9606. LinesToStr([ // statements
  9607. 'rtl.createClass($mod, "TObject", null, function () {',
  9608. ' this.$init = function () {',
  9609. ' };',
  9610. ' this.$final = function () {',
  9611. ' };',
  9612. ' this.DoIt = function () {',
  9613. ' this.DoIt();',
  9614. ' this.DoIt$1(1);',
  9615. ' };',
  9616. ' this.DoIt$1 = function (vI) {',
  9617. ' };',
  9618. '});',
  9619. '']),
  9620. LinesToStr([ // $mod.$main
  9621. '']));
  9622. end;
  9623. procedure TTestModule.TestClass_OverloadsAncestor;
  9624. begin
  9625. StartProgram(false);
  9626. Add('type');
  9627. Add(' TObject = class;');
  9628. Add(' TObject = class');
  9629. Add(' procedure DoIt(vA: longint);');
  9630. Add(' procedure DoIt(vA, vB: longint);');
  9631. Add(' end;');
  9632. Add(' TCar = class;');
  9633. Add(' TCar = class');
  9634. Add(' procedure DoIt(vA: longint);');
  9635. Add(' procedure DoIt(vA, vB: longint);');
  9636. Add(' end;');
  9637. Add('procedure tobject.doit(va: longint);');
  9638. Add('begin');
  9639. Add(' doit(1);');
  9640. Add(' doit(1,2);');
  9641. Add('end;');
  9642. Add('procedure tobject.doit(va, vb: longint); begin end;');
  9643. Add('procedure tcar.doit(va: longint);');
  9644. Add('begin');
  9645. Add(' doit(1);');
  9646. Add(' doit(1,2);');
  9647. Add(' inherited doit(1);');
  9648. Add(' inherited doit(1,2);');
  9649. Add('end;');
  9650. Add('procedure tcar.doit(va, vb: longint); begin end;');
  9651. Add('begin');
  9652. ConvertProgram;
  9653. CheckSource('TestClass_OverloadsAncestor',
  9654. LinesToStr([ // statements
  9655. 'rtl.createClass($mod, "TObject", null, function () {',
  9656. ' this.$init = function () {',
  9657. ' };',
  9658. ' this.$final = function () {',
  9659. ' };',
  9660. ' this.DoIt = function (vA) {',
  9661. ' this.DoIt(1);',
  9662. ' this.DoIt$1(1,2);',
  9663. ' };',
  9664. ' this.DoIt$1 = function (vA, vB) {',
  9665. ' };',
  9666. '});',
  9667. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  9668. ' this.DoIt$2 = function (vA) {',
  9669. ' this.DoIt$2(1);',
  9670. ' this.DoIt$3(1, 2);',
  9671. ' $mod.TObject.DoIt.call(this, 1);',
  9672. ' $mod.TObject.DoIt$1.call(this, 1, 2);',
  9673. ' };',
  9674. ' this.DoIt$3 = function (vA, vB) {',
  9675. ' };',
  9676. '});',
  9677. '']),
  9678. LinesToStr([ // $mod.$main
  9679. '']));
  9680. end;
  9681. procedure TTestModule.TestClass_OverloadConstructor;
  9682. begin
  9683. StartProgram(false);
  9684. Add('type');
  9685. Add(' TObject = class');
  9686. Add(' constructor Create(vA: longint);');
  9687. Add(' constructor Create(vA, vB: longint);');
  9688. Add(' end;');
  9689. Add(' TCar = class');
  9690. Add(' constructor Create(vA: longint);');
  9691. Add(' constructor Create(vA, vB: longint);');
  9692. Add(' end;');
  9693. Add('constructor tobject.create(va: longint);');
  9694. Add('begin');
  9695. Add(' create(1);');
  9696. Add(' create(1,2);');
  9697. Add('end;');
  9698. Add('constructor tobject.create(va, vb: longint); begin end;');
  9699. Add('constructor tcar.create(va: longint);');
  9700. Add('begin');
  9701. Add(' create(1);');
  9702. Add(' create(1,2);');
  9703. Add(' inherited create(1);');
  9704. Add(' inherited create(1,2);');
  9705. Add('end;');
  9706. Add('constructor tcar.create(va, vb: longint); begin end;');
  9707. Add('begin');
  9708. Add(' tobject.create(1);');
  9709. Add(' tobject.create(1,2);');
  9710. Add(' tcar.create(1);');
  9711. Add(' tcar.create(1,2);');
  9712. ConvertProgram;
  9713. CheckSource('TestClass_OverloadConstructor',
  9714. LinesToStr([ // statements
  9715. 'rtl.createClass($mod, "TObject", null, function () {',
  9716. ' this.$init = function () {',
  9717. ' };',
  9718. ' this.$final = function () {',
  9719. ' };',
  9720. ' this.Create = function (vA) {',
  9721. ' this.Create(1);',
  9722. ' this.Create$1(1,2);',
  9723. ' };',
  9724. ' this.Create$1 = function (vA, vB) {',
  9725. ' };',
  9726. '});',
  9727. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  9728. ' this.Create$2 = function (vA) {',
  9729. ' this.Create$2(1);',
  9730. ' this.Create$3(1, 2);',
  9731. ' $mod.TObject.Create.call(this, 1);',
  9732. ' $mod.TObject.Create$1.call(this, 1, 2);',
  9733. ' };',
  9734. ' this.Create$3 = function (vA, vB) {',
  9735. ' };',
  9736. '});',
  9737. '']),
  9738. LinesToStr([ // $mod.$main
  9739. '$mod.TObject.$create("Create", [1]);',
  9740. '$mod.TObject.$create("Create$1", [1, 2]);',
  9741. '$mod.TCar.$create("Create$2", [1]);',
  9742. '$mod.TCar.$create("Create$3", [1, 2]);',
  9743. '']));
  9744. end;
  9745. procedure TTestModule.TestClass_OverloadDelphiOverride;
  9746. begin
  9747. StartProgram(false);
  9748. Add([
  9749. '{$mode delphi}',
  9750. 'type',
  9751. ' TObject = class end;',
  9752. ' TBird = class',
  9753. ' function {#a}GetValue: longint; overload; virtual;',
  9754. ' function {#b}GetValue(AValue: longint): longint; overload; virtual;',
  9755. ' end;',
  9756. ' TEagle = class(TBird)',
  9757. ' function {#c}GetValue: longint; overload; override;',
  9758. ' function {#d}GetValue(AValue: longint): longint; overload; override;',
  9759. ' end;',
  9760. 'function TBird.GetValue: longint;',
  9761. 'begin',
  9762. ' if 3={@a}GetValue then ;',
  9763. ' if 4={@b}GetValue(5) then ;',
  9764. 'end;',
  9765. 'function TBird.GetValue(AValue: longint): longint;',
  9766. 'begin',
  9767. 'end;',
  9768. 'function TEagle.GetValue: longint;',
  9769. 'begin',
  9770. ' if 13={@c}GetValue then ;',
  9771. ' if 14={@d}GetValue(15) then ;',
  9772. ' if 15=inherited {@a}GetValue then ;',
  9773. ' if 16=inherited {@b}GetValue(17) then ;',
  9774. 'end;',
  9775. 'function TEagle.GetValue(AValue: longint): longint;',
  9776. 'begin',
  9777. 'end;',
  9778. 'var',
  9779. ' e: TEagle;',
  9780. 'begin',
  9781. ' if 23=e.{@c}GetValue then ;',
  9782. ' if 24=e.{@d}GetValue(25) then ;']);
  9783. ConvertProgram;
  9784. CheckSource('TestClass_OverloadDelphiOverride',
  9785. LinesToStr([ // statements
  9786. 'rtl.createClass($mod, "TObject", null, function () {',
  9787. ' this.$init = function () {',
  9788. ' };',
  9789. ' this.$final = function () {',
  9790. ' };',
  9791. '});',
  9792. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  9793. ' this.GetValue = function () {',
  9794. ' var Result = 0;',
  9795. ' if (3 === this.GetValue()) ;',
  9796. ' if (4 === this.GetValue$1(5)) ;',
  9797. ' return Result;',
  9798. ' };',
  9799. ' this.GetValue$1 = function (AValue) {',
  9800. ' var Result = 0;',
  9801. ' return Result;',
  9802. ' };',
  9803. '});',
  9804. 'rtl.createClass($mod, "TEagle", $mod.TBird, function () {',
  9805. ' this.GetValue = function () {',
  9806. ' var Result = 0;',
  9807. ' if (13 === this.GetValue()) ;',
  9808. ' if (14 === this.GetValue$1(15)) ;',
  9809. ' if (15 === $mod.TBird.GetValue.call(this)) ;',
  9810. ' if (16 === $mod.TBird.GetValue$1.call(this, 17)) ;',
  9811. ' return Result;',
  9812. ' };',
  9813. ' this.GetValue$1 = function (AValue) {',
  9814. ' var Result = 0;',
  9815. ' return Result;',
  9816. ' };',
  9817. '});',
  9818. 'this.e = null;',
  9819. '']),
  9820. LinesToStr([ // $mod.$main
  9821. 'if (23 === $mod.e.GetValue()) ;',
  9822. 'if (24 === $mod.e.GetValue$1(25)) ;',
  9823. '']));
  9824. end;
  9825. procedure TTestModule.TestClass_ReintroducedVar;
  9826. begin
  9827. StartProgram(false);
  9828. Add('type');
  9829. Add(' TObject = class');
  9830. Add(' strict private');
  9831. Add(' Some: longint;');
  9832. Add(' end;');
  9833. Add(' TMobile = class');
  9834. Add(' strict private');
  9835. Add(' Some: string;');
  9836. Add(' end;');
  9837. Add(' TCar = class(tmobile)');
  9838. Add(' procedure Some;');
  9839. Add(' procedure Some(vA: longint);');
  9840. Add(' end;');
  9841. Add('procedure tcar.some;');
  9842. Add('begin');
  9843. Add(' Some;');
  9844. Add(' Some(1);');
  9845. Add('end;');
  9846. Add('procedure tcar.some(va: longint); begin end;');
  9847. Add('begin');
  9848. ConvertProgram;
  9849. CheckSource('TestClass_ReintroducedVar',
  9850. LinesToStr([ // statements
  9851. 'rtl.createClass($mod, "TObject", null, function () {',
  9852. ' this.$init = function () {',
  9853. ' this.Some = 0;',
  9854. ' };',
  9855. ' this.$final = function () {',
  9856. ' };',
  9857. '});',
  9858. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  9859. ' this.$init = function () {',
  9860. ' $mod.TObject.$init.call(this);',
  9861. ' this.Some$1 = "";',
  9862. ' };',
  9863. '});',
  9864. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  9865. ' this.Some$2 = function () {',
  9866. ' this.Some$2();',
  9867. ' this.Some$3(1);',
  9868. ' };',
  9869. ' this.Some$3 = function (vA) {',
  9870. ' };',
  9871. '});',
  9872. '']),
  9873. LinesToStr([ // $mod.$main
  9874. '']));
  9875. end;
  9876. procedure TTestModule.TestClass_RaiseDescendant;
  9877. begin
  9878. StartProgram(false);
  9879. Add([
  9880. 'type',
  9881. ' TObject = class',
  9882. ' constructor Create(Msg: string);',
  9883. ' end;',
  9884. ' Exception = class',
  9885. ' end;',
  9886. ' EConvertError = class(Exception)',
  9887. ' end;',
  9888. 'constructor TObject.Create(Msg: string); begin end;',
  9889. 'function AssertConv(Msg: string = ''def''): EConvertError; begin end;',
  9890. 'begin',
  9891. ' raise Exception.Create(''Bar1'');',
  9892. ' raise EConvertError.Create(''Bar2'');',
  9893. ' raise AssertConv(''Bar2'');',
  9894. ' raise AssertConv;',
  9895. '']);
  9896. ConvertProgram;
  9897. CheckSource('TestClass_RaiseDescendant',
  9898. LinesToStr([ // statements
  9899. 'rtl.createClass($mod, "TObject", null, function () {',
  9900. ' this.$init = function () {',
  9901. ' };',
  9902. ' this.$final = function () {',
  9903. ' };',
  9904. ' this.Create = function (Msg) {',
  9905. ' };',
  9906. '});',
  9907. 'rtl.createClass($mod, "Exception", $mod.TObject, function () {',
  9908. '});',
  9909. 'rtl.createClass($mod, "EConvertError", $mod.Exception, function () {',
  9910. '});',
  9911. 'this.AssertConv = function (Msg) {',
  9912. ' var Result = null;',
  9913. ' return Result;',
  9914. '};',
  9915. '']),
  9916. LinesToStr([ // $mod.$main
  9917. 'throw $mod.Exception.$create("Create",["Bar1"]);',
  9918. 'throw $mod.EConvertError.$create("Create",["Bar2"]);',
  9919. 'throw $mod.AssertConv("Bar2");',
  9920. 'throw $mod.AssertConv("def");',
  9921. '']));
  9922. end;
  9923. procedure TTestModule.TestClass_ExternalMethod;
  9924. begin
  9925. AddModuleWithIntfImplSrc('unit2.pas',
  9926. LinesToStr([
  9927. 'type',
  9928. ' TObject = class',
  9929. ' public',
  9930. ' procedure Intern; external name ''$DoIntern'';',
  9931. ' end;',
  9932. '']),
  9933. LinesToStr([
  9934. '']));
  9935. StartUnit(true);
  9936. Add('interface');
  9937. Add('uses unit2;');
  9938. Add('type');
  9939. Add(' TCar = class(TObject)');
  9940. Add(' public');
  9941. Add(' procedure Intern2; external name ''$DoIntern2'';');
  9942. Add(' procedure DoIt;');
  9943. Add(' end;');
  9944. Add('implementation');
  9945. Add('procedure tcar.doit;');
  9946. Add('begin');
  9947. Add(' Intern;');
  9948. Add(' Intern();');
  9949. Add(' Intern2;');
  9950. Add(' Intern2();');
  9951. Add('end;');
  9952. Add('var Obj: TCar;');
  9953. Add('begin');
  9954. Add(' obj.intern;');
  9955. Add(' obj.intern();');
  9956. Add(' obj.intern2;');
  9957. Add(' obj.intern2();');
  9958. Add(' obj.doit;');
  9959. Add(' obj.doit();');
  9960. Add(' with obj do begin');
  9961. Add(' Intern;');
  9962. Add(' Intern();');
  9963. Add(' Intern2;');
  9964. Add(' Intern2();');
  9965. Add(' end;');
  9966. ConvertUnit;
  9967. CheckSource('TestClass_ExternalMethod',
  9968. LinesToStr([
  9969. 'var $impl = $mod.$impl;',
  9970. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  9971. ' this.DoIt = function () {',
  9972. ' this.$DoIntern();',
  9973. ' this.$DoIntern();',
  9974. ' this.$DoIntern2();',
  9975. ' this.$DoIntern2();',
  9976. ' };',
  9977. ' });',
  9978. '']),
  9979. LinesToStr([ // this.$init
  9980. '$impl.Obj.$DoIntern();',
  9981. '$impl.Obj.$DoIntern();',
  9982. '$impl.Obj.$DoIntern2();',
  9983. '$impl.Obj.$DoIntern2();',
  9984. '$impl.Obj.DoIt();',
  9985. '$impl.Obj.DoIt();',
  9986. 'var $with1 = $impl.Obj;',
  9987. '$with1.$DoIntern();',
  9988. '$with1.$DoIntern();',
  9989. '$with1.$DoIntern2();',
  9990. '$with1.$DoIntern2();',
  9991. '']),
  9992. LinesToStr([ // implementation
  9993. '$impl.Obj = null;',
  9994. '']) );
  9995. end;
  9996. procedure TTestModule.TestClass_ExternalVirtualNameMismatchFail;
  9997. begin
  9998. StartProgram(false);
  9999. Add('type');
  10000. Add(' TObject = class');
  10001. Add(' procedure DoIt; virtual; external name ''Foo'';');
  10002. Add(' end;');
  10003. Add('begin');
  10004. SetExpectedPasResolverError('Virtual method name must match external',
  10005. nVirtualMethodNameMustMatchExternal);
  10006. ConvertProgram;
  10007. end;
  10008. procedure TTestModule.TestClass_ExternalOverrideFail;
  10009. begin
  10010. StartProgram(false);
  10011. Add('type');
  10012. Add(' TObject = class');
  10013. Add(' procedure DoIt; virtual; external name ''DoIt'';');
  10014. Add(' end;');
  10015. Add(' TCar = class');
  10016. Add(' procedure DoIt; override; external name ''DoIt'';');
  10017. Add(' end;');
  10018. Add('begin');
  10019. SetExpectedPasResolverError('Invalid procedure modifier override,external',
  10020. nInvalidXModifierY);
  10021. ConvertProgram;
  10022. end;
  10023. procedure TTestModule.TestClass_ExternalVar;
  10024. begin
  10025. AddModuleWithIntfImplSrc('unit2.pas',
  10026. LinesToStr([
  10027. '{$modeswitch externalclass}',
  10028. 'type',
  10029. ' TObject = class',
  10030. ' public',
  10031. ' Intern: longint external name ''$Intern'';',
  10032. ' end;',
  10033. '']),
  10034. LinesToStr([
  10035. '']));
  10036. StartUnit(true);
  10037. Add('interface');
  10038. Add('uses unit2;');
  10039. Add('{$modeswitch externalclass}');
  10040. Add('type');
  10041. Add(' TCar = class(tobject)');
  10042. Add(' public');
  10043. Add(' Intern2: longint external name ''$Intern2'';');
  10044. Add(' procedure DoIt;');
  10045. Add(' end;');
  10046. Add('implementation');
  10047. Add('procedure tcar.doit;');
  10048. Add('begin');
  10049. Add(' Intern:=Intern+1;');
  10050. Add(' Intern2:=Intern2+2;');
  10051. Add('end;');
  10052. Add('var Obj: TCar;');
  10053. Add('begin');
  10054. Add(' obj.intern:=obj.intern+1;');
  10055. Add(' obj.intern2:=obj.intern2+2;');
  10056. Add(' with obj do begin');
  10057. Add(' intern:=intern+1;');
  10058. Add(' intern2:=intern2+2;');
  10059. Add(' end;');
  10060. ConvertUnit;
  10061. CheckSource('TestClass_ExternalVar',
  10062. LinesToStr([
  10063. 'var $impl = $mod.$impl;',
  10064. 'rtl.createClass($mod, "TCar", pas.unit2.TObject, function () {',
  10065. ' this.DoIt = function () {',
  10066. ' this.$Intern = this.$Intern + 1;',
  10067. ' this.$Intern2 = this.$Intern2 + 2;',
  10068. ' };',
  10069. ' });',
  10070. '']),
  10071. LinesToStr([
  10072. '$impl.Obj.$Intern = $impl.Obj.$Intern + 1;',
  10073. '$impl.Obj.$Intern2 = $impl.Obj.$Intern2 + 2;',
  10074. 'var $with1 = $impl.Obj;',
  10075. '$with1.$Intern = $with1.$Intern + 1;',
  10076. '$with1.$Intern2 = $with1.$Intern2 + 2;',
  10077. '']),
  10078. LinesToStr([ // implementation
  10079. '$impl.Obj = null;',
  10080. '']));
  10081. end;
  10082. procedure TTestModule.TestClass_Const;
  10083. begin
  10084. StartProgram(false);
  10085. Add('type');
  10086. Add(' integer = longint;');
  10087. Add(' TClass = class of TObject;');
  10088. Add(' TObject = class');
  10089. Add(' public');
  10090. Add(' const cI: integer = 3;');
  10091. Add(' procedure DoIt;');
  10092. Add(' class procedure DoMore;');
  10093. Add(' end;');
  10094. Add('implementation');
  10095. Add('procedure tobject.doit;');
  10096. Add('begin');
  10097. Add(' if cI=4 then;');
  10098. Add(' if 5=cI then;');
  10099. Add(' if Self.cI=6 then;');
  10100. Add(' if 7=Self.cI then;');
  10101. Add(' with Self do begin');
  10102. Add(' if cI=11 then;');
  10103. Add(' if 12=cI then;');
  10104. Add(' end;');
  10105. Add('end;');
  10106. Add('class procedure tobject.domore;');
  10107. Add('begin');
  10108. Add(' if cI=8 then;');
  10109. Add(' if Self.cI=9 then;');
  10110. Add(' if 10=cI then;');
  10111. Add(' if 11=Self.cI then;');
  10112. Add(' with Self do begin');
  10113. Add(' if cI=13 then;');
  10114. Add(' if 14=cI then;');
  10115. Add(' end;');
  10116. Add('end;');
  10117. Add('var');
  10118. Add(' Obj: TObject;');
  10119. Add(' Cla: TClass;');
  10120. Add('begin');
  10121. Add(' if TObject.cI=21 then ;');
  10122. Add(' if Obj.cI=22 then ;');
  10123. Add(' if Cla.cI=23 then ;');
  10124. Add(' with obj do if ci=24 then;');
  10125. Add(' with TObject do if ci=25 then;');
  10126. Add(' with Cla do if ci=26 then;');
  10127. ConvertProgram;
  10128. CheckSource('TestClass_Const',
  10129. LinesToStr([
  10130. 'rtl.createClass($mod, "TObject", null, function () {',
  10131. ' this.cI = 3;',
  10132. ' this.$init = function () {',
  10133. ' };',
  10134. ' this.$final = function () {',
  10135. ' };',
  10136. ' this.DoIt = function () {',
  10137. ' if (this.cI === 4) ;',
  10138. ' if (5 === this.cI) ;',
  10139. ' if (this.cI === 6) ;',
  10140. ' if (7 === this.cI) ;',
  10141. ' if (this.cI === 11) ;',
  10142. ' if (12 === this.cI) ;',
  10143. ' };',
  10144. ' this.DoMore = function () {',
  10145. ' if (this.cI === 8) ;',
  10146. ' if (this.cI === 9) ;',
  10147. ' if (10 === this.cI) ;',
  10148. ' if (11 === this.cI) ;',
  10149. ' if (this.cI === 13) ;',
  10150. ' if (14 === this.cI) ;',
  10151. ' };',
  10152. '});',
  10153. 'this.Obj = null;',
  10154. 'this.Cla = null;',
  10155. '']),
  10156. LinesToStr([
  10157. 'if ($mod.TObject.cI === 21) ;',
  10158. 'if ($mod.Obj.cI === 22) ;',
  10159. 'if ($mod.Cla.cI === 23) ;',
  10160. 'var $with1 = $mod.Obj;',
  10161. 'if ($with1.cI === 24) ;',
  10162. 'var $with2 = $mod.TObject;',
  10163. 'if ($with2.cI === 25) ;',
  10164. 'var $with3 = $mod.Cla;',
  10165. 'if ($with3.cI === 26) ;',
  10166. '']));
  10167. end;
  10168. procedure TTestModule.TestClass_LocalVarSelfFail;
  10169. begin
  10170. StartProgram(false);
  10171. Add([
  10172. 'type',
  10173. ' TObject = class',
  10174. ' constructor Create;',
  10175. ' end;',
  10176. 'constructor tobject.create;',
  10177. 'var self: longint;',
  10178. 'begin',
  10179. 'end',
  10180. 'begin',
  10181. '']);
  10182. SetExpectedPasResolverError('Duplicate identifier "self" at (0)',nDuplicateIdentifier);
  10183. ConvertProgram;
  10184. end;
  10185. procedure TTestModule.TestClass_ArgSelfFail;
  10186. begin
  10187. StartProgram(false);
  10188. Add([
  10189. 'type',
  10190. ' TObject = class',
  10191. ' procedure DoIt(Self: longint);',
  10192. ' end;',
  10193. 'procedure tobject.doit(self: longint);',
  10194. 'begin',
  10195. 'end',
  10196. 'begin',
  10197. '']);
  10198. SetExpectedPasResolverError('Duplicate identifier "Self" at test1.pp(5,24)',nDuplicateIdentifier);
  10199. ConvertProgram;
  10200. end;
  10201. procedure TTestModule.TestClass_NestedProcSelf;
  10202. begin
  10203. StartProgram(false);
  10204. Add([
  10205. 'type',
  10206. ' TObject = class',
  10207. ' Key: longint;',
  10208. ' class var State: longint;',
  10209. ' procedure DoIt;',
  10210. ' function GetSize: longint; virtual; abstract;',
  10211. ' procedure SetSize(Value: longint); virtual; abstract;',
  10212. ' property Size: longint read GetSize write SetSize;',
  10213. ' end;',
  10214. 'procedure tobject.doit;',
  10215. ' procedure Sub;',
  10216. ' begin',
  10217. ' key:=key+2;',
  10218. ' self.key:=self.key+3;',
  10219. ' state:=state+4;',
  10220. ' self.state:=self.state+5;',
  10221. ' tobject.state:=tobject.state+6;',
  10222. ' size:=size+7;',
  10223. ' self.size:=self.size+8;',
  10224. ' end;',
  10225. 'begin',
  10226. ' sub;',
  10227. ' key:=key+12;',
  10228. ' self.key:=self.key+13;',
  10229. ' state:=state+14;',
  10230. ' self.state:=self.state+15;',
  10231. ' tobject.state:=tobject.state+16;',
  10232. ' size:=size+17;',
  10233. ' self.size:=self.size+18;',
  10234. 'end;',
  10235. 'begin',
  10236. '']);
  10237. ConvertProgram;
  10238. CheckSource('TestClass_NestedProcSelf',
  10239. LinesToStr([ // statements
  10240. 'rtl.createClass($mod, "TObject", null, function () {',
  10241. ' this.State = 0;',
  10242. ' this.$init = function () {',
  10243. ' this.Key = 0;',
  10244. ' };',
  10245. ' this.$final = function () {',
  10246. ' };',
  10247. ' this.DoIt = function () {',
  10248. ' var Self = this;',
  10249. ' function Sub() {',
  10250. ' Self.Key = Self.Key + 2;',
  10251. ' Self.Key = Self.Key + 3;',
  10252. ' Self.$class.State = Self.State + 4;',
  10253. ' Self.$class.State = Self.State + 5;',
  10254. ' $mod.TObject.State = $mod.TObject.State + 6;',
  10255. ' Self.SetSize(Self.GetSize() + 7);',
  10256. ' Self.SetSize(Self.GetSize() + 8);',
  10257. ' };',
  10258. ' Sub();',
  10259. ' Self.Key = Self.Key + 12;',
  10260. ' Self.Key = Self.Key + 13;',
  10261. ' Self.$class.State = Self.State + 14;',
  10262. ' Self.$class.State = Self.State + 15;',
  10263. ' $mod.TObject.State = $mod.TObject.State + 16;',
  10264. ' Self.SetSize(Self.GetSize() + 17);',
  10265. ' Self.SetSize(Self.GetSize() + 18);',
  10266. ' };',
  10267. '});',
  10268. '']),
  10269. LinesToStr([ // $mod.$main
  10270. '']));
  10271. end;
  10272. procedure TTestModule.TestClass_NestedProcSelf2;
  10273. begin
  10274. StartProgram(false);
  10275. Add([
  10276. 'type',
  10277. ' TObject = class',
  10278. ' Key: longint;',
  10279. ' class var State: longint;',
  10280. ' function GetSize: longint; virtual; abstract;',
  10281. ' procedure SetSize(Value: longint); virtual; abstract;',
  10282. ' property Size: longint read GetSize write SetSize;',
  10283. ' end;',
  10284. ' TBird = class',
  10285. ' procedure DoIt;',
  10286. ' end;',
  10287. 'procedure tbird.doit;',
  10288. ' procedure Sub;',
  10289. ' begin',
  10290. ' key:=key+2;',
  10291. ' self.key:=self.key+3;',
  10292. ' state:=state+4;',
  10293. ' self.state:=self.state+5;',
  10294. ' tobject.state:=tobject.state+6;',
  10295. ' size:=size+7;',
  10296. ' self.size:=self.size+8;',
  10297. ' end;',
  10298. 'begin',
  10299. ' sub;',
  10300. ' key:=key+12;',
  10301. ' self.key:=self.key+13;',
  10302. ' state:=state+14;',
  10303. ' self.state:=self.state+15;',
  10304. ' tobject.state:=tobject.state+16;',
  10305. ' size:=size+17;',
  10306. ' self.size:=self.size+18;',
  10307. 'end;',
  10308. 'begin',
  10309. '']);
  10310. ConvertProgram;
  10311. CheckSource('TestClass_NestedProcSelf2',
  10312. LinesToStr([ // statements
  10313. 'rtl.createClass($mod, "TObject", null, function () {',
  10314. ' this.State = 0;',
  10315. ' this.$init = function () {',
  10316. ' this.Key = 0;',
  10317. ' };',
  10318. ' this.$final = function () {',
  10319. ' };',
  10320. '});',
  10321. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  10322. ' this.DoIt = function () {',
  10323. ' var Self = this;',
  10324. ' function Sub() {',
  10325. ' Self.Key = Self.Key + 2;',
  10326. ' Self.Key = Self.Key + 3;',
  10327. ' Self.$class.State = Self.State + 4;',
  10328. ' Self.$class.State = Self.State + 5;',
  10329. ' $mod.TObject.State = $mod.TObject.State + 6;',
  10330. ' Self.SetSize(Self.GetSize() + 7);',
  10331. ' Self.SetSize(Self.GetSize() + 8);',
  10332. ' };',
  10333. ' Sub();',
  10334. ' Self.Key = Self.Key + 12;',
  10335. ' Self.Key = Self.Key + 13;',
  10336. ' Self.$class.State = Self.State + 14;',
  10337. ' Self.$class.State = Self.State + 15;',
  10338. ' $mod.TObject.State = $mod.TObject.State + 16;',
  10339. ' Self.SetSize(Self.GetSize() + 17);',
  10340. ' Self.SetSize(Self.GetSize() + 18);',
  10341. ' };',
  10342. '});',
  10343. '']),
  10344. LinesToStr([ // $mod.$main
  10345. '']));
  10346. end;
  10347. procedure TTestModule.TestClass_NestedProcClassSelf;
  10348. begin
  10349. StartProgram(false);
  10350. Add([
  10351. 'type',
  10352. ' TObject = class',
  10353. ' class var State: longint;',
  10354. ' class procedure DoIt;',
  10355. ' class function GetSize: longint; virtual; abstract;',
  10356. ' class procedure SetSize(Value: longint); virtual; abstract;',
  10357. ' class property Size: longint read GetSize write SetSize;',
  10358. ' end;',
  10359. 'class procedure tobject.doit;',
  10360. ' procedure Sub;',
  10361. ' begin',
  10362. ' state:=state+2;',
  10363. ' self.state:=self.state+3;',
  10364. ' tobject.state:=tobject.state+4;',
  10365. ' size:=size+5;',
  10366. ' self.size:=self.size+6;',
  10367. ' tobject.size:=tobject.size+7;',
  10368. ' end;',
  10369. 'begin',
  10370. ' sub;',
  10371. ' state:=state+12;',
  10372. ' self.state:=self.state+13;',
  10373. ' tobject.state:=tobject.state+14;',
  10374. ' size:=size+15;',
  10375. ' self.size:=self.size+16;',
  10376. ' tobject.size:=tobject.size+17;',
  10377. 'end;',
  10378. 'begin',
  10379. '']);
  10380. ConvertProgram;
  10381. CheckSource('TestClass_NestedProcClassSelf',
  10382. LinesToStr([ // statements
  10383. 'rtl.createClass($mod, "TObject", null, function () {',
  10384. ' this.State = 0;',
  10385. ' this.$init = function () {',
  10386. ' };',
  10387. ' this.$final = function () {',
  10388. ' };',
  10389. ' this.DoIt = function () {',
  10390. ' var Self = this;',
  10391. ' function Sub() {',
  10392. ' Self.State = Self.State + 2;',
  10393. ' Self.State = Self.State + 3;',
  10394. ' $mod.TObject.State = $mod.TObject.State + 4;',
  10395. ' Self.SetSize(Self.GetSize() + 5);',
  10396. ' Self.SetSize(Self.GetSize() + 6);',
  10397. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 7);',
  10398. ' };',
  10399. ' Sub();',
  10400. ' Self.State = Self.State + 12;',
  10401. ' Self.State = Self.State + 13;',
  10402. ' $mod.TObject.State = $mod.TObject.State + 14;',
  10403. ' Self.SetSize(Self.GetSize() + 15);',
  10404. ' Self.SetSize(Self.GetSize() + 16);',
  10405. ' $mod.TObject.SetSize($mod.TObject.GetSize() + 17);',
  10406. ' };',
  10407. '});',
  10408. '']),
  10409. LinesToStr([ // $mod.$main
  10410. '']));
  10411. end;
  10412. procedure TTestModule.TestClass_NestedProcCallInherited;
  10413. begin
  10414. StartProgram(false);
  10415. Add([
  10416. 'type',
  10417. ' TObject = class',
  10418. ' function DoIt(k: boolean): longint; virtual;',
  10419. ' end;',
  10420. ' TBird = class',
  10421. ' function DoIt(k: boolean): longint; override;',
  10422. ' end;',
  10423. 'function tobject.doit(k: boolean): longint;',
  10424. 'begin',
  10425. 'end;',
  10426. 'function tbird.doit(k: boolean): longint;',
  10427. ' procedure Sub;',
  10428. ' begin',
  10429. ' inherited DoIt(true);',
  10430. //' if inherited DoIt(false)=4 then ;',
  10431. ' end;',
  10432. 'begin',
  10433. ' Sub;',
  10434. ' inherited;',
  10435. ' inherited DoIt(true);',
  10436. //' if inherited DoIt(false)=14 then ;',
  10437. 'end;',
  10438. 'begin',
  10439. '']);
  10440. ConvertProgram;
  10441. CheckSource('TestClass_NestedProcCallInherited',
  10442. LinesToStr([ // statements
  10443. 'rtl.createClass($mod, "TObject", null, function () {',
  10444. ' this.$init = function () {',
  10445. ' };',
  10446. ' this.$final = function () {',
  10447. ' };',
  10448. ' this.DoIt = function (k) {',
  10449. ' var Result = 0;',
  10450. ' return Result;',
  10451. ' };',
  10452. '});',
  10453. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  10454. ' this.DoIt = function (k) {',
  10455. ' var Self = this;',
  10456. ' var Result = 0;',
  10457. ' function Sub() {',
  10458. ' $mod.TObject.DoIt.call(Self, true);',
  10459. ' };',
  10460. ' Sub();',
  10461. ' $mod.TObject.DoIt.apply(Self, arguments);',
  10462. ' $mod.TObject.DoIt.call(Self, true);',
  10463. ' return Result;',
  10464. ' };',
  10465. '});',
  10466. '']),
  10467. LinesToStr([ // $mod.$main
  10468. '']));
  10469. end;
  10470. procedure TTestModule.TestClass_TObjectFree;
  10471. begin
  10472. StartProgram(false);
  10473. Add([
  10474. 'type',
  10475. ' TObject = class',
  10476. ' Obj: tobject;',
  10477. ' procedure Free;',
  10478. ' end;',
  10479. 'procedure tobject.free;',
  10480. 'begin',
  10481. 'end;',
  10482. 'function DoIt(o: tobject): tobject;',
  10483. 'var l: tobject;',
  10484. 'begin',
  10485. ' o.free;',
  10486. ' o.free();',
  10487. ' l.free;',
  10488. ' l.free();',
  10489. ' o.obj.free;',
  10490. ' o.obj.free();',
  10491. ' with o do obj.free;',
  10492. ' with o do obj.free();',
  10493. ' result.Free;',
  10494. ' result.Free();',
  10495. 'end;',
  10496. 'var o: tobject;',
  10497. ' a: array of tobject;',
  10498. 'begin',
  10499. ' o.free;',
  10500. ' o.obj.free;',
  10501. ' a[1+2].free;',
  10502. '']);
  10503. ConvertProgram;
  10504. CheckSource('TestClass_TObjectFree',
  10505. LinesToStr([ // statements
  10506. 'rtl.createClass($mod, "TObject", null, function () {',
  10507. ' this.$init = function () {',
  10508. ' this.Obj = null;',
  10509. ' };',
  10510. ' this.$final = function () {',
  10511. ' this.Obj = undefined;',
  10512. ' };',
  10513. ' this.Free = function () {',
  10514. ' };',
  10515. '});',
  10516. 'this.DoIt = function (o) {',
  10517. ' var Result = null;',
  10518. ' var l = null;',
  10519. ' o = rtl.freeLoc(o);',
  10520. ' o = rtl.freeLoc(o);',
  10521. ' l = rtl.freeLoc(l);',
  10522. ' l = rtl.freeLoc(l);',
  10523. ' rtl.free(o, "Obj");',
  10524. ' rtl.free(o, "Obj");',
  10525. ' rtl.free(o, "Obj");',
  10526. ' rtl.free(o, "Obj");',
  10527. ' Result = rtl.freeLoc(Result);',
  10528. ' Result = rtl.freeLoc(Result);',
  10529. ' return Result;',
  10530. '};',
  10531. 'this.o = null;',
  10532. 'this.a = [];',
  10533. '']),
  10534. LinesToStr([ // $mod.$main
  10535. 'rtl.free($mod, "o");',
  10536. 'rtl.free($mod.o, "Obj");',
  10537. 'rtl.free($mod.a, 1 + 2);',
  10538. '']));
  10539. end;
  10540. procedure TTestModule.TestClass_TObjectFreeNewInstance;
  10541. begin
  10542. StartProgram(false);
  10543. Add([
  10544. 'type',
  10545. ' TObject = class',
  10546. ' constructor Create;',
  10547. ' procedure Free;',
  10548. ' end;',
  10549. 'constructor TObject.Create; begin end;',
  10550. 'procedure tobject.free; begin end;',
  10551. 'begin',
  10552. ' with tobject.create do free;',
  10553. '']);
  10554. ConvertProgram;
  10555. CheckSource('TestClass_TObjectFreeNewInstance',
  10556. LinesToStr([ // statements
  10557. 'rtl.createClass($mod, "TObject", null, function () {',
  10558. ' this.$init = function () {',
  10559. ' };',
  10560. ' this.$final = function () {',
  10561. ' };',
  10562. ' this.Create = function () {',
  10563. ' };',
  10564. ' this.Free = function () {',
  10565. ' };',
  10566. '});',
  10567. '']),
  10568. LinesToStr([ // $mod.$main
  10569. 'var $with1 = $mod.TObject.$create("Create");',
  10570. '$with1=rtl.freeLoc($with1);',
  10571. '']));
  10572. end;
  10573. procedure TTestModule.TestClass_TObjectFreeLowerCase;
  10574. begin
  10575. StartProgram(false);
  10576. Add([
  10577. 'type',
  10578. ' TObject = class',
  10579. ' destructor Destroy;',
  10580. ' procedure Free;',
  10581. ' end;',
  10582. 'destructor TObject.Destroy; begin end;',
  10583. 'procedure tobject.free; begin end;',
  10584. 'var o: tobject;',
  10585. 'begin',
  10586. ' o.free;',
  10587. '']);
  10588. Converter.UseLowerCase:=true;
  10589. ConvertProgram;
  10590. CheckSource('TestClass_TObjectFreeLowerCase',
  10591. LinesToStr([ // statements
  10592. 'rtl.createClass($mod, "tobject", null, function () {',
  10593. ' this.$init = function () {',
  10594. ' };',
  10595. ' this.$final = function () {',
  10596. ' };',
  10597. ' rtl.tObjectDestroy = "destroy";',
  10598. ' this.destroy = function () {',
  10599. ' };',
  10600. ' this.free = function () {',
  10601. ' };',
  10602. '});',
  10603. 'this.o = null;',
  10604. '']),
  10605. LinesToStr([ // $mod.$main
  10606. 'rtl.free($mod, "o");',
  10607. '']));
  10608. end;
  10609. procedure TTestModule.TestClass_TObjectFreeFunctionFail;
  10610. begin
  10611. StartProgram(false);
  10612. Add([
  10613. 'type',
  10614. ' TObject = class',
  10615. ' procedure Free;',
  10616. ' function GetObj: tobject; virtual; abstract;',
  10617. ' end;',
  10618. 'procedure tobject.free;',
  10619. 'begin',
  10620. 'end;',
  10621. 'var o: tobject;',
  10622. 'begin',
  10623. ' o.getobj.free;',
  10624. '']);
  10625. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  10626. ConvertProgram;
  10627. end;
  10628. procedure TTestModule.TestClass_TObjectFreePropertyFail;
  10629. begin
  10630. StartProgram(false);
  10631. Add([
  10632. 'type',
  10633. ' TObject = class',
  10634. ' procedure Free;',
  10635. ' FObj: TObject;',
  10636. ' property Obj: tobject read FObj write FObj;',
  10637. ' end;',
  10638. 'procedure tobject.free;',
  10639. 'begin',
  10640. 'end;',
  10641. 'var o: tobject;',
  10642. 'begin',
  10643. ' o.obj.free;',
  10644. '']);
  10645. SetExpectedPasResolverError(sFreeNeedsVar,nFreeNeedsVar);
  10646. ConvertProgram;
  10647. end;
  10648. procedure TTestModule.TestClass_ForIn;
  10649. begin
  10650. StartProgram(false);
  10651. Add([
  10652. 'type',
  10653. ' TObject = class end;',
  10654. ' TItem = TObject;',
  10655. ' TEnumerator = class',
  10656. ' FCurrent: TItem;',
  10657. ' property Current: TItem read FCurrent;',
  10658. ' function MoveNext: boolean;',
  10659. ' end;',
  10660. ' TBird = class',
  10661. ' function GetEnumerator: TEnumerator;',
  10662. ' end;',
  10663. 'function TEnumerator.MoveNext: boolean;',
  10664. 'begin',
  10665. 'end;',
  10666. 'function TBird.GetEnumerator: TEnumerator;',
  10667. 'begin',
  10668. 'end;',
  10669. 'var',
  10670. ' b: TBird;',
  10671. ' i, i2: TItem;',
  10672. 'begin',
  10673. ' for i in b do i2:=i;']);
  10674. ConvertProgram;
  10675. CheckSource('TestClass_ForIn',
  10676. LinesToStr([ // statements
  10677. 'rtl.createClass($mod, "TObject", null, function () {',
  10678. ' this.$init = function () {',
  10679. ' };',
  10680. ' this.$final = function () {',
  10681. ' };',
  10682. '});',
  10683. 'rtl.createClass($mod, "TEnumerator", $mod.TObject, function () {',
  10684. ' this.$init = function () {',
  10685. ' $mod.TObject.$init.call(this);',
  10686. ' this.FCurrent = null;',
  10687. ' };',
  10688. ' this.$final = function () {',
  10689. ' this.FCurrent = undefined;',
  10690. ' $mod.TObject.$final.call(this);',
  10691. ' };',
  10692. ' this.MoveNext = function () {',
  10693. ' var Result = false;',
  10694. ' return Result;',
  10695. ' };',
  10696. '});',
  10697. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  10698. ' this.GetEnumerator = function () {',
  10699. ' var Result = null;',
  10700. ' return Result;',
  10701. ' };',
  10702. '});',
  10703. 'this.b = null;',
  10704. 'this.i = null;',
  10705. 'this.i2 = null;'
  10706. ]),
  10707. LinesToStr([ // $mod.$main
  10708. 'var $in1 = $mod.b.GetEnumerator();',
  10709. 'try {',
  10710. ' while ($in1.MoveNext()){',
  10711. ' $mod.i = $in1.FCurrent;',
  10712. ' $mod.i2 = $mod.i;',
  10713. ' }',
  10714. '} finally {',
  10715. ' $in1 = rtl.freeLoc($in1)',
  10716. '};',
  10717. '']));
  10718. end;
  10719. procedure TTestModule.TestClassOf_Create;
  10720. begin
  10721. StartProgram(false);
  10722. Add('type');
  10723. Add(' TObject = class');
  10724. Add(' constructor Create;');
  10725. Add(' end;');
  10726. Add(' TClass = class of TObject;');
  10727. Add('constructor tobject.create; begin end;');
  10728. Add('var');
  10729. Add(' Obj: tobject;');
  10730. Add(' C: tclass;');
  10731. Add('begin');
  10732. Add(' obj:=C.create;');
  10733. Add(' with c do obj:=create;');
  10734. ConvertProgram;
  10735. CheckSource('TestClassOf_Create',
  10736. LinesToStr([ // statements
  10737. 'rtl.createClass($mod, "TObject", null, function () {',
  10738. ' this.$init = function () {',
  10739. ' };',
  10740. ' this.$final = function () {',
  10741. ' };',
  10742. ' this.Create = function () {',
  10743. ' };',
  10744. '});',
  10745. 'this.Obj = null;',
  10746. 'this.C = null;'
  10747. ]),
  10748. LinesToStr([ // $mod.$main
  10749. '$mod.Obj = $mod.C.$create("Create");',
  10750. 'var $with1 = $mod.C;',
  10751. '$mod.Obj = $with1.$create("Create");',
  10752. '']));
  10753. end;
  10754. procedure TTestModule.TestClassOf_Call;
  10755. begin
  10756. StartProgram(false);
  10757. Add('type');
  10758. Add(' TObject = class');
  10759. Add(' class procedure DoIt;');
  10760. Add(' end;');
  10761. Add(' TClass = class of TObject;');
  10762. Add('class procedure tobject.doit; begin end;');
  10763. Add('var');
  10764. Add(' C: tclass;');
  10765. Add('begin');
  10766. Add(' c.doit;');
  10767. Add(' with c do doit;');
  10768. ConvertProgram;
  10769. CheckSource('TestClassOf_Call',
  10770. LinesToStr([ // statements
  10771. 'rtl.createClass($mod, "TObject", null, function () {',
  10772. ' this.$init = function () {',
  10773. ' };',
  10774. ' this.$final = function () {',
  10775. ' };',
  10776. ' this.DoIt = function () {',
  10777. ' };',
  10778. '});',
  10779. 'this.C = null;'
  10780. ]),
  10781. LinesToStr([ // $mod.$main
  10782. '$mod.C.DoIt();',
  10783. 'var $with1 = $mod.C;',
  10784. '$with1.DoIt();',
  10785. '']));
  10786. end;
  10787. procedure TTestModule.TestClassOf_Assign;
  10788. begin
  10789. StartProgram(false);
  10790. Add('type');
  10791. Add(' TClass = class of TObject;');
  10792. Add(' TObject = class');
  10793. Add(' ClassType: TClass; ');
  10794. Add(' end;');
  10795. Add('var');
  10796. Add(' Obj: tobject;');
  10797. Add(' C: tclass;');
  10798. Add('begin');
  10799. Add(' c:=nil;');
  10800. Add(' c:=obj.classtype;');
  10801. ConvertProgram;
  10802. CheckSource('TestClassOf_Assign',
  10803. LinesToStr([ // statements
  10804. 'rtl.createClass($mod, "TObject", null, function () {',
  10805. ' this.$init = function () {',
  10806. ' this.ClassType = null;',
  10807. ' };',
  10808. ' this.$final = function () {',
  10809. ' this.ClassType = undefined;',
  10810. ' };',
  10811. '});',
  10812. 'this.Obj = null;',
  10813. 'this.C = null;'
  10814. ]),
  10815. LinesToStr([ // $mod.$main
  10816. '$mod.C = null;',
  10817. '$mod.C = $mod.Obj.ClassType;',
  10818. '']));
  10819. end;
  10820. procedure TTestModule.TestClassOf_Is;
  10821. begin
  10822. StartProgram(false);
  10823. Add('type');
  10824. Add(' TClass = class of TObject;');
  10825. Add(' TObject = class');
  10826. Add(' end;');
  10827. Add(' TCar = class');
  10828. Add(' end;');
  10829. Add(' TCars = class of TCar;');
  10830. Add('var');
  10831. Add(' Obj: tobject;');
  10832. Add(' C: tclass;');
  10833. Add(' Cars: tcars;');
  10834. Add('begin');
  10835. Add(' if c is tcar then ;');
  10836. Add(' if c is tcars then ;');
  10837. ConvertProgram;
  10838. CheckSource('TestClassOf_Is',
  10839. LinesToStr([ // statements
  10840. 'rtl.createClass($mod, "TObject", null, function () {',
  10841. ' this.$init = function () {',
  10842. ' };',
  10843. ' this.$final = function () {',
  10844. ' };',
  10845. '});',
  10846. 'rtl.createClass($mod, "TCar", $mod.TObject, function () {',
  10847. '});',
  10848. 'this.Obj = null;',
  10849. 'this.C = null;',
  10850. 'this.Cars = null;'
  10851. ]),
  10852. LinesToStr([ // $mod.$main
  10853. 'if(rtl.is($mod.C,$mod.TCar));',
  10854. 'if(rtl.is($mod.C,$mod.TCar));',
  10855. '']));
  10856. end;
  10857. procedure TTestModule.TestClassOf_Compare;
  10858. begin
  10859. StartProgram(false);
  10860. Add('type');
  10861. Add(' TClass = class of TObject;');
  10862. Add(' TObject = class');
  10863. Add(' ClassType: TClass; ');
  10864. Add(' end;');
  10865. Add('var');
  10866. Add(' b: boolean;');
  10867. Add(' Obj: tobject;');
  10868. Add(' C: tclass;');
  10869. Add('begin');
  10870. Add(' b:=c=nil;');
  10871. Add(' b:=nil=c;');
  10872. Add(' b:=c=obj.classtype;');
  10873. Add(' b:=obj.classtype=c;');
  10874. Add(' b:=c=TObject;');
  10875. Add(' b:=TObject=c;');
  10876. Add(' b:=c<>nil;');
  10877. Add(' b:=nil<>c;');
  10878. Add(' b:=c<>obj.classtype;');
  10879. Add(' b:=obj.classtype<>c;');
  10880. Add(' b:=c<>TObject;');
  10881. Add(' b:=TObject<>c;');
  10882. ConvertProgram;
  10883. CheckSource('TestClassOf_Compare',
  10884. LinesToStr([ // statements
  10885. 'rtl.createClass($mod, "TObject", null, function () {',
  10886. ' this.$init = function () {',
  10887. ' this.ClassType = null;',
  10888. ' };',
  10889. ' this.$final = function () {',
  10890. ' this.ClassType = undefined;',
  10891. ' };',
  10892. '});',
  10893. 'this.b = false;',
  10894. 'this.Obj = null;',
  10895. 'this.C = null;'
  10896. ]),
  10897. LinesToStr([ // $mod.$main
  10898. '$mod.b = $mod.C === null;',
  10899. '$mod.b = null === $mod.C;',
  10900. '$mod.b = $mod.C === $mod.Obj.ClassType;',
  10901. '$mod.b = $mod.Obj.ClassType === $mod.C;',
  10902. '$mod.b = $mod.C === $mod.TObject;',
  10903. '$mod.b = $mod.TObject === $mod.C;',
  10904. '$mod.b = $mod.C !== null;',
  10905. '$mod.b = null !== $mod.C;',
  10906. '$mod.b = $mod.C !== $mod.Obj.ClassType;',
  10907. '$mod.b = $mod.Obj.ClassType !== $mod.C;',
  10908. '$mod.b = $mod.C !== $mod.TObject;',
  10909. '$mod.b = $mod.TObject !== $mod.C;',
  10910. '']));
  10911. end;
  10912. procedure TTestModule.TestClassOf_ClassVar;
  10913. begin
  10914. StartProgram(false);
  10915. Add('type');
  10916. Add(' TObject = class');
  10917. Add(' class var id: longint;');
  10918. Add(' end;');
  10919. Add(' TClass = class of TObject;');
  10920. Add('var');
  10921. Add(' C: tclass;');
  10922. Add('begin');
  10923. Add(' C.id:=C.id;');
  10924. ConvertProgram;
  10925. CheckSource('TestClassOf_ClassVar',
  10926. LinesToStr([ // statements
  10927. 'rtl.createClass($mod, "TObject", null, function () {',
  10928. ' this.id = 0;',
  10929. ' this.$init = function () {',
  10930. ' };',
  10931. ' this.$final = function () {',
  10932. ' };',
  10933. '});',
  10934. 'this.C = null;'
  10935. ]),
  10936. LinesToStr([ // $mod.$main
  10937. '$mod.C.id = $mod.C.id;',
  10938. '']));
  10939. end;
  10940. procedure TTestModule.TestClassOf_ClassMethod;
  10941. begin
  10942. StartProgram(false);
  10943. Add('type');
  10944. Add(' TObject = class');
  10945. Add(' class function DoIt(i: longint = 0): longint;');
  10946. Add(' end;');
  10947. Add(' TClass = class of TObject;');
  10948. Add('class function tobject.doit(i: longint = 0): longint; begin end;');
  10949. Add('var');
  10950. Add(' i: longint;');
  10951. Add(' C: tclass;');
  10952. Add('begin');
  10953. Add(' C.DoIt;');
  10954. Add(' C.DoIt();');
  10955. Add(' i:=C.DoIt;');
  10956. Add(' i:=C.DoIt();');
  10957. ConvertProgram;
  10958. CheckSource('TestClassOf_ClassMethod',
  10959. LinesToStr([ // statements
  10960. 'rtl.createClass($mod, "TObject", null, function () {',
  10961. ' this.$init = function () {',
  10962. ' };',
  10963. ' this.$final = function () {',
  10964. ' };',
  10965. ' this.DoIt = function (i) {',
  10966. ' var Result = 0;',
  10967. ' return Result;',
  10968. ' };',
  10969. '});',
  10970. 'this.i = 0;',
  10971. 'this.C = null;'
  10972. ]),
  10973. LinesToStr([ // $mod.$main
  10974. '$mod.C.DoIt(0);',
  10975. '$mod.C.DoIt(0);',
  10976. '$mod.i = $mod.C.DoIt(0);',
  10977. '$mod.i = $mod.C.DoIt(0);',
  10978. '']));
  10979. end;
  10980. procedure TTestModule.TestClassOf_ClassProperty;
  10981. begin
  10982. StartProgram(false);
  10983. Add('type');
  10984. Add(' TObject = class');
  10985. Add(' class var FA: longint;');
  10986. Add(' class function GetA: longint;');
  10987. Add(' class procedure SetA(Value: longint);');
  10988. Add(' class property pA: longint read fa write fa;');
  10989. Add(' class property pB: longint read geta write seta;');
  10990. Add(' end;');
  10991. Add(' TObjectClass = class of tobject;');
  10992. Add('class function tobject.geta: longint; begin end;');
  10993. Add('class procedure tobject.seta(value: longint); begin end;');
  10994. Add('var');
  10995. Add(' b: boolean;');
  10996. Add(' Obj: tobject;');
  10997. Add(' Cla: tobjectclass;');
  10998. Add('begin');
  10999. Add(' obj.pa:=obj.pa;');
  11000. Add(' obj.pb:=obj.pb;');
  11001. Add(' b:=obj.pa=4;');
  11002. Add(' b:=obj.pb=obj.pb;');
  11003. Add(' b:=5=obj.pa;');
  11004. Add(' cla.pa:=6;');
  11005. Add(' cla.pa:=cla.pa;');
  11006. Add(' cla.pb:=cla.pb;');
  11007. Add(' b:=cla.pa=7;');
  11008. Add(' b:=cla.pb=cla.pb;');
  11009. Add(' b:=8=cla.pa;');
  11010. Add(' tobject.pa:=9;');
  11011. Add(' tobject.pb:=tobject.pb;');
  11012. Add(' b:=tobject.pa=10;');
  11013. Add(' b:=11=tobject.pa;');
  11014. ConvertProgram;
  11015. CheckSource('TestClassOf_ClassProperty',
  11016. LinesToStr([ // statements
  11017. 'rtl.createClass($mod, "TObject", null, function () {',
  11018. ' this.FA = 0;',
  11019. ' this.$init = function () {',
  11020. ' };',
  11021. ' this.$final = function () {',
  11022. ' };',
  11023. ' this.GetA = function () {',
  11024. ' var Result = 0;',
  11025. ' return Result;',
  11026. ' };',
  11027. ' this.SetA = function (Value) {',
  11028. ' };',
  11029. '});',
  11030. 'this.b = false;',
  11031. 'this.Obj = null;',
  11032. 'this.Cla = null;'
  11033. ]),
  11034. LinesToStr([ // $mod.$main
  11035. '$mod.Obj.$class.FA = $mod.Obj.FA;',
  11036. '$mod.Obj.$class.SetA($mod.Obj.$class.GetA());',
  11037. '$mod.b = $mod.Obj.FA === 4;',
  11038. '$mod.b = $mod.Obj.$class.GetA() === $mod.Obj.$class.GetA();',
  11039. '$mod.b = 5 === $mod.Obj.FA;',
  11040. '$mod.Cla.FA = 6;',
  11041. '$mod.Cla.FA = $mod.Cla.FA;',
  11042. '$mod.Cla.SetA($mod.Cla.GetA());',
  11043. '$mod.b = $mod.Cla.FA === 7;',
  11044. '$mod.b = $mod.Cla.GetA() === $mod.Cla.GetA();',
  11045. '$mod.b = 8 === $mod.Cla.FA;',
  11046. '$mod.TObject.FA = 9;',
  11047. '$mod.TObject.SetA($mod.TObject.GetA());',
  11048. '$mod.b = $mod.TObject.FA === 10;',
  11049. '$mod.b = 11 === $mod.TObject.FA;',
  11050. '']));
  11051. end;
  11052. procedure TTestModule.TestClassOf_ClassMethodSelf;
  11053. begin
  11054. StartProgram(false);
  11055. Add('type');
  11056. Add(' TObject = class');
  11057. Add(' class var GlobalId: longint;');
  11058. Add(' class procedure ProcA;');
  11059. Add(' end;');
  11060. Add('class procedure tobject.proca;');
  11061. Add('var b: boolean;');
  11062. Add('begin');
  11063. Add(' b:=self=nil;');
  11064. Add(' b:=self.globalid=3;');
  11065. Add(' b:=4=self.globalid;');
  11066. Add(' self.globalid:=5;');
  11067. Add(' self.proca;');
  11068. Add('end;');
  11069. Add('begin');
  11070. ConvertProgram;
  11071. CheckSource('TestClassOf_ClassMethodSelf',
  11072. LinesToStr([ // statements
  11073. 'rtl.createClass($mod, "TObject", null, function () {',
  11074. ' this.GlobalId = 0;',
  11075. ' this.$init = function () {',
  11076. ' };',
  11077. ' this.$final = function () {',
  11078. ' };',
  11079. ' this.ProcA = function () {',
  11080. ' var b = false;',
  11081. ' b = this === null;',
  11082. ' b = this.GlobalId === 3;',
  11083. ' b = 4 === this.GlobalId;',
  11084. ' this.GlobalId = 5;',
  11085. ' this.ProcA();',
  11086. ' };',
  11087. '});'
  11088. ]),
  11089. LinesToStr([ // $mod.$main
  11090. '']));
  11091. end;
  11092. procedure TTestModule.TestClassOf_TypeCast;
  11093. begin
  11094. StartProgram(false);
  11095. Add('type');
  11096. Add(' TObject = class');
  11097. Add(' class procedure {#TObject_DoIt}DoIt;');
  11098. Add(' end;');
  11099. Add(' TClass = class of TObject;');
  11100. Add(' TMobile = class');
  11101. Add(' class procedure {#TMobile_DoIt}DoIt;');
  11102. Add(' end;');
  11103. Add(' TMobileClass = class of TMobile;');
  11104. Add(' TCar = class(TMobile)');
  11105. Add(' class procedure {#TCar_DoIt}DoIt;');
  11106. Add(' end;');
  11107. Add(' TCarClass = class of TCar;');
  11108. Add('class procedure TObject.DoIt;');
  11109. Add('begin');
  11110. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  11111. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  11112. Add('end;');
  11113. Add('class procedure TMobile.DoIt;');
  11114. Add('begin');
  11115. Add(' TClass(Self).{@TObject_DoIt}DoIt;');
  11116. Add(' TMobileClass(Self).{@TMobile_DoIt}DoIt;');
  11117. Add(' TCarClass(Self).{@TCar_DoIt}DoIt;');
  11118. Add('end;');
  11119. Add('class procedure TCar.DoIt; begin end;');
  11120. Add('var');
  11121. Add(' ObjC: TClass;');
  11122. Add(' MobileC: TMobileClass;');
  11123. Add(' CarC: TCarClass;');
  11124. Add('begin');
  11125. Add(' ObjC.{@TObject_DoIt}DoIt;');
  11126. Add(' MobileC.{@TMobile_DoIt}DoIt;');
  11127. Add(' CarC.{@TCar_DoIt}DoIt;');
  11128. Add(' TClass(ObjC).{@TObject_DoIt}DoIt;');
  11129. Add(' TMobileClass(ObjC).{@TMobile_DoIt}DoIt;');
  11130. Add(' TCarClass(ObjC).{@TCar_DoIt}DoIt;');
  11131. Add(' TClass(MobileC).{@TObject_DoIt}DoIt;');
  11132. Add(' TMobileClass(MobileC).{@TMobile_DoIt}DoIt;');
  11133. Add(' TCarClass(MobileC).{@TCar_DoIt}DoIt;');
  11134. Add(' TClass(CarC).{@TObject_DoIt}DoIt;');
  11135. Add(' TMobileClass(CarC).{@TMobile_DoIt}DoIt;');
  11136. Add(' TCarClass(CarC).{@TCar_DoIt}DoIt;');
  11137. ConvertProgram;
  11138. CheckSource('TestClassOf_TypeCast',
  11139. LinesToStr([ // statements
  11140. 'rtl.createClass($mod, "TObject", null, function () {',
  11141. ' this.$init = function () {',
  11142. ' };',
  11143. ' this.$final = function () {',
  11144. ' };',
  11145. ' this.DoIt = function () {',
  11146. ' this.DoIt();',
  11147. ' this.DoIt$1();',
  11148. ' };',
  11149. '});',
  11150. 'rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
  11151. ' this.DoIt$1 = function () {',
  11152. ' this.DoIt();',
  11153. ' this.DoIt$1();',
  11154. ' this.DoIt$2();',
  11155. ' };',
  11156. '});',
  11157. 'rtl.createClass($mod, "TCar", $mod.TMobile, function () {',
  11158. ' this.DoIt$2 = function () {',
  11159. ' };',
  11160. '});',
  11161. 'this.ObjC = null;',
  11162. 'this.MobileC = null;',
  11163. 'this.CarC = null;',
  11164. '']),
  11165. LinesToStr([ // $mod.$main
  11166. '$mod.ObjC.DoIt();',
  11167. '$mod.MobileC.DoIt$1();',
  11168. '$mod.CarC.DoIt$2();',
  11169. '$mod.ObjC.DoIt();',
  11170. '$mod.ObjC.DoIt$1();',
  11171. '$mod.ObjC.DoIt$2();',
  11172. '$mod.MobileC.DoIt();',
  11173. '$mod.MobileC.DoIt$1();',
  11174. '$mod.MobileC.DoIt$2();',
  11175. '$mod.CarC.DoIt();',
  11176. '$mod.CarC.DoIt$1();',
  11177. '$mod.CarC.DoIt$2();',
  11178. '']));
  11179. end;
  11180. procedure TTestModule.TestClassOf_ImplicitFunctionCall;
  11181. begin
  11182. StartProgram(false);
  11183. Add('type');
  11184. Add(' TObject = class');
  11185. Add(' function CurNow: longint; ');
  11186. Add(' class function Now: longint; ');
  11187. Add(' end;');
  11188. Add('function TObject.CurNow: longint; begin end;');
  11189. Add('class function TObject.Now: longint; begin end;');
  11190. Add('var');
  11191. Add(' Obj: tobject;');
  11192. Add(' vI: longint;');
  11193. Add('begin');
  11194. Add(' obj.curnow;');
  11195. Add(' vi:=obj.curnow;');
  11196. Add(' tobject.now;');
  11197. Add(' vi:=tobject.now;');
  11198. ConvertProgram;
  11199. CheckSource('TestClassOf_ImplicitFunctionCall',
  11200. LinesToStr([ // statements
  11201. 'rtl.createClass($mod, "TObject", null, function () {',
  11202. ' this.$init = function () {',
  11203. ' };',
  11204. ' this.$final = function () {',
  11205. ' };',
  11206. ' this.CurNow = function () {',
  11207. ' var Result = 0;',
  11208. ' return Result;',
  11209. ' };',
  11210. ' this.Now = function () {',
  11211. ' var Result = 0;',
  11212. ' return Result;',
  11213. ' };',
  11214. '});',
  11215. 'this.Obj = null;',
  11216. 'this.vI = 0;',
  11217. '']),
  11218. LinesToStr([ // $mod.$main
  11219. '$mod.Obj.CurNow();',
  11220. '$mod.vI = $mod.Obj.CurNow();',
  11221. '$mod.TObject.Now();',
  11222. '$mod.vI = $mod.TObject.Now();',
  11223. '']));
  11224. end;
  11225. procedure TTestModule.TestClassOf_Const;
  11226. begin
  11227. StartProgram(false);
  11228. Add([
  11229. 'type',
  11230. ' TObject = class',
  11231. ' end;',
  11232. ' TBird = TObject;',
  11233. ' TBirds = class of TBird;',
  11234. ' TEagles = TBirds;',
  11235. ' THawk = class(TBird);',
  11236. 'const',
  11237. ' Hawk: TEagles = THawk;',
  11238. ' DefaultBirdClasses : Array [1..2] of TEagles = (',
  11239. ' TBird,',
  11240. ' THawk',
  11241. ' );',
  11242. 'begin']);
  11243. ConvertProgram;
  11244. CheckSource('TestClassOf_Const',
  11245. LinesToStr([ // statements
  11246. 'rtl.createClass($mod, "TObject", null, function () {',
  11247. ' this.$init = function () {',
  11248. ' };',
  11249. ' this.$final = function () {',
  11250. ' };',
  11251. '});',
  11252. 'rtl.createClass($mod, "THawk", $mod.TObject, function () {',
  11253. '});',
  11254. 'this.Hawk = $mod.THawk;',
  11255. 'this.DefaultBirdClasses = [$mod.TObject, $mod.THawk];',
  11256. '']),
  11257. LinesToStr([ // $mod.$main
  11258. '']));
  11259. end;
  11260. procedure TTestModule.TestNestedClass_Alias;
  11261. begin
  11262. Converter.Options:=Converter.Options-[coNoTypeInfo];
  11263. StartProgram(false);
  11264. Add([
  11265. 'type',
  11266. ' TObject = class',
  11267. ' type TNested = type longint;',
  11268. ' end;',
  11269. 'type TAlias = type tobject.tnested;',
  11270. 'var i: tobject.tnested = 3;',
  11271. 'var j: TAlias = 4;',
  11272. 'begin',
  11273. ' if typeinfo(TAlias)=nil then ;',
  11274. ' if typeinfo(tobject.tnested)=nil then ;',
  11275. '']);
  11276. ConvertProgram;
  11277. CheckSource('TestNestedClass_Alias',
  11278. LinesToStr([ // statements
  11279. 'rtl.createClass($mod, "TObject", null, function () {',
  11280. ' $mod.$rtti.$inherited("TObject.TNested", rtl.longint, {});',
  11281. ' this.$init = function () {',
  11282. ' };',
  11283. ' this.$final = function () {',
  11284. ' };',
  11285. '});',
  11286. '$mod.$rtti.$inherited("TAlias", $mod.$rtti["TObject.TNested"], {});',
  11287. 'this.i = 3;',
  11288. 'this.j = 4;',
  11289. '']),
  11290. LinesToStr([ // $mod.$main
  11291. 'if ($mod.$rtti["TAlias"] === null) ;',
  11292. 'if ($mod.$rtti["TObject.TNested"] === null) ;',
  11293. '']));
  11294. end;
  11295. procedure TTestModule.TestNestedClass_Record;
  11296. begin
  11297. Converter.Options:=Converter.Options-[coNoTypeInfo];
  11298. StartProgram(false);
  11299. Add([
  11300. 'type',
  11301. ' TObject = class',
  11302. ' type TPoint = record',
  11303. ' x,y: byte;',
  11304. ' end;',
  11305. ' procedure DoIt(t: TPoint);',
  11306. ' end;',
  11307. 'procedure tobject.DoIt(t: TPoint);',
  11308. 'var p: TPoint;',
  11309. 'begin',
  11310. ' t.x:=t.y;',
  11311. ' p:=t;',
  11312. 'end;',
  11313. 'var',
  11314. ' p: tobject.tpoint = (x:2; y:4);',
  11315. ' o: TObject;',
  11316. 'begin',
  11317. ' p:=p;',
  11318. ' o.doit(p);',
  11319. '']);
  11320. ConvertProgram;
  11321. CheckSource('TestNestedClass_Record',
  11322. LinesToStr([ // statements
  11323. 'rtl.createClass($mod, "TObject", null, function () {',
  11324. ' this.TPoint = function (s) {',
  11325. ' if (s) {',
  11326. ' this.x = s.x;',
  11327. ' this.y = s.y;',
  11328. ' } else {',
  11329. ' this.x = 0;',
  11330. ' this.y = 0;',
  11331. ' };',
  11332. ' this.$equal = function (b) {',
  11333. ' return (this.x === b.x) && (this.y === b.y);',
  11334. ' };',
  11335. ' };',
  11336. ' $mod.$rtti.$Record("TObject.TPoint", {}).addFields("x", rtl.byte, "y", rtl.byte);',
  11337. ' this.$init = function () {',
  11338. ' };',
  11339. ' this.$final = function () {',
  11340. ' };',
  11341. ' this.DoIt = function (t) {',
  11342. ' var p = new this.TPoint();',
  11343. ' t.x = t.y;',
  11344. ' p = new this.TPoint(t);',
  11345. ' };',
  11346. '});',
  11347. 'this.p = new $mod.TObject.TPoint({',
  11348. ' x: 2,',
  11349. ' y: 4',
  11350. '});',
  11351. 'this.o = null;',
  11352. '']),
  11353. LinesToStr([ // $mod.$main
  11354. '$mod.p = new $mod.TObject.TPoint($mod.p);',
  11355. '$mod.o.DoIt(new $mod.TObject.TPoint($mod.p));',
  11356. '']));
  11357. end;
  11358. procedure TTestModule.TestNestedClass_Class;
  11359. begin
  11360. Converter.Options:=Converter.Options-[coNoTypeInfo];
  11361. StartProgram(false);
  11362. Add([
  11363. 'type',
  11364. ' TObject = class end;',
  11365. ' TBird = class',
  11366. ' type TLeg = class',
  11367. ' FId: longint;',
  11368. ' constructor Create;',
  11369. ' function Create(i: longint): TLeg;',
  11370. ' end;',
  11371. ' function DoIt(b: TBird): Tleg;',
  11372. ' end;',
  11373. 'constructor tbird.tleg.create;',
  11374. 'begin',
  11375. ' FId:=3;',
  11376. 'end;',
  11377. 'function tbird.tleg.Create(i: longint): TLeg;',
  11378. 'begin',
  11379. ' Create;',
  11380. ' Result:=TLeg.Create;',
  11381. ' Result:=TBird.TLeg.Create;',
  11382. ' Result:=Create(3);',
  11383. ' FId:=i;',
  11384. 'end;',
  11385. 'function tbird.DoIt(b: tbird): tleg;',
  11386. 'begin',
  11387. ' Result.Create;',
  11388. ' Result:=TLeg.Create;',
  11389. ' Result:=TBird.TLeg.Create;',
  11390. ' Result:=Result.Create(3);',
  11391. 'end;',
  11392. 'var',
  11393. ' b: Tbird.tleg;',
  11394. 'begin',
  11395. ' b.Create;',
  11396. ' b:=TBird.TLeg.Create;',
  11397. ' b:=b.Create(3);',
  11398. '']);
  11399. ConvertProgram;
  11400. CheckSource('TestNestedClass_Class',
  11401. LinesToStr([ // statements
  11402. 'rtl.createClass($mod, "TObject", null, function () {',
  11403. ' this.$init = function () {',
  11404. ' };',
  11405. ' this.$final = function () {',
  11406. ' };',
  11407. '});',
  11408. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  11409. ' rtl.createClass(this, "TLeg", $mod.TObject, function () {',
  11410. ' this.$init = function () {',
  11411. ' $mod.TObject.$init.call(this);',
  11412. ' this.FId = 0;',
  11413. ' };',
  11414. ' this.Create = function () {',
  11415. ' this.FId = 3;',
  11416. ' };',
  11417. ' this.Create$1 = function (i) {',
  11418. ' var Result = null;',
  11419. ' this.Create();',
  11420. ' Result = $mod.TBird.TLeg.$create("Create");',
  11421. ' Result = $mod.TBird.TLeg.$create("Create");',
  11422. ' Result = this.Create$1(3);',
  11423. ' this.FId = i;',
  11424. ' return Result;',
  11425. ' };',
  11426. ' });',
  11427. ' this.DoIt = function (b) {',
  11428. ' var Result = null;',
  11429. ' Result.Create();',
  11430. ' Result = this.TLeg.$create("Create");',
  11431. ' Result = $mod.TBird.TLeg.$create("Create");',
  11432. ' Result = Result.Create$1(3);',
  11433. ' return Result;',
  11434. ' };',
  11435. '});',
  11436. 'this.b = null;',
  11437. '']),
  11438. LinesToStr([ // $mod.$main
  11439. '$mod.b.Create();',
  11440. '$mod.b = $mod.TBird.TLeg.$create("Create");',
  11441. '$mod.b = $mod.b.Create$1(3);',
  11442. '']));
  11443. end;
  11444. procedure TTestModule.TestExternalClass_Var;
  11445. begin
  11446. StartProgram(false);
  11447. Add([
  11448. '{$modeswitch externalclass}',
  11449. 'type',
  11450. ' TExtA = class external name ''ExtObj''',
  11451. ' Id: longint external name ''$Id'';',
  11452. ' B: longint;',
  11453. ' end;',
  11454. 'var Obj: TExtA;',
  11455. 'begin',
  11456. ' obj.id:=obj.id+1;',
  11457. ' obj.B:=obj.B+1;']);
  11458. ConvertProgram;
  11459. CheckSource('TestExternalClass_Var',
  11460. LinesToStr([ // statements
  11461. 'this.Obj = null;',
  11462. '']),
  11463. LinesToStr([ // $mod.$main
  11464. '$mod.Obj.$Id = $mod.Obj.$Id + 1;',
  11465. '$mod.Obj.B = $mod.Obj.B + 1;',
  11466. '']));
  11467. end;
  11468. procedure TTestModule.TestExternalClass_Const;
  11469. begin
  11470. StartProgram(false);
  11471. Add([
  11472. '{$modeswitch externalclass}',
  11473. 'type',
  11474. ' TExtA = class external name ''ExtObj''',
  11475. ' const Two: longint = 2;',
  11476. ' const Three = 3;',
  11477. ' const Id: longint;',
  11478. ' end;',
  11479. ' TExtB = class external name ''ExtB''',
  11480. ' A: TExtA;',
  11481. ' end;',
  11482. 'var',
  11483. ' A: texta;',
  11484. ' B: textb;',
  11485. ' i: longint;',
  11486. 'begin',
  11487. ' i:=a.two;',
  11488. ' i:=texta.two;',
  11489. ' i:=a.three;',
  11490. ' i:=texta.three;',
  11491. ' i:=a.id;',
  11492. ' i:=texta.id;',
  11493. '']);
  11494. ConvertProgram;
  11495. CheckSource('TestExternalClass_Const',
  11496. LinesToStr([ // statements
  11497. 'this.A = null;',
  11498. 'this.B = null;',
  11499. 'this.i = 0;',
  11500. '']),
  11501. LinesToStr([ // $mod.$main
  11502. '$mod.i = 2;',
  11503. '$mod.i = 2;',
  11504. '$mod.i = 3;',
  11505. '$mod.i = 3;',
  11506. '$mod.i = $mod.A.Id;',
  11507. '$mod.i = ExtObj.Id;',
  11508. '']));
  11509. end;
  11510. procedure TTestModule.TestExternalClass_Dollar;
  11511. begin
  11512. StartProgram(false);
  11513. Add([
  11514. '{$modeswitch externalclass}',
  11515. 'type',
  11516. ' TExtA = class external name ''$''',
  11517. ' Id: longint external name ''$'';',
  11518. ' function Bla(i: longint): longint; external name ''$'';',
  11519. ' end;',
  11520. 'function dollar(k: longint): longint; external name ''$'';',
  11521. 'var Obj: TExtA;',
  11522. 'begin',
  11523. ' dollar(1);',
  11524. ' obj.id:=obj.id+2;',
  11525. ' obj.Bla(3);',
  11526. '']);
  11527. ConvertProgram;
  11528. CheckSource('TestExternalClass_Dollar',
  11529. LinesToStr([ // statements
  11530. 'this.Obj = null;',
  11531. '']),
  11532. LinesToStr([ // $mod.$main
  11533. '$(1);',
  11534. '$mod.Obj.$ = $mod.Obj.$ + 2;',
  11535. '$mod.Obj.$(3);',
  11536. '']));
  11537. end;
  11538. procedure TTestModule.TestExternalClass_DuplicateVarFail;
  11539. begin
  11540. StartProgram(false);
  11541. Add('{$modeswitch externalclass}');
  11542. Add('type');
  11543. Add(' TExtA = class external name ''ExtA''');
  11544. Add(' Id: longint external name ''$Id'';');
  11545. Add(' end;');
  11546. Add(' TExtB = class external ''lib'' name ''ExtB''(TExtA)');
  11547. Add(' Id: longint;');
  11548. Add(' end;');
  11549. Add('begin');
  11550. SetExpectedPasResolverError('Duplicate identifier "Id" at test1.pp(6,5)',nDuplicateIdentifier);
  11551. ConvertProgram;
  11552. end;
  11553. procedure TTestModule.TestExternalClass_Method;
  11554. begin
  11555. StartProgram(false);
  11556. Add('{$modeswitch externalclass}');
  11557. Add('type');
  11558. Add(' TExtA = class external name ''ExtObj''');
  11559. Add(' procedure DoIt(Id: longint = 1); external name ''$Execute'';');
  11560. Add(' procedure DoSome(Id: longint = 1);');
  11561. Add(' end;');
  11562. Add('var Obj: texta;');
  11563. Add('begin');
  11564. Add(' obj.doit;');
  11565. Add(' obj.doit();');
  11566. Add(' obj.doit(2);');
  11567. Add(' with obj do begin');
  11568. Add(' doit;');
  11569. Add(' doit();');
  11570. Add(' doit(3);');
  11571. Add(' end;');
  11572. ConvertProgram;
  11573. CheckSource('TestExternalClass_Method',
  11574. LinesToStr([ // statements
  11575. 'this.Obj = null;',
  11576. '']),
  11577. LinesToStr([ // $mod.$main
  11578. '$mod.Obj.$Execute(1);',
  11579. '$mod.Obj.$Execute(1);',
  11580. '$mod.Obj.$Execute(2);',
  11581. 'var $with1 = $mod.Obj;',
  11582. '$with1.$Execute(1);',
  11583. '$with1.$Execute(1);',
  11584. '$with1.$Execute(3);',
  11585. '']));
  11586. end;
  11587. procedure TTestModule.TestExternalClass_ClassMethod;
  11588. begin
  11589. StartProgram(false);
  11590. Add([
  11591. '{$modeswitch externalclass}',
  11592. 'type',
  11593. ' TExtA = class external name ''ExtObj''',
  11594. ' class procedure DoIt(Id: longint = 1); external name ''$Execute'';',
  11595. ' end;',
  11596. ' TExtB = TExtA;',
  11597. 'begin',
  11598. ' texta.doit;',
  11599. ' texta.doit();',
  11600. ' texta.doit(2);',
  11601. ' with texta do begin',
  11602. ' doit;',
  11603. ' doit();',
  11604. ' doit(3);',
  11605. ' end;',
  11606. ' textb.doit;',
  11607. ' textb.doit();',
  11608. ' textb.doit(4);',
  11609. ' with textb do begin',
  11610. ' doit;',
  11611. ' doit();',
  11612. ' doit(5);',
  11613. ' end;',
  11614. '']);
  11615. ConvertProgram;
  11616. CheckSource('TestExternalClass_ClassMethod',
  11617. LinesToStr([ // statements
  11618. '']),
  11619. LinesToStr([ // $mod.$main
  11620. 'ExtObj.$Execute(1);',
  11621. 'ExtObj.$Execute(1);',
  11622. 'ExtObj.$Execute(2);',
  11623. 'ExtObj.$Execute(1);',
  11624. 'ExtObj.$Execute(1);',
  11625. 'ExtObj.$Execute(3);',
  11626. 'ExtObj.$Execute(1);',
  11627. 'ExtObj.$Execute(1);',
  11628. 'ExtObj.$Execute(4);',
  11629. 'ExtObj.$Execute(1);',
  11630. 'ExtObj.$Execute(1);',
  11631. 'ExtObj.$Execute(5);',
  11632. '']));
  11633. end;
  11634. procedure TTestModule.TestExternalClass_NonExternalOverride;
  11635. begin
  11636. StartProgram(false);
  11637. Add('{$modeswitch externalclass}');
  11638. Add('type');
  11639. Add(' TExtA = class external name ''ExtObjA''');
  11640. Add(' procedure ProcA; virtual;');
  11641. Add(' procedure ProcB; virtual;');
  11642. Add(' end;');
  11643. Add(' TExtB = class external name ''ExtObjB'' (TExtA)');
  11644. Add(' end;');
  11645. Add(' TExtC = class (TExtB)');
  11646. Add(' procedure ProcA; override;');
  11647. Add(' end;');
  11648. Add('procedure TExtC.ProcA;');
  11649. Add('begin');
  11650. Add(' ProcA;');
  11651. Add(' Self.ProcA;');
  11652. Add(' ProcB;');
  11653. Add(' Self.ProcB;');
  11654. Add('end;');
  11655. Add('var');
  11656. Add(' A: texta;');
  11657. Add(' B: textb;');
  11658. Add(' C: textc;');
  11659. Add('begin');
  11660. Add(' a.proca;');
  11661. Add(' b.proca;');
  11662. Add(' c.proca;');
  11663. ConvertProgram;
  11664. CheckSource('TestExternalClass_NonExternalOverride',
  11665. LinesToStr([ // statements
  11666. 'rtl.createClassExt($mod, "TExtC", ExtObjB, "", function () {',
  11667. ' this.$init = function () {',
  11668. ' };',
  11669. ' this.$final = function () {',
  11670. ' };',
  11671. ' this.ProcA = function () {',
  11672. ' this.ProcA();',
  11673. ' this.ProcA();',
  11674. ' this.ProcB();',
  11675. ' this.ProcB();',
  11676. ' };',
  11677. '});',
  11678. 'this.A = null;',
  11679. 'this.B = null;',
  11680. 'this.C = null;',
  11681. '']),
  11682. LinesToStr([ // $mod.$main
  11683. '$mod.A.ProcA();',
  11684. '$mod.B.ProcA();',
  11685. '$mod.C.ProcA();',
  11686. '']));
  11687. end;
  11688. procedure TTestModule.TestExternalClass_Property;
  11689. begin
  11690. StartProgram(false);
  11691. Add('{$modeswitch externalclass}');
  11692. Add('type');
  11693. Add(' TExtA = class external name ''ExtA''');
  11694. Add(' function getYear: longint;');
  11695. Add(' procedure setYear(Value: longint);');
  11696. Add(' property Year: longint read getyear write setyear;');
  11697. Add(' end;');
  11698. Add(' TExtB = class (TExtA)');
  11699. Add(' procedure OtherSetYear(Value: longint);');
  11700. Add(' property year write othersetyear;');
  11701. Add(' end;');
  11702. Add('procedure textb.othersetyear(value: longint);');
  11703. Add('begin');
  11704. Add(' setYear(Value+4);');
  11705. Add('end;');
  11706. Add('var');
  11707. Add(' A: texta;');
  11708. Add(' B: textb;');
  11709. Add('begin');
  11710. Add(' a.year:=a.year+1;');
  11711. Add(' b.year:=b.year+2;');
  11712. ConvertProgram;
  11713. CheckSource('TestExternalClass_NonExternalOverride',
  11714. LinesToStr([ // statements
  11715. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  11716. ' this.$init = function () {',
  11717. ' };',
  11718. ' this.$final = function () {',
  11719. ' };',
  11720. ' this.OtherSetYear = function (Value) {',
  11721. ' this.setYear(Value+4);',
  11722. ' };',
  11723. '});',
  11724. 'this.A = null;',
  11725. 'this.B = null;',
  11726. '']),
  11727. LinesToStr([ // $mod.$main
  11728. '$mod.A.setYear($mod.A.getYear()+1);',
  11729. '$mod.B.OtherSetYear($mod.B.getYear()+2);',
  11730. '']));
  11731. end;
  11732. procedure TTestModule.TestExternalClass_ClassProperty;
  11733. begin
  11734. StartProgram(false);
  11735. Add('{$modeswitch externalclass}');
  11736. Add('type');
  11737. Add(' TExtA = class external name ''ExtA''');
  11738. Add(' class function getYear: longint;');
  11739. Add(' class procedure setYear(Value: longint);');
  11740. Add(' class property Year: longint read getyear write setyear;');
  11741. Add(' end;');
  11742. Add(' TExtB = class (TExtA)');
  11743. Add(' class function GetCentury: longint;');
  11744. Add(' class procedure SetCentury(Value: longint);');
  11745. Add(' class property Century: longint read getcentury write setcentury;');
  11746. Add(' end;');
  11747. Add('class function textb.getcentury: longint;');
  11748. Add('begin');
  11749. Add('end;');
  11750. Add('class procedure textb.setcentury(value: longint);');
  11751. Add('begin');
  11752. Add(' setyear(value+11);');
  11753. Add(' texta.year:=texta.year+12;');
  11754. Add(' year:=year+13;');
  11755. Add(' textb.century:=textb.century+14;');
  11756. Add(' century:=century+15;');
  11757. Add('end;');
  11758. Add('var');
  11759. Add(' A: texta;');
  11760. Add(' B: textb;');
  11761. Add('begin');
  11762. Add(' texta.year:=texta.year+1;');
  11763. Add(' textb.year:=textb.year+2;');
  11764. Add(' TextA.year:=TextA.year+3;');
  11765. Add(' b.year:=b.year+4;');
  11766. Add(' textb.century:=textb.century+5;');
  11767. Add(' b.century:=b.century+6;');
  11768. ConvertProgram;
  11769. CheckSource('TestExternalClass_ClassProperty',
  11770. LinesToStr([ // statements
  11771. 'rtl.createClassExt($mod, "TExtB", ExtA, "", function () {',
  11772. ' this.$init = function () {',
  11773. ' };',
  11774. ' this.$final = function () {',
  11775. ' };',
  11776. ' this.GetCentury = function () {',
  11777. ' var Result = 0;',
  11778. ' return Result;',
  11779. ' };',
  11780. ' this.SetCentury = function (Value) {',
  11781. ' this.setYear(Value + 11);',
  11782. ' ExtA.setYear(ExtA.getYear() + 12);',
  11783. ' this.setYear(this.getYear() + 13);',
  11784. ' $mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 14);',
  11785. ' this.SetCentury(this.GetCentury() + 15);',
  11786. ' };',
  11787. '});',
  11788. 'this.A = null;',
  11789. 'this.B = null;',
  11790. '']),
  11791. LinesToStr([ // $mod.$main
  11792. 'ExtA.setYear(ExtA.getYear() + 1);',
  11793. '$mod.TExtB.setYear($mod.TExtB.getYear() + 2);',
  11794. 'ExtA.setYear(ExtA.getYear() + 3);',
  11795. '$mod.B.setYear($mod.B.getYear() + 4);',
  11796. '$mod.TExtB.SetCentury($mod.TExtB.GetCentury() + 5);',
  11797. '$mod.B.$class.SetCentury($mod.B.$class.GetCentury() + 6);',
  11798. '']));
  11799. end;
  11800. procedure TTestModule.TestExternalClass_ClassOf;
  11801. begin
  11802. StartProgram(false);
  11803. Add('{$modeswitch externalclass}');
  11804. Add('type');
  11805. Add(' TExtA = class external name ''ExtA''');
  11806. Add(' procedure ProcA; virtual;');
  11807. Add(' procedure ProcB; virtual;');
  11808. Add(' end;');
  11809. Add(' TExtAClass = class of TExtA;');
  11810. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  11811. Add(' end;');
  11812. Add(' TExtBClass = class of TExtB;');
  11813. Add(' TExtC = class (TExtB)');
  11814. Add(' procedure ProcA; override;');
  11815. Add(' end;');
  11816. Add(' TExtCClass = class of TExtC;');
  11817. Add('procedure TExtC.ProcA; begin end;');
  11818. Add('var');
  11819. Add(' A: texta; ClA: TExtAClass;');
  11820. Add(' B: textb; ClB: TExtBClass;');
  11821. Add(' C: textc; ClC: TExtCClass;');
  11822. Add('begin');
  11823. Add(' ClA:=texta;');
  11824. Add(' ClA:=textb;');
  11825. Add(' ClA:=textc;');
  11826. Add(' ClB:=textb;');
  11827. Add(' ClB:=textc;');
  11828. Add(' ClC:=textc;');
  11829. ConvertProgram;
  11830. CheckSource('TestExternalClass_ClassOf',
  11831. LinesToStr([ // statements
  11832. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  11833. ' this.$init = function () {',
  11834. ' };',
  11835. ' this.$final = function () {',
  11836. ' };',
  11837. ' this.ProcA = function () {',
  11838. ' };',
  11839. '});',
  11840. 'this.A = null;',
  11841. 'this.ClA = null;',
  11842. 'this.B = null;',
  11843. 'this.ClB = null;',
  11844. 'this.C = null;',
  11845. 'this.ClC = null;',
  11846. '']),
  11847. LinesToStr([ // $mod.$main
  11848. '$mod.ClA = ExtA;',
  11849. '$mod.ClA = ExtB;',
  11850. '$mod.ClA = $mod.TExtC;',
  11851. '$mod.ClB = ExtB;',
  11852. '$mod.ClB = $mod.TExtC;',
  11853. '$mod.ClC = $mod.TExtC;',
  11854. '']));
  11855. end;
  11856. procedure TTestModule.TestExternalClass_ClassOtherUnit;
  11857. begin
  11858. AddModuleWithIntfImplSrc('unit2.pas',
  11859. LinesToStr([
  11860. '{$modeswitch externalclass}',
  11861. 'type',
  11862. ' TExtA = class external name ''ExtA''',
  11863. ' class var Id: longint;',
  11864. ' end;',
  11865. '']),
  11866. '');
  11867. StartUnit(true);
  11868. Add('interface');
  11869. Add('uses unit2;');
  11870. Add('implementation');
  11871. Add('begin');
  11872. Add(' unit2.texta.id:=unit2.texta.id+1;');
  11873. ConvertUnit;
  11874. CheckSource('TestExternalClass_ClassOtherUnit',
  11875. LinesToStr([
  11876. '']),
  11877. LinesToStr([
  11878. 'ExtA.Id = ExtA.Id + 1;',
  11879. '']));
  11880. end;
  11881. procedure TTestModule.TestExternalClass_Is;
  11882. begin
  11883. StartProgram(false);
  11884. Add('{$modeswitch externalclass}');
  11885. Add('type');
  11886. Add(' TExtA = class external name ''ExtA''');
  11887. Add(' end;');
  11888. Add(' TExtAClass = class of TExtA;');
  11889. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  11890. Add(' end;');
  11891. Add(' TExtBClass = class of TExtB;');
  11892. Add(' TExtC = class (TExtB)');
  11893. Add(' end;');
  11894. Add(' TExtCClass = class of TExtC;');
  11895. Add('var');
  11896. Add(' A: texta; ClA: TExtAClass;');
  11897. Add(' B: textb; ClB: TExtBClass;');
  11898. Add(' C: textc; ClC: TExtCClass;');
  11899. Add('begin');
  11900. Add(' if a is textb then ;');
  11901. Add(' if a is textc then ;');
  11902. Add(' if b is textc then ;');
  11903. Add(' if cla is textb then ;');
  11904. Add(' if cla is textc then ;');
  11905. Add(' if clb is textc then ;');
  11906. ConvertProgram;
  11907. CheckSource('TestExternalClass_Is',
  11908. LinesToStr([ // statements
  11909. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  11910. ' this.$init = function () {',
  11911. ' };',
  11912. ' this.$final = function () {',
  11913. ' };',
  11914. '});',
  11915. 'this.A = null;',
  11916. 'this.ClA = null;',
  11917. 'this.B = null;',
  11918. 'this.ClB = null;',
  11919. 'this.C = null;',
  11920. 'this.ClC = null;',
  11921. '']),
  11922. LinesToStr([ // $mod.$main
  11923. 'if (rtl.isExt($mod.A, ExtB)) ;',
  11924. 'if ($mod.TExtC.isPrototypeOf($mod.A)) ;',
  11925. 'if ($mod.TExtC.isPrototypeOf($mod.B)) ;',
  11926. 'if (rtl.isExt($mod.ClA, ExtB)) ;',
  11927. 'if (rtl.is($mod.ClA, $mod.TExtC)) ;',
  11928. 'if (rtl.is($mod.ClB, $mod.TExtC)) ;',
  11929. '']));
  11930. end;
  11931. procedure TTestModule.TestExternalClass_As;
  11932. begin
  11933. StartProgram(false);
  11934. Add('{$modeswitch externalclass}');
  11935. Add('type');
  11936. Add(' TExtA = class external name ''ExtA''');
  11937. Add(' end;');
  11938. Add(' TExtB = class external name ''ExtB'' (TExtA)');
  11939. Add(' end;');
  11940. Add(' TExtC = class (TExtB)');
  11941. Add(' end;');
  11942. Add('var');
  11943. Add(' A: texta;');
  11944. Add(' B: textb;');
  11945. Add(' C: textc;');
  11946. Add('begin');
  11947. Add(' b:=a as textb;');
  11948. Add(' c:=a as textc;');
  11949. Add(' c:=b as textc;');
  11950. ConvertProgram;
  11951. CheckSource('TestExternalClass_Is',
  11952. LinesToStr([ // statements
  11953. 'rtl.createClassExt($mod, "TExtC", ExtB, "", function () {',
  11954. ' this.$init = function () {',
  11955. ' };',
  11956. ' this.$final = function () {',
  11957. ' };',
  11958. '});',
  11959. 'this.A = null;',
  11960. 'this.B = null;',
  11961. 'this.C = null;',
  11962. '']),
  11963. LinesToStr([ // $mod.$main
  11964. '$mod.B = rtl.asExt($mod.A, ExtB);',
  11965. '$mod.C = rtl.as($mod.A, $mod.TExtC);',
  11966. '$mod.C = rtl.as($mod.B, $mod.TExtC);',
  11967. '']));
  11968. end;
  11969. procedure TTestModule.TestExternalClass_DestructorFail;
  11970. begin
  11971. StartProgram(false);
  11972. Add('{$modeswitch externalclass}');
  11973. Add('type');
  11974. Add(' TExtA = class external name ''ExtA''');
  11975. Add(' destructor Free;');
  11976. Add(' end;');
  11977. SetExpectedPasResolverError('Pascal element not supported: destructor',
  11978. nPasElementNotSupported);
  11979. ConvertProgram;
  11980. end;
  11981. procedure TTestModule.TestExternalClass_New;
  11982. begin
  11983. StartProgram(false);
  11984. Add('{$modeswitch externalclass}');
  11985. Add('type');
  11986. Add(' TExtA = class external name ''ExtA''');
  11987. Add(' constructor New;');
  11988. Add(' constructor New(i: longint; j: longint = 2);');
  11989. Add(' end;');
  11990. Add('var');
  11991. Add(' A: texta;');
  11992. Add('begin');
  11993. Add(' a:=texta.new;');
  11994. Add(' a:=texta.new();');
  11995. Add(' a:=texta.new(1);');
  11996. Add(' with texta do begin');
  11997. Add(' a:=new;');
  11998. Add(' a:=new();');
  11999. Add(' a:=new(2);');
  12000. Add(' end;');
  12001. Add(' a:=test1.texta.new;');
  12002. Add(' a:=test1.texta.new();');
  12003. Add(' a:=test1.texta.new(3);');
  12004. ConvertProgram;
  12005. CheckSource('TestExternalClass_New',
  12006. LinesToStr([ // statements
  12007. 'this.A = null;',
  12008. '']),
  12009. LinesToStr([ // $mod.$main
  12010. '$mod.A = new ExtA();',
  12011. '$mod.A = new ExtA();',
  12012. '$mod.A = new ExtA(1,2);',
  12013. '$mod.A = new ExtA();',
  12014. '$mod.A = new ExtA();',
  12015. '$mod.A = new ExtA(2,2);',
  12016. '$mod.A = new ExtA();',
  12017. '$mod.A = new ExtA();',
  12018. '$mod.A = new ExtA(3,2);',
  12019. '']));
  12020. end;
  12021. procedure TTestModule.TestExternalClass_ClassOf_New;
  12022. begin
  12023. StartProgram(false);
  12024. Add('{$modeswitch externalclass}');
  12025. Add('type');
  12026. Add(' TExtAClass = class of TExtA;');
  12027. Add(' TExtA = class external name ''ExtA''');
  12028. Add(' constructor New;');
  12029. Add(' end;');
  12030. Add('var');
  12031. Add(' A: texta;');
  12032. Add(' C: textaclass;');
  12033. Add('begin');
  12034. Add(' a:=c.new;');
  12035. Add(' a:=c.new();');
  12036. Add(' with C do begin');
  12037. Add(' a:=new;');
  12038. Add(' a:=new();');
  12039. Add(' end;');
  12040. Add(' a:=test1.c.new;');
  12041. Add(' a:=test1.c.new();');
  12042. ConvertProgram;
  12043. CheckSource('TestExternalClass_ClassOf_New',
  12044. LinesToStr([ // statements
  12045. 'this.A = null;',
  12046. 'this.C = null;',
  12047. '']),
  12048. LinesToStr([ // $mod.$main
  12049. '$mod.A = new $mod.C();',
  12050. '$mod.A = new $mod.C();',
  12051. 'var $with1 = $mod.C;',
  12052. '$mod.A = new $with1();',
  12053. '$mod.A = new $with1();',
  12054. '$mod.A = new $mod.C();',
  12055. '$mod.A = new $mod.C();',
  12056. '']));
  12057. end;
  12058. procedure TTestModule.TestExternalClass_FuncClassOf_New;
  12059. begin
  12060. StartProgram(false);
  12061. Add('{$modeswitch externalclass}');
  12062. Add('type');
  12063. Add(' TExtAClass = class of TExtA;');
  12064. Add(' TExtA = class external name ''ExtA''');
  12065. Add(' constructor New;');
  12066. Add(' end;');
  12067. Add('function GetCreator: TExtAClass;');
  12068. Add('begin');
  12069. Add(' Result:=TExtA;');
  12070. Add('end;');
  12071. Add('var');
  12072. Add(' A: texta;');
  12073. Add('begin');
  12074. Add(' a:=getcreator.new;');
  12075. Add(' a:=getcreator().new;');
  12076. Add(' a:=getcreator().new();');
  12077. Add(' a:=getcreator.new();');
  12078. Add(' with getcreator do begin');
  12079. Add(' a:=new;');
  12080. Add(' a:=new();');
  12081. Add(' end;');
  12082. ConvertProgram;
  12083. CheckSource('TestExternalClass_FuncClassOf_New',
  12084. LinesToStr([ // statements
  12085. 'this.GetCreator = function () {',
  12086. ' var Result = null;',
  12087. ' Result = ExtA;',
  12088. ' return Result;',
  12089. '};',
  12090. 'this.A = null;',
  12091. '']),
  12092. LinesToStr([ // $mod.$main
  12093. '$mod.A = new ($mod.GetCreator())();',
  12094. '$mod.A = new ($mod.GetCreator())();',
  12095. '$mod.A = new ($mod.GetCreator())();',
  12096. '$mod.A = new ($mod.GetCreator())();',
  12097. 'var $with1 = $mod.GetCreator();',
  12098. '$mod.A = new $with1();',
  12099. '$mod.A = new $with1();',
  12100. '']));
  12101. end;
  12102. procedure TTestModule.TestExternalClass_LocalConstSameName;
  12103. begin
  12104. StartProgram(false);
  12105. Add('{$modeswitch externalclass}');
  12106. Add('type');
  12107. Add(' TExtA = class external name ''ExtA''');
  12108. Add(' constructor New;');
  12109. Add(' end;');
  12110. Add('function DoIt: longint;');
  12111. Add('const ExtA: longint = 3;');
  12112. Add('begin');
  12113. Add(' Result:=ExtA;');
  12114. Add('end;');
  12115. Add('var');
  12116. Add(' A: texta;');
  12117. Add('begin');
  12118. Add(' a:=texta.new;');
  12119. ConvertProgram;
  12120. CheckSource('TestExternalClass_LocalConstSameName',
  12121. LinesToStr([ // statements
  12122. 'var ExtA$1 = 3;',
  12123. 'this.DoIt = function () {',
  12124. ' var Result = 0;',
  12125. ' Result = ExtA$1;',
  12126. ' return Result;',
  12127. '};',
  12128. 'this.A = null;',
  12129. '']),
  12130. LinesToStr([ // $mod.$main
  12131. '$mod.A = new ExtA();',
  12132. '']));
  12133. end;
  12134. procedure TTestModule.TestExternalClass_ReintroduceOverload;
  12135. begin
  12136. StartProgram(false);
  12137. Add('{$modeswitch externalclass}');
  12138. Add('type');
  12139. Add(' TExtA = class external name ''ExtA''');
  12140. Add(' procedure DoIt;');
  12141. Add(' end;');
  12142. Add(' TMyA = class(TExtA)');
  12143. Add(' procedure DoIt;');
  12144. Add(' end;');
  12145. Add('procedure TMyA.DoIt; begin end;');
  12146. Add('begin');
  12147. ConvertProgram;
  12148. CheckSource('TestExternalClass_ReintroduceOverload',
  12149. LinesToStr([ // statements
  12150. 'rtl.createClassExt($mod, "TMyA", ExtA, "", function () {',
  12151. ' this.$init = function () {',
  12152. ' };',
  12153. ' this.$final = function () {',
  12154. ' };',
  12155. ' this.DoIt$1 = function () {',
  12156. ' };',
  12157. '});',
  12158. '']),
  12159. LinesToStr([ // $mod.$main
  12160. '']));
  12161. end;
  12162. procedure TTestModule.TestExternalClass_Inherited;
  12163. begin
  12164. StartProgram(false);
  12165. Add('{$modeswitch externalclass}');
  12166. Add('type');
  12167. Add(' TExtA = class external name ''ExtA''');
  12168. Add(' procedure DoIt(i: longint = 1); virtual;');
  12169. Add(' procedure DoSome(j: longint = 2);');
  12170. Add(' end;');
  12171. Add(' TExtB = class external name ''ExtB''(TExtA)');
  12172. Add(' end;');
  12173. Add(' TMyC = class(TExtB)');
  12174. Add(' procedure DoIt(i: longint = 1); override;');
  12175. Add(' procedure DoSome(j: longint = 2); reintroduce;');
  12176. Add(' end;');
  12177. Add('procedure TMyC.DoIt(i: longint);');
  12178. Add('begin');
  12179. Add(' inherited;');
  12180. Add(' inherited DoIt;');
  12181. Add(' inherited DoIt();');
  12182. Add(' inherited DoIt(3);');
  12183. Add(' inherited DoSome;');
  12184. Add(' inherited DoSome();');
  12185. Add(' inherited DoSome(4);');
  12186. Add('end;');
  12187. Add('procedure TMyC.DoSome(j: longint);');
  12188. Add('begin');
  12189. Add(' inherited;');
  12190. Add('end;');
  12191. Add('begin');
  12192. ConvertProgram;
  12193. CheckSource('TestExternalClass_ReintroduceOverload',
  12194. LinesToStr([ // statements
  12195. 'rtl.createClassExt($mod, "TMyC", ExtB, "", function () {',
  12196. ' this.$init = function () {',
  12197. ' };',
  12198. ' this.$final = function () {',
  12199. ' };',
  12200. ' this.DoIt = function (i) {',
  12201. ' ExtB.DoIt.apply(this, arguments);',
  12202. ' ExtB.DoIt.call(this, 1);',
  12203. ' ExtB.DoIt.call(this, 1);',
  12204. ' ExtB.DoIt.call(this, 3);',
  12205. ' ExtB.DoSome.call(this, 2);',
  12206. ' ExtB.DoSome.call(this, 2);',
  12207. ' ExtB.DoSome.call(this, 4);',
  12208. ' };',
  12209. ' this.DoSome$1 = function (j) {',
  12210. ' ExtB.DoSome.apply(this, arguments);',
  12211. ' };',
  12212. '});',
  12213. '']),
  12214. LinesToStr([ // $mod.$main
  12215. '']));
  12216. end;
  12217. procedure TTestModule.TestExternalClass_PascalAncestorFail;
  12218. begin
  12219. StartProgram(false);
  12220. Add('{$modeswitch externalclass}');
  12221. Add('type');
  12222. Add(' TObject = class');
  12223. Add(' end;');
  12224. Add(' TExtA = class external name ''ExtA''(TObject)');
  12225. Add(' end;');
  12226. Add('begin');
  12227. SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
  12228. ConvertProgram;
  12229. end;
  12230. procedure TTestModule.TestExternalClass_NewInstance;
  12231. begin
  12232. StartProgram(false);
  12233. Add('{$modeswitch externalclass}');
  12234. Add('type');
  12235. Add(' TExtA = class external name ''ExtA''');
  12236. Add(' end;');
  12237. Add(' TMyB = class(TExtA)');
  12238. Add(' protected');
  12239. Add(' class function NewInstance(fnname: string; const paramarray): TMyB; virtual;');
  12240. Add(' end;');
  12241. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  12242. Add('begin end;');
  12243. Add('begin');
  12244. ConvertProgram;
  12245. CheckSource('TestExternalClass_NewInstance',
  12246. LinesToStr([ // statements
  12247. 'rtl.createClassExt($mod, "TMyB", ExtA, "NewInstance", function () {',
  12248. ' this.$init = function () {',
  12249. ' };',
  12250. ' this.$final = function () {',
  12251. ' };',
  12252. ' this.NewInstance = function (fnname, paramarray) {',
  12253. ' var Result = null;',
  12254. ' return Result;',
  12255. ' };',
  12256. '});',
  12257. '']),
  12258. LinesToStr([ // $mod.$main
  12259. '']));
  12260. end;
  12261. procedure TTestModule.TestExternalClass_NewInstance_NonVirtualFail;
  12262. begin
  12263. StartProgram(false);
  12264. Add('{$modeswitch externalclass}');
  12265. Add('type');
  12266. Add(' TExtA = class external name ''ExtA''');
  12267. Add(' end;');
  12268. Add(' TMyB = class(TExtA)');
  12269. Add(' protected');
  12270. Add(' class function NewInstance(fnname: string; const paramarray): TMyB;');
  12271. Add(' end;');
  12272. Add('class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;');
  12273. Add('begin end;');
  12274. Add('begin');
  12275. SetExpectedPasResolverError(sNewInstanceFunctionMustBeVirtual,nNewInstanceFunctionMustBeVirtual);
  12276. ConvertProgram;
  12277. end;
  12278. procedure TTestModule.TestExternalClass_NewInstance_FirstParamNotString_Fail;
  12279. begin
  12280. StartProgram(false);
  12281. Add('{$modeswitch externalclass}');
  12282. Add('type');
  12283. Add(' TExtA = class external name ''ExtA''');
  12284. Add(' end;');
  12285. Add(' TMyB = class(TExtA)');
  12286. Add(' protected');
  12287. Add(' class function NewInstance(fnname: longint; const paramarray): TMyB; virtual;');
  12288. Add(' end;');
  12289. Add('class function TMyB.NewInstance(fnname: longint; const paramarray): TMyB;');
  12290. Add('begin end;');
  12291. Add('begin');
  12292. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Longint", expected "String"',
  12293. nIncompatibleTypeArgNo);
  12294. ConvertProgram;
  12295. end;
  12296. procedure TTestModule.TestExternalClass_NewInstance_SecondParamTyped_Fail;
  12297. begin
  12298. StartProgram(false);
  12299. Add('{$modeswitch externalclass}');
  12300. Add('type');
  12301. Add(' TExtA = class external name ''ExtA''');
  12302. Add(' end;');
  12303. Add(' TMyB = class(TExtA)');
  12304. Add(' protected');
  12305. Add(' class function NewInstance(fnname: string; const paramarray: string): TMyB; virtual;');
  12306. Add(' end;');
  12307. Add('class function TMyB.NewInstance(fnname: string; const paramarray: string): TMyB;');
  12308. Add('begin end;');
  12309. Add('begin');
  12310. SetExpectedPasResolverError('Incompatible type arg no. 2: Got "type", expected "untyped"',
  12311. nIncompatibleTypeArgNo);
  12312. ConvertProgram;
  12313. end;
  12314. procedure TTestModule.TestExternalClass_PascalProperty;
  12315. begin
  12316. StartProgram(false);
  12317. Add('{$modeswitch externalclass}');
  12318. Add('type');
  12319. Add(' TJSElement = class;');
  12320. Add(' TJSNotifyEvent = procedure(Sender: TJSElement) of object;');
  12321. Add(' TJSElement = class external name ''ExtA''');
  12322. Add(' end;');
  12323. Add(' TControl = class(TJSElement)');
  12324. Add(' private');
  12325. Add(' FOnClick: TJSNotifyEvent;');
  12326. Add(' property OnClick: TJSNotifyEvent read FOnClick write FOnClick;');
  12327. Add(' procedure Click(Sender: TJSElement);');
  12328. Add(' end;');
  12329. Add('procedure TControl.Click(Sender: TJSElement);');
  12330. Add('begin');
  12331. Add(' OnClick(Self);');
  12332. Add('end;');
  12333. Add('var');
  12334. Add(' Ctrl: TControl;');
  12335. Add('begin');
  12336. Add(' Ctrl.OnClick:[email protected];');
  12337. Add(' Ctrl.OnClick(Ctrl);');
  12338. ConvertProgram;
  12339. CheckSource('TestExternalClass_PascalProperty',
  12340. LinesToStr([ // statements
  12341. 'rtl.createClassExt($mod, "TControl", ExtA, "", function () {',
  12342. ' this.$init = function () {',
  12343. ' this.FOnClick = null;',
  12344. ' };',
  12345. ' this.$final = function () {',
  12346. ' this.FOnClick = undefined;',
  12347. ' };',
  12348. ' this.Click = function (Sender) {',
  12349. ' this.FOnClick(this);',
  12350. ' };',
  12351. '});',
  12352. 'this.Ctrl = null;',
  12353. '']),
  12354. LinesToStr([ // $mod.$main
  12355. '$mod.Ctrl.FOnClick = rtl.createCallback($mod.Ctrl, "Click");',
  12356. '$mod.Ctrl.FOnClick($mod.Ctrl);',
  12357. '']));
  12358. end;
  12359. procedure TTestModule.TestExternalClass_TypeCastToRootClass;
  12360. begin
  12361. StartProgram(false);
  12362. Add([
  12363. '{$modeswitch externalclass}',
  12364. 'type',
  12365. ' IUnknown = interface end;',
  12366. ' TObject = class',
  12367. ' end;',
  12368. ' TChild = class',
  12369. ' end;',
  12370. ' TExtRootA = class external name ''ExtRootA''',
  12371. ' end;',
  12372. ' TExtChildA = class external name ''ExtChildA''(TExtRootA)',
  12373. ' end;',
  12374. ' TExtRootB = class external name ''ExtRootB''',
  12375. ' end;',
  12376. ' TExtChildB = class external name ''ExtChildB''(TExtRootB)',
  12377. ' end;',
  12378. 'var',
  12379. ' Obj: TObject;',
  12380. ' Child: TChild;',
  12381. ' RootA: TExtRootA;',
  12382. ' ChildA: TExtChildA;',
  12383. ' RootB: TExtRootB;',
  12384. ' ChildB: TExtChildB;',
  12385. ' i: IUnknown;',
  12386. 'begin',
  12387. ' obj:=tobject(roota);',
  12388. ' obj:=tobject(childa);',
  12389. ' child:=tchild(tobject(roota));',
  12390. ' roota:=textroota(obj);',
  12391. ' roota:=textroota(child);',
  12392. ' roota:=textroota(rootb);',
  12393. ' roota:=textroota(childb);',
  12394. ' childa:=textchilda(textroota(obj));',
  12395. ' roota:=TExtRootA(i)',
  12396. '']);
  12397. ConvertProgram;
  12398. CheckSource('TestExternalClass_TypeCastToRootClass',
  12399. LinesToStr([ // statements
  12400. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  12401. 'rtl.createClass($mod, "TObject", null, function () {',
  12402. ' this.$init = function () {',
  12403. ' };',
  12404. ' this.$final = function () {',
  12405. ' };',
  12406. '});',
  12407. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  12408. '});',
  12409. 'this.Obj = null;',
  12410. 'this.Child = null;',
  12411. 'this.RootA = null;',
  12412. 'this.ChildA = null;',
  12413. 'this.RootB = null;',
  12414. 'this.ChildB = null;',
  12415. 'this.i = null;',
  12416. '']),
  12417. LinesToStr([ // $mod.$main
  12418. '$mod.Obj = $mod.RootA;',
  12419. '$mod.Obj = $mod.ChildA;',
  12420. '$mod.Child = $mod.RootA;',
  12421. '$mod.RootA = $mod.Obj;',
  12422. '$mod.RootA = $mod.Child;',
  12423. '$mod.RootA = $mod.RootB;',
  12424. '$mod.RootA = $mod.ChildB;',
  12425. '$mod.ChildA = $mod.Obj;',
  12426. '$mod.RootA = $mod.i;',
  12427. '']));
  12428. end;
  12429. procedure TTestModule.TestExternalClass_TypeCastToJSObject;
  12430. begin
  12431. StartProgram(false);
  12432. Add([
  12433. '{$modeswitch externalclass}',
  12434. 'type',
  12435. ' IUnknown = interface end;',
  12436. ' IBird = interface(IUnknown) end;',
  12437. ' TClass = class of TObject;',
  12438. ' TObject = class',
  12439. ' end;',
  12440. ' TChild = class',
  12441. ' end;',
  12442. ' TJSObject = class external name ''Object''',
  12443. ' end;',
  12444. ' TRec = record end;',
  12445. 'var',
  12446. ' Obj: TObject;',
  12447. ' Child: TChild;',
  12448. ' i: IUnknown;',
  12449. ' Bird: IBird;',
  12450. ' j: TJSObject;',
  12451. ' r: TRec;',
  12452. ' c: TClass;',
  12453. 'begin',
  12454. ' j:=tjsobject(IUnknown);',
  12455. ' j:=tjsobject(IBird);',
  12456. ' j:=tjsobject(TObject);',
  12457. ' j:=tjsobject(TChild);',
  12458. ' j:=tjsobject(TRec);',
  12459. ' j:=tjsobject(Obj);',
  12460. ' j:=tjsobject(Child);',
  12461. ' j:=tjsobject(i);',
  12462. ' j:=tjsobject(Bird);',
  12463. ' j:=tjsobject(r);',
  12464. ' j:=tjsobject(c);',
  12465. '']);
  12466. ConvertProgram;
  12467. CheckSource('TestExternalClass_TypeCastToJSObject',
  12468. LinesToStr([ // statements
  12469. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  12470. 'rtl.createInterface($mod, "IBird", "{48E3FF4A-AF76-3465-A738-D462ECC63074}", [], $mod.IUnknown);',
  12471. 'rtl.createClass($mod, "TObject", null, function () {',
  12472. ' this.$init = function () {',
  12473. ' };',
  12474. ' this.$final = function () {',
  12475. ' };',
  12476. '});',
  12477. 'rtl.createClass($mod, "TChild", $mod.TObject, function () {',
  12478. '});',
  12479. 'this.TRec = function (s) {',
  12480. ' this.$equal = function (b) {',
  12481. ' return true;',
  12482. ' };',
  12483. '};',
  12484. 'this.Obj = null;',
  12485. 'this.Child = null;',
  12486. 'this.i = null;',
  12487. 'this.Bird = null;',
  12488. 'this.j = null;',
  12489. 'this.r = new $mod.TRec();',
  12490. 'this.c = null;',
  12491. '']),
  12492. LinesToStr([ // $mod.$main
  12493. '$mod.j = $mod.IUnknown;',
  12494. '$mod.j = $mod.IBird;',
  12495. '$mod.j = $mod.TObject;',
  12496. '$mod.j = $mod.TChild;',
  12497. '$mod.j = $mod.TRec;',
  12498. '$mod.j = $mod.Obj;',
  12499. '$mod.j = $mod.Child;',
  12500. '$mod.j = $mod.i;',
  12501. '$mod.j = $mod.Bird;',
  12502. '$mod.j = $mod.r;',
  12503. '$mod.j = $mod.c;',
  12504. '']));
  12505. end;
  12506. procedure TTestModule.TestExternalClass_TypeCastStringToExternalString;
  12507. begin
  12508. StartProgram(false);
  12509. Add('{$modeswitch externalclass}');
  12510. Add('type');
  12511. Add(' TJSString = class external name ''String''');
  12512. Add(' class function fromCharCode() : string; varargs;');
  12513. Add(' function anchor(const aName : string) : string;');
  12514. Add(' end;');
  12515. Add('var');
  12516. Add(' s: string;');
  12517. Add('begin');
  12518. Add(' s:=TJSString.fromCharCode(65,66);');
  12519. Add(' s:=TJSString(s).anchor(s);');
  12520. Add(' s:=TJSString(''foo'').anchor(s);');
  12521. ConvertProgram;
  12522. CheckSource('TestExternalClass_TypeCastStringToExternalString',
  12523. LinesToStr([ // statements
  12524. 'this.s = "";',
  12525. '']),
  12526. LinesToStr([ // $mod.$main
  12527. '$mod.s = String.fromCharCode(65, 66);',
  12528. '$mod.s = $mod.s.anchor($mod.s);',
  12529. '$mod.s = "foo".anchor($mod.s);',
  12530. '']));
  12531. end;
  12532. procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
  12533. begin
  12534. StartProgram(false);
  12535. Add('{$modeswitch externalclass}');
  12536. Add('type');
  12537. Add(' TJSString = class external name ''String''');
  12538. Add(' class function fromCharCode() : string; varargs;');
  12539. Add(' end;');
  12540. Add('var');
  12541. Add(' s: string;');
  12542. Add(' sObj: TJSString;');
  12543. Add('begin');
  12544. Add(' s:=sObj.fromCharCode(65,66);');
  12545. SetExpectedPasResolverError('External class instance cannot access static class function fromCharCode',
  12546. nExternalClassInstanceCannotAccessStaticX);
  12547. ConvertProgram;
  12548. end;
  12549. procedure TTestModule.TestExternalClass_BracketAccessor;
  12550. begin
  12551. StartProgram(false);
  12552. Add('{$modeswitch externalclass}');
  12553. Add('type');
  12554. Add(' TJSArray = class external name ''Array2''');
  12555. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  12556. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  12557. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  12558. Add(' end;');
  12559. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);');
  12560. Add('begin end;');
  12561. Add('var');
  12562. Add(' Arr: tjsarray;');
  12563. Add(' s: string;');
  12564. Add(' i: longint;');
  12565. Add(' v: jsvalue;');
  12566. Add('begin');
  12567. Add(' v:=arr[0];');
  12568. Add(' v:=arr.items[1];');
  12569. Add(' arr[2]:=s;');
  12570. Add(' arr.items[3]:=s;');
  12571. Add(' arr[4]:=i;');
  12572. Add(' arr[5]:=arr[6];');
  12573. Add(' arr.items[7]:=arr.items[8];');
  12574. Add(' with arr do items[9]:=items[10];');
  12575. Add(' doit(arr[7],arr[8],arr[9],arr[10]);');
  12576. ConvertProgram;
  12577. CheckSource('TestExternalClass_BracketAccessor',
  12578. LinesToStr([ // statements
  12579. 'this.DoIt = function (vI, vJ, vK, vL) {',
  12580. '};',
  12581. 'this.Arr = null;',
  12582. 'this.s = "";',
  12583. 'this.i = 0;',
  12584. 'this.v = undefined;',
  12585. '']),
  12586. LinesToStr([ // $mod.$main
  12587. '$mod.v = $mod.Arr[0];',
  12588. '$mod.v = $mod.Arr[1];',
  12589. '$mod.Arr[2] = $mod.s;',
  12590. '$mod.Arr[3] = $mod.s;',
  12591. '$mod.Arr[4] = $mod.i;',
  12592. '$mod.Arr[5] = $mod.Arr[6];',
  12593. '$mod.Arr[7] = $mod.Arr[8];',
  12594. 'var $with1 = $mod.Arr;',
  12595. '$with1[9] = $with1[10];',
  12596. '$mod.DoIt($mod.Arr[7], $mod.Arr[8], {',
  12597. ' a: 9,',
  12598. ' p: $mod.Arr,',
  12599. ' get: function () {',
  12600. ' return this.p[this.a];',
  12601. ' },',
  12602. ' set: function (v) {',
  12603. ' this.p[this.a] = v;',
  12604. ' }',
  12605. '}, {',
  12606. ' a: 10,',
  12607. ' p: $mod.Arr,',
  12608. ' get: function () {',
  12609. ' return this.p[this.a];',
  12610. ' },',
  12611. ' set: function (v) {',
  12612. ' this.p[this.a] = v;',
  12613. ' }',
  12614. '});',
  12615. '']));
  12616. end;
  12617. procedure TTestModule.TestExternalClass_BracketAccessor_2ParamsFail;
  12618. begin
  12619. StartProgram(false);
  12620. Add('{$modeswitch externalclass}');
  12621. Add('type');
  12622. Add(' TJSArray = class external name ''Array2''');
  12623. Add(' function GetItems(Index1, Index2: longint): jsvalue; external name ''[]'';');
  12624. Add(' procedure SetItems(Index1, Index2: longint; Value: jsvalue); external name ''[]'';');
  12625. Add(' property Items[Index1, Index2: longint]: jsvalue read GetItems write SetItems; default;');
  12626. Add(' end;');
  12627. Add('begin');
  12628. SetExpectedPasResolverError(sBracketAccessorOfExternalClassMustHaveOneParameter,
  12629. nBracketAccessorOfExternalClassMustHaveOneParameter);
  12630. ConvertProgram;
  12631. end;
  12632. procedure TTestModule.TestExternalClass_BracketAccessor_ReadOnly;
  12633. begin
  12634. StartProgram(false);
  12635. Add('{$modeswitch externalclass}');
  12636. Add('type');
  12637. Add(' TJSArray = class external name ''Array2''');
  12638. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  12639. Add(' property Items[Index: longint]: jsvalue read GetItems; default;');
  12640. Add(' end;');
  12641. Add('procedure DoIt(vI: JSValue; const vJ: jsvalue);');
  12642. Add('begin end;');
  12643. Add('var');
  12644. Add(' Arr: tjsarray;');
  12645. Add(' v: jsvalue;');
  12646. Add('begin');
  12647. Add(' v:=arr[0];');
  12648. Add(' v:=arr.items[1];');
  12649. Add(' with arr do v:=items[2];');
  12650. Add(' doit(arr[3],arr[4]);');
  12651. ConvertProgram;
  12652. CheckSource('TestExternalClass_BracketAccessor_ReadOnly',
  12653. LinesToStr([ // statements
  12654. 'this.DoIt = function (vI, vJ) {',
  12655. '};',
  12656. 'this.Arr = null;',
  12657. 'this.v = undefined;',
  12658. '']),
  12659. LinesToStr([ // $mod.$main
  12660. '$mod.v = $mod.Arr[0];',
  12661. '$mod.v = $mod.Arr[1];',
  12662. 'var $with1 = $mod.Arr;',
  12663. '$mod.v = $with1[2];',
  12664. '$mod.DoIt($mod.Arr[3], $mod.Arr[4]);',
  12665. '']));
  12666. end;
  12667. procedure TTestModule.TestExternalClass_BracketAccessor_WriteOnly;
  12668. begin
  12669. StartProgram(false);
  12670. Add('{$modeswitch externalclass}');
  12671. Add('type');
  12672. Add(' TJSArray = class external name ''Array2''');
  12673. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  12674. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  12675. Add(' end;');
  12676. Add('var');
  12677. Add(' Arr: tjsarray;');
  12678. Add(' s: string;');
  12679. Add(' i: longint;');
  12680. Add(' v: jsvalue;');
  12681. Add('begin');
  12682. Add(' arr[2]:=s;');
  12683. Add(' arr.items[3]:=s;');
  12684. Add(' arr[4]:=i;');
  12685. Add(' with arr do items[5]:=i;');
  12686. ConvertProgram;
  12687. CheckSource('TestExternalClass_BracketAccessor_WriteOnly',
  12688. LinesToStr([ // statements
  12689. 'this.Arr = null;',
  12690. 'this.s = "";',
  12691. 'this.i = 0;',
  12692. 'this.v = undefined;',
  12693. '']),
  12694. LinesToStr([ // $mod.$main
  12695. '$mod.Arr[2] = $mod.s;',
  12696. '$mod.Arr[3] = $mod.s;',
  12697. '$mod.Arr[4] = $mod.i;',
  12698. 'var $with1 = $mod.Arr;',
  12699. '$with1[5] = $mod.i;',
  12700. '']));
  12701. end;
  12702. procedure TTestModule.TestExternalClass_BracketAccessor_MultiType;
  12703. begin
  12704. StartProgram(false);
  12705. Add('{$modeswitch externalclass}');
  12706. Add('type');
  12707. Add(' TJSArray = class external name ''Array2''');
  12708. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  12709. Add(' property Items[Index: longint]: jsvalue write SetItems; default;');
  12710. Add(' procedure SetNumbers(Index: longint; Value: longint); external name ''[]'';');
  12711. Add(' property Numbers[Index: longint]: longint write SetNumbers;');
  12712. Add(' end;');
  12713. Add('var');
  12714. Add(' Arr: tjsarray;');
  12715. Add(' s: string;');
  12716. Add(' i: longint;');
  12717. Add(' v: jsvalue;');
  12718. Add('begin');
  12719. Add(' arr[2]:=s;');
  12720. Add(' arr.items[3]:=s;');
  12721. Add(' arr.numbers[4]:=i;');
  12722. Add(' with arr do items[5]:=i;');
  12723. Add(' with arr do numbers[6]:=i;');
  12724. ConvertProgram;
  12725. CheckSource('TestExternalClass_BracketAccessor_MultiType',
  12726. LinesToStr([ // statements
  12727. 'this.Arr = null;',
  12728. 'this.s = "";',
  12729. 'this.i = 0;',
  12730. 'this.v = undefined;',
  12731. '']),
  12732. LinesToStr([ // $mod.$main
  12733. '$mod.Arr[2] = $mod.s;',
  12734. '$mod.Arr[3] = $mod.s;',
  12735. '$mod.Arr[4] = $mod.i;',
  12736. 'var $with1 = $mod.Arr;',
  12737. '$with1[5] = $mod.i;',
  12738. 'var $with2 = $mod.Arr;',
  12739. '$with2[6] = $mod.i;',
  12740. '']));
  12741. end;
  12742. procedure TTestModule.TestExternalClass_BracketAccessor_Index;
  12743. begin
  12744. StartProgram(false);
  12745. Add('{$modeswitch externalclass}');
  12746. Add('type');
  12747. Add(' TJSArray = class external name ''Array2''');
  12748. Add(' function GetItems(Index: longint): jsvalue; external name ''[]'';');
  12749. Add(' procedure SetItems(Index: longint; Value: jsvalue); external name ''[]'';');
  12750. Add(' property Items[Index: longint]: jsvalue read GetItems write SetItems; default;');
  12751. Add(' end;');
  12752. Add('var');
  12753. Add(' Arr: tjsarray;');
  12754. Add(' i: longint;');
  12755. Add(' IntArr: array of longint;');
  12756. Add(' v: jsvalue;');
  12757. Add('begin');
  12758. Add(' v:=arr.items[i];');
  12759. Add(' arr[longint(v)]:=arr.items[intarr[0]];');
  12760. Add(' arr.items[intarr[1]]:=arr[IntArr[2]];');
  12761. ConvertProgram;
  12762. CheckSource('TestExternalClass_BracketAccessor_Index',
  12763. LinesToStr([ // statements
  12764. 'this.Arr = null;',
  12765. 'this.i = 0;',
  12766. 'this.IntArr = [];',
  12767. 'this.v = undefined;',
  12768. '']),
  12769. LinesToStr([ // $mod.$main
  12770. '$mod.v = $mod.Arr[$mod.i];',
  12771. '$mod.Arr[Math.floor($mod.v)] = $mod.Arr[$mod.IntArr[0]];',
  12772. '$mod.Arr[$mod.IntArr[1]] = $mod.Arr[$mod.IntArr[2]];',
  12773. '']));
  12774. end;
  12775. procedure TTestModule.TestExternalClass_ForInJSObject;
  12776. begin
  12777. StartProgram(false);
  12778. Add([
  12779. '{$modeswitch externalclass}',
  12780. 'type',
  12781. ' TJSObject = class external name ''Object''',
  12782. ' end;',
  12783. 'var',
  12784. ' o: TJSObject;',
  12785. ' key: string;',
  12786. 'begin',
  12787. ' for key in o do',
  12788. ' if key=''abc'' then ;',
  12789. '']);
  12790. ConvertProgram;
  12791. CheckSource('TestExternalClass_ForInJSObject',
  12792. LinesToStr([ // statements
  12793. 'this.o = null;',
  12794. 'this.key = "";',
  12795. '']),
  12796. LinesToStr([ // $mod.$main
  12797. 'for ($mod.key in $mod.o) if ($mod.key === "abc") ;',
  12798. '']));
  12799. end;
  12800. procedure TTestModule.TestClassInterface_Corba;
  12801. begin
  12802. StartProgram(false);
  12803. Add([
  12804. '{$interfaces corba}',
  12805. 'type',
  12806. ' IUnknown = interface;',
  12807. ' IUnknown = interface',
  12808. ' [''{00000000-0000-0000-C000-000000000046}'']',
  12809. ' end;',
  12810. ' IInterface = IUnknown;',
  12811. ' IBird = interface(IInterface)',
  12812. ' function GetSize: longint;',
  12813. ' procedure SetSize(i: longint);',
  12814. ' property Size: longint read GetSize write SetSize;',
  12815. ' procedure DoIt(i: longint);',
  12816. ' end;',
  12817. ' TObject = class',
  12818. ' end;',
  12819. ' TBird = class(TObject,IBird)',
  12820. ' function GetSize: longint; virtual; abstract;',
  12821. ' procedure SetSize(i: longint); virtual; abstract;',
  12822. ' procedure DoIt(i: longint); virtual; abstract;',
  12823. ' end;',
  12824. 'var',
  12825. ' BirdIntf: IBird;',
  12826. 'begin',
  12827. ' BirdIntf.Size:=BirdIntf.Size;',
  12828. '']);
  12829. ConvertProgram;
  12830. CheckSource('TestClassInterface_Corba',
  12831. LinesToStr([ // statements
  12832. 'rtl.createInterface($mod, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
  12833. 'rtl.createInterface($mod, "IBird", "{B0AF836B-4E58-31BA-A735-D744B6DAA205}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
  12834. 'rtl.createClass($mod, "TObject", null, function () {',
  12835. ' this.$init = function () {',
  12836. ' };',
  12837. ' this.$final = function () {',
  12838. ' };',
  12839. '});',
  12840. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  12841. ' this.$intfmaps = {};',
  12842. ' rtl.addIntf(this, $mod.IBird);',
  12843. '});',
  12844. 'this.BirdIntf = null;',
  12845. '']),
  12846. LinesToStr([ // $mod.$main
  12847. ' $mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
  12848. '']));
  12849. end;
  12850. procedure TTestModule.TestClassInterface_ProcExternalFail;
  12851. begin
  12852. StartProgram(false);
  12853. Add([
  12854. '{$interfaces corba}',
  12855. 'type',
  12856. ' IUnknown = interface',
  12857. ' procedure DoIt; external name ''foo'';',
  12858. ' end;',
  12859. 'begin']);
  12860. SetExpectedParserError(
  12861. 'Fields are not allowed in Interfaces at token "Identifier external" in file test1.pp at line 6 column 21',
  12862. nParserNoFieldsAllowed);
  12863. ConvertProgram;
  12864. end;
  12865. procedure TTestModule.TestClassInterface_Overloads;
  12866. begin
  12867. StartProgram(false);
  12868. Add([
  12869. '{$interfaces corba}',
  12870. 'type',
  12871. ' integer = longint;',
  12872. ' IUnknown = interface',
  12873. ' procedure DoIt(i: integer);',
  12874. ' procedure DoIt(s: string);',
  12875. ' end;',
  12876. ' IBird = interface(IUnknown)',
  12877. ' procedure DoIt(b: boolean); overload;',
  12878. ' end;',
  12879. ' TObject = class',
  12880. ' end;',
  12881. ' TBird = class(TObject,IBird)',
  12882. ' procedure DoIt(o: TObject);',
  12883. ' procedure DoIt(s: string);',
  12884. ' procedure DoIt(i: integer);',
  12885. ' procedure DoIt(b: boolean);',
  12886. ' end;',
  12887. 'procedure TBird.DoIt(o: TObject); begin end;',
  12888. 'procedure TBird.DoIt(s: string); begin end;',
  12889. 'procedure TBird.DoIt(i: integer); begin end;',
  12890. 'procedure TBird.DoIt(b: boolean); begin end;',
  12891. 'var',
  12892. ' BirdIntf: IBird;',
  12893. 'begin',
  12894. ' BirdIntf.DoIt(3);',
  12895. ' BirdIntf.DoIt(''abc'');',
  12896. ' BirdIntf.DoIt(true);',
  12897. '']);
  12898. ConvertProgram;
  12899. CheckSource('TestClassInterface_Overloads',
  12900. LinesToStr([ // statements
  12901. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E71-32CA-B8EF-650000000000}", ["DoIt", "DoIt$1"], null);',
  12902. 'rtl.createInterface($mod, "IBird", "{D2E3FF4A-AF76-3468-AB38-EB26B77CE676}", ["DoIt$2"], $mod.IUnknown);',
  12903. 'rtl.createClass($mod, "TObject", null, function () {',
  12904. ' this.$init = function () {',
  12905. ' };',
  12906. ' this.$final = function () {',
  12907. ' };',
  12908. '});',
  12909. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  12910. ' this.DoIt = function (o) {',
  12911. ' };',
  12912. ' this.DoIt$1 = function (s) {',
  12913. ' };',
  12914. ' this.DoIt$2 = function (i) {',
  12915. ' };',
  12916. ' this.DoIt$3 = function (b) {',
  12917. ' };',
  12918. ' this.$intfmaps = {};',
  12919. ' rtl.addIntf(this, $mod.IBird, {',
  12920. ' DoIt$2: "DoIt$3",',
  12921. ' DoIt: "DoIt$2"',
  12922. ' });',
  12923. '});',
  12924. 'this.BirdIntf = null;',
  12925. '']),
  12926. LinesToStr([ // $mod.$main
  12927. '$mod.BirdIntf.DoIt(3);',
  12928. '$mod.BirdIntf.DoIt$1("abc");',
  12929. '$mod.BirdIntf.DoIt$2(true);',
  12930. '']));
  12931. end;
  12932. procedure TTestModule.TestClassInterface_DuplicateGUIInIntfListFail;
  12933. begin
  12934. StartProgram(false);
  12935. Add([
  12936. '{$interfaces corba}',
  12937. 'type',
  12938. ' IBird = interface',
  12939. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  12940. ' end;',
  12941. ' IDog = interface',
  12942. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  12943. ' end;',
  12944. ' TObject = class(IBird,IDog)',
  12945. ' end;',
  12946. 'begin']);
  12947. SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IDog and IBird',
  12948. nDuplicateGUIDXInYZ);
  12949. ConvertProgram;
  12950. end;
  12951. procedure TTestModule.TestClassInterface_DuplicateGUIInAncestorFail;
  12952. begin
  12953. StartProgram(false);
  12954. Add([
  12955. '{$interfaces corba}',
  12956. 'type',
  12957. ' IAnimal = interface',
  12958. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  12959. ' end;',
  12960. ' IBird = interface(IAnimal)',
  12961. ' end;',
  12962. ' IHawk = interface(IBird)',
  12963. ' [''{4B3BA825-E0EC-4799-A19C-55F714A07959}'']',
  12964. ' end;',
  12965. 'begin']);
  12966. SetExpectedPasResolverError('Duplicate GUID {4B3BA825-E0EC-4799-A19C-55F714A07959} in IHawk and IAnimal',
  12967. nDuplicateGUIDXInYZ);
  12968. ConvertProgram;
  12969. end;
  12970. procedure TTestModule.TestClassInterface_AncestorImpl;
  12971. begin
  12972. StartProgram(false);
  12973. Add([
  12974. '{$interfaces corba}',
  12975. 'type',
  12976. ' integer = longint;',
  12977. ' IUnknown = interface',
  12978. ' procedure DoIt(i: integer);',
  12979. ' end;',
  12980. ' IBird = interface',
  12981. ' procedure Fly(i: integer);',
  12982. ' end;',
  12983. ' TObject = class(IUnknown)',
  12984. ' procedure DoIt(i: integer);',
  12985. ' end;',
  12986. ' TBird = class(IBird)',
  12987. ' procedure Fly(i: integer);',
  12988. ' end;',
  12989. 'procedure TObject.DoIt(i: integer); begin end;',
  12990. 'procedure TBird.Fly(i: integer); begin end;',
  12991. 'begin',
  12992. '']);
  12993. ConvertProgram;
  12994. CheckSource('TestClassInterface_AncestorIntf',
  12995. LinesToStr([ // statements
  12996. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E71-32CA-8000-000000000000}", ["DoIt"], null);',
  12997. 'rtl.createInterface($mod, "IBird", "{585952B8-2CC8-3000-8000-000000000000}", ["Fly"], null);',
  12998. 'rtl.createClass($mod, "TObject", null, function () {',
  12999. ' this.$init = function () {',
  13000. ' };',
  13001. ' this.$final = function () {',
  13002. ' };',
  13003. ' this.DoIt = function (i) {',
  13004. ' };',
  13005. ' this.$intfmaps = {};',
  13006. ' rtl.addIntf(this, $mod.IUnknown);',
  13007. '});',
  13008. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13009. ' this.Fly = function (i) {',
  13010. ' };',
  13011. ' this.$intfmaps = {};',
  13012. ' rtl.addIntf(this, $mod.IBird);',
  13013. ' rtl.addIntf(this, $mod.IUnknown);',
  13014. '});',
  13015. '']),
  13016. LinesToStr([ // $mod.$main
  13017. '']));
  13018. end;
  13019. procedure TTestModule.TestClassInterface_ImplReintroduce;
  13020. begin
  13021. StartProgram(false);
  13022. Add([
  13023. '{$interfaces corba}',
  13024. 'type',
  13025. ' integer = longint;',
  13026. ' IBird = interface',
  13027. ' procedure DoIt(i: integer);',
  13028. ' end;',
  13029. ' TObject = class',
  13030. ' procedure DoIt(i: integer);',
  13031. ' end;',
  13032. ' TBird = class(IBird)',
  13033. ' procedure DoIt(i: integer); virtual; reintroduce;',
  13034. ' end;',
  13035. 'procedure TObject.DoIt(i: integer); begin end;',
  13036. 'procedure TBird.DoIt(i: integer); begin end;',
  13037. 'begin',
  13038. '']);
  13039. ConvertProgram;
  13040. CheckSource('TestClassInterface_ImplReintroduce',
  13041. LinesToStr([ // statements
  13042. 'rtl.createInterface($mod, "IBird", "{585952B8-EF65-3000-8000-000000000000}", ["DoIt"], null);',
  13043. 'rtl.createClass($mod, "TObject", null, function () {',
  13044. ' this.$init = function () {',
  13045. ' };',
  13046. ' this.$final = function () {',
  13047. ' };',
  13048. ' this.DoIt = function (i) {',
  13049. ' };',
  13050. '});',
  13051. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13052. ' this.DoIt$1 = function (i) {',
  13053. ' };',
  13054. ' this.$intfmaps = {};',
  13055. ' rtl.addIntf(this, $mod.IBird, {',
  13056. ' DoIt: "DoIt$1"',
  13057. ' });',
  13058. '});',
  13059. '']),
  13060. LinesToStr([ // $mod.$main
  13061. '']));
  13062. end;
  13063. procedure TTestModule.TestClassInterface_MethodResolution;
  13064. begin
  13065. StartProgram(false);
  13066. Add([
  13067. '{$interfaces corba}',
  13068. 'type',
  13069. ' IUnknown = interface',
  13070. ' procedure Walk(i: longint);',
  13071. ' end;',
  13072. ' IBird = interface(IUnknown)',
  13073. ' procedure Walk(b: boolean); overload;',
  13074. ' procedure Fly(s: string);',
  13075. ' end;',
  13076. ' TObject = class',
  13077. ' end;',
  13078. ' TBird = class(TObject,IBird)',
  13079. ' procedure IBird.Fly = Move;',
  13080. ' procedure IBird.Walk = Hop;',
  13081. ' procedure Hop(i: longint);',
  13082. ' procedure Move(s: string);',
  13083. ' procedure Hop(b: boolean);',
  13084. ' end;',
  13085. 'procedure TBird.Move(s: string); begin end;',
  13086. 'procedure TBird.Hop(i: longint); begin end;',
  13087. 'procedure TBird.Hop(b: boolean); begin end;',
  13088. 'var',
  13089. ' BirdIntf: IBird;',
  13090. 'begin',
  13091. ' BirdIntf.Walk(3);',
  13092. ' BirdIntf.Walk(true);',
  13093. ' BirdIntf.Fly(''abc'');',
  13094. '']);
  13095. ConvertProgram;
  13096. CheckSource('TestClassInterface_MethodResolution',
  13097. LinesToStr([ // statements
  13098. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E75-38F5-8000-000000000000}", ["Walk"], null);',
  13099. 'rtl.createInterface($mod, "IBird", "{F8E3FF4A-AF76-3468-BB38-1CCFAB120092}", ["Walk$1", "Fly"], $mod.IUnknown);',
  13100. 'rtl.createClass($mod, "TObject", null, function () {',
  13101. ' this.$init = function () {',
  13102. ' };',
  13103. ' this.$final = function () {',
  13104. ' };',
  13105. '});',
  13106. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13107. ' this.Hop = function (i) {',
  13108. ' };',
  13109. ' this.Move = function (s) {',
  13110. ' };',
  13111. ' this.Hop$1 = function (b) {',
  13112. ' };',
  13113. ' this.$intfmaps = {};',
  13114. ' rtl.addIntf(this, $mod.IBird, {',
  13115. ' Walk$1: "Hop$1",',
  13116. ' Fly: "Move",',
  13117. ' Walk: "Hop"',
  13118. ' });',
  13119. '});',
  13120. 'this.BirdIntf = null;',
  13121. '']),
  13122. LinesToStr([ // $mod.$main
  13123. '$mod.BirdIntf.Walk(3);',
  13124. '$mod.BirdIntf.Walk$1(true);',
  13125. '$mod.BirdIntf.Fly("abc");',
  13126. '']));
  13127. end;
  13128. procedure TTestModule.TestClassInterface_AncestorMoreInterfaces;
  13129. begin
  13130. StartProgram(false);
  13131. Add([
  13132. '{$interfaces com}',
  13133. 'type',
  13134. ' IUnknown = interface',
  13135. ' function _AddRef: longint;',
  13136. ' procedure Walk;',
  13137. ' end;',
  13138. ' IBird = interface end;',
  13139. ' IDog = interface end;',
  13140. ' TObject = class(IBird,IDog)',
  13141. ' function _AddRef: longint; virtual; abstract;',
  13142. ' procedure Walk; virtual; abstract;',
  13143. ' end;',
  13144. ' TBird = class(IUnknown)',
  13145. ' end;',
  13146. 'begin',
  13147. '']);
  13148. ConvertProgram;
  13149. CheckSource('TestClassInterface_COM_AncestorLess',
  13150. LinesToStr([ // statements
  13151. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-7588F5800000}", ["_AddRef", "Walk"], null);',
  13152. 'rtl.createInterface($mod, "IBird", "{136757F2-AF76-3468-8338-1526EC563676}", [], $mod.IUnknown);',
  13153. 'rtl.createInterface($mod, "IDog", "{136757F2-AF76-3468-8565-8D26EC563676}", [], $mod.IUnknown);',
  13154. 'rtl.createClass($mod, "TObject", null, function () {',
  13155. ' this.$init = function () {',
  13156. ' };',
  13157. ' this.$final = function () {',
  13158. ' };',
  13159. ' this.$intfmaps = {};',
  13160. ' rtl.addIntf(this, $mod.IBird);',
  13161. ' rtl.addIntf(this, $mod.IDog);',
  13162. '});',
  13163. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13164. ' this.$intfmaps = {};',
  13165. ' rtl.addIntf(this, $mod.IUnknown);',
  13166. ' rtl.addIntf(this, $mod.IBird);',
  13167. ' rtl.addIntf(this, $mod.IDog);',
  13168. '});',
  13169. '']),
  13170. LinesToStr([ // $mod.$main
  13171. '']));
  13172. end;
  13173. procedure TTestModule.TestClassInterface_Corba_Delegation;
  13174. begin
  13175. StartProgram(false);
  13176. Add([
  13177. '{$interfaces corba}',
  13178. 'type',
  13179. ' IUnknown = interface',
  13180. ' end;',
  13181. ' IBird = interface(IUnknown)',
  13182. ' procedure Fly(s: string);',
  13183. ' end;',
  13184. ' IEagle = interface(IBird)',
  13185. ' end;',
  13186. ' IDove = interface(IBird)',
  13187. ' end;',
  13188. ' ISwallow = interface(IBird)',
  13189. ' end;',
  13190. ' TObject = class',
  13191. ' end;',
  13192. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  13193. ' procedure Fly(s: string); virtual; abstract;',
  13194. ' end;',
  13195. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  13196. ' FBirdIntf: IBird;',
  13197. ' property BirdIntf: IBird read FBirdIntf implements IBird;',
  13198. ' function GetEagleIntf: IEagle; virtual; abstract;',
  13199. ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  13200. ' FDoveObj: TBird;',
  13201. ' property DoveObj: TBird read FDoveObj implements IDove;',
  13202. ' function GetSwallowObj: TBird; virtual; abstract;',
  13203. ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  13204. ' end;',
  13205. 'begin',
  13206. '']);
  13207. ConvertProgram;
  13208. CheckSource('TestClassInterface_Delegation',
  13209. LinesToStr([ // statements
  13210. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  13211. 'rtl.createInterface($mod, "IBird", "{48E3FF4A-AF76-3465-A738-D745ABE63074}", ["Fly"], $mod.IUnknown);',
  13212. 'rtl.createInterface($mod, "IEagle", "{56CEF525-B037-3078-82F5-4C3CF0629879}", [], $mod.IBird);',
  13213. 'rtl.createInterface($mod, "IDove", "{56CEF525-B037-3078-8169-F7ECF0629879}", [], $mod.IBird);',
  13214. 'rtl.createInterface($mod, "ISwallow", "{56CEF525-B037-3078-90A3-CCE44C629879}", [], $mod.IBird);',
  13215. 'rtl.createClass($mod, "TObject", null, function () {',
  13216. ' this.$init = function () {',
  13217. ' };',
  13218. ' this.$final = function () {',
  13219. ' };',
  13220. '});',
  13221. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13222. ' this.$intfmaps = {};',
  13223. ' rtl.addIntf(this, $mod.IBird);',
  13224. ' rtl.addIntf(this, $mod.IEagle);',
  13225. ' rtl.addIntf(this, $mod.IDove);',
  13226. ' rtl.addIntf(this, $mod.ISwallow);',
  13227. '});',
  13228. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  13229. ' this.$init = function () {',
  13230. ' $mod.TObject.$init.call(this);',
  13231. ' this.FBirdIntf = null;',
  13232. ' this.FDoveObj = null;',
  13233. ' };',
  13234. ' this.$final = function () {',
  13235. ' this.FBirdIntf = undefined;',
  13236. ' this.FDoveObj = undefined;',
  13237. ' $mod.TObject.$final.call(this);',
  13238. ' };',
  13239. ' this.$intfmaps = {',
  13240. ' "{48E3FF4A-AF76-3465-A738-D745ABE63074}": function () {',
  13241. ' return this.FBirdIntf;',
  13242. ' },',
  13243. ' "{56CEF525-B037-3078-82F5-4C3CF0629879}": function () {',
  13244. ' return this.GetEagleIntf();',
  13245. ' },',
  13246. ' "{56CEF525-B037-3078-8169-F7ECF0629879}": function () {',
  13247. ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
  13248. ' },',
  13249. ' "{56CEF525-B037-3078-90A3-CCE44C629879}": function () {',
  13250. ' return rtl.getIntfT(this.GetSwallowObj(), $mod.ISwallow);',
  13251. ' }',
  13252. ' };',
  13253. '});',
  13254. '']),
  13255. LinesToStr([ // $mod.$main
  13256. '']));
  13257. end;
  13258. procedure TTestModule.TestClassInterface_Corba_DelegationStatic;
  13259. begin
  13260. StartProgram(false);
  13261. Add([
  13262. '{$interfaces corba}',
  13263. 'type',
  13264. ' IUnknown = interface',
  13265. ' end;',
  13266. ' IBird = interface(IUnknown)',
  13267. ' procedure Fly(s: string);',
  13268. ' end;',
  13269. ' IEagle = interface(IBird)',
  13270. ' end;',
  13271. ' IDove = interface(IBird)',
  13272. ' end;',
  13273. ' ISwallow = interface(IBird)',
  13274. ' end;',
  13275. ' TObject = class',
  13276. ' end;',
  13277. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  13278. ' procedure Fly(s: string); virtual; abstract;',
  13279. ' end;',
  13280. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  13281. ' private',
  13282. ' class var FBirdIntf: IBird;',
  13283. ' class var FDoveObj: TBird;',
  13284. ' class function GetEagleIntf: IEagle; virtual; abstract;',
  13285. ' class function GetSwallowObj: TBird; virtual; abstract;',
  13286. ' protected',
  13287. ' class property BirdIntf: IBird read FBirdIntf implements IBird;',
  13288. ' class property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  13289. ' class property DoveObj: TBird read FDoveObj implements IDove;',
  13290. ' class property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  13291. ' end;',
  13292. 'begin',
  13293. '']);
  13294. ConvertProgram;
  13295. CheckSource('TestClassInterface_DelegationStatic',
  13296. LinesToStr([ // statements
  13297. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  13298. 'rtl.createInterface($mod, "IBird", "{48E3FF4A-AF76-3465-A738-D745ABE63074}", ["Fly"], $mod.IUnknown);',
  13299. 'rtl.createInterface($mod, "IEagle", "{56CEF525-B037-3078-82F5-4C3CF0629879}", [], $mod.IBird);',
  13300. 'rtl.createInterface($mod, "IDove", "{56CEF525-B037-3078-8169-F7ECF0629879}", [], $mod.IBird);',
  13301. 'rtl.createInterface($mod, "ISwallow", "{56CEF525-B037-3078-90A3-CCE44C629879}", [], $mod.IBird);',
  13302. 'rtl.createClass($mod, "TObject", null, function () {',
  13303. ' this.$init = function () {',
  13304. ' };',
  13305. ' this.$final = function () {',
  13306. ' };',
  13307. '});',
  13308. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13309. ' this.$intfmaps = {};',
  13310. ' rtl.addIntf(this, $mod.IBird);',
  13311. ' rtl.addIntf(this, $mod.IEagle);',
  13312. ' rtl.addIntf(this, $mod.IDove);',
  13313. ' rtl.addIntf(this, $mod.ISwallow);',
  13314. '});',
  13315. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  13316. ' this.FBirdIntf = null;',
  13317. ' this.FDoveObj = null;',
  13318. ' this.$intfmaps = {',
  13319. ' "{48E3FF4A-AF76-3465-A738-D745ABE63074}": function () {',
  13320. ' return this.FBirdIntf;',
  13321. ' },',
  13322. ' "{56CEF525-B037-3078-82F5-4C3CF0629879}": function () {',
  13323. ' return this.$class.GetEagleIntf();',
  13324. ' },',
  13325. ' "{56CEF525-B037-3078-8169-F7ECF0629879}": function () {',
  13326. ' return rtl.getIntfT(this.FDoveObj, $mod.IDove);',
  13327. ' },',
  13328. ' "{56CEF525-B037-3078-90A3-CCE44C629879}": function () {',
  13329. ' return rtl.getIntfT(this.$class.GetSwallowObj(), $mod.ISwallow);',
  13330. ' }',
  13331. ' };',
  13332. '});',
  13333. '']),
  13334. LinesToStr([ // $mod.$main
  13335. '']));
  13336. end;
  13337. procedure TTestModule.TestClassInterface_Corba_Operators;
  13338. begin
  13339. StartProgram(false);
  13340. Add([
  13341. '{$interfaces corba}',
  13342. 'type',
  13343. ' IUnknown = interface',
  13344. ' end;',
  13345. ' IBird = interface(IUnknown)',
  13346. ' function GetItems(Index: longint): longint;',
  13347. ' procedure SetItems(Index: longint; Value: longint);',
  13348. ' property Items[Index: longint]: longint read GetItems write SetItems; default;',
  13349. ' end;',
  13350. ' TObject = class',
  13351. ' end;',
  13352. ' TBird = class(TObject,IBird)',
  13353. ' function GetItems(Index: longint): longint; virtual; abstract;',
  13354. ' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
  13355. ' end;',
  13356. 'var',
  13357. ' IntfVar: IBird = nil;',
  13358. ' IntfVar2: IBird;',
  13359. ' ObjVar: TBird;',
  13360. ' v: JSValue;',
  13361. 'begin',
  13362. ' IntfVar:=nil;',
  13363. ' IntfVar[3]:=IntfVar[4];',
  13364. ' if Assigned(IntfVar) then ;',
  13365. ' IntfVar:=IntfVar2;',
  13366. ' IntfVar:=ObjVar;',
  13367. ' if IntfVar=IntfVar2 then ;',
  13368. ' if IntfVar<>IntfVar2 then ;',
  13369. ' if IntfVar is IBird then ;',
  13370. ' if IntfVar is TBird then ;',
  13371. ' if ObjVar is IBird then ;',
  13372. ' IntfVar:=IntfVar2 as IBird;',
  13373. ' ObjVar:=IntfVar2 as TBird;',
  13374. ' IntfVar:=ObjVar as IBird;',
  13375. ' IntfVar:=IBird(IntfVar2);',
  13376. ' ObjVar:=TBird(IntfVar);',
  13377. ' IntfVar:=IBird(ObjVar);',
  13378. ' v:=IntfVar;',
  13379. ' IntfVar:=IBird(v);',
  13380. ' if v is IBird then ;',
  13381. ' v:=JSValue(IntfVar);',
  13382. ' v:=IBird;',
  13383. '']);
  13384. ConvertProgram;
  13385. CheckSource('TestClassInterface_Corba_Operators',
  13386. LinesToStr([ // statements
  13387. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  13388. 'rtl.createInterface($mod, "IBird", "{8E3C13AF-8080-3465-A738-D7460F8FE995}", ["GetItems", "SetItems"], $mod.IUnknown);',
  13389. 'rtl.createClass($mod, "TObject", null, function () {',
  13390. ' this.$init = function () {',
  13391. ' };',
  13392. ' this.$final = function () {',
  13393. ' };',
  13394. '});',
  13395. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13396. ' this.$intfmaps = {};',
  13397. ' rtl.addIntf(this, $mod.IBird);',
  13398. '});',
  13399. 'this.IntfVar = null;',
  13400. 'this.IntfVar2 = null;',
  13401. 'this.ObjVar = null;',
  13402. 'this.v = undefined;',
  13403. '']),
  13404. LinesToStr([ // $mod.$main
  13405. '$mod.IntfVar = null;',
  13406. '$mod.IntfVar.SetItems(3, $mod.IntfVar.GetItems(4));',
  13407. 'if ($mod.IntfVar != null) ;',
  13408. '$mod.IntfVar = $mod.IntfVar2;',
  13409. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar,$mod.IBird);',
  13410. 'if ($mod.IntfVar === $mod.IntfVar2) ;',
  13411. 'if ($mod.IntfVar !== $mod.IntfVar2) ;',
  13412. 'if ($mod.IBird.isPrototypeOf($mod.IntfVar)) ;',
  13413. 'if (rtl.intfIsClass($mod.IntfVar, $mod.TBird)) ;',
  13414. 'if (rtl.getIntfT($mod.ObjVar, $mod.IBird) !== null) ;',
  13415. '$mod.IntfVar = rtl.as($mod.IntfVar2, $mod.IBird);',
  13416. '$mod.ObjVar = rtl.intfAsClass($mod.IntfVar2, $mod.TBird);',
  13417. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
  13418. '$mod.IntfVar = $mod.IntfVar2;',
  13419. '$mod.ObjVar = rtl.intfToClass($mod.IntfVar, $mod.TBird);',
  13420. '$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
  13421. '$mod.v = $mod.IntfVar;',
  13422. '$mod.IntfVar = rtl.getObject($mod.v);',
  13423. 'if (rtl.isExt($mod.v, $mod.IBird, 1)) ;',
  13424. '$mod.v = rtl.getObject($mod.IntfVar);',
  13425. '$mod.v = $mod.IBird;',
  13426. '']));
  13427. end;
  13428. procedure TTestModule.TestClassInterface_Corba_Args;
  13429. begin
  13430. StartProgram(false);
  13431. Add([
  13432. '{$interfaces corba}',
  13433. 'type',
  13434. ' IUnknown = interface',
  13435. ' end;',
  13436. ' IBird = interface(IUnknown)',
  13437. ' end;',
  13438. ' TObject = class',
  13439. ' end;',
  13440. ' TBird = class(TObject,IBird)',
  13441. ' end;',
  13442. 'procedure DoIt(var u; i: IBird; const j: IBird);',
  13443. 'begin',
  13444. ' DoIt(i,i,i);',
  13445. 'end;',
  13446. 'procedure Change(var i: IBird; out j: IBird);',
  13447. 'begin',
  13448. ' DoIt(i,i,i);',
  13449. ' Change(i,i);',
  13450. 'end;',
  13451. 'var',
  13452. ' i: IBird;',
  13453. ' o: TBird;',
  13454. 'begin',
  13455. ' DoIt(i,i,i);',
  13456. ' Change(i,i);',
  13457. ' DoIt(o,o,o);',
  13458. '']);
  13459. ConvertProgram;
  13460. CheckSource('TestClassInterface_Corba_Args',
  13461. LinesToStr([ // statements
  13462. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  13463. 'rtl.createInterface($mod, "IBird", "{48E3FF4A-AF76-3465-A738-D462ECC63074}", [], $mod.IUnknown);',
  13464. 'rtl.createClass($mod, "TObject", null, function () {',
  13465. ' this.$init = function () {',
  13466. ' };',
  13467. ' this.$final = function () {',
  13468. ' };',
  13469. '});',
  13470. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  13471. ' this.$intfmaps = {};',
  13472. ' rtl.addIntf(this, $mod.IBird);',
  13473. '});',
  13474. 'this.DoIt = function (u, i, j) {',
  13475. ' $mod.DoIt({',
  13476. ' get: function () {',
  13477. ' return i;',
  13478. ' },',
  13479. ' set: function (v) {',
  13480. ' i = v;',
  13481. ' }',
  13482. ' }, i, i);',
  13483. '};',
  13484. 'this.Change = function (i, j) {',
  13485. ' $mod.DoIt(i, i.get(), i.get());',
  13486. ' $mod.Change(i, i);',
  13487. '};',
  13488. 'this.i = null;',
  13489. 'this.o = null;',
  13490. '']),
  13491. LinesToStr([ // $mod.$main
  13492. '$mod.DoIt({',
  13493. ' p: $mod,',
  13494. ' get: function () {',
  13495. ' return this.p.i;',
  13496. ' },',
  13497. ' set: function (v) {',
  13498. ' this.p.i = v;',
  13499. ' }',
  13500. '}, $mod.i, $mod.i);',
  13501. '$mod.Change({',
  13502. ' p: $mod,',
  13503. ' get: function () {',
  13504. ' return this.p.i;',
  13505. ' },',
  13506. ' set: function (v) {',
  13507. ' this.p.i = v;',
  13508. ' }',
  13509. '}, {',
  13510. ' p: $mod,',
  13511. ' get: function () {',
  13512. ' return this.p.i;',
  13513. ' },',
  13514. ' set: function (v) {',
  13515. ' this.p.i = v;',
  13516. ' }',
  13517. '});',
  13518. '$mod.DoIt({',
  13519. ' p: $mod,',
  13520. ' get: function () {',
  13521. ' return this.p.o;',
  13522. ' },',
  13523. ' set: function (v) {',
  13524. ' this.p.o = v;',
  13525. ' }',
  13526. '}, rtl.getIntfT($mod.o, $mod.IBird), rtl.getIntfT($mod.o, $mod.IBird));',
  13527. '']));
  13528. end;
  13529. procedure TTestModule.TestClassInterface_Corba_ForIn;
  13530. begin
  13531. StartProgram(false);
  13532. Add([
  13533. '{$interfaces corba}',
  13534. 'type',
  13535. ' IUnknown = interface end;',
  13536. ' TObject = class',
  13537. ' Id: longint;',
  13538. ' end;',
  13539. ' IEnumerator = interface(IUnknown)',
  13540. ' function GetCurrent: TObject;',
  13541. ' function MoveNext: Boolean;',
  13542. ' property Current: TObject read GetCurrent;',
  13543. ' end;',
  13544. ' IEnumerable = interface(IUnknown)',
  13545. ' function GetEnumerator: IEnumerator;',
  13546. ' end;',
  13547. 'var',
  13548. ' o: TObject;',
  13549. ' i: IEnumerable;',
  13550. 'begin',
  13551. ' for o in i do o.Id:=3;',
  13552. '']);
  13553. ConvertProgram;
  13554. CheckSource('TestClassInterface_Corba_ForIn',
  13555. LinesToStr([ // statements
  13556. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  13557. 'rtl.createClass($mod, "TObject", null, function () {',
  13558. ' this.$init = function () {',
  13559. ' this.Id = 0;',
  13560. ' };',
  13561. ' this.$final = function () {',
  13562. ' };',
  13563. '});',
  13564. 'rtl.createInterface($mod, "IEnumerator", "{D2FE11F3-D2CC-36BB-A5B2-66EB7FB5CB08}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
  13565. 'rtl.createInterface($mod, "IEnumerable", "{D20534CB-D9C0-3EA5-AA60-ACEB7D726308}", ["GetEnumerator"], $mod.IUnknown);',
  13566. 'this.o = null;',
  13567. 'this.i = null;',
  13568. '']),
  13569. LinesToStr([ // $mod.$main
  13570. 'var $in1 = $mod.i.GetEnumerator();',
  13571. 'while ($in1.MoveNext()) {',
  13572. ' $mod.o = $in1.GetCurrent();',
  13573. ' $mod.o.Id = 3;',
  13574. '};',
  13575. '']));
  13576. end;
  13577. procedure TTestModule.TestClassInterface_COM_AssignVar;
  13578. begin
  13579. StartProgram(false);
  13580. Add([
  13581. '{$interfaces com}',
  13582. 'type',
  13583. ' IUnknown = interface',
  13584. ' function _AddRef: longint;',
  13585. ' function _Release: longint;',
  13586. ' end;',
  13587. ' TObject = class(IUnknown)',
  13588. ' function _AddRef: longint; virtual; abstract;',
  13589. ' function _Release: longint; virtual; abstract;',
  13590. ' end;',
  13591. 'var',
  13592. ' i: IUnknown;',
  13593. 'procedure DoGlobal(o: TObject);',
  13594. 'begin',
  13595. ' i:=nil;',
  13596. ' i:=o;',
  13597. ' i:=i;',
  13598. 'end;',
  13599. 'procedure DoLocal(o: TObject);',
  13600. 'const k: IUnknown = nil;',
  13601. 'var j: IUnknown;',
  13602. 'begin',
  13603. ' k:=o;',
  13604. ' k:=i;',
  13605. ' j:=o;',
  13606. ' j:=i;',
  13607. 'end;',
  13608. 'var o: TObject;',
  13609. 'begin',
  13610. ' i:=nil;',
  13611. ' i:=o;',
  13612. '']);
  13613. ConvertProgram;
  13614. CheckSource('TestClassInterface_COM_AssignVar',
  13615. LinesToStr([ // statements
  13616. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  13617. 'rtl.createClass($mod, "TObject", null, function () {',
  13618. ' this.$init = function () {',
  13619. ' };',
  13620. ' this.$final = function () {',
  13621. ' };',
  13622. ' this.$intfmaps = {};',
  13623. ' rtl.addIntf(this, $mod.IUnknown);',
  13624. '});',
  13625. 'this.i = null;',
  13626. 'this.DoGlobal = function (o) {',
  13627. ' rtl.setIntfP($mod, "i", null);',
  13628. ' rtl.setIntfP($mod, "i", rtl.queryIntfT(o, $mod.IUnknown), true);',
  13629. ' rtl.setIntfP($mod, "i", $mod.i);',
  13630. '};',
  13631. 'var k = null;',
  13632. 'this.DoLocal = function (o) {',
  13633. ' var j = null;',
  13634. ' try{',
  13635. ' k = rtl.setIntfL(k, rtl.queryIntfT(o, $mod.IUnknown), true);',
  13636. ' k = rtl.setIntfL(k, $mod.i);',
  13637. ' j = rtl.setIntfL(j, rtl.queryIntfT(o, $mod.IUnknown), true);',
  13638. ' j = rtl.setIntfL(j, $mod.i);',
  13639. ' }finally{',
  13640. ' rtl._Release(j);',
  13641. ' };',
  13642. '};',
  13643. 'this.o = null;',
  13644. '']),
  13645. LinesToStr([ // $mod.$main
  13646. 'rtl.setIntfP($mod, "i", null);',
  13647. 'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.o, $mod.IUnknown), true);',
  13648. '']));
  13649. end;
  13650. procedure TTestModule.TestClassInterface_COM_AssignArg;
  13651. begin
  13652. StartProgram(false);
  13653. Add([
  13654. '{$interfaces com}',
  13655. 'type',
  13656. ' IUnknown = interface',
  13657. ' function _AddRef: longint;',
  13658. ' function _Release: longint;',
  13659. ' end;',
  13660. ' TObject = class(IUnknown)',
  13661. ' function _AddRef: longint; virtual; abstract;',
  13662. ' function _Release: longint; virtual; abstract;',
  13663. ' end;',
  13664. 'procedure DoDefault(i, j: IUnknown);',
  13665. 'begin',
  13666. ' i:=nil;',
  13667. ' i:=j;',
  13668. 'end;',
  13669. 'begin',
  13670. '']);
  13671. ConvertProgram;
  13672. CheckSource('TestClassInterface_COM_AssignArg',
  13673. LinesToStr([ // statements
  13674. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  13675. 'rtl.createClass($mod, "TObject", null, function () {',
  13676. ' this.$init = function () {',
  13677. ' };',
  13678. ' this.$final = function () {',
  13679. ' };',
  13680. ' this.$intfmaps = {};',
  13681. ' rtl.addIntf(this, $mod.IUnknown);',
  13682. '});',
  13683. 'this.DoDefault = function (i, j) {',
  13684. ' rtl._AddRef(i);',
  13685. ' try {',
  13686. ' i = rtl.setIntfL(i, null);',
  13687. ' i = rtl.setIntfL(i, j);',
  13688. ' } finally {',
  13689. ' rtl._Release(i);',
  13690. ' };',
  13691. '};',
  13692. '']),
  13693. LinesToStr([ // $mod.$main
  13694. '']));
  13695. end;
  13696. procedure TTestModule.TestClassInterface_COM_FunctionResult;
  13697. begin
  13698. StartProgram(false);
  13699. Add([
  13700. '{$interfaces com}',
  13701. 'type',
  13702. ' IUnknown = interface',
  13703. ' function _AddRef: longint;',
  13704. ' function _Release: longint;',
  13705. ' end;',
  13706. ' TObject = class(IUnknown)',
  13707. ' function _AddRef: longint; virtual; abstract;',
  13708. ' function _Release: longint; virtual; abstract;',
  13709. ' end;',
  13710. 'function DoDefault(i: IUnknown): IUnknown;',
  13711. 'begin',
  13712. ' Result:=i;',
  13713. ' if Result<>nil then exit;',
  13714. 'end;',
  13715. 'begin',
  13716. '']);
  13717. ConvertProgram;
  13718. CheckSource('TestClassInterface_COM_FunctionResult',
  13719. LinesToStr([ // statements
  13720. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  13721. 'rtl.createClass($mod, "TObject", null, function () {',
  13722. ' this.$init = function () {',
  13723. ' };',
  13724. ' this.$final = function () {',
  13725. ' };',
  13726. ' this.$intfmaps = {};',
  13727. ' rtl.addIntf(this, $mod.IUnknown);',
  13728. '});',
  13729. 'this.DoDefault = function (i) {',
  13730. ' var Result = null;',
  13731. ' var $ok = false;',
  13732. ' try {',
  13733. ' Result = rtl.setIntfL(Result, i);',
  13734. ' if(Result !== null){',
  13735. ' $ok = true;',
  13736. ' return Result;',
  13737. ' };',
  13738. ' $ok = true;',
  13739. ' } finally {',
  13740. ' if(!$ok) rtl._Release(Result);',
  13741. ' };',
  13742. ' return Result;',
  13743. '};',
  13744. '']),
  13745. LinesToStr([ // $mod.$main
  13746. '']));
  13747. end;
  13748. procedure TTestModule.TestClassInterface_COM_InheritedFuncResult;
  13749. begin
  13750. StartProgram(false);
  13751. Add([
  13752. '{$interfaces com}',
  13753. 'type',
  13754. ' IUnknown = interface',
  13755. ' function _AddRef: longint;',
  13756. ' function _Release: longint;',
  13757. ' end;',
  13758. ' TObject = class(IUnknown)',
  13759. ' function _AddRef: longint; virtual; abstract;',
  13760. ' function _Release: longint; virtual; abstract;',
  13761. ' function GetIntf: IUnknown; virtual;',
  13762. ' end;',
  13763. ' TMouse = class',
  13764. ' function GetIntf: IUnknown; override;',
  13765. ' end;',
  13766. 'function TObject.GetIntf: IUnknown; begin end;',
  13767. 'function TMouse.GetIntf: IUnknown;',
  13768. 'var i: IUnknown;',
  13769. 'begin',
  13770. ' inherited;',
  13771. ' inherited GetIntf;',
  13772. ' inherited GetIntf();',
  13773. ' Result:=inherited GetIntf;',
  13774. ' Result:=inherited GetIntf();',
  13775. ' i:=inherited GetIntf;',
  13776. ' i:=inherited GetIntf();',
  13777. 'end;',
  13778. 'begin',
  13779. '']);
  13780. ConvertProgram;
  13781. CheckSource('TestClassInterface_COM_InheritedFuncResult',
  13782. LinesToStr([ // statements
  13783. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  13784. 'rtl.createClass($mod, "TObject", null, function () {',
  13785. ' this.$init = function () {',
  13786. ' };',
  13787. ' this.$final = function () {',
  13788. ' };',
  13789. ' this.GetIntf = function () {',
  13790. ' var Result = null;',
  13791. ' return Result;',
  13792. ' };',
  13793. ' this.$intfmaps = {};',
  13794. ' rtl.addIntf(this, $mod.IUnknown);',
  13795. '});',
  13796. 'rtl.createClass($mod, "TMouse", $mod.TObject, function () {',
  13797. ' this.GetIntf = function () {',
  13798. ' var Result = null;',
  13799. ' var i = null;',
  13800. ' var $ir = rtl.createIntfRefs();',
  13801. ' var $ok = false;',
  13802. ' try {',
  13803. ' $ir.ref(1, $mod.TObject.GetIntf.apply(this, arguments));',
  13804. ' $ir.ref(2, $mod.TObject.GetIntf.call(this));',
  13805. ' $ir.ref(3, $mod.TObject.GetIntf.call(this));',
  13806. ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
  13807. ' Result = rtl.setIntfL(Result, $mod.TObject.GetIntf.call(this), true);',
  13808. ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
  13809. ' i = rtl.setIntfL(i, $mod.TObject.GetIntf.call(this), true);',
  13810. ' $ok = true;',
  13811. ' } finally {',
  13812. ' $ir.free();',
  13813. ' rtl._Release(i);',
  13814. ' if (!$ok) rtl._Release(Result);',
  13815. ' };',
  13816. ' return Result;',
  13817. ' };',
  13818. '});',
  13819. '']),
  13820. LinesToStr([ // $mod.$main
  13821. '']));
  13822. end;
  13823. procedure TTestModule.TestClassInterface_COM_IsAsTypeCasts;
  13824. begin
  13825. StartProgram(false);
  13826. Add([
  13827. '{$interfaces com}',
  13828. 'type',
  13829. ' IUnknown = interface',
  13830. ' function _AddRef: longint;',
  13831. ' function _Release: longint;',
  13832. ' end;',
  13833. ' TObject = class(IUnknown)',
  13834. ' function _AddRef: longint; virtual; abstract;',
  13835. ' function _Release: longint; virtual; abstract;',
  13836. ' end;',
  13837. 'procedure DoDefault(i, j: IUnknown; o: TObject);',
  13838. 'begin',
  13839. ' if i is IUnknown then ;',
  13840. ' if o is IUnknown then ;',
  13841. ' if i is TObject then ;',
  13842. ' i:=j as IUnknown;',
  13843. ' i:=o as IUnknown;',
  13844. ' o:=j as TObject;',
  13845. ' i:=IUnknown(j);',
  13846. ' i:=IUnknown(o);',
  13847. ' o:=TObject(i);',
  13848. 'end;',
  13849. 'begin',
  13850. '']);
  13851. ConvertProgram;
  13852. CheckSource('TestClassInterface_COM_IsAsTypeCasts',
  13853. LinesToStr([ // statements
  13854. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  13855. 'rtl.createClass($mod, "TObject", null, function () {',
  13856. ' this.$init = function () {',
  13857. ' };',
  13858. ' this.$final = function () {',
  13859. ' };',
  13860. ' this.$intfmaps = {};',
  13861. ' rtl.addIntf(this, $mod.IUnknown);',
  13862. '});',
  13863. 'this.DoDefault = function (i, j, o) {',
  13864. ' rtl._AddRef(i);',
  13865. ' try {',
  13866. ' if ($mod.IUnknown.isPrototypeOf(i)) ;',
  13867. ' if (rtl.queryIntfIsT(o, $mod.IUnknown)) ;',
  13868. ' if (rtl.intfIsClass(i, $mod.TObject)) ;',
  13869. ' i = rtl.setIntfL(i, rtl.as(j, $mod.IUnknown));',
  13870. ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
  13871. ' o = rtl.intfAsClass(j, $mod.TObject);',
  13872. ' i = rtl.setIntfL(i, j);',
  13873. ' i = rtl.setIntfL(i, rtl.queryIntfT(o, $mod.IUnknown), true);',
  13874. ' o = rtl.intfToClass(i, $mod.TObject);',
  13875. ' } finally {',
  13876. ' rtl._Release(i);',
  13877. ' };',
  13878. '};',
  13879. '']),
  13880. LinesToStr([ // $mod.$main
  13881. '']));
  13882. end;
  13883. procedure TTestModule.TestClassInterface_COM_PassAsArg;
  13884. begin
  13885. StartProgram(false);
  13886. Add([
  13887. '{$interfaces com}',
  13888. 'type',
  13889. ' IUnknown = interface',
  13890. ' function _AddRef: longint;',
  13891. ' function _Release: longint;',
  13892. ' end;',
  13893. ' TObject = class(IUnknown)',
  13894. ' function _AddRef: longint; virtual; abstract;',
  13895. ' function _Release: longint; virtual; abstract;',
  13896. ' end;',
  13897. 'procedure DoIt(v: IUnknown; const j: IUnknown; var k: IUnknown; out l: IUnknown);',
  13898. 'var o: TObject;',
  13899. 'begin',
  13900. ' DoIt(v,v,v,v);',
  13901. ' DoIt(o,o,k,k);',
  13902. 'end;',
  13903. 'procedure DoSome;',
  13904. 'var v: IUnknown;',
  13905. 'begin',
  13906. ' DoIt(v,v,v,v);',
  13907. 'end;',
  13908. 'var i: IUnknown;',
  13909. 'begin',
  13910. ' DoIt(i,i,i,i);',
  13911. '']);
  13912. ConvertProgram;
  13913. CheckSource('TestClassInterface_COM_PassAsArg',
  13914. LinesToStr([ // statements
  13915. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  13916. 'rtl.createClass($mod, "TObject", null, function () {',
  13917. ' this.$init = function () {',
  13918. ' };',
  13919. ' this.$final = function () {',
  13920. ' };',
  13921. ' this.$intfmaps = {};',
  13922. ' rtl.addIntf(this, $mod.IUnknown);',
  13923. '});',
  13924. 'this.DoIt = function (v, j, k, l) {',
  13925. ' var o = null;',
  13926. ' var $ir = rtl.createIntfRefs();',
  13927. ' rtl._AddRef(v);',
  13928. ' try {',
  13929. ' $mod.DoIt(v, v, {',
  13930. ' get: function () {',
  13931. ' return v;',
  13932. ' },',
  13933. ' set: function (w) {',
  13934. ' v = rtl.setIntfL(v, w);',
  13935. ' }',
  13936. ' }, {',
  13937. ' get: function () {',
  13938. ' return v;',
  13939. ' },',
  13940. ' set: function (w) {',
  13941. ' v = rtl.setIntfL(v, w);',
  13942. ' }',
  13943. ' });',
  13944. ' $mod.DoIt($ir.ref(1, rtl.queryIntfT(o, $mod.IUnknown)), $ir.ref(2, rtl.queryIntfT(o, $mod.IUnknown)), k, k);',
  13945. ' } finally {',
  13946. ' $ir.free();',
  13947. ' rtl._Release(v);',
  13948. ' };',
  13949. '};',
  13950. 'this.DoSome = function () {',
  13951. ' var v = null;',
  13952. ' try {',
  13953. ' $mod.DoIt(v, v, {',
  13954. ' get: function () {',
  13955. ' return v;',
  13956. ' },',
  13957. ' set: function (w) {',
  13958. ' v = rtl.setIntfL(v, w);',
  13959. ' }',
  13960. ' }, {',
  13961. ' get: function () {',
  13962. ' return v;',
  13963. ' },',
  13964. ' set: function (w) {',
  13965. ' v = rtl.setIntfL(v, w);',
  13966. ' }',
  13967. ' });',
  13968. ' } finally {',
  13969. ' rtl._Release(v);',
  13970. ' };',
  13971. '};',
  13972. 'this.i = null;',
  13973. '']),
  13974. LinesToStr([ // $mod.$main
  13975. '$mod.DoIt($mod.i, $mod.i, {',
  13976. ' p: $mod,',
  13977. ' get: function () {',
  13978. ' return this.p.i;',
  13979. ' },',
  13980. ' set: function (v) {',
  13981. ' rtl.setIntfP(this.p, "i", v);',
  13982. ' }',
  13983. '}, {',
  13984. ' p: $mod,',
  13985. ' get: function () {',
  13986. ' return this.p.i;',
  13987. ' },',
  13988. ' set: function (v) {',
  13989. ' rtl.setIntfP(this.p, "i", v);',
  13990. ' }',
  13991. '});',
  13992. '']));
  13993. end;
  13994. procedure TTestModule.TestClassInterface_COM_PassToUntypedParam;
  13995. begin
  13996. StartProgram(false);
  13997. Add([
  13998. '{$interfaces com}',
  13999. 'type',
  14000. ' IUnknown = interface',
  14001. ' function _AddRef: longint;',
  14002. ' function _Release: longint;',
  14003. ' end;',
  14004. ' TObject = class(IUnknown)',
  14005. ' function _AddRef: longint; virtual; abstract;',
  14006. ' function _Release: longint; virtual; abstract;',
  14007. ' end;',
  14008. 'procedure DoIt(out i);',
  14009. 'begin end;',
  14010. 'procedure DoSome;',
  14011. 'var v: IUnknown;',
  14012. 'begin',
  14013. ' DoIt(v);',
  14014. 'end;',
  14015. 'function GetIt: IUnknown;',
  14016. 'begin',
  14017. ' DoIt(Result);',
  14018. 'end;',
  14019. 'var i: IUnknown;',
  14020. 'begin',
  14021. ' DoIt(i);',
  14022. '']);
  14023. ConvertProgram;
  14024. CheckSource('TestClassInterface_COM_PassToUntypedParam',
  14025. LinesToStr([ // statements
  14026. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  14027. 'rtl.createClass($mod, "TObject", null, function () {',
  14028. ' this.$init = function () {',
  14029. ' };',
  14030. ' this.$final = function () {',
  14031. ' };',
  14032. ' this.$intfmaps = {};',
  14033. ' rtl.addIntf(this, $mod.IUnknown);',
  14034. '});',
  14035. 'this.DoIt = function (i) {',
  14036. '};',
  14037. 'this.DoSome = function () {',
  14038. ' var v = null;',
  14039. ' try {',
  14040. ' $mod.DoIt({',
  14041. ' get: function () {',
  14042. ' return v;',
  14043. ' },',
  14044. ' set: function (w) {',
  14045. ' v = w;',
  14046. ' }',
  14047. ' });',
  14048. ' } finally {',
  14049. ' rtl._Release(v);',
  14050. ' };',
  14051. '};',
  14052. 'this.GetIt = function () {',
  14053. ' var Result = null;',
  14054. ' var $ok = false;',
  14055. ' try {',
  14056. ' $mod.DoIt({',
  14057. ' get: function () {',
  14058. ' return Result;',
  14059. ' },',
  14060. ' set: function (v) {',
  14061. ' Result = v;',
  14062. ' }',
  14063. ' });',
  14064. ' $ok = true;',
  14065. ' } finally {',
  14066. ' if (!$ok) rtl._Release(Result);',
  14067. ' };',
  14068. ' return Result;',
  14069. '};',
  14070. 'this.i = null;',
  14071. '']),
  14072. LinesToStr([ // $mod.$main
  14073. 'try {',
  14074. ' $mod.DoIt({',
  14075. ' p: $mod,',
  14076. ' get: function () {',
  14077. ' return this.p.i;',
  14078. ' },',
  14079. ' set: function (v) {',
  14080. ' this.p.i = v;',
  14081. ' }',
  14082. ' });',
  14083. '} finally {',
  14084. ' rtl._Release($mod.i);',
  14085. '};',
  14086. '']));
  14087. end;
  14088. procedure TTestModule.TestClassInterface_COM_FunctionInExpr;
  14089. begin
  14090. StartProgram(false);
  14091. Add([
  14092. '{$interfaces com}',
  14093. 'type',
  14094. ' IUnknown = interface',
  14095. ' function _AddRef: longint;',
  14096. ' function _Release: longint;',
  14097. ' end;',
  14098. ' TObject = class(IUnknown)',
  14099. ' function _AddRef: longint; virtual; abstract;',
  14100. ' function _Release: longint; virtual; abstract;',
  14101. ' end;',
  14102. 'function GetIt: IUnknown;',
  14103. 'begin',
  14104. 'end;',
  14105. 'procedure DoSome;',
  14106. 'var v: IUnknown;',
  14107. ' i: longint;',
  14108. 'begin',
  14109. ' v:=GetIt;',
  14110. ' v:=GetIt();',
  14111. ' GetIt()._AddRef;',
  14112. ' i:=GetIt()._AddRef;',
  14113. 'end;',
  14114. 'var v: IUnknown;',
  14115. ' i: longint;',
  14116. 'begin',
  14117. ' v:=GetIt;',
  14118. ' v:=GetIt();',
  14119. ' GetIt()._AddRef;',
  14120. ' i:=GetIt()._AddRef;',
  14121. '']);
  14122. ConvertProgram;
  14123. CheckSource('TestClassInterface_COM_FunctionInExpr',
  14124. LinesToStr([ // statements
  14125. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  14126. 'rtl.createClass($mod, "TObject", null, function () {',
  14127. ' this.$init = function () {',
  14128. ' };',
  14129. ' this.$final = function () {',
  14130. ' };',
  14131. ' this.$intfmaps = {};',
  14132. ' rtl.addIntf(this, $mod.IUnknown);',
  14133. '});',
  14134. 'this.GetIt = function () {',
  14135. ' var Result = null;',
  14136. ' return Result;',
  14137. '};',
  14138. 'this.DoSome = function () {',
  14139. ' var v = null;',
  14140. ' var i = 0;',
  14141. ' var $ir = rtl.createIntfRefs();',
  14142. ' try {',
  14143. ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
  14144. ' v = rtl.setIntfL(v, $mod.GetIt(), true);',
  14145. ' $ir.ref(1, $mod.GetIt())._AddRef();',
  14146. ' i = $ir.ref(2, $mod.GetIt())._AddRef();',
  14147. ' } finally {',
  14148. ' $ir.free();',
  14149. ' rtl._Release(v);',
  14150. ' };',
  14151. '};',
  14152. 'this.v = null;',
  14153. 'this.i = 0;',
  14154. '']),
  14155. LinesToStr([ // $mod.$main
  14156. 'var $ir = rtl.createIntfRefs();',
  14157. 'try {',
  14158. ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
  14159. ' rtl.setIntfP($mod, "v", $mod.GetIt(), true);',
  14160. ' $ir.ref(1, $mod.GetIt())._AddRef();',
  14161. ' $mod.i = $ir.ref(2, $mod.GetIt())._AddRef();',
  14162. '} finally {',
  14163. ' $ir.free();',
  14164. '};',
  14165. '']));
  14166. end;
  14167. procedure TTestModule.TestClassInterface_COM_Property;
  14168. begin
  14169. StartProgram(false);
  14170. Add([
  14171. '{$interfaces com}',
  14172. 'type',
  14173. ' IUnknown = interface',
  14174. ' function _AddRef: longint;',
  14175. ' function _Release: longint;',
  14176. ' end;',
  14177. ' TObject = class(IUnknown)',
  14178. ' FAnt: IUnknown;',
  14179. ' function _AddRef: longint; virtual; abstract;',
  14180. ' function _Release: longint; virtual; abstract;',
  14181. ' function GetBird: IUnknown; virtual; abstract;',
  14182. ' procedure SetBird(Value: IUnknown); virtual; abstract;',
  14183. ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
  14184. ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
  14185. ' property Ant: IUnknown read FAnt write FAnt;',
  14186. ' property Bird: IUnknown read GetBird write SetBird;',
  14187. ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
  14188. ' end;',
  14189. 'procedure DoIt;',
  14190. 'var',
  14191. ' o: TObject;',
  14192. ' v: IUnknown;',
  14193. 'begin',
  14194. ' v:=o.Ant;',
  14195. ' o.Ant:=v;',
  14196. ' o.Ant:=o.Ant;',
  14197. ' v:=o.Bird;',
  14198. ' o.Bird:=v;',
  14199. ' o.Bird:=o.Bird;',
  14200. ' v:=o.Items[1];',
  14201. ' o.Items[2]:=v;',
  14202. ' o.Items[3]:=o.Items[4];',
  14203. ' v:=o[5];',
  14204. ' o[6]:=v;',
  14205. ' o[7]:=o[8];',
  14206. 'end;',
  14207. 'begin',
  14208. '']);
  14209. ConvertProgram;
  14210. CheckSource('TestClassInterface_COM_Property',
  14211. LinesToStr([ // statements
  14212. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  14213. 'rtl.createClass($mod, "TObject", null, function () {',
  14214. ' this.$init = function () {',
  14215. ' this.FAnt = null;',
  14216. ' };',
  14217. ' this.$final = function () {',
  14218. ' this.FAnt = undefined;',
  14219. ' };',
  14220. ' this.$intfmaps = {};',
  14221. ' rtl.addIntf(this, $mod.IUnknown);',
  14222. '});',
  14223. 'this.DoIt = function () {',
  14224. ' var o = null;',
  14225. ' var v = null;',
  14226. ' var $ir = rtl.createIntfRefs();',
  14227. ' try {',
  14228. ' v = rtl.setIntfL(v, o.FAnt);',
  14229. ' rtl.setIntfP(o, "FAnt", v);',
  14230. ' rtl.setIntfP(o, "FAnt", o.FAnt);',
  14231. ' v = rtl.setIntfL(v, o.GetBird(), true);',
  14232. ' o.SetBird(v);',
  14233. ' o.SetBird($ir.ref(1, o.GetBird()));',
  14234. ' v = rtl.setIntfL(v, o.GetItems(1), true);',
  14235. ' o.SetItems(2, v);',
  14236. ' o.SetItems(3, $ir.ref(2, o.GetItems(4)));',
  14237. ' v = rtl.setIntfL(v, o.GetItems(5), true);',
  14238. ' o.SetItems(6, v);',
  14239. ' o.SetItems(7, $ir.ref(3, o.GetItems(8)));',
  14240. ' } finally {',
  14241. ' $ir.free();',
  14242. ' rtl._Release(v);',
  14243. ' };',
  14244. '};',
  14245. '']),
  14246. LinesToStr([ // $mod.$main
  14247. '']));
  14248. end;
  14249. procedure TTestModule.TestClassInterface_COM_IntfProperty;
  14250. begin
  14251. StartProgram(false);
  14252. Add([
  14253. '{$interfaces com}',
  14254. 'type',
  14255. ' IUnknown = interface',
  14256. ' function _AddRef: longint;',
  14257. ' function _Release: longint;',
  14258. ' function GetBird: IUnknown;',
  14259. ' procedure SetBird(Value: IUnknown);',
  14260. ' function GetItems(Index: longint): IUnknown;',
  14261. ' procedure SetItems(Index: longint; Value: IUnknown);',
  14262. ' property Bird: IUnknown read GetBird write SetBird;',
  14263. ' property Items[Index: longint]: IUnknown read GetItems write SetItems; default;',
  14264. ' end;',
  14265. ' TObject = class(IUnknown)',
  14266. ' function _AddRef: longint; virtual; abstract;',
  14267. ' function _Release: longint; virtual; abstract;',
  14268. ' function GetBird: IUnknown; virtual; abstract;',
  14269. ' procedure SetBird(Value: IUnknown); virtual; abstract;',
  14270. ' function GetItems(Index: longint): IUnknown; virtual; abstract;',
  14271. ' procedure SetItems(Index: longint; Value: IUnknown); virtual; abstract;',
  14272. ' end;',
  14273. 'procedure DoIt;',
  14274. 'var',
  14275. ' o: TObject;',
  14276. ' v: IUnknown;',
  14277. 'begin',
  14278. ' v:=v.Items[1];',
  14279. ' v.Items[2]:=v;',
  14280. ' v.Items[3]:=v.Items[4];',
  14281. ' v:=v[5];',
  14282. ' v[6]:=v;',
  14283. ' v[7]:=v[8];',
  14284. ' v[9].Bird.Bird:=v;',
  14285. ' v:=v.Bird[10].Bird',
  14286. 'end;',
  14287. 'begin',
  14288. '']);
  14289. ConvertProgram;
  14290. CheckSource('TestClassInterface_COM_IntfProperty',
  14291. LinesToStr([ // statements
  14292. 'rtl.createInterface($mod, "IUnknown", "{5406909F-9F0B-32A4-B98B-94CDDE493C91}", [',
  14293. ' "_AddRef",',
  14294. ' "_Release",',
  14295. ' "GetBird",',
  14296. ' "SetBird",',
  14297. ' "GetItems",',
  14298. ' "SetItems"',
  14299. '], null);',
  14300. 'rtl.createClass($mod, "TObject", null, function () {',
  14301. ' this.$init = function () {',
  14302. ' };',
  14303. ' this.$final = function () {',
  14304. ' };',
  14305. ' this.$intfmaps = {};',
  14306. ' rtl.addIntf(this, $mod.IUnknown);',
  14307. '});',
  14308. 'this.DoIt = function () {',
  14309. ' var o = null;',
  14310. ' var v = null;',
  14311. ' var $ir = rtl.createIntfRefs();',
  14312. ' try {',
  14313. ' v = rtl.setIntfL(v, v.GetItems(1), true);',
  14314. ' v.SetItems(2, v);',
  14315. ' v.SetItems(3, $ir.ref(1, v.GetItems(4)));',
  14316. ' v = rtl.setIntfL(v, v.GetItems(5), true);',
  14317. ' v.SetItems(6, v);',
  14318. ' v.SetItems(7, $ir.ref(2, v.GetItems(8)));',
  14319. ' $ir.ref(4, $ir.ref(3, v.GetItems(9)).GetBird()).SetBird(v);',
  14320. ' v = rtl.setIntfL(v, $ir.ref(6, v.$ir.ref(5, GetBird()).GetItems(10)).GetBird(), true);',
  14321. ' } finally {',
  14322. ' $ir.free();',
  14323. ' rtl._Release(v);',
  14324. ' };',
  14325. '};',
  14326. '']),
  14327. LinesToStr([ // $mod.$main
  14328. '']));
  14329. end;
  14330. procedure TTestModule.TestClassInterface_COM_Delegation;
  14331. begin
  14332. StartProgram(false);
  14333. Add([
  14334. '{$interfaces com}',
  14335. 'type',
  14336. ' IUnknown = interface',
  14337. ' function _AddRef: longint;',
  14338. ' function _Release: longint;',
  14339. ' end;',
  14340. ' IBird = interface(IUnknown)',
  14341. ' procedure Fly(s: string);',
  14342. ' end;',
  14343. ' IEagle = interface(IBird) end;',
  14344. ' IDove = interface(IBird) end;',
  14345. ' ISwallow = interface(IBird) end;',
  14346. ' TObject = class',
  14347. ' end;',
  14348. ' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
  14349. ' function _AddRef: longint; virtual; abstract;',
  14350. ' function _Release: longint; virtual; abstract;',
  14351. ' procedure Fly(s: string); virtual; abstract;',
  14352. ' end;',
  14353. ' TBat = class(IBird,IEagle,IDove,ISwallow)',
  14354. ' function _AddRef: longint; virtual; abstract;',
  14355. ' function _Release: longint; virtual; abstract;',
  14356. ' FBirdIntf: IBird;',
  14357. ' property BirdIntf: IBird read FBirdIntf implements IBird;',
  14358. ' function GetEagleIntf: IEagle; virtual; abstract;',
  14359. ' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
  14360. ' FDoveObj: TBird;',
  14361. ' property DoveObj: TBird read FDoveObj implements IDove;',
  14362. ' function GetSwallowObj: TBird; virtual; abstract;',
  14363. ' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
  14364. ' end;',
  14365. 'begin',
  14366. '']);
  14367. ConvertProgram;
  14368. CheckSource('TestClassInterface_COM_Delegation',
  14369. LinesToStr([ // statements
  14370. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E77-3872-9406-776A86A09328}", ["_AddRef", "_Release"], null);',
  14371. 'rtl.createInterface($mod, "IBird", "{174B9F1B-B1BC-3868-8338-1709AB763676}", ["Fly"], $mod.IUnknown);',
  14372. 'rtl.createInterface($mod, "IEagle", "{95CDEE63-AD4B-322E-B6F5-6C42ECD29875}", [], $mod.IBird);',
  14373. 'rtl.createInterface($mod, "IDove", "{95CDEE63-AD4B-322E-B569-17F2ECD29875}", [], $mod.IBird);',
  14374. 'rtl.createInterface($mod, "ISwallow", "{95CDEE63-AD4B-322E-84A4-ECEA48D29875}", [], $mod.IBird);',
  14375. 'rtl.createClass($mod, "TObject", null, function () {',
  14376. ' this.$init = function () {',
  14377. ' };',
  14378. ' this.$final = function () {',
  14379. ' };',
  14380. '});',
  14381. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  14382. ' this.$intfmaps = {};',
  14383. ' rtl.addIntf(this, $mod.IBird);',
  14384. ' rtl.addIntf(this, $mod.IEagle);',
  14385. ' rtl.addIntf(this, $mod.IDove);',
  14386. ' rtl.addIntf(this, $mod.ISwallow);',
  14387. '});',
  14388. 'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
  14389. ' this.$init = function () {',
  14390. ' $mod.TObject.$init.call(this);',
  14391. ' this.FBirdIntf = null;',
  14392. ' this.FDoveObj = null;',
  14393. ' };',
  14394. ' this.$final = function () {',
  14395. ' this.FBirdIntf = undefined;',
  14396. ' this.FDoveObj = undefined;',
  14397. ' $mod.TObject.$final.call(this);',
  14398. ' };',
  14399. ' this.$intfmaps = {',
  14400. ' "{174B9F1B-B1BC-3868-8338-1709AB763676}": function () {',
  14401. ' return rtl._AddRef(this.FBirdIntf);',
  14402. ' },',
  14403. ' "{95CDEE63-AD4B-322E-B6F5-6C42ECD29875}": function () {',
  14404. ' return this.GetEagleIntf();',
  14405. ' },',
  14406. ' "{95CDEE63-AD4B-322E-B569-17F2ECD29875}": function () {',
  14407. ' return rtl.queryIntfT(this.FDoveObj, $mod.IDove);',
  14408. ' },',
  14409. ' "{95CDEE63-AD4B-322E-84A4-ECEA48D29875}": function () {',
  14410. ' return rtl.queryIntfT(this.GetSwallowObj(), $mod.ISwallow);',
  14411. ' }',
  14412. ' };',
  14413. '});',
  14414. '']),
  14415. LinesToStr([ // $mod.$main
  14416. '']));
  14417. end;
  14418. procedure TTestModule.TestClassInterface_COM_With;
  14419. begin
  14420. StartProgram(false);
  14421. Add([
  14422. '{$interfaces com}',
  14423. 'type',
  14424. ' IUnknown = interface',
  14425. ' function _AddRef: longint;',
  14426. ' function _Release: longint;',
  14427. ' function GetAnt: IUnknown;',
  14428. ' property Ant: IUnknown read GetAnt;',
  14429. ' end;',
  14430. ' TObject = class(IUnknown)',
  14431. ' function _AddRef: longint; virtual; abstract;',
  14432. ' function _Release: longint; virtual; abstract;',
  14433. ' function GetAnt: IUnknown; virtual; abstract;',
  14434. ' property Ant: IUnknown read GetAnt;',
  14435. ' end;',
  14436. 'procedure DoIt;',
  14437. 'var',
  14438. ' i: IUnknown;',
  14439. 'begin',
  14440. ' with i do ',
  14441. ' GetAnt;',
  14442. ' with i.Ant, Ant do ',
  14443. ' GetAnt;',
  14444. 'end;',
  14445. 'begin',
  14446. '']);
  14447. ConvertProgram;
  14448. CheckSource('TestClassInterface_COM_With',
  14449. LinesToStr([ // statements
  14450. 'rtl.createInterface($mod, "IUnknown", "{F1ACF9FE-4E77-3872-9406-776A86A09333}", ["_AddRef", "_Release", "GetAnt"], null);',
  14451. 'rtl.createClass($mod, "TObject", null, function () {',
  14452. ' this.$init = function () {',
  14453. ' };',
  14454. ' this.$final = function () {',
  14455. ' };',
  14456. ' this.$intfmaps = {};',
  14457. ' rtl.addIntf(this, $mod.IUnknown);',
  14458. '});',
  14459. 'this.DoIt = function () {',
  14460. ' var i = null;',
  14461. ' var $ir = rtl.createIntfRefs();',
  14462. ' try {',
  14463. ' $ir.ref(1, i.GetAnt());',
  14464. ' var $with1 = $ir.ref(2, i.GetAnt());',
  14465. ' var $with2 = $ir.ref(3, $with1.GetAnt());',
  14466. ' $ir.ref(4, $with2.GetAnt());',
  14467. ' } finally {',
  14468. ' $ir.free();',
  14469. ' };',
  14470. '};',
  14471. '']),
  14472. LinesToStr([ // $mod.$main
  14473. '']));
  14474. end;
  14475. procedure TTestModule.TestClassInterface_COM_ForIn;
  14476. begin
  14477. StartProgram(false);
  14478. Add([
  14479. '{$interfaces com}',
  14480. 'type',
  14481. ' IUnknown = interface end;',
  14482. ' TObject = class',
  14483. ' Id: longint;',
  14484. ' end;',
  14485. ' IEnumerator = interface(IUnknown)',
  14486. ' function GetCurrent: TObject;',
  14487. ' function MoveNext: Boolean;',
  14488. ' property Current: TObject read GetCurrent;',
  14489. ' end;',
  14490. ' IEnumerable = interface(IUnknown)',
  14491. ' function GetEnumerator: IEnumerator;',
  14492. ' end;',
  14493. 'var',
  14494. ' o: TObject;',
  14495. ' i: IEnumerable;',
  14496. 'begin',
  14497. ' for o in i do o.Id:=3;',
  14498. '']);
  14499. ConvertProgram;
  14500. CheckSource('TestClassInterface_COM_ForIn',
  14501. LinesToStr([ // statements
  14502. 'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
  14503. 'rtl.createClass($mod, "TObject", null, function () {',
  14504. ' this.$init = function () {',
  14505. ' this.Id = 0;',
  14506. ' };',
  14507. ' this.$final = function () {',
  14508. ' };',
  14509. '});',
  14510. 'rtl.createInterface($mod, "IEnumerator", "{D2FE11F3-D2CC-36BB-A5B2-66EB7FB5CB08}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
  14511. 'rtl.createInterface($mod, "IEnumerable", "{D20534CB-D9C0-3EA5-AA60-ACEB7D726308}", ["GetEnumerator"], $mod.IUnknown);',
  14512. 'this.o = null;',
  14513. 'this.i = null;',
  14514. '']),
  14515. LinesToStr([ // $mod.$main
  14516. 'var $in1 = $mod.i.GetEnumerator();',
  14517. 'try {',
  14518. ' while ($in1.MoveNext()) {',
  14519. ' $mod.o = $in1.GetCurrent();',
  14520. ' $mod.o.Id = 3;',
  14521. ' }',
  14522. '} finally {',
  14523. ' rtl._Release($in1)',
  14524. '};',
  14525. '']));
  14526. end;
  14527. procedure TTestModule.TestClassInterface_COM_ArrayOfIntfFail;
  14528. begin
  14529. StartProgram(false);
  14530. Add([
  14531. '{$interfaces com}',
  14532. 'type',
  14533. ' IUnknown = interface',
  14534. ' function _AddRef: longint;',
  14535. ' function _Release: longint;',
  14536. ' end;',
  14537. ' TObject = class',
  14538. ' end;',
  14539. ' TArrOfIntf = array of IUnknown;',
  14540. 'begin',
  14541. '']);
  14542. SetExpectedPasResolverError('Not supported: array of COM-interface',nNotSupportedX);
  14543. ConvertProgram;
  14544. end;
  14545. procedure TTestModule.TestClassInterface_COM_RecordIntfFail;
  14546. begin
  14547. StartProgram(false);
  14548. Add([
  14549. '{$interfaces com}',
  14550. 'type',
  14551. ' IUnknown = interface',
  14552. ' function _AddRef: longint;',
  14553. ' function _Release: longint;',
  14554. ' end;',
  14555. ' TRec = record',
  14556. ' i: IUnknown;',
  14557. ' end;',
  14558. 'begin',
  14559. '']);
  14560. SetExpectedPasResolverError('Not supported: COM-interface as record member',nNotSupportedX);
  14561. ConvertProgram;
  14562. end;
  14563. procedure TTestModule.TestClassInterface_COM_UnitInitialization;
  14564. begin
  14565. StartUnit(false);
  14566. Add([
  14567. '{$interfaces com}',
  14568. 'interface',
  14569. 'implementation',
  14570. 'type',
  14571. ' IUnknown = interface',
  14572. ' function _AddRef: longint;',
  14573. ' end;',
  14574. ' TObject = class(IUnknown)',
  14575. ' function _AddRef: longint;',
  14576. ' end;',
  14577. 'function TObject._AddRef: longint; begin end;',
  14578. 'var i: IUnknown;',
  14579. ' o: TObject;',
  14580. 'initialization',
  14581. ' i:=nil;',
  14582. ' i:=i;',
  14583. ' i:=o;',
  14584. ' if (o as IUnknown)=nil then ;',
  14585. '']);
  14586. ConvertUnit;
  14587. CheckSource('TestClassInterface_COM_UnitInitialization',
  14588. LinesToStr([ // statements
  14589. 'var $impl = $mod.$impl;',
  14590. '']),
  14591. LinesToStr([ // this.$init
  14592. 'var $ir = rtl.createIntfRefs();',
  14593. 'try {',
  14594. ' rtl.setIntfP($impl, "i", null);',
  14595. ' rtl.setIntfP($impl, "i", $impl.i);',
  14596. ' rtl.setIntfP($impl, "i", rtl.queryIntfT($impl.o, $impl.IUnknown), true);',
  14597. ' if ($ir.ref(1, rtl.queryIntfT($impl.o, $impl.IUnknown)) === null) ;',
  14598. '} finally {',
  14599. ' $ir.free();',
  14600. '};',
  14601. '']),
  14602. LinesToStr([ // implementation
  14603. 'rtl.createInterface($impl, "IUnknown", "{5D22E7CA-4E77-3872-9406-000000000000}", ["_AddRef"], null);',
  14604. 'rtl.createClass($impl, "TObject", null, function () {',
  14605. ' this.$init = function () {',
  14606. ' };',
  14607. ' this.$final = function () {',
  14608. ' };',
  14609. ' this._AddRef = function () {',
  14610. ' var Result = 0;',
  14611. ' return Result;',
  14612. ' };',
  14613. ' this.$intfmaps = {};',
  14614. ' rtl.addIntf(this, $impl.IUnknown);',
  14615. '});',
  14616. '$impl.i = null;',
  14617. '$impl.o = null;',
  14618. ''])
  14619. );
  14620. end;
  14621. procedure TTestModule.TestClassInterface_GUID;
  14622. begin
  14623. StartProgram(false);
  14624. Add([
  14625. '{$interfaces corba}',
  14626. 'type',
  14627. ' IUnknown = interface',
  14628. ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
  14629. ' end;',
  14630. ' TObject = class end;',
  14631. ' TGUID = record D1, D2, D3, D4: word; end;',
  14632. ' TAliasGUID = TGUID;',
  14633. ' TGUIDString = string;',
  14634. ' TAliasGUIDString = TGUIDString;',
  14635. 'procedure DoConstGUIDIt(const g: TAliasGUID); overload;',
  14636. 'begin end;',
  14637. 'procedure DoDefGUID(g: TAliasGUID); overload;',
  14638. 'begin end;',
  14639. 'procedure DoStr(const s: TAliasGUIDString); overload;',
  14640. 'begin end;',
  14641. 'var',
  14642. ' i: IUnknown;',
  14643. ' g: TAliasGUID = ''{d91c9af4-3C93-420F-A303-BF5BA82BFD23}'';',
  14644. ' s: TAliasGUIDString;',
  14645. 'begin',
  14646. ' DoConstGUIDIt(IUnknown);',
  14647. ' DoDefGUID(IUnknown);',
  14648. ' DoStr(IUnknown);',
  14649. ' DoConstGUIDIt(i);',
  14650. ' DoDefGUID(i);',
  14651. ' DoStr(i);',
  14652. ' DoConstGUIDIt(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
  14653. ' DoDefGUID(''{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}'');',
  14654. ' DoStr(g);',
  14655. ' g:=i;',
  14656. ' g:=IUnknown;',
  14657. ' g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
  14658. ' s:=i;',
  14659. ' s:=IUnknown;',
  14660. ' s:=g;',
  14661. ' if g=i then ;',
  14662. ' if i=g then ;',
  14663. ' if g=IUnknown then ;',
  14664. ' if IUnknown=g then ;',
  14665. ' if s=i then ;',
  14666. ' if i=s then ;',
  14667. ' if s=IUnknown then ;',
  14668. ' if IUnknown=s then ;',
  14669. ' if s=g then ;',
  14670. ' if g=s then ;',
  14671. '']);
  14672. ConvertProgram;
  14673. CheckSource('TestClassInterface_GUID',
  14674. LinesToStr([ // statements
  14675. 'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
  14676. 'rtl.createClass($mod, "TObject", null, function () {',
  14677. ' this.$init = function () {',
  14678. ' };',
  14679. ' this.$final = function () {',
  14680. ' };',
  14681. '});',
  14682. 'this.TGUID = function (s) {',
  14683. ' if (s) {',
  14684. ' this.D1 = s.D1;',
  14685. ' this.D2 = s.D2;',
  14686. ' this.D3 = s.D3;',
  14687. ' this.D4 = s.D4;',
  14688. ' } else {',
  14689. ' this.D1 = 0;',
  14690. ' this.D2 = 0;',
  14691. ' this.D3 = 0;',
  14692. ' this.D4 = 0;',
  14693. ' };',
  14694. ' this.$equal = function (b) {',
  14695. ' return (this.D1 === b.D1) && ((this.D2 === b.D2) && ((this.D3 === b.D3) && (this.D4 === b.D4)));',
  14696. ' };',
  14697. '};',
  14698. 'this.DoConstGUIDIt = function (g) {',
  14699. '};',
  14700. 'this.DoDefGUID = function (g) {',
  14701. '};',
  14702. 'this.DoStr = function (s) {',
  14703. '};',
  14704. 'this.i = null;',
  14705. 'this.g = new $mod.TGUID({',
  14706. ' D1: 0xD91C9AF4,',
  14707. ' D2: 0x3C93,',
  14708. ' D3: 0x420F,',
  14709. ' D4: [',
  14710. ' 0xA3,',
  14711. ' 0x03,',
  14712. ' 0xBF,',
  14713. ' 0x5B,',
  14714. ' 0xA8,',
  14715. ' 0x2B,',
  14716. ' 0xFD,',
  14717. ' 0x23',
  14718. ' ]',
  14719. '});',
  14720. 'this.s = "";',
  14721. '']),
  14722. LinesToStr([ // $mod.$main
  14723. '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.IUnknown));',
  14724. '$mod.DoDefGUID(new $mod.TGUID(rtl.getIntfGUIDR($mod.IUnknown)));',
  14725. '$mod.DoStr($mod.IUnknown.$guid);',
  14726. '$mod.DoConstGUIDIt(rtl.getIntfGUIDR($mod.i));',
  14727. '$mod.DoDefGUID(new $mod.TGUID(rtl.getIntfGUIDR($mod.i)));',
  14728. '$mod.DoStr($mod.i.$guid);',
  14729. '$mod.DoConstGUIDIt(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
  14730. '$mod.DoDefGUID(rtl.strToGUIDR("{D91C9AF4-3c93-420f-A303-BF5BA82BFD23}"));',
  14731. '$mod.DoStr(rtl.guidrToStr($mod.g));',
  14732. '$mod.g = new $mod.TGUID(rtl.getIntfGUIDR($mod.i));',
  14733. '$mod.g = new $mod.TGUID(rtl.getIntfGUIDR($mod.IUnknown));',
  14734. '$mod.g = new $mod.TGUID({',
  14735. ' D1: 0xD91C9AF4,',
  14736. ' D2: 0x3C93,',
  14737. ' D3: 0x420F,',
  14738. ' D4: [',
  14739. ' 0xA3,',
  14740. ' 0x03,',
  14741. ' 0xBF,',
  14742. ' 0x5B,',
  14743. ' 0xA8,',
  14744. ' 0x2B,',
  14745. ' 0xFD,',
  14746. ' 0x23',
  14747. ' ]',
  14748. '});',
  14749. '$mod.s = $mod.i.$guid;',
  14750. '$mod.s = $mod.IUnknown.$guid;',
  14751. '$mod.s = rtl.guidrToStr($mod.g);',
  14752. 'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.i))) ;',
  14753. 'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.i))) ;',
  14754. 'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.IUnknown))) ;',
  14755. 'if ($mod.g.$equal(rtl.getIntfGUIDR($mod.IUnknown))) ;',
  14756. 'if ($mod.s === $mod.i.$guid) ;',
  14757. 'if ($mod.i.$guid === $mod.s) ;',
  14758. 'if ($mod.s === $mod.IUnknown.$guid) ;',
  14759. 'if ($mod.IUnknown.$guid === $mod.s) ;',
  14760. 'if ($mod.g.$equal(rtl.createTGUID($mod.s))) ;',
  14761. 'if ($mod.g.$equal(rtl.createTGUID($mod.s))) ;',
  14762. '']));
  14763. end;
  14764. procedure TTestModule.TestClassInterface_GUIDProperty;
  14765. begin
  14766. StartProgram(false);
  14767. Add([
  14768. '{$interfaces corba}',
  14769. 'type',
  14770. ' IUnknown = interface',
  14771. ' [''{f31db68f-3010-D355-4EBA-CDD4EF4A737C}'']',
  14772. ' end;',
  14773. ' TGUID = record D1, D2, D3, D4: word; end;',
  14774. ' TAliasGUID = TGUID;',
  14775. ' TGUIDString = string;',
  14776. ' TAliasGUIDString = TGUIDString;',
  14777. ' TObject = class',
  14778. ' function GetG: TAliasGUID; virtual; abstract;',
  14779. ' procedure SetG(const Value: TAliasGUID); virtual; abstract;',
  14780. ' function GetS: TAliasGUIDString; virtual; abstract;',
  14781. ' procedure SetS(const Value: TAliasGUIDString); virtual; abstract;',
  14782. ' property g: TAliasGUID read GetG write SetG;',
  14783. ' property s: TAliasGUIDString read GetS write SetS;',
  14784. ' end;',
  14785. 'var o: TObject;',
  14786. 'begin',
  14787. ' o.g:=IUnknown;',
  14788. ' o.g:=''{D91C9AF4-3C93-420F-A303-bf5ba82bfd23}'';',
  14789. ' o.s:=IUnknown;',
  14790. ' o.s:=o.g;',
  14791. '']);
  14792. ConvertProgram;
  14793. CheckSource('TestClassInterface_GUIDProperty',
  14794. LinesToStr([ // statements
  14795. 'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
  14796. 'this.TGUID = function (s) {',
  14797. ' if (s) {',
  14798. ' this.D1 = s.D1;',
  14799. ' this.D2 = s.D2;',
  14800. ' this.D3 = s.D3;',
  14801. ' this.D4 = s.D4;',
  14802. ' } else {',
  14803. ' this.D1 = 0;',
  14804. ' this.D2 = 0;',
  14805. ' this.D3 = 0;',
  14806. ' this.D4 = 0;',
  14807. ' };',
  14808. ' this.$equal = function (b) {',
  14809. ' return (this.D1 === b.D1) && ((this.D2 === b.D2) && ((this.D3 === b.D3) && (this.D4 === b.D4)));',
  14810. ' };',
  14811. '};',
  14812. 'rtl.createClass($mod, "TObject", null, function () {',
  14813. ' this.$init = function () {',
  14814. ' };',
  14815. ' this.$final = function () {',
  14816. ' };',
  14817. '});',
  14818. 'this.o = null;',
  14819. '']),
  14820. LinesToStr([ // $mod.$main
  14821. '$mod.o.SetG(new $mod.TGUID(rtl.getIntfGUIDR($mod.IUnknown)));',
  14822. '$mod.o.SetG(new $mod.TGUID({',
  14823. ' D1: 0xD91C9AF4,',
  14824. ' D2: 0x3C93,',
  14825. ' D3: 0x420F,',
  14826. ' D4: [',
  14827. ' 0xA3,',
  14828. ' 0x03,',
  14829. ' 0xBF,',
  14830. ' 0x5B,',
  14831. ' 0xA8,',
  14832. ' 0x2B,',
  14833. ' 0xFD,',
  14834. ' 0x23',
  14835. ' ]',
  14836. '}));',
  14837. '$mod.o.SetS($mod.IUnknown.$guid);',
  14838. '$mod.o.SetS(rtl.guidrToStr($mod.o.GetG()));',
  14839. '']));
  14840. end;
  14841. procedure TTestModule.TestProcType;
  14842. begin
  14843. StartProgram(false);
  14844. Add([
  14845. 'type',
  14846. ' TProcInt = procedure(vI: longint = 1);',
  14847. 'procedure DoIt(vJ: longint);',
  14848. 'begin end;',
  14849. 'var',
  14850. ' b: boolean;',
  14851. ' vP, vQ: tprocint;',
  14852. 'begin',
  14853. ' vp:=nil;',
  14854. ' vp:=vp;',
  14855. ' vp:=@doit;',
  14856. ' vp;',
  14857. ' vp();',
  14858. ' vp(2);',
  14859. ' b:=vp=nil;',
  14860. ' b:=nil=vp;',
  14861. ' b:=vp=vq;',
  14862. ' b:=vp=@doit;',
  14863. ' b:=@doit=vp;',
  14864. ' b:=vp<>nil;',
  14865. ' b:=nil<>vp;',
  14866. ' b:=vp<>vq;',
  14867. ' b:=vp<>@doit;',
  14868. ' b:=@doit<>vp;',
  14869. ' b:=Assigned(vp);',
  14870. ' if Assigned(vp) then ;']);
  14871. ConvertProgram;
  14872. CheckSource('TestProcType',
  14873. LinesToStr([ // statements
  14874. 'this.DoIt = function(vJ) {',
  14875. '};',
  14876. 'this.b = false;',
  14877. 'this.vP = null;',
  14878. 'this.vQ = null;'
  14879. ]),
  14880. LinesToStr([ // $mod.$main
  14881. '$mod.vP = null;',
  14882. '$mod.vP = $mod.vP;',
  14883. '$mod.vP = $mod.DoIt;',
  14884. '$mod.vP(1);',
  14885. '$mod.vP(1);',
  14886. '$mod.vP(2);',
  14887. '$mod.b = $mod.vP === null;',
  14888. '$mod.b = null === $mod.vP;',
  14889. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  14890. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  14891. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  14892. '$mod.b = $mod.vP !== null;',
  14893. '$mod.b = null !== $mod.vP;',
  14894. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  14895. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  14896. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  14897. '$mod.b = $mod.vP != null;',
  14898. 'if ($mod.vP != null) ;',
  14899. '']));
  14900. end;
  14901. procedure TTestModule.TestProcType_Arg;
  14902. begin
  14903. StartProgram(false);
  14904. Add([
  14905. 'type',
  14906. ' TProcInt = procedure(vI: longint = 1);',
  14907. 'procedure DoIt(vJ: longint); begin end;',
  14908. 'procedure DoSome(vP, vQ: TProcInt);',
  14909. 'var',
  14910. ' b: boolean;',
  14911. 'begin',
  14912. ' vp:=nil;',
  14913. ' vp:=vp;',
  14914. ' vp:=@doit;',
  14915. ' vp;',
  14916. ' vp();',
  14917. ' vp(2);',
  14918. ' b:=vp=nil;',
  14919. ' b:=nil=vp;',
  14920. ' b:=vp=vq;',
  14921. ' b:=vp=@doit;',
  14922. ' b:=@doit=vp;',
  14923. ' b:=vp<>nil;',
  14924. ' b:=nil<>vp;',
  14925. ' b:=vp<>vq;',
  14926. ' b:=vp<>@doit;',
  14927. ' b:=@doit<>vp;',
  14928. ' b:=Assigned(vp);',
  14929. ' if Assigned(vp) then ;',
  14930. 'end;',
  14931. 'begin',
  14932. ' DoSome(@DoIt,nil);']);
  14933. ConvertProgram;
  14934. CheckSource('TestProcType_Arg',
  14935. LinesToStr([ // statements
  14936. 'this.DoIt = function(vJ) {',
  14937. '};',
  14938. 'this.DoSome = function(vP, vQ) {',
  14939. ' var b = false;',
  14940. ' vP = null;',
  14941. ' vP = vP;',
  14942. ' vP = $mod.DoIt;',
  14943. ' vP(1);',
  14944. ' vP(1);',
  14945. ' vP(2);',
  14946. ' b = vP === null;',
  14947. ' b = null === vP;',
  14948. ' b = rtl.eqCallback(vP,vQ);',
  14949. ' b = rtl.eqCallback(vP, $mod.DoIt);',
  14950. ' b = rtl.eqCallback($mod.DoIt, vP);',
  14951. ' b = vP !== null;',
  14952. ' b = null !== vP;',
  14953. ' b = !rtl.eqCallback(vP, vQ);',
  14954. ' b = !rtl.eqCallback(vP, $mod.DoIt);',
  14955. ' b = !rtl.eqCallback($mod.DoIt, vP);',
  14956. ' b = vP != null;',
  14957. ' if (vP != null) ;',
  14958. '};',
  14959. '']),
  14960. LinesToStr([ // $mod.$main
  14961. '$mod.DoSome($mod.DoIt,null);',
  14962. '']));
  14963. end;
  14964. procedure TTestModule.TestProcType_FunctionFPC;
  14965. begin
  14966. StartProgram(false);
  14967. Add('type');
  14968. Add(' TFuncInt = function(vA: longint = 1): longint;');
  14969. Add('function DoIt(vI: longint): longint;');
  14970. Add('begin end;');
  14971. Add('var');
  14972. Add(' b: boolean;');
  14973. Add(' vP, vQ: tfuncint;');
  14974. Add('begin');
  14975. Add(' vp:=nil;');
  14976. Add(' vp:=vp;');
  14977. Add(' vp:=@doit;'); // ok in fpc and delphi
  14978. //Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  14979. Add(' vp;'); // ok in fpc and delphi
  14980. Add(' vp();');
  14981. Add(' vp(2);');
  14982. Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  14983. Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  14984. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  14985. Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  14986. Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  14987. //Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  14988. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  14989. Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  14990. Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  14991. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  14992. Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  14993. Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  14994. //Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  14995. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  14996. Add(' b:=Assigned(vp);');
  14997. //Add(' doit(vp);'); // illegal in fpc, ok in delphi
  14998. Add(' doit(vp());'); // ok in fpc and delphi
  14999. Add(' doit(vp(2));'); // ok in fpc and delphi
  15000. ConvertProgram;
  15001. CheckSource('TestProcType_FunctionFPC',
  15002. LinesToStr([ // statements
  15003. 'this.DoIt = function(vI) {',
  15004. ' var Result = 0;',
  15005. ' return Result;',
  15006. '};',
  15007. 'this.b = false;',
  15008. 'this.vP = null;',
  15009. 'this.vQ = null;'
  15010. ]),
  15011. LinesToStr([ // $mod.$main
  15012. '$mod.vP = null;',
  15013. '$mod.vP = $mod.vP;',
  15014. '$mod.vP = $mod.DoIt;',
  15015. '$mod.vP(1);',
  15016. '$mod.vP(1);',
  15017. '$mod.vP(2);',
  15018. '$mod.b = $mod.vP === null;',
  15019. '$mod.b = null === $mod.vP;',
  15020. '$mod.b = rtl.eqCallback($mod.vP,$mod.vQ);',
  15021. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  15022. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  15023. '$mod.b = 4 === $mod.vP(1);',
  15024. '$mod.b = $mod.vP !== null;',
  15025. '$mod.b = null !== $mod.vP;',
  15026. '$mod.b = !rtl.eqCallback($mod.vP,$mod.vQ);',
  15027. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  15028. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  15029. '$mod.b = 6 !== $mod.vP(1);',
  15030. '$mod.b = $mod.vP != null;',
  15031. '$mod.DoIt($mod.vP(1));',
  15032. '$mod.DoIt($mod.vP(2));',
  15033. '']));
  15034. end;
  15035. procedure TTestModule.TestProcType_FunctionDelphi;
  15036. begin
  15037. StartProgram(false);
  15038. Add('{$mode Delphi}');
  15039. Add('type');
  15040. Add(' TFuncInt = function(vA: longint = 1): longint;');
  15041. Add('function DoIt(vI: longint): longint;');
  15042. Add('begin end;');
  15043. Add('var');
  15044. Add(' b: boolean;');
  15045. Add(' vP, vQ: tfuncint;');
  15046. Add('begin');
  15047. Add(' vp:=nil;');
  15048. Add(' vp:=vp;');
  15049. Add(' vp:=@doit;'); // ok in fpc and delphi
  15050. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  15051. Add(' vp;'); // ok in fpc and delphi
  15052. Add(' vp();');
  15053. Add(' vp(2);');
  15054. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  15055. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  15056. Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  15057. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  15058. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  15059. Add(' b:=vp=3;'); // illegal in fpc, ok in delphi
  15060. Add(' b:=4=vp;'); // illegal in fpc, ok in delphi
  15061. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  15062. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  15063. Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  15064. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  15065. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  15066. Add(' b:=vp<>5;'); // illegal in fpc, ok in delphi
  15067. Add(' b:=6<>vp;'); // illegal in fpc, ok in delphi
  15068. Add(' b:=Assigned(vp);');
  15069. Add(' doit(vp);'); // illegal in fpc, ok in delphi
  15070. Add(' doit(vp());'); // ok in fpc and delphi
  15071. Add(' doit(vp(2));'); // ok in fpc and delphi *)
  15072. ConvertProgram;
  15073. CheckSource('TestProcType_FunctionDelphi',
  15074. LinesToStr([ // statements
  15075. 'this.DoIt = function(vI) {',
  15076. ' var Result = 0;',
  15077. ' return Result;',
  15078. '};',
  15079. 'this.b = false;',
  15080. 'this.vP = null;',
  15081. 'this.vQ = null;'
  15082. ]),
  15083. LinesToStr([ // $mod.$main
  15084. '$mod.vP = null;',
  15085. '$mod.vP = $mod.vP;',
  15086. '$mod.vP = $mod.DoIt;',
  15087. '$mod.vP = $mod.DoIt;',
  15088. '$mod.vP(1);',
  15089. '$mod.vP(1);',
  15090. '$mod.vP(2);',
  15091. '$mod.b = $mod.vP(1) === $mod.vQ(1);',
  15092. '$mod.b = $mod.vP(1) === 3;',
  15093. '$mod.b = 4 === $mod.vP(1);',
  15094. '$mod.b = $mod.vP(1) !== $mod.vQ(1);',
  15095. '$mod.b = $mod.vP(1) !== 5;',
  15096. '$mod.b = 6 !== $mod.vP(1);',
  15097. '$mod.b = $mod.vP != null;',
  15098. '$mod.DoIt($mod.vP(1));',
  15099. '$mod.DoIt($mod.vP(1));',
  15100. '$mod.DoIt($mod.vP(2));',
  15101. '']));
  15102. end;
  15103. procedure TTestModule.TestProcType_ProcedureDelphi;
  15104. begin
  15105. StartProgram(false);
  15106. Add('{$mode Delphi}');
  15107. Add('type');
  15108. Add(' TProc = procedure;');
  15109. Add('procedure DoIt;');
  15110. Add('begin end;');
  15111. Add('var');
  15112. Add(' b: boolean;');
  15113. Add(' vP, vQ: tproc;');
  15114. Add('begin');
  15115. Add(' vp:=nil;');
  15116. Add(' vp:=vp;');
  15117. Add(' vp:=vq;');
  15118. 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
  15119. Add(' vp:=doit;'); // illegal in fpc, ok in delphi
  15120. //Add(' vp:=@doit;'); // illegal in fpc, ok in delphi (because Delphi treats @F as Pointer), not supported by resolver
  15121. Add(' vp;'); // ok in fpc and delphi
  15122. Add(' vp();');
  15123. // equal
  15124. //Add(' b:=vp=nil;'); // ok in fpc, illegal in delphi
  15125. Add(' b:=@@vp=nil;'); // ok in fpc delphi mode, ok in delphi
  15126. //Add(' b:=nil=vp;'); // ok in fpc, illegal in delphi
  15127. Add(' b:=nil=@@vp;'); // ok in fpc delphi mode, ok in delphi
  15128. Add(' b:=@@vp=@@vq;'); // ok in fpc delphi mode, ok in Delphi
  15129. //Add(' b:=vp=vq;'); // in fpc compare proctypes, in delphi compare results
  15130. //Add(' b:=vp=@doit;'); // ok in fpc, illegal in delphi
  15131. Add(' b:=@@vp=@doit;'); // ok in fpc delphi mode, ok in delphi
  15132. //Add(' b:=@doit=vp;'); // ok in fpc, illegal in delphi
  15133. Add(' b:=@doit=@@vp;'); // ok in fpc delphi mode, ok in delphi
  15134. // unequal
  15135. //Add(' b:=vp<>nil;'); // ok in fpc, illegal in delphi
  15136. Add(' b:=@@vp<>nil;'); // ok in fpc mode delphi, ok in delphi
  15137. //Add(' b:=nil<>vp;'); // ok in fpc, illegal in delphi
  15138. Add(' b:=nil<>@@vp;'); // ok in fpc mode delphi, ok in delphi
  15139. //Add(' b:=vp<>vq;'); // in fpc compare proctypes, in delphi compare results
  15140. Add(' b:=@@vp<>@@vq;'); // ok in fpc mode delphi, ok in delphi
  15141. //Add(' b:=vp<>@doit;'); // ok in fpc, illegal in delphi
  15142. Add(' b:=@@vp<>@doit;'); // ok in fpc mode delphi, illegal in delphi
  15143. //Add(' b:=@doit<>vp;'); // ok in fpc, illegal in delphi
  15144. Add(' b:=@doit<>@@vp;'); // ok in fpc mode delphi, illegal in delphi
  15145. Add(' b:=Assigned(vp);');
  15146. ConvertProgram;
  15147. CheckSource('TestProcType_ProcedureDelphi',
  15148. LinesToStr([ // statements
  15149. 'this.DoIt = function() {',
  15150. '};',
  15151. 'this.b = false;',
  15152. 'this.vP = null;',
  15153. 'this.vQ = null;'
  15154. ]),
  15155. LinesToStr([ // $mod.$main
  15156. '$mod.vP = null;',
  15157. '$mod.vP = $mod.vP;',
  15158. '$mod.vP = $mod.vQ;',
  15159. '$mod.vP = $mod.DoIt;',
  15160. '$mod.vP = $mod.DoIt;',
  15161. '$mod.vP();',
  15162. '$mod.vP();',
  15163. '$mod.b = $mod.vP === null;',
  15164. '$mod.b = null === $mod.vP;',
  15165. '$mod.b = rtl.eqCallback($mod.vP, $mod.vQ);',
  15166. '$mod.b = rtl.eqCallback($mod.vP, $mod.DoIt);',
  15167. '$mod.b = rtl.eqCallback($mod.DoIt, $mod.vP);',
  15168. '$mod.b = $mod.vP !== null;',
  15169. '$mod.b = null !== $mod.vP;',
  15170. '$mod.b = !rtl.eqCallback($mod.vP, $mod.vQ);',
  15171. '$mod.b = !rtl.eqCallback($mod.vP, $mod.DoIt);',
  15172. '$mod.b = !rtl.eqCallback($mod.DoIt, $mod.vP);',
  15173. '$mod.b = $mod.vP != null;',
  15174. '']));
  15175. end;
  15176. procedure TTestModule.TestProcType_AsParam;
  15177. begin
  15178. StartProgram(false);
  15179. Add('type');
  15180. Add(' TFuncInt = function(vA: longint = 1): longint;');
  15181. Add('procedure DoIt(vG: tfuncint; const vH: tfuncint; var vI: tfuncint);');
  15182. Add('var vJ: tfuncint;');
  15183. Add('begin');
  15184. Add(' vg:=vg;');
  15185. Add(' vj:=vh;');
  15186. Add(' vi:=vi;');
  15187. Add(' doit(vg,vg,vg);');
  15188. Add(' doit(vh,vh,vj);');
  15189. Add(' doit(vi,vi,vi);');
  15190. Add(' doit(vj,vj,vj);');
  15191. Add('end;');
  15192. Add('var i: tfuncint;');
  15193. Add('begin');
  15194. Add(' doit(i,i,i);');
  15195. ConvertProgram;
  15196. CheckSource('TestProcType_AsParam',
  15197. LinesToStr([ // statements
  15198. 'this.DoIt = function (vG,vH,vI) {',
  15199. ' var vJ = null;',
  15200. ' vG = vG;',
  15201. ' vJ = vH;',
  15202. ' vI.set(vI.get());',
  15203. ' $mod.DoIt(vG, vG, {',
  15204. ' get: function () {',
  15205. ' return vG;',
  15206. ' },',
  15207. ' set: function (v) {',
  15208. ' vG = v;',
  15209. ' }',
  15210. ' });',
  15211. ' $mod.DoIt(vH, vH, {',
  15212. ' get: function () {',
  15213. ' return vJ;',
  15214. ' },',
  15215. ' set: function (v) {',
  15216. ' vJ = v;',
  15217. ' }',
  15218. ' });',
  15219. ' $mod.DoIt(vI.get(), vI.get(), vI);',
  15220. ' $mod.DoIt(vJ, vJ, {',
  15221. ' get: function () {',
  15222. ' return vJ;',
  15223. ' },',
  15224. ' set: function (v) {',
  15225. ' vJ = v;',
  15226. ' }',
  15227. ' });',
  15228. '};',
  15229. 'this.i = null;'
  15230. ]),
  15231. LinesToStr([
  15232. '$mod.DoIt($mod.i,$mod.i,{',
  15233. ' p: $mod,',
  15234. ' get: function () {',
  15235. ' return this.p.i;',
  15236. ' },',
  15237. ' set: function (v) {',
  15238. ' this.p.i = v;',
  15239. ' }',
  15240. '});'
  15241. ]));
  15242. end;
  15243. procedure TTestModule.TestProcType_MethodFPC;
  15244. begin
  15245. StartProgram(false);
  15246. Add('type');
  15247. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  15248. Add(' TObject = class');
  15249. Add(' function DoIt(vA: longint = 1): longint;');
  15250. Add(' end;');
  15251. Add('function TObject.DoIt(vA: longint = 1): longint;');
  15252. Add('begin');
  15253. Add('end;');
  15254. Add('var');
  15255. Add(' Obj: TObject;');
  15256. Add(' vP: tfuncint;');
  15257. Add(' b: boolean;');
  15258. Add('begin');
  15259. Add(' vp:[email protected];'); // ok in fpc and delphi
  15260. //Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  15261. Add(' vp;'); // ok in fpc and delphi
  15262. Add(' vp();');
  15263. Add(' vp(2);');
  15264. Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  15265. Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  15266. Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  15267. Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  15268. ConvertProgram;
  15269. CheckSource('TestProcType_MethodFPC',
  15270. LinesToStr([ // statements
  15271. 'rtl.createClass($mod, "TObject", null, function () {',
  15272. ' this.$init = function () {',
  15273. ' };',
  15274. ' this.$final = function () {',
  15275. ' };',
  15276. ' this.DoIt = function (vA) {',
  15277. ' var Result = 0;',
  15278. ' return Result;',
  15279. ' };',
  15280. '});',
  15281. 'this.Obj = null;',
  15282. 'this.vP = null;',
  15283. 'this.b = false;'
  15284. ]),
  15285. LinesToStr([
  15286. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  15287. '$mod.vP(1);',
  15288. '$mod.vP(1);',
  15289. '$mod.vP(2);',
  15290. '$mod.b = rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  15291. '$mod.b = rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  15292. '$mod.b = !rtl.eqCallback($mod.vP, rtl.createCallback($mod.Obj, "DoIt"));',
  15293. '$mod.b = !rtl.eqCallback(rtl.createCallback($mod.Obj, "DoIt"), $mod.vP);',
  15294. '']));
  15295. end;
  15296. procedure TTestModule.TestProcType_MethodDelphi;
  15297. begin
  15298. StartProgram(false);
  15299. Add('{$mode delphi}');
  15300. Add('type');
  15301. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  15302. Add(' TObject = class');
  15303. Add(' function DoIt(vA: longint = 1): longint;');
  15304. Add(' end;');
  15305. Add('function TObject.DoIt(vA: longint = 1): longint;');
  15306. Add('begin');
  15307. Add('end;');
  15308. Add('var');
  15309. Add(' Obj: TObject;');
  15310. Add(' vP: tfuncint;');
  15311. Add(' b: boolean;');
  15312. Add('begin');
  15313. Add(' vp:[email protected];'); // ok in fpc and delphi
  15314. Add(' vp:=obj.doit;'); // illegal in fpc, ok in delphi
  15315. Add(' vp;'); // ok in fpc and delphi
  15316. Add(' vp();');
  15317. Add(' vp(2);');
  15318. //Add(' b:[email protected];'); // ok in fpc, illegal in delphi
  15319. //Add(' b:[email protected]=vp;'); // ok in fpc, illegal in delphi
  15320. //Add(' b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
  15321. //Add(' b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
  15322. ConvertProgram;
  15323. CheckSource('TestProcType_MethodDelphi',
  15324. LinesToStr([ // statements
  15325. 'rtl.createClass($mod, "TObject", null, function () {',
  15326. ' this.$init = function () {',
  15327. ' };',
  15328. ' this.$final = function () {',
  15329. ' };',
  15330. ' this.DoIt = function (vA) {',
  15331. ' var Result = 0;',
  15332. ' return Result;',
  15333. ' };',
  15334. '});',
  15335. 'this.Obj = null;',
  15336. 'this.vP = null;',
  15337. 'this.b = false;'
  15338. ]),
  15339. LinesToStr([
  15340. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  15341. '$mod.vP = rtl.createCallback($mod.Obj, "DoIt");',
  15342. '$mod.vP(1);',
  15343. '$mod.vP(1);',
  15344. '$mod.vP(2);',
  15345. '']));
  15346. end;
  15347. procedure TTestModule.TestProcType_PropertyFPC;
  15348. begin
  15349. StartProgram(false);
  15350. Add('type');
  15351. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  15352. Add(' TObject = class');
  15353. Add(' FOnFoo: TFuncInt;');
  15354. Add(' function DoIt(vA: longint = 1): longint;');
  15355. Add(' function GetFoo: TFuncInt;');
  15356. Add(' procedure SetFoo(const Value: TFuncInt);');
  15357. Add(' function GetEvents(Index: longint): TFuncInt;');
  15358. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  15359. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  15360. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  15361. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  15362. Add(' end;');
  15363. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  15364. Add('function tobject.getfoo: tfuncint; begin end;');
  15365. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  15366. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  15367. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  15368. Add('var');
  15369. Add(' Obj: TObject;');
  15370. Add(' vP: tfuncint;');
  15371. Add(' b: boolean;');
  15372. Add('begin');
  15373. Add(' obj.onfoo:=nil;');
  15374. Add(' obj.onbar:=nil;');
  15375. Add(' obj.events[1]:=nil;');
  15376. Add(' obj.onfoo:=obj.onfoo;');
  15377. Add(' obj.onbar:=obj.onbar;');
  15378. Add(' obj.events[2]:=obj.events[3];');
  15379. Add(' obj.onfoo:[email protected];');
  15380. Add(' obj.onbar:[email protected];');
  15381. Add(' obj.events[4]:[email protected];');
  15382. //Add(' obj.onfoo:=obj.doit;'); // delphi
  15383. //Add(' obj.onbar:=obj.doit;'); // delphi
  15384. //Add(' obj.events[4]:=obj.doit;'); // delphi
  15385. Add(' obj.onfoo;');
  15386. Add(' obj.onbar;');
  15387. //Add(' obj.events[5];'); ToDo in pasresolver
  15388. Add(' obj.onfoo();');
  15389. Add(' obj.onbar();');
  15390. Add(' obj.events[6]();');
  15391. Add(' b:=obj.onfoo=nil;');
  15392. Add(' b:=obj.onbar=nil;');
  15393. Add(' b:=obj.events[7]=nil;');
  15394. Add(' b:=obj.onfoo<>nil;');
  15395. Add(' b:=obj.onbar<>nil;');
  15396. Add(' b:=obj.events[8]<>nil;');
  15397. Add(' b:=obj.onfoo=vp;');
  15398. Add(' b:=obj.onbar=vp;');
  15399. Add(' b:=obj.events[9]=vp;');
  15400. Add(' b:=obj.onfoo=obj.onfoo;');
  15401. Add(' b:=obj.onbar=obj.onfoo;');
  15402. Add(' b:=obj.events[10]=obj.onfoo;');
  15403. Add(' b:=obj.onfoo<>obj.onfoo;');
  15404. Add(' b:=obj.onbar<>obj.onfoo;');
  15405. Add(' b:=obj.events[11]<>obj.onfoo;');
  15406. Add(' b:[email protected];');
  15407. Add(' b:[email protected];');
  15408. Add(' b:=obj.events[12][email protected];');
  15409. Add(' b:=obj.onfoo<>@obj.doit;');
  15410. Add(' b:=obj.onbar<>@obj.doit;');
  15411. Add(' b:=obj.events[12]<>@obj.doit;');
  15412. Add(' b:=Assigned(obj.onfoo);');
  15413. Add(' b:=Assigned(obj.onbar);');
  15414. Add(' b:=Assigned(obj.events[13]);');
  15415. ConvertProgram;
  15416. CheckSource('TestProcType_PropertyFPC',
  15417. LinesToStr([ // statements
  15418. 'rtl.createClass($mod, "TObject", null, function () {',
  15419. ' this.$init = function () {',
  15420. ' this.FOnFoo = null;',
  15421. ' };',
  15422. ' this.$final = function () {',
  15423. ' this.FOnFoo = undefined;',
  15424. ' };',
  15425. ' this.DoIt = function (vA) {',
  15426. ' var Result = 0;',
  15427. ' return Result;',
  15428. ' };',
  15429. 'this.GetFoo = function () {',
  15430. ' var Result = null;',
  15431. ' return Result;',
  15432. '};',
  15433. 'this.SetFoo = function (Value) {',
  15434. '};',
  15435. 'this.GetEvents = function (Index) {',
  15436. ' var Result = null;',
  15437. ' return Result;',
  15438. '};',
  15439. 'this.SetEvents = function (Index, Value) {',
  15440. '};',
  15441. '});',
  15442. 'this.Obj = null;',
  15443. 'this.vP = null;',
  15444. 'this.b = false;'
  15445. ]),
  15446. LinesToStr([
  15447. '$mod.Obj.FOnFoo = null;',
  15448. '$mod.Obj.SetFoo(null);',
  15449. '$mod.Obj.SetEvents(1, null);',
  15450. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  15451. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  15452. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  15453. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  15454. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  15455. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  15456. '$mod.Obj.FOnFoo(1);',
  15457. '$mod.Obj.GetFoo();',
  15458. '$mod.Obj.FOnFoo(1);',
  15459. '$mod.Obj.GetFoo()(1);',
  15460. '$mod.Obj.GetEvents(6)(1);',
  15461. '$mod.b = $mod.Obj.FOnFoo === null;',
  15462. '$mod.b = $mod.Obj.GetFoo() === null;',
  15463. '$mod.b = $mod.Obj.GetEvents(7) === null;',
  15464. '$mod.b = $mod.Obj.FOnFoo !== null;',
  15465. '$mod.b = $mod.Obj.GetFoo() !== null;',
  15466. '$mod.b = $mod.Obj.GetEvents(8) !== null;',
  15467. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.vP);',
  15468. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.vP);',
  15469. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(9), $mod.vP);',
  15470. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  15471. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  15472. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(10), $mod.Obj.FOnFoo);',
  15473. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, $mod.Obj.FOnFoo);',
  15474. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), $mod.Obj.FOnFoo);',
  15475. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(11), $mod.Obj.FOnFoo);',
  15476. '$mod.b = rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  15477. '$mod.b = rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  15478. '$mod.b = rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  15479. '$mod.b = !rtl.eqCallback($mod.Obj.FOnFoo, rtl.createCallback($mod.Obj, "DoIt"));',
  15480. '$mod.b = !rtl.eqCallback($mod.Obj.GetFoo(), rtl.createCallback($mod.Obj, "DoIt"));',
  15481. '$mod.b = !rtl.eqCallback($mod.Obj.GetEvents(12), rtl.createCallback($mod.Obj, "DoIt"));',
  15482. '$mod.b = $mod.Obj.FOnFoo != null;',
  15483. '$mod.b = $mod.Obj.GetFoo() != null;',
  15484. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  15485. '']));
  15486. end;
  15487. procedure TTestModule.TestProcType_PropertyDelphi;
  15488. begin
  15489. StartProgram(false);
  15490. Add('{$mode delphi}');
  15491. Add('type');
  15492. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  15493. Add(' TObject = class');
  15494. Add(' FOnFoo: TFuncInt;');
  15495. Add(' function DoIt(vA: longint = 1): longint;');
  15496. Add(' function GetFoo: TFuncInt;');
  15497. Add(' procedure SetFoo(const Value: TFuncInt);');
  15498. Add(' function GetEvents(Index: longint): TFuncInt;');
  15499. Add(' procedure SetEvents(Index: longint; const Value: TFuncInt);');
  15500. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  15501. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  15502. Add(' property Events[Index: longint]: TFuncInt read GetEvents write SetEvents; default;');
  15503. Add(' end;');
  15504. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  15505. Add('function tobject.getfoo: tfuncint; begin end;');
  15506. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  15507. Add('function tobject.getevents(index: longint): tfuncint; begin end;');
  15508. Add('procedure tobject.setevents(index: longint; const value: tfuncint); begin end;');
  15509. Add('var');
  15510. Add(' Obj: TObject;');
  15511. Add(' vP: tfuncint;');
  15512. Add(' b: boolean;');
  15513. Add('begin');
  15514. Add(' obj.onfoo:=nil;');
  15515. Add(' obj.onbar:=nil;');
  15516. Add(' obj.events[1]:=nil;');
  15517. Add(' obj.onfoo:=obj.onfoo;');
  15518. Add(' obj.onbar:=obj.onbar;');
  15519. Add(' obj.events[2]:=obj.events[3];');
  15520. Add(' obj.onfoo:[email protected];');
  15521. Add(' obj.onbar:[email protected];');
  15522. Add(' obj.events[4]:[email protected];');
  15523. Add(' obj.onfoo:=obj.doit;'); // delphi
  15524. Add(' obj.onbar:=obj.doit;'); // delphi
  15525. Add(' obj.events[4]:=obj.doit;'); // delphi
  15526. Add(' obj.onfoo;');
  15527. Add(' obj.onbar;');
  15528. //Add(' obj.events[5];'); ToDo in pasresolver
  15529. Add(' obj.onfoo();');
  15530. Add(' obj.onbar();');
  15531. Add(' obj.events[6]();');
  15532. //Add(' b:=obj.onfoo=nil;'); // fpc
  15533. //Add(' b:=obj.onbar=nil;'); // fpc
  15534. //Add(' b:=obj.events[7]=nil;'); // fpc
  15535. //Add(' b:=obj.onfoo<>nil;'); // fpc
  15536. //Add(' b:=obj.onbar<>nil;'); // fpc
  15537. //Add(' b:=obj.events[8]<>nil;'); // fpc
  15538. Add(' b:=obj.onfoo=vp;');
  15539. Add(' b:=obj.onbar=vp;');
  15540. //Add(' b:=obj.events[9]=vp;'); ToDo in pasresolver
  15541. Add(' b:=obj.onfoo=obj.onfoo;');
  15542. Add(' b:=obj.onbar=obj.onfoo;');
  15543. //Add(' b:=obj.events[10]=obj.onfoo;'); // ToDo in pasresolver
  15544. Add(' b:=obj.onfoo<>obj.onfoo;');
  15545. Add(' b:=obj.onbar<>obj.onfoo;');
  15546. //Add(' b:=obj.events[11]<>obj.onfoo;'); // ToDo in pasresolver
  15547. //Add(' b:[email protected];'); // fpc
  15548. //Add(' b:[email protected];'); // fpc
  15549. //Add(' b:=obj.events[12][email protected];'); // fpc
  15550. //Add(' b:=obj.onfoo<>@obj.doit;'); // fpc
  15551. //Add(' b:=obj.onbar<>@obj.doit;'); // fpc
  15552. //Add(' b:=obj.events[12]<>@obj.doit;'); // fpc
  15553. Add(' b:=Assigned(obj.onfoo);');
  15554. Add(' b:=Assigned(obj.onbar);');
  15555. Add(' b:=Assigned(obj.events[13]);');
  15556. ConvertProgram;
  15557. CheckSource('TestProcType_PropertyDelphi',
  15558. LinesToStr([ // statements
  15559. 'rtl.createClass($mod, "TObject", null, function () {',
  15560. ' this.$init = function () {',
  15561. ' this.FOnFoo = null;',
  15562. ' };',
  15563. ' this.$final = function () {',
  15564. ' this.FOnFoo = undefined;',
  15565. ' };',
  15566. ' this.DoIt = function (vA) {',
  15567. ' var Result = 0;',
  15568. ' return Result;',
  15569. ' };',
  15570. 'this.GetFoo = function () {',
  15571. ' var Result = null;',
  15572. ' return Result;',
  15573. '};',
  15574. 'this.SetFoo = function (Value) {',
  15575. '};',
  15576. 'this.GetEvents = function (Index) {',
  15577. ' var Result = null;',
  15578. ' return Result;',
  15579. '};',
  15580. 'this.SetEvents = function (Index, Value) {',
  15581. '};',
  15582. '});',
  15583. 'this.Obj = null;',
  15584. 'this.vP = null;',
  15585. 'this.b = false;'
  15586. ]),
  15587. LinesToStr([
  15588. '$mod.Obj.FOnFoo = null;',
  15589. '$mod.Obj.SetFoo(null);',
  15590. '$mod.Obj.SetEvents(1, null);',
  15591. '$mod.Obj.FOnFoo = $mod.Obj.FOnFoo;',
  15592. '$mod.Obj.SetFoo($mod.Obj.GetFoo());',
  15593. '$mod.Obj.SetEvents(2, $mod.Obj.GetEvents(3));',
  15594. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  15595. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  15596. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  15597. '$mod.Obj.FOnFoo = rtl.createCallback($mod.Obj, "DoIt");',
  15598. '$mod.Obj.SetFoo(rtl.createCallback($mod.Obj, "DoIt"));',
  15599. '$mod.Obj.SetEvents(4, rtl.createCallback($mod.Obj, "DoIt"));',
  15600. '$mod.Obj.FOnFoo(1);',
  15601. '$mod.Obj.GetFoo();',
  15602. '$mod.Obj.FOnFoo(1);',
  15603. '$mod.Obj.GetFoo()(1);',
  15604. '$mod.Obj.GetEvents(6)(1);',
  15605. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.vP(1);',
  15606. '$mod.b = $mod.Obj.GetFoo() === $mod.vP(1);',
  15607. '$mod.b = $mod.Obj.FOnFoo(1) === $mod.Obj.FOnFoo(1);',
  15608. '$mod.b = $mod.Obj.GetFoo() === $mod.Obj.FOnFoo(1);',
  15609. '$mod.b = $mod.Obj.FOnFoo(1) !== $mod.Obj.FOnFoo(1);',
  15610. '$mod.b = $mod.Obj.GetFoo() !== $mod.Obj.FOnFoo(1);',
  15611. '$mod.b = $mod.Obj.FOnFoo != null;',
  15612. '$mod.b = $mod.Obj.GetFoo() != null;',
  15613. '$mod.b = $mod.Obj.GetEvents(13) != null;',
  15614. '']));
  15615. end;
  15616. procedure TTestModule.TestProcType_WithClassInstDoPropertyFPC;
  15617. begin
  15618. StartProgram(false);
  15619. Add('type');
  15620. Add(' TFuncInt = function(vA: longint = 1): longint of object;');
  15621. Add(' TObject = class');
  15622. Add(' FOnFoo: TFuncInt;');
  15623. Add(' function DoIt(vA: longint = 1): longint;');
  15624. Add(' function GetFoo: TFuncInt;');
  15625. Add(' procedure SetFoo(const Value: TFuncInt);');
  15626. Add(' property OnFoo: TFuncInt read FOnFoo write FOnFoo;');
  15627. Add(' property OnBar: TFuncInt read GetFoo write SetFoo;');
  15628. Add(' end;');
  15629. Add('function tobject.doit(va: longint = 1): longint; begin end;');
  15630. Add('function tobject.getfoo: tfuncint; begin end;');
  15631. Add('procedure tobject.setfoo(const value: tfuncint); begin end;');
  15632. Add('var');
  15633. Add(' Obj: TObject;');
  15634. Add(' vP: tfuncint;');
  15635. Add(' b: boolean;');
  15636. Add('begin');
  15637. Add('with obj do begin');
  15638. Add(' fonfoo:=nil;');
  15639. Add(' onfoo:=nil;');
  15640. Add(' onbar:=nil;');
  15641. Add(' fonfoo:=fonfoo;');
  15642. Add(' onfoo:=onfoo;');
  15643. Add(' onbar:=onbar;');
  15644. Add(' fonfoo:=@doit;');
  15645. Add(' onfoo:=@doit;');
  15646. Add(' onbar:=@doit;');
  15647. //Add(' fonfoo:=doit;'); // delphi
  15648. //Add(' onfoo:=doit;'); // delphi
  15649. //Add(' onbar:=doit;'); // delphi
  15650. Add(' fonfoo;');
  15651. Add(' onfoo;');
  15652. Add(' onbar;');
  15653. Add(' fonfoo();');
  15654. Add(' onfoo();');
  15655. Add(' onbar();');
  15656. Add(' b:=fonfoo=nil;');
  15657. Add(' b:=onfoo=nil;');
  15658. Add(' b:=onbar=nil;');
  15659. Add(' b:=fonfoo<>nil;');
  15660. Add(' b:=onfoo<>nil;');
  15661. Add(' b:=onbar<>nil;');
  15662. Add(' b:=fonfoo=vp;');
  15663. Add(' b:=onfoo=vp;');
  15664. Add(' b:=onbar=vp;');
  15665. Add(' b:=fonfoo=fonfoo;');
  15666. Add(' b:=onfoo=onfoo;');
  15667. Add(' b:=onbar=onfoo;');
  15668. Add(' b:=fonfoo<>fonfoo;');
  15669. Add(' b:=onfoo<>onfoo;');
  15670. Add(' b:=onbar<>onfoo;');
  15671. Add(' b:=fonfoo=@doit;');
  15672. Add(' b:=onfoo=@doit;');
  15673. Add(' b:=onbar=@doit;');
  15674. Add(' b:=fonfoo<>@doit;');
  15675. Add(' b:=onfoo<>@doit;');
  15676. Add(' b:=onbar<>@doit;');
  15677. Add(' b:=Assigned(fonfoo);');
  15678. Add(' b:=Assigned(onfoo);');
  15679. Add(' b:=Assigned(onbar);');
  15680. Add('end;');
  15681. ConvertProgram;
  15682. CheckSource('TestProcType_WithClassInstDoPropertyFPC',
  15683. LinesToStr([ // statements
  15684. 'rtl.createClass($mod, "TObject", null, function () {',
  15685. ' this.$init = function () {',
  15686. ' this.FOnFoo = null;',
  15687. ' };',
  15688. ' this.$final = function () {',
  15689. ' this.FOnFoo = undefined;',
  15690. ' };',
  15691. ' this.DoIt = function (vA) {',
  15692. ' var Result = 0;',
  15693. ' return Result;',
  15694. ' };',
  15695. ' this.GetFoo = function () {',
  15696. ' var Result = null;',
  15697. ' return Result;',
  15698. ' };',
  15699. ' this.SetFoo = function (Value) {',
  15700. ' };',
  15701. '});',
  15702. 'this.Obj = null;',
  15703. 'this.vP = null;',
  15704. 'this.b = false;'
  15705. ]),
  15706. LinesToStr([
  15707. 'var $with1 = $mod.Obj;',
  15708. '$with1.FOnFoo = null;',
  15709. '$with1.FOnFoo = null;',
  15710. '$with1.SetFoo(null);',
  15711. '$with1.FOnFoo = $with1.FOnFoo;',
  15712. '$with1.FOnFoo = $with1.FOnFoo;',
  15713. '$with1.SetFoo($with1.GetFoo());',
  15714. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  15715. '$with1.FOnFoo = rtl.createCallback($with1, "DoIt");',
  15716. '$with1.SetFoo(rtl.createCallback($with1, "DoIt"));',
  15717. '$with1.FOnFoo(1);',
  15718. '$with1.FOnFoo(1);',
  15719. '$with1.GetFoo();',
  15720. '$with1.FOnFoo(1);',
  15721. '$with1.FOnFoo(1);',
  15722. '$with1.GetFoo()(1);',
  15723. '$mod.b = $with1.FOnFoo === null;',
  15724. '$mod.b = $with1.FOnFoo === null;',
  15725. '$mod.b = $with1.GetFoo() === null;',
  15726. '$mod.b = $with1.FOnFoo !== null;',
  15727. '$mod.b = $with1.FOnFoo !== null;',
  15728. '$mod.b = $with1.GetFoo() !== null;',
  15729. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  15730. '$mod.b = rtl.eqCallback($with1.FOnFoo, $mod.vP);',
  15731. '$mod.b = rtl.eqCallback($with1.GetFoo(), $mod.vP);',
  15732. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  15733. '$mod.b = rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  15734. '$mod.b = rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  15735. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  15736. '$mod.b = !rtl.eqCallback($with1.FOnFoo, $with1.FOnFoo);',
  15737. '$mod.b = !rtl.eqCallback($with1.GetFoo(), $with1.FOnFoo);',
  15738. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  15739. '$mod.b = rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  15740. '$mod.b = rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  15741. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  15742. '$mod.b = !rtl.eqCallback($with1.FOnFoo, rtl.createCallback($with1, "DoIt"));',
  15743. '$mod.b = !rtl.eqCallback($with1.GetFoo(), rtl.createCallback($with1, "DoIt"));',
  15744. '$mod.b = $with1.FOnFoo != null;',
  15745. '$mod.b = $with1.FOnFoo != null;',
  15746. '$mod.b = $with1.GetFoo() != null;',
  15747. '']));
  15748. end;
  15749. procedure TTestModule.TestProcType_Nested;
  15750. begin
  15751. StartProgram(false);
  15752. Add([
  15753. 'type',
  15754. ' TProcInt = procedure(vI: longint = 1);',
  15755. 'procedure DoIt(vJ: longint);',
  15756. 'var aProc: TProcInt;',
  15757. ' b: boolean;',
  15758. ' procedure Sub(vK: longint);',
  15759. ' var aSub: TProcInt;',
  15760. ' procedure SubSub(vK: longint);',
  15761. ' var aSubSub: TProcInt;',
  15762. ' begin;',
  15763. ' aProc:=@DoIt;',
  15764. ' aSub:=@DoIt;',
  15765. ' aSubSub:=@DoIt;',
  15766. ' aProc:=@Sub;',
  15767. ' aSub:=@Sub;',
  15768. ' aSubSub:=@Sub;',
  15769. ' aProc:=@SubSub;',
  15770. ' aSub:=@SubSub;',
  15771. ' aSubSub:=@SubSub;',
  15772. ' end;',
  15773. ' begin;',
  15774. ' end;',
  15775. 'begin;',
  15776. ' aProc:=@Sub;',
  15777. ' b:=aProc=@Sub;',
  15778. ' b:=@Sub=aProc;',
  15779. 'end;',
  15780. 'begin',
  15781. '']);
  15782. ConvertProgram;
  15783. CheckSource('TestProcType_Nested',
  15784. LinesToStr([ // statements
  15785. 'this.DoIt = function (vJ) {',
  15786. ' var aProc = null;',
  15787. ' var b = false;',
  15788. ' function Sub(vK) {',
  15789. ' var aSub = null;',
  15790. ' function SubSub(vK) {',
  15791. ' var aSubSub = null;',
  15792. ' aProc = $mod.DoIt;',
  15793. ' aSub = $mod.DoIt;',
  15794. ' aSubSub = $mod.DoIt;',
  15795. ' aProc = Sub;',
  15796. ' aSub = Sub;',
  15797. ' aSubSub = Sub;',
  15798. ' aProc = SubSub;',
  15799. ' aSub = SubSub;',
  15800. ' aSubSub = SubSub;',
  15801. ' };',
  15802. ' };',
  15803. ' aProc = Sub;',
  15804. ' b = rtl.eqCallback(aProc, Sub);',
  15805. ' b = rtl.eqCallback(Sub, aProc);',
  15806. '};',
  15807. '']),
  15808. LinesToStr([ // $mod.$main
  15809. '']));
  15810. end;
  15811. procedure TTestModule.TestProcType_NestedOfObject;
  15812. begin
  15813. StartProgram(false);
  15814. Add([
  15815. 'type',
  15816. ' TProcInt = procedure(vI: longint = 1) of object;',
  15817. ' TObject = class',
  15818. ' procedure DoIt(vJ: longint);',
  15819. ' end;',
  15820. 'procedure TObject.DoIt(vJ: longint);',
  15821. 'var aProc: TProcInt;',
  15822. ' b: boolean;',
  15823. ' procedure Sub(vK: longint);',
  15824. ' var aSub: TProcInt;',
  15825. ' procedure SubSub(vK: longint);',
  15826. ' var aSubSub: TProcInt;',
  15827. ' begin;',
  15828. ' aProc:=@DoIt;',
  15829. ' aSub:=@DoIt;',
  15830. ' aSubSub:=@DoIt;',
  15831. ' aProc:=@Sub;',
  15832. ' aSub:=@Sub;',
  15833. ' aSubSub:=@Sub;',
  15834. ' aProc:=@SubSub;',
  15835. ' aSub:=@SubSub;',
  15836. ' aSubSub:=@SubSub;',
  15837. ' end;',
  15838. ' begin;',
  15839. ' end;',
  15840. 'begin;',
  15841. ' aProc:=@Sub;',
  15842. ' b:=aProc=@Sub;',
  15843. ' b:=@Sub=aProc;',
  15844. 'end;',
  15845. 'begin',
  15846. '']);
  15847. ConvertProgram;
  15848. CheckSource('TestProcType_Nested',
  15849. LinesToStr([ // statements
  15850. 'rtl.createClass($mod, "TObject", null, function () {',
  15851. ' this.$init = function () {',
  15852. ' };',
  15853. ' this.$final = function () {',
  15854. ' };',
  15855. ' this.DoIt = function (vJ) {',
  15856. ' var Self = this;',
  15857. ' var aProc = null;',
  15858. ' var b = false;',
  15859. ' function Sub(vK) {',
  15860. ' var aSub = null;',
  15861. ' function SubSub(vK) {',
  15862. ' var aSubSub = null;',
  15863. ' aProc = rtl.createCallback(Self, "DoIt");',
  15864. ' aSub = rtl.createCallback(Self, "DoIt");',
  15865. ' aSubSub = rtl.createCallback(Self, "DoIt");',
  15866. ' aProc = Sub;',
  15867. ' aSub = Sub;',
  15868. ' aSubSub = Sub;',
  15869. ' aProc = SubSub;',
  15870. ' aSub = SubSub;',
  15871. ' aSubSub = SubSub;',
  15872. ' };',
  15873. ' };',
  15874. ' aProc = Sub;',
  15875. ' b = rtl.eqCallback(aProc, Sub);',
  15876. ' b = rtl.eqCallback(Sub, aProc);',
  15877. ' };',
  15878. '});',
  15879. '']),
  15880. LinesToStr([ // $mod.$main
  15881. '']));
  15882. end;
  15883. procedure TTestModule.TestProcType_ReferenceToProc;
  15884. begin
  15885. StartProgram(false);
  15886. Add([
  15887. 'type',
  15888. ' TProcRef = reference to procedure(i: longint = 0);',
  15889. ' TFuncRef = reference to function(i: longint = 0): longint;',
  15890. 'var',
  15891. ' p: TProcRef;',
  15892. ' f: TFuncRef;',
  15893. 'procedure DoIt(i: longint);',
  15894. 'begin',
  15895. 'end;',
  15896. 'function GetIt(i: longint): longint;',
  15897. 'begin',
  15898. ' p:=@DoIt;',
  15899. ' f:=@GetIt;',
  15900. ' f;',
  15901. ' f();',
  15902. ' f(1);',
  15903. 'end;',
  15904. 'begin',
  15905. ' p:=@DoIt;',
  15906. ' f:=@GetIt;',
  15907. ' f;',
  15908. ' f();',
  15909. ' f(1);',
  15910. ' p:=TProcRef(f);',
  15911. '']);
  15912. ConvertProgram;
  15913. CheckSource('TestProcType_ReferenceToProc',
  15914. LinesToStr([ // statements
  15915. 'this.p = null;',
  15916. 'this.f = null;',
  15917. 'this.DoIt = function (i) {',
  15918. '};',
  15919. 'this.GetIt = function (i) {',
  15920. ' var Result = 0;',
  15921. ' $mod.p = $mod.DoIt;',
  15922. ' $mod.f = $mod.GetIt;',
  15923. ' $mod.f(0);',
  15924. ' $mod.f(0);',
  15925. ' $mod.f(1);',
  15926. ' return Result;',
  15927. '};',
  15928. '']),
  15929. LinesToStr([ // $mod.$main
  15930. '$mod.p = $mod.DoIt;',
  15931. '$mod.f = $mod.GetIt;',
  15932. '$mod.f(0);',
  15933. '$mod.f(0);',
  15934. '$mod.f(1);',
  15935. '$mod.p = $mod.f;',
  15936. '']));
  15937. end;
  15938. procedure TTestModule.TestProcType_ReferenceToMethod;
  15939. begin
  15940. StartProgram(false);
  15941. Add([
  15942. 'type',
  15943. ' TFuncRef = reference to function(i: longint = 5): longint;',
  15944. ' TObject = class',
  15945. ' function Grow(s: longint): longint;',
  15946. ' end;',
  15947. 'var',
  15948. ' f: tfuncref;',
  15949. 'function tobject.grow(s: longint): longint;',
  15950. ' function GrowSub(i: longint): longint;',
  15951. ' begin',
  15952. ' f:=@grow;',
  15953. ' f:=@growsub;',
  15954. ' end;',
  15955. 'begin',
  15956. ' f:=@grow;',
  15957. ' f:=@growsub;',
  15958. 'end;',
  15959. 'begin',
  15960. '']);
  15961. ConvertProgram;
  15962. CheckSource('TestProcType_ReferenceToMethod',
  15963. LinesToStr([ // statements
  15964. 'rtl.createClass($mod, "TObject", null, function () {',
  15965. ' this.$init = function () {',
  15966. ' };',
  15967. ' this.$final = function () {',
  15968. ' };',
  15969. ' this.Grow = function (s) {',
  15970. ' var Self = this;',
  15971. ' var Result = 0;',
  15972. ' function GrowSub(i) {',
  15973. ' var Result = 0;',
  15974. ' $mod.f = rtl.createCallback(Self, "Grow");',
  15975. ' $mod.f = GrowSub;',
  15976. ' return Result;',
  15977. ' };',
  15978. ' $mod.f = rtl.createCallback(Self, "Grow");',
  15979. ' $mod.f = GrowSub;',
  15980. ' return Result;',
  15981. ' };',
  15982. '});',
  15983. 'this.f = null;',
  15984. '']),
  15985. LinesToStr([ // $mod.$main
  15986. '']));
  15987. end;
  15988. procedure TTestModule.TestProcType_Typecast;
  15989. begin
  15990. StartProgram(false);
  15991. Add([
  15992. 'type',
  15993. ' TNotifyEvent = procedure(Sender: Pointer) of object;',
  15994. ' TEvent = procedure of object;',
  15995. ' TGetter = function:longint of object;',
  15996. ' TProcA = procedure(i: longint);',
  15997. ' TFuncB = function(i, j: longint): longint;',
  15998. 'procedure DoIt(); varargs; begin end;',
  15999. 'var',
  16000. ' Notify: tnotifyevent;',
  16001. ' Event: tevent;',
  16002. ' Getter: tgetter;',
  16003. ' ProcA: tproca;',
  16004. ' FuncB: tfuncb;',
  16005. ' p: pointer;',
  16006. 'begin',
  16007. ' notify:=tnotifyevent(event);',
  16008. ' event:=tevent(event);',
  16009. ' event:=tevent(notify);',
  16010. ' event:=tevent(getter);',
  16011. ' event:=tevent(proca);',
  16012. ' proca:=tproca(funcb);',
  16013. ' funcb:=tfuncb(funcb);',
  16014. ' funcb:=tfuncb(proca);',
  16015. ' funcb:=tfuncb(getter);',
  16016. ' proca:=tproca(p);',
  16017. ' funcb:=tfuncb(p);',
  16018. ' getter:=tgetter(p);',
  16019. ' p:=pointer(notify);',
  16020. ' p:=notify;',
  16021. ' p:=pointer(proca);',
  16022. ' p:=proca;',
  16023. ' p:=pointer(funcb);',
  16024. ' p:=funcb;',
  16025. ' doit(Pointer(notify),pointer(event),pointer(proca));',
  16026. '']);
  16027. ConvertProgram;
  16028. CheckSource('TestProcType_Typecast',
  16029. LinesToStr([ // statements
  16030. 'this.DoIt = function () {',
  16031. '};',
  16032. 'this.Notify = null;',
  16033. 'this.Event = null;',
  16034. 'this.Getter = null;',
  16035. 'this.ProcA = null;',
  16036. 'this.FuncB = null;',
  16037. 'this.p = null;',
  16038. '']),
  16039. LinesToStr([ // $mod.$main
  16040. '$mod.Notify = $mod.Event;',
  16041. '$mod.Event = $mod.Event;',
  16042. '$mod.Event = $mod.Notify;',
  16043. '$mod.Event = $mod.Getter;',
  16044. '$mod.Event = $mod.ProcA;',
  16045. '$mod.ProcA = $mod.FuncB;',
  16046. '$mod.FuncB = $mod.FuncB;',
  16047. '$mod.FuncB = $mod.ProcA;',
  16048. '$mod.FuncB = $mod.Getter;',
  16049. '$mod.ProcA = $mod.p;',
  16050. '$mod.FuncB = $mod.p;',
  16051. '$mod.Getter = $mod.p;',
  16052. '$mod.p = $mod.Notify;',
  16053. '$mod.p = $mod.Notify;',
  16054. '$mod.p = $mod.ProcA;',
  16055. '$mod.p = $mod.ProcA;',
  16056. '$mod.p = $mod.FuncB;',
  16057. '$mod.p = $mod.FuncB;',
  16058. '$mod.DoIt($mod.Notify, $mod.Event, $mod.ProcA);',
  16059. '']));
  16060. end;
  16061. procedure TTestModule.TestProcType_PassProcToUntyped;
  16062. begin
  16063. StartProgram(false);
  16064. Add([
  16065. 'type',
  16066. ' TEvent = procedure of object;',
  16067. ' TFunc = function: longint;',
  16068. 'procedure DoIt(); varargs; begin end;',
  16069. 'procedure DoSome(const a; var b; p: pointer); begin end;',
  16070. 'var',
  16071. ' Event: tevent;',
  16072. ' Func: TFunc;',
  16073. 'begin',
  16074. ' doit(event,func);',
  16075. ' dosome(event,event,event);',
  16076. ' dosome(func,func,func);',
  16077. '']);
  16078. ConvertProgram;
  16079. CheckSource('TestProcType_PassProcToUntyped',
  16080. LinesToStr([ // statements
  16081. 'this.DoIt = function () {',
  16082. '};',
  16083. 'this.DoSome = function (a, b, p) {',
  16084. '};',
  16085. 'this.Event = null;',
  16086. 'this.Func = null;',
  16087. '']),
  16088. LinesToStr([ // $mod.$main
  16089. '$mod.DoIt($mod.Event, $mod.Func);',
  16090. '$mod.DoSome($mod.Event, {',
  16091. ' p: $mod,',
  16092. ' get: function () {',
  16093. ' return this.p.Event;',
  16094. ' },',
  16095. ' set: function (v) {',
  16096. ' this.p.Event = v;',
  16097. ' }',
  16098. '}, $mod.Event);',
  16099. '$mod.DoSome($mod.Func, {',
  16100. ' p: $mod,',
  16101. ' get: function () {',
  16102. ' return this.p.Func;',
  16103. ' },',
  16104. ' set: function (v) {',
  16105. ' this.p.Func = v;',
  16106. ' }',
  16107. '}, $mod.Func);',
  16108. '']));
  16109. end;
  16110. procedure TTestModule.TestProcType_PassProcToArray;
  16111. begin
  16112. StartProgram(false);
  16113. Add([
  16114. 'type',
  16115. ' TFunc = function: longint;',
  16116. ' TArrFunc = array of TFunc;',
  16117. 'procedure DoIt(Arr: TArrFunc); begin end;',
  16118. 'function GetIt: longint; begin end;',
  16119. 'var',
  16120. ' Func: tfunc;',
  16121. 'begin',
  16122. ' doit([]);',
  16123. ' doit([@GetIt]);',
  16124. ' doit([Func]);',
  16125. '']);
  16126. ConvertProgram;
  16127. CheckSource('TestProcType_PassProcToArray',
  16128. LinesToStr([ // statements
  16129. 'this.DoIt = function (Arr) {',
  16130. '};',
  16131. 'this.GetIt = function () {',
  16132. ' var Result = 0;',
  16133. ' return Result;',
  16134. '};',
  16135. 'this.Func = null;',
  16136. '']),
  16137. LinesToStr([ // $mod.$main
  16138. '$mod.DoIt([]);',
  16139. '$mod.DoIt([$mod.GetIt]);',
  16140. '$mod.DoIt([$mod.Func]);',
  16141. '']));
  16142. end;
  16143. procedure TTestModule.TestPointer;
  16144. begin
  16145. StartProgram(false);
  16146. Add(['type',
  16147. ' TObject = class end;',
  16148. ' TClass = class of TObject;',
  16149. ' TArrInt = array of longint;',
  16150. 'const',
  16151. ' n = nil;',
  16152. 'var',
  16153. ' v: jsvalue;',
  16154. ' Obj: tobject;',
  16155. ' C: tclass;',
  16156. ' a: tarrint;',
  16157. ' p: Pointer = nil;',
  16158. 'begin',
  16159. ' p:=p;',
  16160. ' p:=nil;',
  16161. ' if p=nil then;',
  16162. ' if nil=p then;',
  16163. ' if Assigned(p) then;',
  16164. ' p:=Pointer(v);',
  16165. ' p:=obj;',
  16166. ' p:=c;',
  16167. ' p:=a;',
  16168. ' p:=tobject;',
  16169. ' obj:=TObject(p);',
  16170. ' c:=TClass(p);',
  16171. ' a:=TArrInt(p);',
  16172. ' p:=n;']);
  16173. ConvertProgram;
  16174. CheckSource('TestPointer',
  16175. LinesToStr([ // statements
  16176. 'rtl.createClass($mod, "TObject", null, function () {',
  16177. ' this.$init = function () {',
  16178. ' };',
  16179. ' this.$final = function () {',
  16180. ' };',
  16181. '});',
  16182. 'this.n = null;',
  16183. 'this.v = undefined;',
  16184. 'this.Obj = null;',
  16185. 'this.C = null;',
  16186. 'this.a = [];',
  16187. 'this.p = null;',
  16188. '']),
  16189. LinesToStr([ // $mod.$main
  16190. '$mod.p = $mod.p;',
  16191. '$mod.p = null;',
  16192. 'if ($mod.p === null) ;',
  16193. 'if (null === $mod.p) ;',
  16194. 'if ($mod.p != null) ;',
  16195. '$mod.p = $mod.v;',
  16196. '$mod.p = $mod.Obj;',
  16197. '$mod.p = $mod.C;',
  16198. '$mod.p = $mod.a;',
  16199. '$mod.p = $mod.TObject;',
  16200. '$mod.Obj = $mod.p;',
  16201. '$mod.C = $mod.p;',
  16202. '$mod.a = $mod.p;',
  16203. '$mod.p = null;',
  16204. '']));
  16205. end;
  16206. procedure TTestModule.TestPointer_Proc;
  16207. begin
  16208. StartProgram(false);
  16209. Add('type');
  16210. Add(' TObject = class');
  16211. Add(' procedure DoIt; virtual; abstract;');
  16212. Add(' end;');
  16213. Add('procedure DoSome; begin end;');
  16214. Add('var');
  16215. Add(' o: TObject;');
  16216. Add(' p: Pointer;');
  16217. Add('begin');
  16218. Add(' p:=@DoSome;');
  16219. Add(' p:[email protected];');
  16220. ConvertProgram;
  16221. CheckSource('TestPointer_Proc',
  16222. LinesToStr([ // statements
  16223. 'rtl.createClass($mod, "TObject", null, function () {',
  16224. ' this.$init = function () {',
  16225. ' };',
  16226. ' this.$final = function () {',
  16227. ' };',
  16228. '});',
  16229. 'this.DoSome = function () {',
  16230. '};',
  16231. 'this.o = null;',
  16232. 'this.p = null;',
  16233. '']),
  16234. LinesToStr([ // $mod.$main
  16235. '$mod.p = $mod.DoSome;',
  16236. '$mod.p = rtl.createCallback($mod.o, "DoIt");',
  16237. '']));
  16238. end;
  16239. procedure TTestModule.TestPointer_AssignRecordFail;
  16240. begin
  16241. StartProgram(false);
  16242. Add('type');
  16243. Add(' TRec = record end;');
  16244. Add('var');
  16245. Add(' p: Pointer;');
  16246. Add(' r: TRec;');
  16247. Add('begin');
  16248. Add(' p:=r;');
  16249. SetExpectedPasResolverError('Incompatible types: got "TRec" expected "Pointer"',
  16250. nIncompatibleTypesGotExpected);
  16251. ConvertProgram;
  16252. end;
  16253. procedure TTestModule.TestPointer_AssignStaticArrayFail;
  16254. begin
  16255. StartProgram(false);
  16256. Add('type');
  16257. Add(' TArr = array[boolean] of longint;');
  16258. Add('var');
  16259. Add(' p: Pointer;');
  16260. Add(' a: TArr;');
  16261. Add('begin');
  16262. Add(' p:=a;');
  16263. SetExpectedPasResolverError('Incompatible types: got "TArr" expected "Pointer"',
  16264. nIncompatibleTypesGotExpected);
  16265. ConvertProgram;
  16266. end;
  16267. procedure TTestModule.TestPointer_TypeCastJSValueToPointer;
  16268. begin
  16269. StartProgram(false);
  16270. Add([
  16271. 'procedure DoIt(args: array of jsvalue); begin end;',
  16272. 'procedure DoAll; varargs; begin end;',
  16273. 'var',
  16274. ' v: jsvalue;',
  16275. 'begin',
  16276. ' DoIt([pointer(v)]);',
  16277. ' DoAll(pointer(v));',
  16278. '']);
  16279. ConvertProgram;
  16280. CheckSource('TestPointer_TypeCastJSValueToPointer',
  16281. LinesToStr([ // statements
  16282. 'this.DoIt = function (args) {',
  16283. '};',
  16284. 'this.DoAll = function () {',
  16285. '};',
  16286. 'this.v = undefined;',
  16287. '']),
  16288. LinesToStr([ // $mod.$main
  16289. '$mod.DoIt([$mod.v]);',
  16290. '$mod.DoAll($mod.v);',
  16291. '']));
  16292. end;
  16293. procedure TTestModule.TestPointer_NonRecordFail;
  16294. begin
  16295. StartProgram(false);
  16296. Add([
  16297. 'type',
  16298. ' p = ^longint;',
  16299. 'begin',
  16300. '']);
  16301. SetExpectedPasResolverError('Not supported: pointer of Longint',nNotSupportedX);
  16302. ConvertProgram;
  16303. end;
  16304. procedure TTestModule.TestPointer_AnonymousArgTypeFail;
  16305. begin
  16306. StartProgram(false);
  16307. Add([
  16308. 'procedure DoIt(p: ^longint); begin end;',
  16309. 'begin',
  16310. '']);
  16311. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  16312. ConvertProgram;
  16313. end;
  16314. procedure TTestModule.TestPointer_AnonymousVarTypeFail;
  16315. begin
  16316. StartProgram(false);
  16317. Add([
  16318. 'var p: ^longint;',
  16319. 'begin',
  16320. '']);
  16321. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  16322. ConvertProgram;
  16323. end;
  16324. procedure TTestModule.TestPointer_AnonymousResultTypeFail;
  16325. begin
  16326. StartProgram(false);
  16327. Add([
  16328. 'function DoIt: ^longint; begin end;',
  16329. 'begin',
  16330. '']);
  16331. SetExpectedPasResolverError('Not supported: pointer',nNotSupportedX);
  16332. ConvertProgram;
  16333. end;
  16334. procedure TTestModule.TestPointer_AddrOperatorFail;
  16335. begin
  16336. StartProgram(false);
  16337. Add([
  16338. 'var i: longint;',
  16339. 'begin',
  16340. ' if @i=nil then ;',
  16341. '']);
  16342. SetExpectedConverterError('illegal qualifier "@" in front of "i:Longint"',nIllegalQualifierInFrontOf);
  16343. ConvertProgram;
  16344. end;
  16345. procedure TTestModule.TestPointer_ArrayParamsFail;
  16346. begin
  16347. StartProgram(false);
  16348. Add([
  16349. 'var',
  16350. ' p: Pointer;',
  16351. 'begin',
  16352. ' p:=p[1];',
  16353. '']);
  16354. SetExpectedPasResolverError('illegal qualifier "[" after "Pointer"',nIllegalQualifierAfter);
  16355. ConvertProgram;
  16356. end;
  16357. procedure TTestModule.TestPointer_PointerAddFail;
  16358. begin
  16359. StartProgram(false);
  16360. Add([
  16361. 'var',
  16362. ' p: Pointer;',
  16363. 'begin',
  16364. ' p:=p+1;',
  16365. '']);
  16366. SetExpectedPasResolverError('Operator is not overloaded: "Pointer" + "Longint"',nOperatorIsNotOverloadedAOpB);
  16367. ConvertProgram;
  16368. end;
  16369. procedure TTestModule.TestPointer_IncPointerFail;
  16370. begin
  16371. StartProgram(false);
  16372. Add([
  16373. 'var',
  16374. ' p: Pointer;',
  16375. 'begin',
  16376. ' inc(p,1);',
  16377. '']);
  16378. SetExpectedPasResolverError('Incompatible type arg no. 1: Got "Pointer", expected "integer"',
  16379. nIncompatibleTypeArgNo);
  16380. ConvertProgram;
  16381. end;
  16382. procedure TTestModule.TestPointer_Record;
  16383. begin
  16384. StartProgram(false);
  16385. Add([
  16386. 'type',
  16387. ' TRec = record x: longint; end;',
  16388. ' PRec = ^TRec;',
  16389. 'var',
  16390. ' r: TRec;',
  16391. ' p: PRec;',
  16392. ' q: ^TRec;',
  16393. 'begin',
  16394. ' new(p);',
  16395. ' p:=@r;',
  16396. ' r:=p^;',
  16397. ' r.x:=p^.x;',
  16398. ' p^.x:=r.x;',
  16399. ' if p^.x=3 then ;',
  16400. ' if 4=p^.x then ;',
  16401. ' dispose(p);',
  16402. ' new(q);',
  16403. ' dispose(q);',
  16404. '']);
  16405. ConvertProgram;
  16406. CheckSource('TestPointer_Record',
  16407. LinesToStr([ // statements
  16408. 'this.TRec = function (s) {',
  16409. ' if (s) {',
  16410. ' this.x = s.x;',
  16411. ' } else {',
  16412. ' this.x = 0;',
  16413. ' };',
  16414. ' this.$equal = function (b) {',
  16415. ' return this.x === b.x;',
  16416. ' };',
  16417. '};',
  16418. 'this.r = new $mod.TRec();',
  16419. 'this.p = null;',
  16420. 'this.q = null;',
  16421. '']),
  16422. LinesToStr([ // $mod.$main
  16423. '$mod.p = new $mod.TRec();',
  16424. '$mod.p = $mod.r;',
  16425. '$mod.r = new $mod.TRec($mod.p);',
  16426. '$mod.r.x = $mod.p.x;',
  16427. '$mod.p.x = $mod.r.x;',
  16428. 'if ($mod.p.x === 3) ;',
  16429. 'if (4 === $mod.p.x) ;',
  16430. '$mod.p = null;',
  16431. '$mod.q = new $mod.TRec();',
  16432. '$mod.q = null;',
  16433. '']));
  16434. end;
  16435. procedure TTestModule.TestPointer_RecordArg;
  16436. begin
  16437. StartProgram(false);
  16438. Add([
  16439. '{$modeswitch autoderef}',
  16440. 'type',
  16441. ' TRec = record x: longint; end;',
  16442. ' PRec = ^TRec;',
  16443. 'function DoIt(const a: PRec; var b: PRec; out c: PRec): TRec;',
  16444. 'begin',
  16445. ' a.x:=a.x;',
  16446. ' a^.x:=a^.x;',
  16447. ' with a^ do',
  16448. ' x:=x;',
  16449. 'end;',
  16450. 'function GetIt(p: PRec): PRec;',
  16451. 'begin',
  16452. ' p.x:=p.x;',
  16453. ' p^.x:=p^.x;',
  16454. ' with p^ do',
  16455. ' x:=x;',
  16456. 'end;',
  16457. 'var',
  16458. ' r: TRec;',
  16459. ' p: PRec;',
  16460. 'begin',
  16461. ' p:=GetIt(p);',
  16462. ' p^:=GetIt(@r)^;',
  16463. ' DoIt(p,p,p);',
  16464. ' DoIt(@r,p,p);',
  16465. '']);
  16466. ConvertProgram;
  16467. CheckSource('TestPointer_Record',
  16468. LinesToStr([ // statements
  16469. 'this.TRec = function (s) {',
  16470. ' if (s) {',
  16471. ' this.x = s.x;',
  16472. ' } else {',
  16473. ' this.x = 0;',
  16474. ' };',
  16475. ' this.$equal = function (b) {',
  16476. ' return this.x === b.x;',
  16477. ' };',
  16478. '};',
  16479. 'this.DoIt = function (a, b, c) {',
  16480. ' var Result = new $mod.TRec();',
  16481. ' a.x = a.x;',
  16482. ' a.x = a.x;',
  16483. ' a.x = a.x;',
  16484. ' return Result;',
  16485. '};',
  16486. 'this.GetIt = function (p) {',
  16487. ' var Result = null;',
  16488. ' p.x = p.x;',
  16489. ' p.x = p.x;',
  16490. ' p.x = p.x;',
  16491. ' return Result;',
  16492. '};',
  16493. 'this.r = new $mod.TRec();',
  16494. 'this.p = null;',
  16495. '']),
  16496. LinesToStr([ // $mod.$main
  16497. '$mod.p = $mod.GetIt($mod.p);',
  16498. '$mod.p = new $mod.TRec($mod.GetIt($mod.r));',
  16499. '$mod.DoIt($mod.p, {',
  16500. ' p: $mod,',
  16501. ' get: function () {',
  16502. ' return this.p.p;',
  16503. ' },',
  16504. ' set: function (v) {',
  16505. ' this.p.p = v;',
  16506. ' }',
  16507. '}, {',
  16508. ' p: $mod,',
  16509. ' get: function () {',
  16510. ' return this.p.p;',
  16511. ' },',
  16512. ' set: function (v) {',
  16513. ' this.p.p = v;',
  16514. ' }',
  16515. '});',
  16516. '$mod.DoIt($mod.r, {',
  16517. ' p: $mod,',
  16518. ' get: function () {',
  16519. ' return this.p.p;',
  16520. ' },',
  16521. ' set: function (v) {',
  16522. ' this.p.p = v;',
  16523. ' }',
  16524. '}, {',
  16525. ' p: $mod,',
  16526. ' get: function () {',
  16527. ' return this.p.p;',
  16528. ' },',
  16529. ' set: function (v) {',
  16530. ' this.p.p = v;',
  16531. ' }',
  16532. '});',
  16533. '']));
  16534. end;
  16535. procedure TTestModule.TestJSValue_AssignToJSValue;
  16536. begin
  16537. StartProgram(false);
  16538. Add('var');
  16539. Add(' v: jsvalue;');
  16540. Add(' i: longint;');
  16541. Add(' s: string;');
  16542. Add(' b: boolean;');
  16543. Add(' d: double;');
  16544. Add(' p: pointer;');
  16545. Add('begin');
  16546. Add(' v:=v;');
  16547. Add(' v:=1;');
  16548. Add(' v:=i;');
  16549. Add(' v:='''';');
  16550. Add(' v:=''c'';');
  16551. Add(' v:=''foo'';');
  16552. Add(' v:=s;');
  16553. Add(' v:=false;');
  16554. Add(' v:=true;');
  16555. Add(' v:=b;');
  16556. Add(' v:=0.1;');
  16557. Add(' v:=d;');
  16558. Add(' v:=nil;');
  16559. Add(' v:=p;');
  16560. ConvertProgram;
  16561. CheckSource('TestJSValue_AssignToJSValue',
  16562. LinesToStr([ // statements
  16563. 'this.v = undefined;',
  16564. 'this.i = 0;',
  16565. 'this.s = "";',
  16566. 'this.b = false;',
  16567. 'this.d = 0.0;',
  16568. 'this.p = null;',
  16569. '']),
  16570. LinesToStr([ // $mod.$main
  16571. '$mod.v = $mod.v;',
  16572. '$mod.v = 1;',
  16573. '$mod.v = $mod.i;',
  16574. '$mod.v = "";',
  16575. '$mod.v = "c";',
  16576. '$mod.v = "foo";',
  16577. '$mod.v = $mod.s;',
  16578. '$mod.v = false;',
  16579. '$mod.v = true;',
  16580. '$mod.v = $mod.b;',
  16581. '$mod.v = 0.1;',
  16582. '$mod.v = $mod.d;',
  16583. '$mod.v = null;',
  16584. '$mod.v = $mod.p;',
  16585. '']));
  16586. end;
  16587. procedure TTestModule.TestJSValue_TypeCastToBaseType;
  16588. begin
  16589. StartProgram(false);
  16590. Add('type');
  16591. Add(' integer = longint;');
  16592. Add(' TYesNo = boolean;');
  16593. Add(' TFloat = double;');
  16594. Add(' TCaption = string;');
  16595. Add(' TChar = char;');
  16596. Add('var');
  16597. Add(' v: jsvalue;');
  16598. Add(' i: integer;');
  16599. Add(' s: TCaption;');
  16600. Add(' b: TYesNo;');
  16601. Add(' d: TFloat;');
  16602. Add(' c: char;');
  16603. Add('begin');
  16604. Add(' i:=longint(v);');
  16605. Add(' i:=integer(v);');
  16606. Add(' s:=string(v);');
  16607. Add(' s:=TCaption(v);');
  16608. Add(' b:=boolean(v);');
  16609. Add(' b:=TYesNo(v);');
  16610. Add(' d:=double(v);');
  16611. Add(' d:=TFloat(v);');
  16612. Add(' c:=char(v);');
  16613. Add(' c:=TChar(v);');
  16614. ConvertProgram;
  16615. CheckSource('TestJSValue_TypeCastToBaseType',
  16616. LinesToStr([ // statements
  16617. 'this.v = undefined;',
  16618. 'this.i = 0;',
  16619. 'this.s = "";',
  16620. 'this.b = false;',
  16621. 'this.d = 0.0;',
  16622. 'this.c = "";',
  16623. '']),
  16624. LinesToStr([ // $mod.$main
  16625. '$mod.i = Math.floor($mod.v);',
  16626. '$mod.i = Math.floor($mod.v);',
  16627. '$mod.s = "" + $mod.v;',
  16628. '$mod.s = "" + $mod.v;',
  16629. '$mod.b = !($mod.v == false);',
  16630. '$mod.b = !($mod.v == false);',
  16631. '$mod.d = rtl.getNumber($mod.v);',
  16632. '$mod.d = rtl.getNumber($mod.v);',
  16633. '$mod.c = rtl.getChar($mod.v);',
  16634. '$mod.c = rtl.getChar($mod.v);',
  16635. '']));
  16636. end;
  16637. procedure TTestModule.TestJSValue_Equal;
  16638. begin
  16639. StartProgram(false);
  16640. Add('type');
  16641. Add(' integer = longint;');
  16642. Add(' TYesNo = boolean;');
  16643. Add(' TFloat = double;');
  16644. Add(' TCaption = string;');
  16645. Add(' TChar = char;');
  16646. Add(' TMulti = JSValue;');
  16647. Add('var');
  16648. Add(' v: jsvalue;');
  16649. Add(' i: integer;');
  16650. Add(' s: TCaption;');
  16651. Add(' b: TYesNo;');
  16652. Add(' d: TFloat;');
  16653. Add(' c: char;');
  16654. Add(' m: TMulti;');
  16655. Add('begin');
  16656. Add(' b:=v=v;');
  16657. Add(' b:=v<>v;');
  16658. Add(' b:=v=1;');
  16659. Add(' b:=v<>1;');
  16660. Add(' b:=2=v;');
  16661. Add(' b:=2<>v;');
  16662. Add(' b:=v=i;');
  16663. Add(' b:=i=v;');
  16664. Add(' b:=v=nil;');
  16665. Add(' b:=nil=v;');
  16666. Add(' b:=v=false;');
  16667. Add(' b:=true=v;');
  16668. Add(' b:=v=b;');
  16669. Add(' b:=b=v;');
  16670. Add(' b:=v=s;');
  16671. Add(' b:=s=v;');
  16672. Add(' b:=v=''foo'';');
  16673. Add(' b:=''''=v;');
  16674. Add(' b:=v=d;');
  16675. Add(' b:=d=v;');
  16676. Add(' b:=v=3.4;');
  16677. Add(' b:=5.6=v;');
  16678. Add(' b:=v=c;');
  16679. Add(' b:=c=v;');
  16680. Add(' b:=m=m;');
  16681. Add(' b:=v=m;');
  16682. Add(' b:=m=v;');
  16683. ConvertProgram;
  16684. CheckSource('TestJSValue_Equal',
  16685. LinesToStr([ // statements
  16686. 'this.v = undefined;',
  16687. 'this.i = 0;',
  16688. 'this.s = "";',
  16689. 'this.b = false;',
  16690. 'this.d = 0.0;',
  16691. 'this.c = "";',
  16692. 'this.m = undefined;',
  16693. '']),
  16694. LinesToStr([ // $mod.$main
  16695. '$mod.b = $mod.v == $mod.v;',
  16696. '$mod.b = $mod.v != $mod.v;',
  16697. '$mod.b = $mod.v == 1;',
  16698. '$mod.b = $mod.v != 1;',
  16699. '$mod.b = 2 == $mod.v;',
  16700. '$mod.b = 2 != $mod.v;',
  16701. '$mod.b = $mod.v == $mod.i;',
  16702. '$mod.b = $mod.i == $mod.v;',
  16703. '$mod.b = $mod.v == null;',
  16704. '$mod.b = null == $mod.v;',
  16705. '$mod.b = $mod.v == false;',
  16706. '$mod.b = true == $mod.v;',
  16707. '$mod.b = $mod.v == $mod.b;',
  16708. '$mod.b = $mod.b == $mod.v;',
  16709. '$mod.b = $mod.v == $mod.s;',
  16710. '$mod.b = $mod.s == $mod.v;',
  16711. '$mod.b = $mod.v == "foo";',
  16712. '$mod.b = "" == $mod.v;',
  16713. '$mod.b = $mod.v == $mod.d;',
  16714. '$mod.b = $mod.d == $mod.v;',
  16715. '$mod.b = $mod.v == 3.4;',
  16716. '$mod.b = 5.6 == $mod.v;',
  16717. '$mod.b = $mod.v == $mod.c;',
  16718. '$mod.b = $mod.c == $mod.v;',
  16719. '$mod.b = $mod.m == $mod.m;',
  16720. '$mod.b = $mod.v == $mod.m;',
  16721. '$mod.b = $mod.m == $mod.v;',
  16722. '']));
  16723. end;
  16724. procedure TTestModule.TestJSValue_If;
  16725. begin
  16726. StartProgram(false);
  16727. Add([
  16728. 'var',
  16729. ' v: jsvalue;',
  16730. 'begin',
  16731. ' if v then ;',
  16732. ' while v do ;',
  16733. ' repeat until v;',
  16734. '']);
  16735. ConvertProgram;
  16736. CheckSource('TestJSValue_If',
  16737. LinesToStr([ // statements
  16738. 'this.v = undefined;',
  16739. '']),
  16740. LinesToStr([ // $mod.$main
  16741. 'if ($mod.v) ;',
  16742. 'while($mod.v){',
  16743. '};',
  16744. 'do{',
  16745. '} while(!$mod.v);',
  16746. '']));
  16747. end;
  16748. procedure TTestModule.TestJSValue_Not;
  16749. begin
  16750. StartProgram(false);
  16751. Add([
  16752. 'var',
  16753. ' v: jsvalue;',
  16754. ' b: boolean;',
  16755. 'begin',
  16756. ' b:=not v;',
  16757. ' if not v then ;',
  16758. ' while not v do ;',
  16759. ' repeat until not v;',
  16760. '']);
  16761. ConvertProgram;
  16762. CheckSource('TestJSValue_If',
  16763. LinesToStr([ // statements
  16764. 'this.v = undefined;',
  16765. 'this.b = false;',
  16766. '']),
  16767. LinesToStr([ // $mod.$main
  16768. '$mod.b=!$mod.v;',
  16769. 'if (!$mod.v) ;',
  16770. 'while(!$mod.v){',
  16771. '};',
  16772. 'do{',
  16773. '} while($mod.v);',
  16774. '']));
  16775. end;
  16776. procedure TTestModule.TestJSValue_Enum;
  16777. begin
  16778. StartProgram(false);
  16779. Add('type');
  16780. Add(' TColor = (red, blue);');
  16781. Add(' TRedBlue = TColor;');
  16782. Add('var');
  16783. Add(' v: jsvalue;');
  16784. Add(' e: TColor;');
  16785. Add('begin');
  16786. Add(' v:=e;');
  16787. Add(' v:=TColor(e);');
  16788. Add(' v:=TRedBlue(e);');
  16789. Add(' e:=TColor(v);');
  16790. Add(' e:=TRedBlue(v);');
  16791. ConvertProgram;
  16792. CheckSource('TestJSValue_Enum',
  16793. LinesToStr([ // statements
  16794. 'this.TColor = {',
  16795. ' "0": "red",',
  16796. ' red: 0,',
  16797. ' "1": "blue",',
  16798. ' blue: 1',
  16799. '};',
  16800. 'this.v = undefined;',
  16801. 'this.e = 0;',
  16802. '']),
  16803. LinesToStr([ // $mod.$main
  16804. '$mod.v = $mod.e;',
  16805. '$mod.v = $mod.e;',
  16806. '$mod.v = $mod.e;',
  16807. '$mod.e = $mod.v;',
  16808. '$mod.e = $mod.v;',
  16809. '']));
  16810. end;
  16811. procedure TTestModule.TestJSValue_ClassInstance;
  16812. begin
  16813. StartProgram(false);
  16814. Add([
  16815. 'type',
  16816. ' TObject = class',
  16817. ' end;',
  16818. ' TBirdObject = TObject;',
  16819. 'var',
  16820. ' v: jsvalue;',
  16821. ' o: TObject;',
  16822. 'begin',
  16823. ' v:=o;',
  16824. ' v:=TObject(o);',
  16825. ' v:=TBirdObject(o);',
  16826. ' o:=TObject(v);',
  16827. ' o:=TBirdObject(v);',
  16828. ' if v is TObject then ;',
  16829. '']);
  16830. ConvertProgram;
  16831. CheckSource('TestJSValue_ClassInstance',
  16832. LinesToStr([ // statements
  16833. 'rtl.createClass($mod, "TObject", null, function () {',
  16834. ' this.$init = function () {',
  16835. ' };',
  16836. ' this.$final = function () {',
  16837. ' };',
  16838. '});',
  16839. 'this.v = undefined;',
  16840. 'this.o = null;',
  16841. '']),
  16842. LinesToStr([ // $mod.$main
  16843. '$mod.v = $mod.o;',
  16844. '$mod.v = $mod.o;',
  16845. '$mod.v = $mod.o;',
  16846. '$mod.o = rtl.getObject($mod.v);',
  16847. '$mod.o = rtl.getObject($mod.v);',
  16848. 'if (rtl.isExt($mod.v, $mod.TObject, 1)) ;',
  16849. '']));
  16850. end;
  16851. procedure TTestModule.TestJSValue_ClassOf;
  16852. begin
  16853. StartProgram(false);
  16854. Add([
  16855. 'type',
  16856. ' TClass = class of TObject;',
  16857. ' TObject = class',
  16858. ' end;',
  16859. ' TBirds = class of TBird;',
  16860. ' TBird = class(TObject) end;',
  16861. 'var',
  16862. ' v: jsvalue;',
  16863. ' c: TClass;',
  16864. 'begin',
  16865. ' v:=c;',
  16866. ' v:=TObject;',
  16867. ' v:=TClass(c);',
  16868. ' v:=TBirds(c);',
  16869. ' c:=TClass(v);',
  16870. ' c:=TBirds(v);',
  16871. ' if v is TClass then ;',
  16872. '']);
  16873. ConvertProgram;
  16874. CheckSource('TestJSValue_ClassOf',
  16875. LinesToStr([ // statements
  16876. 'rtl.createClass($mod, "TObject", null, function () {',
  16877. ' this.$init = function () {',
  16878. ' };',
  16879. ' this.$final = function () {',
  16880. ' };',
  16881. '});',
  16882. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  16883. '});',
  16884. 'this.v = undefined;',
  16885. 'this.c = null;',
  16886. '']),
  16887. LinesToStr([ // $mod.$main
  16888. '$mod.v = $mod.c;',
  16889. '$mod.v = $mod.TObject;',
  16890. '$mod.v = $mod.c;',
  16891. '$mod.v = $mod.c;',
  16892. '$mod.c = rtl.getObject($mod.v);',
  16893. '$mod.c = rtl.getObject($mod.v);',
  16894. 'if (rtl.isExt($mod.v, $mod.TObject, 2)) ;',
  16895. '']));
  16896. end;
  16897. procedure TTestModule.TestJSValue_ArrayOfJSValue;
  16898. begin
  16899. StartProgram(false);
  16900. Add([
  16901. 'type',
  16902. ' integer = longint;',
  16903. ' TArray = array of JSValue;',
  16904. ' TArrgh = tarray;',
  16905. ' TArrInt = array of integer;',
  16906. 'var',
  16907. ' v: jsvalue;',
  16908. ' TheArray: tarray = (1,''2'');',
  16909. ' Arr: tarrgh;',
  16910. ' i: integer;',
  16911. ' ArrInt: tarrint;',
  16912. 'begin',
  16913. ' arr:=thearray;',
  16914. ' thearray:=arr;',
  16915. ' setlength(arr,2);',
  16916. ' setlength(thearray,3);',
  16917. ' arr[4]:=v;',
  16918. ' arr[5]:=length(thearray);',
  16919. ' arr[6]:=nil;',
  16920. ' arr[7]:=thearray[8];',
  16921. ' arr[low(arr)]:=high(thearray);',
  16922. ' arr:=arrint;',
  16923. ' arrInt:=tarrint(arr);',
  16924. ' if TheArray = nil then ;',
  16925. ' if nil = TheArray then ;',
  16926. ' if TheArray <> nil then ;',
  16927. ' if nil <> TheArray then ;',
  16928. '']);
  16929. ConvertProgram;
  16930. CheckSource('TestJSValue_ArrayOfJSValue',
  16931. LinesToStr([ // statements
  16932. 'this.v = undefined;',
  16933. 'this.TheArray = [1, "2"];',
  16934. 'this.Arr = [];',
  16935. 'this.i = 0;',
  16936. 'this.ArrInt = [];',
  16937. '']),
  16938. LinesToStr([ // $mod.$main
  16939. '$mod.Arr = $mod.TheArray;',
  16940. '$mod.TheArray = $mod.Arr;',
  16941. '$mod.Arr = rtl.arraySetLength($mod.Arr,undefined,2);',
  16942. '$mod.TheArray = rtl.arraySetLength($mod.TheArray,undefined,3);',
  16943. '$mod.Arr[4] = $mod.v;',
  16944. '$mod.Arr[5] = rtl.length($mod.TheArray);',
  16945. '$mod.Arr[6] = null;',
  16946. '$mod.Arr[7] = $mod.TheArray[8];',
  16947. '$mod.Arr[0] = rtl.length($mod.TheArray) - 1;',
  16948. '$mod.Arr = $mod.ArrInt;',
  16949. '$mod.ArrInt = $mod.Arr;',
  16950. 'if (rtl.length($mod.TheArray) === 0) ;',
  16951. 'if (rtl.length($mod.TheArray) === 0) ;',
  16952. 'if (rtl.length($mod.TheArray) > 0) ;',
  16953. 'if (rtl.length($mod.TheArray) > 0) ;',
  16954. '']));
  16955. end;
  16956. procedure TTestModule.TestJSValue_Params;
  16957. begin
  16958. StartProgram(false);
  16959. Add('type');
  16960. Add(' integer = longint;');
  16961. Add(' TYesNo = boolean;');
  16962. Add(' TFloat = double;');
  16963. Add(' TCaption = string;');
  16964. Add(' TChar = char;');
  16965. Add('function DoIt(a: jsvalue; const b: jsvalue; var c: jsvalue; out d: jsvalue): jsvalue;');
  16966. Add('var');
  16967. Add(' l: jsvalue;');
  16968. Add('begin');
  16969. Add(' a:=a;');
  16970. Add(' l:=b;');
  16971. Add(' c:=c;');
  16972. Add(' d:=d;');
  16973. Add(' Result:=l;');
  16974. Add('end;');
  16975. Add('function DoSome(a: jsvalue; const b: jsvalue): jsvalue; begin end;');
  16976. Add('var');
  16977. Add(' v: jsvalue;');
  16978. Add(' i: integer;');
  16979. Add(' b: TYesNo;');
  16980. Add(' d: TFloat;');
  16981. Add(' s: TCaption;');
  16982. Add(' c: TChar;');
  16983. Add('begin');
  16984. Add(' v:=doit(v,v,v,v);');
  16985. Add(' i:=integer(dosome(i,i));');
  16986. Add(' b:=TYesNo(dosome(b,b));');
  16987. Add(' d:=TFloat(dosome(d,d));');
  16988. Add(' s:=TCaption(dosome(s,s));');
  16989. Add(' c:=TChar(dosome(c,c));');
  16990. ConvertProgram;
  16991. CheckSource('TestJSValue_Params',
  16992. LinesToStr([ // statements
  16993. 'this.DoIt = function (a, b, c, d) {',
  16994. ' var Result = undefined;',
  16995. ' var l = undefined;',
  16996. ' a = a;',
  16997. ' l = b;',
  16998. ' c.set(c.get());',
  16999. ' d.set(d.get());',
  17000. ' Result = l;',
  17001. ' return Result;',
  17002. '};',
  17003. 'this.DoSome = function (a, b) {',
  17004. ' var Result = undefined;',
  17005. ' return Result;',
  17006. '};',
  17007. 'this.v = undefined;',
  17008. 'this.i = 0;',
  17009. 'this.b = false;',
  17010. 'this.d = 0.0;',
  17011. 'this.s = "";',
  17012. 'this.c = "";',
  17013. '']),
  17014. LinesToStr([ // $mod.$main
  17015. '$mod.v = $mod.DoIt($mod.v, $mod.v, {',
  17016. ' p: $mod,',
  17017. ' get: function () {',
  17018. ' return this.p.v;',
  17019. ' },',
  17020. ' set: function (v) {',
  17021. ' this.p.v = v;',
  17022. ' }',
  17023. '}, {',
  17024. ' p: $mod,',
  17025. ' get: function () {',
  17026. ' return this.p.v;',
  17027. ' },',
  17028. ' set: function (v) {',
  17029. ' this.p.v = v;',
  17030. ' }',
  17031. '});',
  17032. '$mod.i = Math.floor($mod.DoSome($mod.i, $mod.i));',
  17033. '$mod.b = !($mod.DoSome($mod.b, $mod.b) == false);',
  17034. '$mod.d = rtl.getNumber($mod.DoSome($mod.d, $mod.d));',
  17035. '$mod.s = "" + $mod.DoSome($mod.s, $mod.s);',
  17036. '$mod.c = rtl.getChar($mod.DoSome($mod.c, $mod.c));',
  17037. '']));
  17038. end;
  17039. procedure TTestModule.TestJSValue_UntypedParam;
  17040. begin
  17041. StartProgram(false);
  17042. Add('function DoIt(const a; var b; out c): jsvalue;');
  17043. Add('begin');
  17044. Add(' Result:=a;');
  17045. Add(' Result:=b;');
  17046. Add(' Result:=c;');
  17047. Add(' b:=Result;');
  17048. Add(' c:=Result;');
  17049. Add('end;');
  17050. Add('var i: longint;');
  17051. Add('begin');
  17052. Add(' doit(i,i,i);');
  17053. ConvertProgram;
  17054. CheckSource('TestJSValue_UntypedParam',
  17055. LinesToStr([ // statements
  17056. 'this.DoIt = function (a, b, c) {',
  17057. ' var Result = undefined;',
  17058. ' Result = a;',
  17059. ' Result = b.get();',
  17060. ' Result = c.get();',
  17061. ' b.set(Result);',
  17062. ' c.set(Result);',
  17063. ' return Result;',
  17064. '};',
  17065. 'this.i = 0;',
  17066. '']),
  17067. LinesToStr([ // $mod.$main
  17068. '$mod.DoIt($mod.i, {',
  17069. ' p: $mod,',
  17070. ' get: function () {',
  17071. ' return this.p.i;',
  17072. ' },',
  17073. ' set: function (v) {',
  17074. ' this.p.i = v;',
  17075. ' }',
  17076. '}, {',
  17077. ' p: $mod,',
  17078. ' get: function () {',
  17079. ' return this.p.i;',
  17080. ' },',
  17081. ' set: function (v) {',
  17082. ' this.p.i = v;',
  17083. ' }',
  17084. '});',
  17085. '']));
  17086. end;
  17087. procedure TTestModule.TestJSValue_FuncResultType;
  17088. begin
  17089. StartProgram(false);
  17090. Add('type');
  17091. Add(' integer = longint;');
  17092. Add(' TJSValueArray = array of JSValue;');
  17093. Add(' TListSortCompare = function(Item1, Item2: JSValue): Integer;');
  17094. Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
  17095. Add('begin');
  17096. Add(' while Compare(P,aList[0])>0 do ;');
  17097. Add('end;');
  17098. Add('var');
  17099. Add(' Compare: TListSortCompare;');
  17100. Add(' V: JSValue;');
  17101. Add(' i: integer;');
  17102. Add('begin');
  17103. Add(' if Compare(V,V)>0 then ;');
  17104. Add(' if Compare(i,i)>1 then ;');
  17105. Add(' if Compare(nil,false)>2 then ;');
  17106. Add(' if Compare(1,true)>3 then ;');
  17107. ConvertProgram;
  17108. CheckSource('TestJSValue_UntypedParam',
  17109. LinesToStr([ // statements
  17110. 'this.Sort = function (P, aList, Compare) {',
  17111. ' while (Compare(P, aList[0]) > 0) {',
  17112. ' };',
  17113. '};',
  17114. 'this.Compare = null;',
  17115. 'this.V = undefined;',
  17116. 'this.i = 0;',
  17117. '']),
  17118. LinesToStr([ // $mod.$main
  17119. 'if ($mod.Compare($mod.V, $mod.V) > 0) ;',
  17120. 'if ($mod.Compare($mod.i, $mod.i) > 1) ;',
  17121. 'if ($mod.Compare(null, false) > 2) ;',
  17122. 'if ($mod.Compare(1, true) > 3) ;',
  17123. '']));
  17124. end;
  17125. procedure TTestModule.TestJSValue_ProcType_Assign;
  17126. begin
  17127. StartProgram(false);
  17128. Add('type');
  17129. Add(' integer = longint;');
  17130. Add(' TObject = class');
  17131. Add(' class function GetGlob: integer;');
  17132. Add(' function Getter: integer;');
  17133. Add(' end;');
  17134. Add('class function TObject.GetGlob: integer;');
  17135. Add('var v1: jsvalue;');
  17136. Add('begin');
  17137. Add(' v1:=@GetGlob;');
  17138. Add(' v1:[email protected];');
  17139. Add('end;');
  17140. Add('function TObject.Getter: integer;');
  17141. Add('var v2: jsvalue;');
  17142. Add('begin');
  17143. Add(' v2:=@Getter;');
  17144. Add(' v2:[email protected];');
  17145. Add(' v2:=@GetGlob;');
  17146. Add(' v2:[email protected];');
  17147. Add('end;');
  17148. Add('function GetIt(i: integer): integer;');
  17149. Add('var v3: jsvalue;');
  17150. Add('begin');
  17151. Add(' v3:=@GetIt;');
  17152. Add('end;');
  17153. Add('var');
  17154. Add(' V: JSValue;');
  17155. Add(' o: TObject;');
  17156. Add('begin');
  17157. Add(' v:=@GetIt;');
  17158. Add(' v:[email protected];');
  17159. Add(' v:[email protected];');
  17160. ConvertProgram;
  17161. CheckSource('TestJSValue_ProcType_Assign',
  17162. LinesToStr([ // statements
  17163. 'rtl.createClass($mod, "TObject", null, function () {',
  17164. ' this.$init = function () {',
  17165. ' };',
  17166. ' this.$final = function () {',
  17167. ' };',
  17168. ' this.GetGlob = function () {',
  17169. ' var Result = 0;',
  17170. ' var v1 = undefined;',
  17171. ' v1 = rtl.createCallback(this, "GetGlob");',
  17172. ' v1 = rtl.createCallback(this, "GetGlob");',
  17173. ' return Result;',
  17174. ' };',
  17175. ' this.Getter = function () {',
  17176. ' var Result = 0;',
  17177. ' var v2 = undefined;',
  17178. ' v2 = rtl.createCallback(this, "Getter");',
  17179. ' v2 = rtl.createCallback(this, "Getter");',
  17180. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  17181. ' v2 = rtl.createCallback(this.$class, "GetGlob");',
  17182. ' return Result;',
  17183. ' };',
  17184. '});',
  17185. 'this.GetIt = function (i) {',
  17186. ' var Result = 0;',
  17187. ' var v3 = undefined;',
  17188. ' v3 = $mod.GetIt;',
  17189. ' return Result;',
  17190. '};',
  17191. 'this.V = undefined;',
  17192. 'this.o = null;',
  17193. '']),
  17194. LinesToStr([ // $mod.$main
  17195. '$mod.V = $mod.GetIt;',
  17196. '$mod.V = rtl.createCallback($mod.o, "Getter");',
  17197. '$mod.V = rtl.createCallback($mod.o.$class, "GetGlob");',
  17198. '']));
  17199. end;
  17200. procedure TTestModule.TestJSValue_ProcType_Equal;
  17201. begin
  17202. StartProgram(false);
  17203. Add('type');
  17204. Add(' integer = longint;');
  17205. Add(' TObject = class');
  17206. Add(' class function GetGlob: integer;');
  17207. Add(' function Getter: integer;');
  17208. Add(' end;');
  17209. Add('class function TObject.GetGlob: integer;');
  17210. Add('var v1: jsvalue;');
  17211. Add('begin');
  17212. Add(' if v1=@GetGlob then;');
  17213. Add(' if [email protected] then ;');
  17214. Add('end;');
  17215. Add('function TObject.Getter: integer;');
  17216. Add('var v2: jsvalue;');
  17217. Add('begin');
  17218. Add(' if v2=@Getter then;');
  17219. Add(' if [email protected] then ;');
  17220. Add(' if v2=@GetGlob then;');
  17221. Add(' if [email protected] then;');
  17222. Add('end;');
  17223. Add('function GetIt(i: integer): integer;');
  17224. Add('var v3: jsvalue;');
  17225. Add('begin');
  17226. Add(' if v3=@GetIt then;');
  17227. Add('end;');
  17228. Add('var');
  17229. Add(' V: JSValue;');
  17230. Add(' o: TObject;');
  17231. Add('begin');
  17232. Add(' if v=@GetIt then;');
  17233. Add(' if [email protected] then;');
  17234. Add(' if [email protected] then;');
  17235. Add(' if @GetIt=v then;');
  17236. Add(' if @o.Getter=v then;');
  17237. Add(' if @o.GetGlob=v then;');
  17238. ConvertProgram;
  17239. CheckSource('TestJSValue_ProcType_Equal',
  17240. LinesToStr([ // statements
  17241. 'rtl.createClass($mod, "TObject", null, function () {',
  17242. ' this.$init = function () {',
  17243. ' };',
  17244. ' this.$final = function () {',
  17245. ' };',
  17246. ' this.GetGlob = function () {',
  17247. ' var Result = 0;',
  17248. ' var v1 = undefined;',
  17249. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  17250. ' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
  17251. ' return Result;',
  17252. ' };',
  17253. ' this.Getter = function () {',
  17254. ' var Result = 0;',
  17255. ' var v2 = undefined;',
  17256. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  17257. ' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
  17258. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  17259. ' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
  17260. ' return Result;',
  17261. ' };',
  17262. '});',
  17263. 'this.GetIt = function (i) {',
  17264. ' var Result = 0;',
  17265. ' var v3 = undefined;',
  17266. ' if (rtl.eqCallback(v3, $mod.GetIt)) ;',
  17267. ' return Result;',
  17268. '};',
  17269. 'this.V = undefined;',
  17270. 'this.o = null;',
  17271. '']),
  17272. LinesToStr([ // $mod.$main
  17273. 'if (rtl.eqCallback($mod.V, $mod.GetIt)) ;',
  17274. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o, "Getter"))) ;',
  17275. 'if (rtl.eqCallback($mod.V, rtl.createCallback($mod.o.$class, "GetGlob"))) ;',
  17276. 'if (rtl.eqCallback($mod.GetIt, $mod.V)) ;',
  17277. 'if (rtl.eqCallback(rtl.createCallback($mod.o, "Getter"), $mod.V)) ;',
  17278. 'if (rtl.eqCallback(rtl.createCallback($mod.o.$class, "GetGlob"), $mod.V)) ;',
  17279. '']));
  17280. end;
  17281. procedure TTestModule.TestJSValue_ProcType_Param;
  17282. begin
  17283. StartProgram(false);
  17284. Add([
  17285. 'type',
  17286. ' variant = jsvalue;',
  17287. ' TArrVariant = array of variant;',
  17288. ' TArrVar2 = TArrVariant;',
  17289. ' TFuncInt = function: longint;',
  17290. 'function GetIt: longint;',
  17291. 'begin',
  17292. 'end;',
  17293. 'procedure DoIt(p: jsvalue; Arr: TArrVar2);',
  17294. 'var v: variant;',
  17295. 'begin',
  17296. ' v:=arr[1];',
  17297. 'end;',
  17298. 'var s: string;',
  17299. 'begin',
  17300. ' DoIt(GetIt,[]);',
  17301. ' DoIt(@GetIt,[]);',
  17302. ' DoIt(1,[s,GetIt]);',
  17303. ' DoIt(1,[s,@GetIt]);',
  17304. '']);
  17305. ConvertProgram;
  17306. CheckSource('TestJSValue_ProcType_Param',
  17307. LinesToStr([ // statements
  17308. 'this.GetIt = function () {',
  17309. ' var Result = 0;',
  17310. ' return Result;',
  17311. '};',
  17312. 'this.DoIt = function (p, Arr) {',
  17313. ' var v = undefined;',
  17314. ' v = Arr[1];',
  17315. '};',
  17316. 'this.s = "";',
  17317. '']),
  17318. LinesToStr([ // $mod.$main
  17319. '$mod.DoIt($mod.GetIt(), []);',
  17320. '$mod.DoIt($mod.GetIt, []);',
  17321. '$mod.DoIt(1, [$mod.s, $mod.GetIt()]);',
  17322. '$mod.DoIt(1, [$mod.s, $mod.GetIt]);',
  17323. '']));
  17324. end;
  17325. procedure TTestModule.TestJSValue_AssignToPointerFail;
  17326. begin
  17327. StartProgram(false);
  17328. Add([
  17329. 'var',
  17330. ' v: JSValue;',
  17331. ' p: Pointer;',
  17332. 'begin',
  17333. ' p:=v;',
  17334. '']);
  17335. SetExpectedPasResolverError('Incompatible types: got "JSValue" expected "Pointer"',
  17336. nIncompatibleTypesGotExpected);
  17337. ConvertProgram;
  17338. end;
  17339. procedure TTestModule.TestJSValue_OverloadDouble;
  17340. begin
  17341. StartProgram(false);
  17342. Add([
  17343. 'type',
  17344. ' integer = longint;',
  17345. ' tdatetime = double;',
  17346. 'procedure DoIt(d: double); begin end;',
  17347. 'procedure DoIt(v: jsvalue); begin end;',
  17348. 'var',
  17349. ' d: double;',
  17350. ' dt: tdatetime;',
  17351. ' i: integer;',
  17352. ' b: byte;',
  17353. ' shi: shortint;',
  17354. ' w: word;',
  17355. ' smi: smallint;',
  17356. ' lw: longword;',
  17357. ' li: longint;',
  17358. ' ni: nativeint;',
  17359. ' nu: nativeuint;',
  17360. 'begin',
  17361. ' DoIt(d);',
  17362. ' DoIt(dt);',
  17363. ' DoIt(i);',
  17364. ' DoIt(b);',
  17365. ' DoIt(shi);',
  17366. ' DoIt(w);',
  17367. ' DoIt(smi);',
  17368. ' DoIt(lw);',
  17369. ' DoIt(li);',
  17370. ' DoIt(ni);',
  17371. ' DoIt(nu);',
  17372. '']);
  17373. ConvertProgram;
  17374. CheckSource('TestJSValue_OverloadDouble',
  17375. LinesToStr([ // statements
  17376. 'this.DoIt = function (d) {',
  17377. '};',
  17378. 'this.DoIt$1 = function (v) {',
  17379. '};',
  17380. 'this.d = 0.0;',
  17381. 'this.dt = 0.0;',
  17382. 'this.i = 0;',
  17383. 'this.b = 0;',
  17384. 'this.shi = 0;',
  17385. 'this.w = 0;',
  17386. 'this.smi = 0;',
  17387. 'this.lw = 0;',
  17388. 'this.li = 0;',
  17389. 'this.ni = 0;',
  17390. 'this.nu = 0;',
  17391. '']),
  17392. LinesToStr([ // $mod.$main
  17393. '$mod.DoIt($mod.d);',
  17394. '$mod.DoIt($mod.dt);',
  17395. '$mod.DoIt($mod.i);',
  17396. '$mod.DoIt($mod.b);',
  17397. '$mod.DoIt($mod.shi);',
  17398. '$mod.DoIt($mod.w);',
  17399. '$mod.DoIt($mod.smi);',
  17400. '$mod.DoIt($mod.lw);',
  17401. '$mod.DoIt($mod.li);',
  17402. '$mod.DoIt($mod.ni);',
  17403. '$mod.DoIt($mod.nu);',
  17404. '']));
  17405. end;
  17406. procedure TTestModule.TestJSValue_OverloadNativeInt;
  17407. begin
  17408. StartProgram(false);
  17409. Add([
  17410. 'type',
  17411. ' integer = longint;',
  17412. ' int53 = nativeint;',
  17413. ' tdatetime = double;',
  17414. 'procedure DoIt(n: nativeint); begin end;',
  17415. 'procedure DoIt(v: jsvalue); begin end;',
  17416. 'var',
  17417. ' d: double;',
  17418. ' dt: tdatetime;',
  17419. ' i: integer;',
  17420. ' b: byte;',
  17421. ' shi: shortint;',
  17422. ' w: word;',
  17423. ' smi: smallint;',
  17424. ' lw: longword;',
  17425. ' li: longint;',
  17426. ' ni: nativeint;',
  17427. ' nu: nativeuint;',
  17428. 'begin',
  17429. ' DoIt(d);',
  17430. ' DoIt(dt);',
  17431. ' DoIt(i);',
  17432. ' DoIt(b);',
  17433. ' DoIt(shi);',
  17434. ' DoIt(w);',
  17435. ' DoIt(smi);',
  17436. ' DoIt(lw);',
  17437. ' DoIt(li);',
  17438. ' DoIt(ni);',
  17439. ' DoIt(nu);',
  17440. '']);
  17441. ConvertProgram;
  17442. CheckSource('TestJSValue_OverloadNativeInt',
  17443. LinesToStr([ // statements
  17444. 'this.DoIt = function (n) {',
  17445. '};',
  17446. 'this.DoIt$1 = function (v) {',
  17447. '};',
  17448. 'this.d = 0.0;',
  17449. 'this.dt = 0.0;',
  17450. 'this.i = 0;',
  17451. 'this.b = 0;',
  17452. 'this.shi = 0;',
  17453. 'this.w = 0;',
  17454. 'this.smi = 0;',
  17455. 'this.lw = 0;',
  17456. 'this.li = 0;',
  17457. 'this.ni = 0;',
  17458. 'this.nu = 0;',
  17459. '']),
  17460. LinesToStr([ // $mod.$main
  17461. '$mod.DoIt$1($mod.d);',
  17462. '$mod.DoIt$1($mod.dt);',
  17463. '$mod.DoIt($mod.i);',
  17464. '$mod.DoIt($mod.b);',
  17465. '$mod.DoIt($mod.shi);',
  17466. '$mod.DoIt($mod.w);',
  17467. '$mod.DoIt($mod.smi);',
  17468. '$mod.DoIt($mod.lw);',
  17469. '$mod.DoIt($mod.li);',
  17470. '$mod.DoIt($mod.ni);',
  17471. '$mod.DoIt($mod.nu);',
  17472. '']));
  17473. end;
  17474. procedure TTestModule.TestJSValue_OverloadWord;
  17475. begin
  17476. StartProgram(false);
  17477. Add([
  17478. 'type',
  17479. ' integer = longint;',
  17480. ' int53 = nativeint;',
  17481. ' tdatetime = double;',
  17482. 'procedure DoIt(w: word); begin end;',
  17483. 'procedure DoIt(v: jsvalue); begin end;',
  17484. 'var',
  17485. ' d: double;',
  17486. ' dt: tdatetime;',
  17487. ' i: integer;',
  17488. ' b: byte;',
  17489. ' shi: shortint;',
  17490. ' w: word;',
  17491. ' smi: smallint;',
  17492. ' lw: longword;',
  17493. ' li: longint;',
  17494. ' ni: nativeint;',
  17495. ' nu: nativeuint;',
  17496. 'begin',
  17497. ' DoIt(d);',
  17498. ' DoIt(dt);',
  17499. ' DoIt(i);',
  17500. ' DoIt(b);',
  17501. ' DoIt(shi);',
  17502. ' DoIt(w);',
  17503. ' DoIt(smi);',
  17504. ' DoIt(lw);',
  17505. ' DoIt(li);',
  17506. ' DoIt(ni);',
  17507. ' DoIt(nu);',
  17508. '']);
  17509. ConvertProgram;
  17510. CheckSource('TestJSValue_OverloadWord',
  17511. LinesToStr([ // statements
  17512. 'this.DoIt = function (w) {',
  17513. '};',
  17514. 'this.DoIt$1 = function (v) {',
  17515. '};',
  17516. 'this.d = 0.0;',
  17517. 'this.dt = 0.0;',
  17518. 'this.i = 0;',
  17519. 'this.b = 0;',
  17520. 'this.shi = 0;',
  17521. 'this.w = 0;',
  17522. 'this.smi = 0;',
  17523. 'this.lw = 0;',
  17524. 'this.li = 0;',
  17525. 'this.ni = 0;',
  17526. 'this.nu = 0;',
  17527. '']),
  17528. LinesToStr([ // $mod.$main
  17529. '$mod.DoIt$1($mod.d);',
  17530. '$mod.DoIt$1($mod.dt);',
  17531. '$mod.DoIt$1($mod.i);',
  17532. '$mod.DoIt($mod.b);',
  17533. '$mod.DoIt($mod.shi);',
  17534. '$mod.DoIt($mod.w);',
  17535. '$mod.DoIt$1($mod.smi);',
  17536. '$mod.DoIt$1($mod.lw);',
  17537. '$mod.DoIt$1($mod.li);',
  17538. '$mod.DoIt$1($mod.ni);',
  17539. '$mod.DoIt$1($mod.nu);',
  17540. '']));
  17541. end;
  17542. procedure TTestModule.TestJSValue_OverloadString;
  17543. begin
  17544. StartProgram(false);
  17545. Add([
  17546. 'type',
  17547. ' uni = string;',
  17548. ' WChar = char;',
  17549. 'procedure DoIt(s: string); begin end;',
  17550. 'procedure DoIt(v: jsvalue); begin end;',
  17551. 'var',
  17552. ' s: string;',
  17553. ' c: char;',
  17554. ' u: uni;',
  17555. 'begin',
  17556. ' DoIt(s);',
  17557. ' DoIt(c);',
  17558. ' DoIt(u);',
  17559. '']);
  17560. ConvertProgram;
  17561. CheckSource('TestJSValue_OverloadString',
  17562. LinesToStr([ // statements
  17563. 'this.DoIt = function (s) {',
  17564. '};',
  17565. 'this.DoIt$1 = function (v) {',
  17566. '};',
  17567. 'this.s = "";',
  17568. 'this.c = "";',
  17569. 'this.u = "";',
  17570. '']),
  17571. LinesToStr([ // $mod.$main
  17572. '$mod.DoIt($mod.s);',
  17573. '$mod.DoIt($mod.c);',
  17574. '$mod.DoIt($mod.u);',
  17575. '']));
  17576. end;
  17577. procedure TTestModule.TestJSValue_OverloadChar;
  17578. begin
  17579. StartProgram(false);
  17580. Add([
  17581. 'type',
  17582. ' uni = string;',
  17583. ' WChar = char;',
  17584. 'procedure DoIt(c: char); begin end;',
  17585. 'procedure DoIt(v: jsvalue); begin end;',
  17586. 'var',
  17587. ' s: string;',
  17588. ' c: char;',
  17589. ' u: uni;',
  17590. 'begin',
  17591. ' DoIt(s);',
  17592. ' DoIt(c);',
  17593. ' DoIt(u);',
  17594. '']);
  17595. ConvertProgram;
  17596. CheckSource('TestJSValue_OverloadChar',
  17597. LinesToStr([ // statements
  17598. 'this.DoIt = function (c) {',
  17599. '};',
  17600. 'this.DoIt$1 = function (v) {',
  17601. '};',
  17602. 'this.s = "";',
  17603. 'this.c = "";',
  17604. 'this.u = "";',
  17605. '']),
  17606. LinesToStr([ // $mod.$main
  17607. '$mod.DoIt$1($mod.s);',
  17608. '$mod.DoIt($mod.c);',
  17609. '$mod.DoIt$1($mod.u);',
  17610. '']));
  17611. end;
  17612. procedure TTestModule.TestJSValue_OverloadPointer;
  17613. begin
  17614. StartProgram(false);
  17615. Add([
  17616. 'type',
  17617. ' TObject = class end;',
  17618. 'procedure DoIt(p: pointer); begin end;',
  17619. 'procedure DoIt(v: jsvalue); begin end;',
  17620. 'var',
  17621. ' o: TObject;',
  17622. 'begin',
  17623. ' DoIt(o);',
  17624. '']);
  17625. ConvertProgram;
  17626. CheckSource('TestJSValue_OverloadPointer',
  17627. LinesToStr([ // statements
  17628. 'rtl.createClass($mod, "TObject", null, function () {',
  17629. ' this.$init = function () {',
  17630. ' };',
  17631. ' this.$final = function () {',
  17632. ' };',
  17633. '});',
  17634. 'this.DoIt = function (p) {',
  17635. '};',
  17636. 'this.DoIt$1 = function (v) {',
  17637. '};',
  17638. 'this.o = null;',
  17639. '']),
  17640. LinesToStr([ // $mod.$main
  17641. '$mod.DoIt($mod.o);',
  17642. '']));
  17643. end;
  17644. procedure TTestModule.TestJSValue_ForIn;
  17645. begin
  17646. StartProgram(false);
  17647. Add([
  17648. 'var',
  17649. ' v: JSValue;',
  17650. ' key: string;',
  17651. 'begin',
  17652. ' for key in v do begin',
  17653. ' if key=''abc'' then ;',
  17654. ' end;',
  17655. '']);
  17656. ConvertProgram;
  17657. CheckSource('TestJSValue_ForIn',
  17658. LinesToStr([ // statements
  17659. 'this.v = undefined;',
  17660. 'this.key = "";',
  17661. '']),
  17662. LinesToStr([ // $mod.$main
  17663. 'for ($mod.key in $mod.v) {',
  17664. ' if ($mod.key === "abc") ;',
  17665. '};',
  17666. '']));
  17667. end;
  17668. procedure TTestModule.TestRTTI_ProcType;
  17669. begin
  17670. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17671. StartProgram(false);
  17672. Add('type');
  17673. Add(' TProcA = procedure;');
  17674. Add(' TMethodB = procedure of object;');
  17675. Add(' TProcC = procedure; varargs;');
  17676. Add(' TProcD = procedure(i: longint; const j: string; var c: char; out d: double);');
  17677. Add(' TProcE = function: nativeint;');
  17678. Add(' TProcF = function(const p: TProcA): nativeuint;');
  17679. Add('var p: pointer;');
  17680. Add('begin');
  17681. Add(' p:=typeinfo(tproca);');
  17682. ConvertProgram;
  17683. CheckSource('TestRTTI_ProcType',
  17684. LinesToStr([ // statements
  17685. '$mod.$rtti.$ProcVar("TProcA", {',
  17686. ' procsig: rtl.newTIProcSig(null)',
  17687. '});',
  17688. '$mod.$rtti.$MethodVar("TMethodB", {',
  17689. ' procsig: rtl.newTIProcSig(null),',
  17690. ' methodkind: 0',
  17691. '});',
  17692. '$mod.$rtti.$ProcVar("TProcC", {',
  17693. ' procsig: rtl.newTIProcSig(null, 2)',
  17694. '});',
  17695. '$mod.$rtti.$ProcVar("TProcD", {',
  17696. ' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
  17697. '});',
  17698. '$mod.$rtti.$ProcVar("TProcE", {',
  17699. ' procsig: rtl.newTIProcSig(null, rtl.nativeint)',
  17700. '});',
  17701. '$mod.$rtti.$ProcVar("TProcF", {',
  17702. ' procsig: rtl.newTIProcSig([["p", $mod.$rtti["TProcA"], 2]], rtl.nativeuint)',
  17703. '});',
  17704. 'this.p = null;',
  17705. '']),
  17706. LinesToStr([ // $mod.$main
  17707. '$mod.p = $mod.$rtti["TProcA"];',
  17708. '']));
  17709. end;
  17710. procedure TTestModule.TestRTTI_ProcType_ArgFromOtherUnit;
  17711. begin
  17712. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17713. AddModuleWithIntfImplSrc('unit2.pas',
  17714. LinesToStr([
  17715. 'type',
  17716. ' TObject = class end;'
  17717. ]),
  17718. '');
  17719. StartUnit(true);
  17720. Add('interface');
  17721. Add('uses unit2;');
  17722. Add('type');
  17723. Add(' TProcA = function(o: tobject): tobject;');
  17724. Add('implementation');
  17725. Add('type');
  17726. Add(' TProcB = function(o: tobject): tobject;');
  17727. Add('var p: Pointer;');
  17728. Add('initialization');
  17729. Add(' p:=typeinfo(tproca);');
  17730. Add(' p:=typeinfo(tprocb);');
  17731. ConvertUnit;
  17732. CheckSource('TestRTTI_ProcType_ArgFromOtherUnit',
  17733. LinesToStr([ // statements
  17734. 'var $impl = $mod.$impl;',
  17735. '$mod.$rtti.$ProcVar("TProcA", {',
  17736. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  17737. '});',
  17738. '']),
  17739. LinesToStr([ // this.$init
  17740. '$impl.p = $mod.$rtti["TProcA"];',
  17741. '$impl.p = $mod.$rtti["TProcB"];',
  17742. '']),
  17743. LinesToStr([ // implementation
  17744. '$mod.$rtti.$ProcVar("TProcB", {',
  17745. ' procsig: rtl.newTIProcSig([["o", pas.unit2.$rtti["TObject"]]], pas.unit2.$rtti["TObject"])',
  17746. '});',
  17747. '$impl.p = null;',
  17748. '']) );
  17749. end;
  17750. procedure TTestModule.TestRTTI_EnumAndSetType;
  17751. begin
  17752. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17753. StartProgram(false);
  17754. Add('type');
  17755. Add(' TFlag = (light,dark);');
  17756. Add(' TFlags = set of TFlag;');
  17757. Add(' TProc = function(f: TFlags): TFlag;');
  17758. Add('var p: pointer;');
  17759. Add('begin');
  17760. Add(' p:=typeinfo(tflag);');
  17761. Add(' p:=typeinfo(tflags);');
  17762. ConvertProgram;
  17763. CheckSource('TestRTTI_EnumAndType',
  17764. LinesToStr([ // statements
  17765. 'this.TFlag = {',
  17766. ' "0": "light",',
  17767. ' light: 0,',
  17768. ' "1": "dark",',
  17769. ' dark: 1',
  17770. '};',
  17771. '$mod.$rtti.$Enum("TFlag", {',
  17772. ' minvalue: 0,',
  17773. ' maxvalue: 1,',
  17774. ' ordtype: 1,',
  17775. ' enumtype: this.TFlag',
  17776. '});',
  17777. '$mod.$rtti.$Set("TFlags", {',
  17778. ' comptype: $mod.$rtti["TFlag"]',
  17779. '});',
  17780. '$mod.$rtti.$ProcVar("TProc", {',
  17781. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TFlags"]]], $mod.$rtti["TFlag"])',
  17782. '});',
  17783. 'this.p = null;',
  17784. '']),
  17785. LinesToStr([ // $mod.$main
  17786. '$mod.p = $mod.$rtti["TFlag"];',
  17787. '$mod.p = $mod.$rtti["TFlags"];',
  17788. '']));
  17789. end;
  17790. procedure TTestModule.TestRTTI_EnumRange;
  17791. begin
  17792. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17793. StartProgram(false);
  17794. Add([
  17795. 'type',
  17796. ' TCol = (red,green,blue);',
  17797. ' TColRg = green..blue;',
  17798. ' TSetOfColRg = set of TColRg;',
  17799. 'var p: pointer;',
  17800. 'begin',
  17801. ' p:=typeinfo(tcolrg);',
  17802. ' p:=typeinfo(tsetofcolrg);',
  17803. '']);
  17804. ConvertProgram;
  17805. end;
  17806. procedure TTestModule.TestRTTI_AnonymousEnumType;
  17807. begin
  17808. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17809. StartProgram(false);
  17810. Add('type');
  17811. Add(' TFlags = set of (red, green);');
  17812. Add('var');
  17813. Add(' f: TFlags;');
  17814. Add('begin');
  17815. Add(' Include(f,red);');
  17816. ConvertProgram;
  17817. CheckSource('TestRTTI_AnonymousEnumType',
  17818. LinesToStr([ // statements
  17819. 'this.TFlags$a = {',
  17820. ' "0": "red",',
  17821. ' red: 0,',
  17822. ' "1": "green",',
  17823. ' green: 1',
  17824. '};',
  17825. '$mod.$rtti.$Enum("TFlags$a", {',
  17826. ' minvalue: 0,',
  17827. ' maxvalue: 1,',
  17828. ' ordtype: 1,',
  17829. ' enumtype: this.TFlags$a',
  17830. '});',
  17831. '$mod.$rtti.$Set("TFlags", {',
  17832. ' comptype: $mod.$rtti["TFlags$a"]',
  17833. '});',
  17834. 'this.f = {};',
  17835. '']),
  17836. LinesToStr([
  17837. '$mod.f = rtl.includeSet($mod.f, $mod.TFlags$a.red);',
  17838. '']));
  17839. end;
  17840. procedure TTestModule.TestRTTI_StaticArray;
  17841. begin
  17842. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17843. StartProgram(false);
  17844. Add('type');
  17845. Add(' TFlag = (light,dark);');
  17846. Add(' TFlagNames = array[TFlag] of string;');
  17847. Add(' TBoolNames = array[boolean] of string;');
  17848. Add(' TByteArray = array[1..32768] of byte;');
  17849. Add(' TProc = function(f: TBoolNames): TFlagNames;');
  17850. Add('var p: pointer;');
  17851. Add('begin');
  17852. Add(' p:=typeinfo(TFlagNames);');
  17853. Add(' p:=typeinfo(TBoolNames);');
  17854. ConvertProgram;
  17855. CheckSource('TestRTTI_StaticArray',
  17856. LinesToStr([ // statements
  17857. 'this.TFlag = {',
  17858. ' "0": "light",',
  17859. ' light: 0,',
  17860. ' "1": "dark",',
  17861. ' dark: 1',
  17862. '};',
  17863. '$mod.$rtti.$Enum("TFlag", {',
  17864. ' minvalue: 0,',
  17865. ' maxvalue: 1,',
  17866. ' ordtype: 1,',
  17867. ' enumtype: this.TFlag',
  17868. '});',
  17869. '$mod.$rtti.$StaticArray("TFlagNames", {',
  17870. ' dims: [2],',
  17871. ' eltype: rtl.string',
  17872. '});',
  17873. '$mod.$rtti.$StaticArray("TBoolNames", {',
  17874. ' dims: [2],',
  17875. ' eltype: rtl.string',
  17876. '});',
  17877. '$mod.$rtti.$StaticArray("TByteArray", {',
  17878. ' dims: [32768],',
  17879. ' eltype: rtl.byte',
  17880. '});',
  17881. '$mod.$rtti.$ProcVar("TProc", {',
  17882. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TBoolNames"]]], $mod.$rtti["TFlagNames"])',
  17883. '});',
  17884. 'this.p = null;',
  17885. '']),
  17886. LinesToStr([ // $mod.$main
  17887. '$mod.p = $mod.$rtti["TFlagNames"];',
  17888. '$mod.p = $mod.$rtti["TBoolNames"];',
  17889. '']));
  17890. end;
  17891. procedure TTestModule.TestRTTI_DynArray;
  17892. begin
  17893. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17894. StartProgram(false);
  17895. Add('type');
  17896. Add(' TArrStr = array of string;');
  17897. Add(' TArr2Dim = array of tarrstr;');
  17898. Add(' TProc = function(f: TArrStr): TArr2Dim;');
  17899. Add('var p: pointer;');
  17900. Add('begin');
  17901. Add(' p:=typeinfo(tarrstr);');
  17902. Add(' p:=typeinfo(tarr2dim);');
  17903. ConvertProgram;
  17904. CheckSource('TestRTTI_DynArray',
  17905. LinesToStr([ // statements
  17906. '$mod.$rtti.$DynArray("TArrStr", {',
  17907. ' eltype: rtl.string',
  17908. '});',
  17909. '$mod.$rtti.$DynArray("TArr2Dim", {',
  17910. ' eltype: $mod.$rtti["TArrStr"]',
  17911. '});',
  17912. '$mod.$rtti.$ProcVar("TProc", {',
  17913. ' procsig: rtl.newTIProcSig([["f", $mod.$rtti["TArrStr"]]], $mod.$rtti["TArr2Dim"])',
  17914. '});',
  17915. 'this.p = null;',
  17916. '']),
  17917. LinesToStr([ // $mod.$main
  17918. '$mod.p = $mod.$rtti["TArrStr"];',
  17919. '$mod.p = $mod.$rtti["TArr2Dim"];',
  17920. '']));
  17921. end;
  17922. procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
  17923. begin
  17924. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17925. StartProgram(false);
  17926. Add('type');
  17927. Add(' TArr = array of array of longint;');
  17928. Add('var a: TArr;');
  17929. Add('begin');
  17930. ConvertProgram;
  17931. CheckSource('TestRTTI_ArrayNestedAnonymous',
  17932. LinesToStr([ // statements
  17933. '$mod.$rtti.$DynArray("TArr$a", {',
  17934. ' eltype: rtl.longint',
  17935. '});',
  17936. '$mod.$rtti.$DynArray("TArr", {',
  17937. ' eltype: $mod.$rtti["TArr$a"]',
  17938. '});',
  17939. 'this.a = [];',
  17940. '']),
  17941. LinesToStr([ // $mod.$main
  17942. ]));
  17943. end;
  17944. procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
  17945. begin
  17946. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17947. StartProgram(false);
  17948. Add('type');
  17949. Add(' TObject = class');
  17950. Add(' published');
  17951. Add(' procedure Proc; virtual; abstract;');
  17952. Add(' procedure Proc(Sender: tobject); virtual; abstract;');
  17953. Add(' end;');
  17954. Add('begin');
  17955. SetExpectedPasResolverError('Duplicate identifier "Proc" at test1.pp(6,19)',
  17956. nDuplicateIdentifier);
  17957. ConvertProgram;
  17958. end;
  17959. procedure TTestModule.TestRTTI_PublishedMethodExternalFail;
  17960. begin
  17961. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17962. StartProgram(false);
  17963. Add('type');
  17964. Add(' TObject = class');
  17965. Add(' published');
  17966. Add(' procedure Proc; external name ''foo'';');
  17967. Add(' end;');
  17968. Add('begin');
  17969. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  17970. nPublishedNameMustMatchExternal);
  17971. ConvertProgram;
  17972. end;
  17973. procedure TTestModule.TestRTTI_PublishedClassPropertyFail;
  17974. begin
  17975. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17976. StartProgram(false);
  17977. Add('type');
  17978. Add(' TObject = class');
  17979. Add(' class var FA: longint;');
  17980. Add(' published');
  17981. Add(' class property A: longint read FA;');
  17982. Add(' end;');
  17983. Add('begin');
  17984. SetExpectedPasResolverError('Invalid published property modifier "class"',
  17985. nInvalidXModifierY);
  17986. ConvertProgram;
  17987. end;
  17988. procedure TTestModule.TestRTTI_PublishedClassFieldFail;
  17989. begin
  17990. Converter.Options:=Converter.Options-[coNoTypeInfo];
  17991. StartProgram(false);
  17992. Add('type');
  17993. Add(' TObject = class');
  17994. Add(' published');
  17995. Add(' class var FA: longint;');
  17996. Add(' end;');
  17997. Add('begin');
  17998. SetExpectedPasResolverError(sSymbolCannotBePublished,
  17999. nSymbolCannotBePublished);
  18000. ConvertProgram;
  18001. end;
  18002. procedure TTestModule.TestRTTI_PublishedFieldExternalFail;
  18003. begin
  18004. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18005. StartProgram(false);
  18006. Add('{$modeswitch externalclass}');
  18007. Add('type');
  18008. Add(' TObject = class');
  18009. Add(' published');
  18010. Add(' V: longint; external name ''foo'';');
  18011. Add(' end;');
  18012. Add('begin');
  18013. SetExpectedPasResolverError(sPublishedNameMustMatchExternal,
  18014. nPublishedNameMustMatchExternal);
  18015. ConvertProgram;
  18016. end;
  18017. procedure TTestModule.TestRTTI_IndexModifier;
  18018. begin
  18019. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18020. StartProgram(false);
  18021. Add([
  18022. 'type',
  18023. ' TEnum = (red, blue);',
  18024. ' TObject = class',
  18025. ' FB: boolean;',
  18026. ' procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
  18027. ' function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
  18028. ' procedure SetBoolBool(Index: boolean; b: boolean); virtual; abstract;',
  18029. ' function GetEnumBool(Index: TEnum): boolean; virtual; abstract;',
  18030. ' function GetStrIntBool(A: String; I: longint): boolean; virtual; abstract;',
  18031. ' procedure SetStrIntBool(A: String; I: longint; b: boolean); virtual; abstract;',
  18032. ' published',
  18033. ' property B1: boolean index 1 read FB write SetIntBool;',
  18034. ' property B2: boolean index TEnum.blue read GetEnumBool write FB;',
  18035. ' property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
  18036. ' end;',
  18037. 'begin']);
  18038. ConvertProgram;
  18039. CheckSource('TestRTTI_IndexModifier',
  18040. LinesToStr([ // statements
  18041. 'this.TEnum = {',
  18042. ' "0": "red",',
  18043. ' red: 0,',
  18044. ' "1": "blue",',
  18045. ' blue: 1',
  18046. '};',
  18047. '$mod.$rtti.$Enum("TEnum", {',
  18048. ' minvalue: 0,',
  18049. ' maxvalue: 1,',
  18050. ' ordtype: 1,',
  18051. ' enumtype: this.TEnum',
  18052. '});',
  18053. 'rtl.createClass($mod, "TObject", null, function () {',
  18054. ' this.$init = function () {',
  18055. ' this.FB = false;',
  18056. ' };',
  18057. ' this.$final = function () {',
  18058. ' };',
  18059. ' var $r = this.$rtti;',
  18060. ' $r.addProperty(',
  18061. ' "B1",',
  18062. ' 18,',
  18063. ' rtl.boolean,',
  18064. ' "FB",',
  18065. ' "SetIntBool",',
  18066. ' {',
  18067. ' index: 1',
  18068. ' }',
  18069. ' );',
  18070. ' $r.addProperty(',
  18071. ' "B2",',
  18072. ' 17,',
  18073. ' rtl.boolean,',
  18074. ' "GetEnumBool",',
  18075. ' "FB",',
  18076. ' {',
  18077. ' index: $mod.TEnum.blue',
  18078. ' }',
  18079. ' );',
  18080. ' $r.addProperty(',
  18081. ' "I1",',
  18082. ' 19,',
  18083. ' rtl.boolean,',
  18084. ' "GetStrIntBool",',
  18085. ' "SetStrIntBool",',
  18086. ' {',
  18087. ' index: 2',
  18088. ' }',
  18089. ' );',
  18090. '});',
  18091. '']),
  18092. LinesToStr([ // $mod.$main
  18093. '']));
  18094. end;
  18095. procedure TTestModule.TestRTTI_StoredModifier;
  18096. begin
  18097. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18098. StartProgram(false);
  18099. Add([
  18100. 'const',
  18101. ' ConstB = true;',
  18102. 'type',
  18103. ' TObject = class',
  18104. ' private',
  18105. ' FB: boolean;',
  18106. ' function IsBStored: boolean; virtual; abstract;',
  18107. ' published',
  18108. ' property BoolA: boolean read FB stored true;',
  18109. ' property BoolB: boolean read FB stored false;',
  18110. ' property BoolC: boolean read FB stored FB;',
  18111. ' property BoolD: boolean read FB stored ConstB;',
  18112. ' property BoolE: boolean read FB stored IsBStored;',
  18113. ' end;',
  18114. 'begin']);
  18115. ConvertProgram;
  18116. CheckSource('TestRTTI_StoredModifier',
  18117. LinesToStr([ // statements
  18118. 'this.ConstB = true;',
  18119. 'rtl.createClass($mod, "TObject", null, function () {',
  18120. ' this.$init = function () {',
  18121. ' this.FB = false;',
  18122. ' };',
  18123. ' this.$final = function () {',
  18124. ' };',
  18125. ' var $r = this.$rtti;',
  18126. ' $r.addProperty("BoolA", 0, rtl.boolean, "FB", "");',
  18127. ' $r.addProperty("BoolB", 4, rtl.boolean, "FB", "");',
  18128. ' $r.addProperty(',
  18129. ' "BoolC",',
  18130. ' 8,',
  18131. ' rtl.boolean,',
  18132. ' "FB",',
  18133. ' "",',
  18134. ' {',
  18135. ' stored: "FB"',
  18136. ' }',
  18137. ' );',
  18138. ' $r.addProperty("BoolD", 0, rtl.boolean, "FB", "");',
  18139. ' $r.addProperty(',
  18140. ' "BoolE",',
  18141. ' 12,',
  18142. ' rtl.boolean,',
  18143. ' "FB",',
  18144. ' "",',
  18145. ' {',
  18146. ' stored: "IsBStored"',
  18147. ' }',
  18148. ' );',
  18149. '});',
  18150. '']),
  18151. LinesToStr([ // $mod.$main
  18152. '']));
  18153. end;
  18154. procedure TTestModule.TestRTTI_DefaultValue;
  18155. begin
  18156. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18157. StartProgram(false);
  18158. Add([
  18159. 'type',
  18160. ' TEnum = (red, blue);',
  18161. 'const',
  18162. ' CB = true or false;',
  18163. ' CI = 1+2;',
  18164. 'type',
  18165. ' TObject = class',
  18166. ' FB: boolean;',
  18167. ' FI: longint;',
  18168. ' FE: TEnum;',
  18169. ' published',
  18170. ' property B1: boolean read FB default true;',
  18171. ' property B2: boolean read FB default CB;',
  18172. ' property B3: boolean read FB default test1.cb;',
  18173. ' property I1: longint read FI default 2;',
  18174. ' property I2: longint read FI default CI;',
  18175. ' property E1: TEnum read FE default red;',
  18176. ' property E2: TEnum read FE default TEnum.blue;',
  18177. ' end;',
  18178. 'begin']);
  18179. ConvertProgram;
  18180. CheckSource('TestRTTI_DefaultValue',
  18181. LinesToStr([ // statements
  18182. 'this.TEnum = {',
  18183. ' "0": "red",',
  18184. ' red: 0,',
  18185. ' "1": "blue",',
  18186. ' blue: 1',
  18187. '};',
  18188. '$mod.$rtti.$Enum("TEnum", {',
  18189. ' minvalue: 0,',
  18190. ' maxvalue: 1,',
  18191. ' ordtype: 1,',
  18192. ' enumtype: this.TEnum',
  18193. '});',
  18194. 'this.CB = true || false;',
  18195. 'this.CI = 1 + 2;',
  18196. 'rtl.createClass($mod, "TObject", null, function () {',
  18197. ' this.$init = function () {',
  18198. ' this.FB = false;',
  18199. ' this.FI = 0;',
  18200. ' this.FE = 0;',
  18201. ' };',
  18202. ' this.$final = function () {',
  18203. ' };',
  18204. ' var $r = this.$rtti;',
  18205. ' $r.addProperty(',
  18206. ' "B1",',
  18207. ' 0,',
  18208. ' rtl.boolean,',
  18209. ' "FB",',
  18210. ' "",',
  18211. ' {',
  18212. ' Default: true',
  18213. ' }',
  18214. ' );',
  18215. ' $r.addProperty(',
  18216. ' "B2",',
  18217. ' 0,',
  18218. ' rtl.boolean,',
  18219. ' "FB",',
  18220. ' "",',
  18221. ' {',
  18222. ' Default: true',
  18223. ' }',
  18224. ' );',
  18225. ' $r.addProperty(',
  18226. ' "B3",',
  18227. ' 0,',
  18228. ' rtl.boolean,',
  18229. ' "FB",',
  18230. ' "",',
  18231. ' {',
  18232. ' Default: true',
  18233. ' }',
  18234. ' );',
  18235. ' $r.addProperty(',
  18236. ' "I1",',
  18237. ' 0,',
  18238. ' rtl.longint,',
  18239. ' "FI",',
  18240. ' "",',
  18241. ' {',
  18242. ' Default: 2',
  18243. ' }',
  18244. ' );',
  18245. ' $r.addProperty(',
  18246. ' "I2",',
  18247. ' 0,',
  18248. ' rtl.longint,',
  18249. ' "FI",',
  18250. ' "",',
  18251. ' {',
  18252. ' Default: 3',
  18253. ' }',
  18254. ' );',
  18255. ' $r.addProperty(',
  18256. ' "E1",',
  18257. ' 0,',
  18258. ' $mod.$rtti["TEnum"],',
  18259. ' "FE",',
  18260. ' "",',
  18261. ' {',
  18262. ' Default: $mod.TEnum.red',
  18263. ' }',
  18264. ' );',
  18265. ' $r.addProperty(',
  18266. ' "E2",',
  18267. ' 0,',
  18268. ' $mod.$rtti["TEnum"],',
  18269. ' "FE",',
  18270. ' "",',
  18271. ' {',
  18272. ' Default: $mod.TEnum.blue',
  18273. ' }',
  18274. ' );',
  18275. '});',
  18276. '']),
  18277. LinesToStr([ // $mod.$main
  18278. '']));
  18279. end;
  18280. procedure TTestModule.TestRTTI_DefaultValueSet;
  18281. begin
  18282. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18283. StartProgram(false);
  18284. Add([
  18285. 'type',
  18286. ' TEnum = (red, blue);',
  18287. ' TSet = set of TEnum;',
  18288. 'const',
  18289. ' CSet = [red,blue];',
  18290. 'type',
  18291. ' TObject = class',
  18292. ' FSet: TSet;',
  18293. ' published',
  18294. ' property Set1: TSet read FSet default [];',
  18295. ' property Set2: TSet read FSet default [red];',
  18296. ' property Set3: TSet read FSet default [red,blue];',
  18297. ' property Set4: TSet read FSet default CSet;',
  18298. ' end;',
  18299. 'begin']);
  18300. ConvertProgram;
  18301. CheckSource('TestRTTI_DefaultValueSet',
  18302. LinesToStr([ // statements
  18303. 'this.TEnum = {',
  18304. ' "0": "red",',
  18305. ' red: 0,',
  18306. ' "1": "blue",',
  18307. ' blue: 1',
  18308. '};',
  18309. '$mod.$rtti.$Enum("TEnum", {',
  18310. ' minvalue: 0,',
  18311. ' maxvalue: 1,',
  18312. ' ordtype: 1,',
  18313. ' enumtype: this.TEnum',
  18314. '});',
  18315. '$mod.$rtti.$Set("TSet", {',
  18316. ' comptype: $mod.$rtti["TEnum"]',
  18317. '});',
  18318. 'this.CSet = rtl.createSet($mod.TEnum.red, $mod.TEnum.blue);',
  18319. 'rtl.createClass($mod, "TObject", null, function () {',
  18320. ' this.$init = function () {',
  18321. ' this.FSet = {};',
  18322. ' };',
  18323. ' this.$final = function () {',
  18324. ' this.FSet = undefined;',
  18325. ' };',
  18326. ' var $r = this.$rtti;',
  18327. ' $r.addProperty(',
  18328. ' "Set1",',
  18329. ' 0,',
  18330. ' $mod.$rtti["TSet"],',
  18331. ' "FSet",',
  18332. ' "",',
  18333. ' {',
  18334. ' Default: {}',
  18335. ' }',
  18336. ' );',
  18337. ' $r.addProperty(',
  18338. ' "Set2",',
  18339. ' 0,',
  18340. ' $mod.$rtti["TSet"],',
  18341. ' "FSet",',
  18342. ' "",',
  18343. ' {',
  18344. ' Default: rtl.createSet($mod.TEnum.red)',
  18345. ' }',
  18346. ' );',
  18347. ' $r.addProperty(',
  18348. ' "Set3",',
  18349. ' 0,',
  18350. ' $mod.$rtti["TSet"],',
  18351. ' "FSet",',
  18352. ' "",',
  18353. ' {',
  18354. ' Default: rtl.createSet($mod.TEnum.red, $mod.TEnum.blue)',
  18355. ' }',
  18356. ' );',
  18357. ' $r.addProperty(',
  18358. ' "Set4",',
  18359. ' 0,',
  18360. ' $mod.$rtti["TSet"],',
  18361. ' "FSet",',
  18362. ' "",',
  18363. ' {',
  18364. ' Default: $mod.CSet',
  18365. ' }',
  18366. ' );',
  18367. '});',
  18368. '']),
  18369. LinesToStr([ // $mod.$main
  18370. '']));
  18371. end;
  18372. procedure TTestModule.TestRTTI_DefaultValueRangeType;
  18373. begin
  18374. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18375. StartProgram(false);
  18376. Add([
  18377. 'type',
  18378. ' TRg = -1..1;',
  18379. 'const',
  18380. ' l = low(TRg);',
  18381. ' h = high(TRg);',
  18382. 'type',
  18383. ' TObject = class',
  18384. ' FV: TRg;',
  18385. ' published',
  18386. ' property V1: TRg read FV default -1;',
  18387. ' end;',
  18388. 'begin']);
  18389. ConvertProgram;
  18390. CheckSource('TestRTTI_DefaultValueRangeType',
  18391. LinesToStr([ // statements
  18392. '$mod.$rtti.$Int("TRg", {',
  18393. ' minvalue: -1,',
  18394. ' maxvalue: 1,',
  18395. ' ordtype: 0',
  18396. '});',
  18397. 'this.l = -1;',
  18398. 'this.h = 1;',
  18399. 'rtl.createClass($mod, "TObject", null, function () {',
  18400. ' this.$init = function () {',
  18401. ' this.FV = -1;',
  18402. ' };',
  18403. ' this.$final = function () {',
  18404. ' };',
  18405. ' var $r = this.$rtti;',
  18406. ' $r.addProperty(',
  18407. ' "V1",',
  18408. ' 0,',
  18409. ' $mod.$rtti["TRg"],',
  18410. ' "FV",',
  18411. ' "",',
  18412. ' {',
  18413. ' Default: -1',
  18414. ' }',
  18415. ' );',
  18416. '});',
  18417. '']),
  18418. LinesToStr([ // $mod.$main
  18419. '']));
  18420. end;
  18421. procedure TTestModule.TestRTTI_DefaultValueInherit;
  18422. begin
  18423. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18424. StartProgram(false);
  18425. Add([
  18426. 'type',
  18427. ' TObject = class',
  18428. ' FA, FB: byte;',
  18429. ' property A: byte read FA default 1;',
  18430. ' property B: byte read FB default 2;',
  18431. ' end;',
  18432. ' TBird = class',
  18433. ' published',
  18434. ' property A;',
  18435. ' property B nodefault;',
  18436. ' end;',
  18437. 'begin']);
  18438. ConvertProgram;
  18439. CheckSource('TestRTTI_DefaultValueInherit',
  18440. LinesToStr([ // statements
  18441. 'rtl.createClass($mod, "TObject", null, function () {',
  18442. ' this.$init = function () {',
  18443. ' this.FA = 0;',
  18444. ' this.FB = 0;',
  18445. ' };',
  18446. ' this.$final = function () {',
  18447. ' };',
  18448. '});',
  18449. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  18450. ' var $r = this.$rtti;',
  18451. ' $r.addProperty(',
  18452. ' "A",',
  18453. ' 0,',
  18454. ' rtl.byte,',
  18455. ' "FA",',
  18456. ' "",',
  18457. ' {',
  18458. ' Default: 1',
  18459. ' }',
  18460. ' );',
  18461. ' $r.addProperty("B", 0, rtl.byte, "FB", "");',
  18462. '});',
  18463. '']),
  18464. LinesToStr([ // $mod.$main
  18465. '']));
  18466. end;
  18467. procedure TTestModule.TestRTTI_Class_Field;
  18468. begin
  18469. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18470. StartProgram(false);
  18471. Add('{$modeswitch externalclass}');
  18472. Add('type');
  18473. Add(' TObject = class');
  18474. Add(' private');
  18475. Add(' FPropA: string;');
  18476. Add(' published');
  18477. Add(' VarLI: longint;');
  18478. Add(' VarC: char;');
  18479. Add(' VarS: string;');
  18480. Add(' VarD: double;');
  18481. Add(' VarB: boolean;');
  18482. Add(' VarLW: longword;');
  18483. Add(' VarSmI: smallint;');
  18484. Add(' VarW: word;');
  18485. Add(' VarShI: shortint;');
  18486. Add(' VarBy: byte;');
  18487. Add(' VarExt: longint external name ''VarExt'';');
  18488. Add(' end;');
  18489. Add('var p: pointer;');
  18490. Add(' Obj: tobject;');
  18491. Add('begin');
  18492. Add(' p:=typeinfo(tobject);');
  18493. Add(' p:=typeinfo(p);');
  18494. Add(' p:=typeinfo(obj);');
  18495. ConvertProgram;
  18496. CheckSource('TestRTTI_Class_Field',
  18497. LinesToStr([ // statements
  18498. 'rtl.createClass($mod, "TObject", null, function () {',
  18499. ' this.$init = function () {',
  18500. ' this.FPropA = "";',
  18501. ' this.VarLI = 0;',
  18502. ' this.VarC = "";',
  18503. ' this.VarS = "";',
  18504. ' this.VarD = 0.0;',
  18505. ' this.VarB = false;',
  18506. ' this.VarLW = 0;',
  18507. ' this.VarSmI = 0;',
  18508. ' this.VarW = 0;',
  18509. ' this.VarShI = 0;',
  18510. ' this.VarBy = 0;',
  18511. ' };',
  18512. ' this.$final = function () {',
  18513. ' };',
  18514. ' var $r = this.$rtti;',
  18515. ' $r.addField("VarLI", rtl.longint);',
  18516. ' $r.addField("VarC", rtl.char);',
  18517. ' $r.addField("VarS", rtl.string);',
  18518. ' $r.addField("VarD", rtl.double);',
  18519. ' $r.addField("VarB", rtl.boolean);',
  18520. ' $r.addField("VarLW", rtl.longword);',
  18521. ' $r.addField("VarSmI", rtl.smallint);',
  18522. ' $r.addField("VarW", rtl.word);',
  18523. ' $r.addField("VarShI", rtl.shortint);',
  18524. ' $r.addField("VarBy", rtl.byte);',
  18525. ' $r.addField("VarExt", rtl.longint);',
  18526. '});',
  18527. 'this.p = null;',
  18528. 'this.Obj = null;',
  18529. '']),
  18530. LinesToStr([ // $mod.$main
  18531. '$mod.p = $mod.$rtti["TObject"];',
  18532. '$mod.p = rtl.pointer;',
  18533. '$mod.p = $mod.Obj.$rtti;',
  18534. '']));
  18535. end;
  18536. procedure TTestModule.TestRTTI_Class_Method;
  18537. begin
  18538. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18539. StartProgram(false);
  18540. Add('type');
  18541. Add(' TObject = class');
  18542. Add(' private');
  18543. Add(' procedure Internal; external name ''$intern'';');
  18544. Add(' published');
  18545. Add(' procedure Click; virtual; abstract;');
  18546. Add(' procedure Notify(Sender: TObject); virtual; abstract;');
  18547. Add(' function GetNotify: boolean; external name ''GetNotify'';');
  18548. Add(' procedure Println(a,b: longint); varargs; virtual; abstract;');
  18549. Add(' end;');
  18550. Add('begin');
  18551. ConvertProgram;
  18552. CheckSource('TestRTTI_Class_Method',
  18553. LinesToStr([ // statements
  18554. 'rtl.createClass($mod, "TObject", null, function () {',
  18555. ' this.$init = function () {',
  18556. ' };',
  18557. ' this.$final = function () {',
  18558. ' };',
  18559. ' var $r = this.$rtti;',
  18560. ' $r.addMethod("Click", 0, null);',
  18561. ' $r.addMethod("Notify", 0, [["Sender", $r]]);',
  18562. ' $r.addMethod("GetNotify", 1, null, rtl.boolean,{flags: 4});',
  18563. ' $r.addMethod("Println", 0, [["a", rtl.longint], ["b", rtl.longint]], null, {',
  18564. ' flags: 2',
  18565. ' });',
  18566. '});',
  18567. '']),
  18568. LinesToStr([ // $mod.$main
  18569. '']));
  18570. end;
  18571. procedure TTestModule.TestRTTI_Class_MethodArgFlags;
  18572. begin
  18573. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18574. StartProgram(false);
  18575. Add('type');
  18576. Add(' TObject = class');
  18577. Add(' published');
  18578. Add(' procedure OpenArray(const Args: array of string); virtual; abstract;');
  18579. Add(' procedure ByRef(var Value: longint; out Item: longint); virtual; abstract;');
  18580. Add(' procedure Untyped(var Value; out Item); virtual; abstract;');
  18581. Add(' end;');
  18582. Add('begin');
  18583. ConvertProgram;
  18584. CheckSource('TestRTTI_Class_MethodOpenArray',
  18585. LinesToStr([ // statements
  18586. 'rtl.createClass($mod, "TObject", null, function () {',
  18587. ' this.$init = function () {',
  18588. ' };',
  18589. ' this.$final = function () {',
  18590. ' };',
  18591. ' var $r = this.$rtti;',
  18592. '$r.addMethod("OpenArray", 0, [["Args", rtl.string, 10]]);',
  18593. '$r.addMethod("ByRef", 0, [["Value", rtl.longint, 1], ["Item", rtl.longint, 4]]);',
  18594. '$r.addMethod("Untyped", 0, [["Value", null, 1], ["Item", null, 4]]);',
  18595. '});',
  18596. '']),
  18597. LinesToStr([ // $mod.$main
  18598. '']));
  18599. end;
  18600. procedure TTestModule.TestRTTI_Class_Property;
  18601. begin
  18602. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18603. StartProgram(false);
  18604. Add('{$modeswitch externalclass}');
  18605. Add('type');
  18606. Add(' TObject = class');
  18607. Add(' private');
  18608. Add(' FColor: longint;');
  18609. Add(' FColorStored: boolean;');
  18610. Add(' procedure SetColor(Value: longint); virtual; abstract;');
  18611. Add(' function GetColor: longint; virtual; abstract;');
  18612. Add(' function GetColorStored: boolean; virtual; abstract;');
  18613. Add(' FExtSize: longint external name ''$extSize'';');
  18614. Add(' FExtSizeStored: boolean external name ''$extSizeStored'';');
  18615. Add(' procedure SetExtSize(Value: longint); external name ''$setSize'';');
  18616. Add(' function GetExtSize: longint; external name ''$getSize'';');
  18617. Add(' function GetExtSizeStored: boolean; external name ''$getExtSizeStored'';');
  18618. Add(' published');
  18619. Add(' property ColorA: longint read FColor;');
  18620. Add(' property ColorB: longint write FColor;');
  18621. Add(' property ColorC: longint read GetColor write SetColor;');
  18622. Add(' property ColorD: longint read FColor write FColor stored FColorStored;');
  18623. Add(' property ExtSizeA: longint read FExtSize write FExtSize;');
  18624. Add(' property ExtSizeB: longint read GetExtSize write SetExtSize stored FExtSizeStored;');
  18625. Add(' property ExtSizeC: longint read FExtSize write FExtSize stored GetExtSizeStored;');
  18626. Add(' end;');
  18627. Add('begin');
  18628. ConvertProgram;
  18629. CheckSource('TestRTTI_Class_Property',
  18630. LinesToStr([ // statements
  18631. 'rtl.createClass($mod, "TObject", null, function () {',
  18632. ' this.$init = function () {',
  18633. ' this.FColor = 0;',
  18634. ' this.FColorStored = false;',
  18635. ' };',
  18636. ' this.$final = function () {',
  18637. ' };',
  18638. ' var $r = this.$rtti;',
  18639. ' $r.addProperty("ColorA", 0, rtl.longint, "FColor", "");',
  18640. ' $r.addProperty("ColorB", 0, rtl.longint, "", "FColor");',
  18641. ' $r.addProperty("ColorC", 3, rtl.longint, "GetColor", "SetColor");',
  18642. ' $r.addProperty(',
  18643. ' "ColorD",',
  18644. ' 8,',
  18645. ' rtl.longint,',
  18646. ' "FColor",',
  18647. ' "FColor",',
  18648. ' {',
  18649. ' stored: "FColorStored"',
  18650. ' }',
  18651. ' );',
  18652. ' $r.addProperty("ExtSizeA", 0, rtl.longint, "$extSize", "$extSize");',
  18653. ' $r.addProperty(',
  18654. ' "ExtSizeB",',
  18655. ' 11,',
  18656. ' rtl.longint,',
  18657. ' "$getSize",',
  18658. ' "$setSize",',
  18659. ' {',
  18660. ' stored: "$extSizeStored"',
  18661. ' }',
  18662. ' );',
  18663. ' $r.addProperty(',
  18664. ' "ExtSizeC",',
  18665. ' 12,',
  18666. ' rtl.longint,',
  18667. ' "$extSize",',
  18668. ' "$extSize",',
  18669. ' {',
  18670. ' stored: "$getExtSizeStored"',
  18671. ' }',
  18672. ' );',
  18673. '});',
  18674. '']),
  18675. LinesToStr([ // $mod.$main
  18676. '']));
  18677. end;
  18678. procedure TTestModule.TestRTTI_Class_PropertyParams;
  18679. begin
  18680. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18681. StartProgram(false);
  18682. Add('{$modeswitch externalclass}');
  18683. Add('type');
  18684. Add(' integer = longint;');
  18685. Add(' TObject = class');
  18686. Add(' private');
  18687. Add(' function GetItems(i: integer): tobject; virtual; abstract;');
  18688. Add(' procedure SetItems(i: integer; value: tobject); virtual; abstract;');
  18689. Add(' function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
  18690. Add(' procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
  18691. Add(' published');
  18692. Add(' property Items[Index: integer]: tobject read getitems write setitems;');
  18693. Add(' property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
  18694. Add(' end;');
  18695. Add('begin');
  18696. ConvertProgram;
  18697. CheckSource('TestRTTI_Class_PropertyParams',
  18698. LinesToStr([ // statements
  18699. 'rtl.createClass($mod, "TObject", null, function () {',
  18700. ' this.$init = function () {',
  18701. ' };',
  18702. ' this.$final = function () {',
  18703. ' };',
  18704. ' var $r = this.$rtti;',
  18705. ' $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
  18706. ' $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
  18707. '});',
  18708. '']),
  18709. LinesToStr([ // $mod.$main
  18710. '']));
  18711. end;
  18712. procedure TTestModule.TestRTTI_OverrideMethod;
  18713. begin
  18714. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18715. StartProgram(false);
  18716. Add('type');
  18717. Add(' TObject = class');
  18718. Add(' published');
  18719. Add(' procedure DoIt; virtual; abstract;');
  18720. Add(' end;');
  18721. Add(' TSky = class');
  18722. Add(' published');
  18723. Add(' procedure DoIt; override;');
  18724. Add(' end;');
  18725. Add('procedure TSky.DoIt; begin end;');
  18726. Add('begin');
  18727. ConvertProgram;
  18728. CheckSource('TestRTTI_OverrideMethod',
  18729. LinesToStr([ // statements
  18730. 'rtl.createClass($mod, "TObject", null, function () {',
  18731. ' this.$init = function () {',
  18732. ' };',
  18733. ' this.$final = function () {',
  18734. ' };',
  18735. ' var $r = this.$rtti;',
  18736. ' $r.addMethod("DoIt", 0, null);',
  18737. '});',
  18738. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  18739. ' this.DoIt = function () {',
  18740. ' };',
  18741. '});',
  18742. '']),
  18743. LinesToStr([ // $mod.$main
  18744. '']));
  18745. end;
  18746. procedure TTestModule.TestRTTI_OverloadProperty;
  18747. begin
  18748. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18749. StartProgram(false);
  18750. Add('type');
  18751. Add(' TObject = class');
  18752. Add(' protected');
  18753. Add(' FFlag: longint;');
  18754. Add(' published');
  18755. Add(' property Flag: longint read fflag;');
  18756. Add(' end;');
  18757. Add(' TSky = class');
  18758. Add(' published');
  18759. Add(' property FLAG: longint write fflag;');
  18760. Add(' end;');
  18761. Add('begin');
  18762. ConvertProgram;
  18763. CheckSource('TestRTTI_OverrideMethod',
  18764. LinesToStr([ // statements
  18765. 'rtl.createClass($mod, "TObject", null, function () {',
  18766. ' this.$init = function () {',
  18767. ' this.FFlag = 0;',
  18768. ' };',
  18769. ' this.$final = function () {',
  18770. ' };',
  18771. ' var $r = this.$rtti;',
  18772. ' $r.addProperty("Flag", 0, rtl.longint, "FFlag", "");',
  18773. '});',
  18774. 'rtl.createClass($mod, "TSky", $mod.TObject, function () {',
  18775. ' var $r = this.$rtti;',
  18776. ' $r.addProperty("Flag", 0, rtl.longint, "", "FFlag");',
  18777. '});',
  18778. '']),
  18779. LinesToStr([ // $mod.$main
  18780. '']));
  18781. end;
  18782. procedure TTestModule.TestRTTI_ClassForward;
  18783. begin
  18784. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18785. StartProgram(false);
  18786. Add('type');
  18787. Add(' TObject = class end;');
  18788. Add(' tbridge = class;');
  18789. Add(' TProc = function: tbridge;');
  18790. Add(' TOger = class');
  18791. Add(' published');
  18792. Add(' FBridge: tbridge;');
  18793. Add(' procedure SetBridge(Value: tbridge); virtual; abstract;');
  18794. Add(' property Bridge: tbridge read fbridge write setbridge;');
  18795. Add(' end;');
  18796. Add(' TBridge = class');
  18797. Add(' FOger: toger;');
  18798. Add(' end;');
  18799. Add('var p: Pointer;');
  18800. Add(' b: tbridge;');
  18801. Add('begin');
  18802. Add(' p:=typeinfo(tbridge);');
  18803. Add(' p:=typeinfo(b);');
  18804. ConvertProgram;
  18805. CheckSource('TestRTTI_ClassForward',
  18806. LinesToStr([ // statements
  18807. 'rtl.createClass($mod, "TObject", null, function () {',
  18808. ' this.$init = function () {',
  18809. ' };',
  18810. ' this.$final = function () {',
  18811. ' };',
  18812. '});',
  18813. '$mod.$rtti.$Class("TBridge");',
  18814. '$mod.$rtti.$ProcVar("TProc", {',
  18815. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TBridge"])',
  18816. '});',
  18817. 'rtl.createClass($mod, "TOger", $mod.TObject, function () {',
  18818. ' this.$init = function () {',
  18819. ' $mod.TObject.$init.call(this);',
  18820. ' this.FBridge = null;',
  18821. ' };',
  18822. ' this.$final = function () {',
  18823. ' this.FBridge = undefined;',
  18824. ' $mod.TObject.$final.call(this);',
  18825. ' };',
  18826. ' var $r = this.$rtti;',
  18827. ' $r.addField("FBridge", $mod.$rtti["TBridge"]);',
  18828. ' $r.addMethod("SetBridge", 0, [["Value", $mod.$rtti["TBridge"]]]);',
  18829. ' $r.addProperty("Bridge", 2, $mod.$rtti["TBridge"], "FBridge", "SetBridge");',
  18830. '});',
  18831. 'rtl.createClass($mod, "TBridge", $mod.TObject, function () {',
  18832. ' this.$init = function () {',
  18833. ' $mod.TObject.$init.call(this);',
  18834. ' this.FOger = null;',
  18835. ' };',
  18836. ' this.$final = function () {',
  18837. ' this.FOger = undefined;',
  18838. ' $mod.TObject.$final.call(this);',
  18839. ' };',
  18840. '});',
  18841. 'this.p = null;',
  18842. 'this.b = null;',
  18843. '']),
  18844. LinesToStr([ // $mod.$main
  18845. '$mod.p = $mod.$rtti["TBridge"];',
  18846. '$mod.p = $mod.b.$rtti;',
  18847. '']));
  18848. end;
  18849. procedure TTestModule.TestRTTI_ClassOf;
  18850. begin
  18851. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18852. StartProgram(false);
  18853. Add('type');
  18854. Add(' TClass = class of tobject;');
  18855. Add(' TProcA = function: TClass;');
  18856. Add(' TObject = class');
  18857. Add(' published');
  18858. Add(' C: tclass;');
  18859. Add(' end;');
  18860. Add(' tfox = class;');
  18861. Add(' TBird = class end;');
  18862. Add(' TBirds = class of tbird;');
  18863. Add(' TFox = class end;');
  18864. Add(' TFoxes = class of tfox;');
  18865. Add(' TCows = class of TCow;');
  18866. Add(' TCow = class;');
  18867. Add(' TCow = class end;');
  18868. Add('begin');
  18869. ConvertProgram;
  18870. CheckSource('TestRTTI_ClassOf',
  18871. LinesToStr([ // statements
  18872. '$mod.$rtti.$Class("TObject");',
  18873. '$mod.$rtti.$ClassRef("TClass", {',
  18874. ' instancetype: $mod.$rtti["TObject"]',
  18875. '});',
  18876. '$mod.$rtti.$ProcVar("TProcA", {',
  18877. ' procsig: rtl.newTIProcSig(null, $mod.$rtti["TClass"])',
  18878. '});',
  18879. 'rtl.createClass($mod, "TObject", null, function () {',
  18880. ' this.$init = function () {',
  18881. ' this.C = null;',
  18882. ' };',
  18883. ' this.$final = function () {',
  18884. ' this.C = undefined;',
  18885. ' };',
  18886. ' var $r = this.$rtti;',
  18887. ' $r.addField("C", $mod.$rtti["TClass"]);',
  18888. '});',
  18889. '$mod.$rtti.$Class("TFox");',
  18890. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  18891. '});',
  18892. '$mod.$rtti.$ClassRef("TBirds", {',
  18893. ' instancetype: $mod.$rtti["TBird"]',
  18894. '});',
  18895. 'rtl.createClass($mod, "TFox", $mod.TObject, function () {',
  18896. '});',
  18897. '$mod.$rtti.$ClassRef("TFoxes", {',
  18898. ' instancetype: $mod.$rtti["TFox"]',
  18899. '});',
  18900. '$mod.$rtti.$Class("TCow");',
  18901. '$mod.$rtti.$ClassRef("TCows", {',
  18902. ' instancetype: $mod.$rtti["TCow"]',
  18903. '});',
  18904. 'rtl.createClass($mod, "TCow", $mod.TObject, function () {',
  18905. '});',
  18906. '']),
  18907. LinesToStr([ // $mod.$main
  18908. '']));
  18909. end;
  18910. procedure TTestModule.TestRTTI_Record;
  18911. begin
  18912. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18913. StartProgram(false);
  18914. Add('type');
  18915. Add(' integer = longint;');
  18916. Add(' TPoint = record');
  18917. Add(' x,y: integer;');
  18918. Add(' end;');
  18919. Add('var p: pointer;');
  18920. Add(' r: tpoint;');
  18921. Add('begin');
  18922. Add(' p:=typeinfo(tpoint);');
  18923. Add(' p:=typeinfo(r);');
  18924. Add(' p:=typeinfo(r.x);');
  18925. ConvertProgram;
  18926. CheckSource('TestRTTI_Record',
  18927. LinesToStr([ // statements
  18928. 'this.TPoint = function (s) {',
  18929. ' if (s) {',
  18930. ' this.x = s.x;',
  18931. ' this.y = s.y;',
  18932. ' } else {',
  18933. ' this.x = 0;',
  18934. ' this.y = 0;',
  18935. ' };',
  18936. ' this.$equal = function (b) {',
  18937. ' return (this.x === b.x) && (this.y === b.y);',
  18938. ' };',
  18939. '};',
  18940. '$mod.$rtti.$Record("TPoint", {}).addFields("x", rtl.longint, "y", rtl.longint);',
  18941. 'this.p = null;',
  18942. 'this.r = new $mod.TPoint();',
  18943. '']),
  18944. LinesToStr([ // $mod.$main
  18945. '$mod.p = $mod.$rtti["TPoint"];',
  18946. '$mod.p = $mod.$rtti["TPoint"];',
  18947. '$mod.p = rtl.longint;',
  18948. '']));
  18949. end;
  18950. procedure TTestModule.TestRTTI_RecordAnonymousArray;
  18951. begin
  18952. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18953. StartProgram(false);
  18954. Add('type');
  18955. Add(' TFloatRec = record');
  18956. Add(' d: array of char;');
  18957. // Add(' i: array of array of longint;');
  18958. Add(' end;');
  18959. Add('var p: pointer;');
  18960. Add(' r: tfloatrec;');
  18961. Add('begin');
  18962. Add(' p:=typeinfo(tfloatrec);');
  18963. Add(' p:=typeinfo(r);');
  18964. Add(' p:=typeinfo(r.d);');
  18965. ConvertProgram;
  18966. CheckSource('TestRTTI_Record',
  18967. LinesToStr([ // statements
  18968. 'this.TFloatRec = function (s) {',
  18969. ' if (s) {',
  18970. ' this.d = s.d;',
  18971. ' } else {',
  18972. ' this.d = [];',
  18973. ' };',
  18974. ' this.$equal = function (b) {',
  18975. ' return this.d === b.d;',
  18976. ' };',
  18977. '};',
  18978. '$mod.$rtti.$DynArray("TFloatRec.d$a", {',
  18979. ' eltype: rtl.char',
  18980. '});',
  18981. '$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);',
  18982. 'this.p = null;',
  18983. 'this.r = new $mod.TFloatRec();',
  18984. '']),
  18985. LinesToStr([ // $mod.$main
  18986. '$mod.p = $mod.$rtti["TFloatRec"];',
  18987. '$mod.p = $mod.$rtti["TFloatRec"];',
  18988. '$mod.p = $mod.$rtti["TFloatRec.d$a"];',
  18989. '']));
  18990. end;
  18991. procedure TTestModule.TestRTTI_LocalTypes;
  18992. begin
  18993. Converter.Options:=Converter.Options-[coNoTypeInfo];
  18994. StartProgram(false);
  18995. Add('procedure DoIt;');
  18996. Add('type');
  18997. Add(' integer = longint;');
  18998. Add(' TPoint = record');
  18999. Add(' x,y: integer;');
  19000. Add(' end;');
  19001. Add('begin');
  19002. Add('end;');
  19003. Add('begin');
  19004. ConvertProgram;
  19005. CheckSource('TestRTTI_LocalTypes',
  19006. LinesToStr([ // statements
  19007. 'this.DoIt = function () {',
  19008. ' this.TPoint = function (s) {',
  19009. ' if (s) {',
  19010. ' this.x = s.x;',
  19011. ' this.y = s.y;',
  19012. ' } else {',
  19013. ' this.x = 0;',
  19014. ' this.y = 0;',
  19015. ' };',
  19016. ' this.$equal = function (b) {',
  19017. ' return (this.x === b.x) && (this.y === b.y);',
  19018. ' };',
  19019. ' };',
  19020. '};',
  19021. '']),
  19022. LinesToStr([ // $mod.$main
  19023. '']));
  19024. end;
  19025. procedure TTestModule.TestRTTI_TypeInfo_BaseTypes;
  19026. begin
  19027. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19028. StartProgram(false);
  19029. Add([
  19030. 'type',
  19031. ' TCaption = string;',
  19032. ' TYesNo = boolean;',
  19033. ' TLetter = char;',
  19034. ' TFloat = double;',
  19035. ' TPtr = pointer;',
  19036. ' TShortInt = shortint;',
  19037. ' TByte = byte;',
  19038. ' TSmallInt = smallint;',
  19039. ' TWord = word;',
  19040. ' TInt32 = longint;',
  19041. ' TDWord = longword;',
  19042. ' TValue = jsvalue;',
  19043. 'var p: TPtr;',
  19044. 'begin',
  19045. ' p:=typeinfo(string);',
  19046. ' p:=typeinfo(tcaption);',
  19047. ' p:=typeinfo(boolean);',
  19048. ' p:=typeinfo(tyesno);',
  19049. ' p:=typeinfo(char);',
  19050. ' p:=typeinfo(tletter);',
  19051. ' p:=typeinfo(double);',
  19052. ' p:=typeinfo(tfloat);',
  19053. ' p:=typeinfo(pointer);',
  19054. ' p:=typeinfo(tptr);',
  19055. ' p:=typeinfo(shortint);',
  19056. ' p:=typeinfo(tshortint);',
  19057. ' p:=typeinfo(byte);',
  19058. ' p:=typeinfo(tbyte);',
  19059. ' p:=typeinfo(smallint);',
  19060. ' p:=typeinfo(tsmallint);',
  19061. ' p:=typeinfo(word);',
  19062. ' p:=typeinfo(tword);',
  19063. ' p:=typeinfo(longword);',
  19064. ' p:=typeinfo(tdword);',
  19065. ' p:=typeinfo(jsvalue);',
  19066. ' p:=typeinfo(tvalue);',
  19067. '']);
  19068. ConvertProgram;
  19069. CheckSource('TestRTTI_TypeInfo_BaseTypes',
  19070. LinesToStr([ // statements
  19071. 'this.p = null;',
  19072. '']),
  19073. LinesToStr([ // $mod.$main
  19074. '$mod.p = rtl.string;',
  19075. '$mod.p = rtl.string;',
  19076. '$mod.p = rtl.boolean;',
  19077. '$mod.p = rtl.boolean;',
  19078. '$mod.p = rtl.char;',
  19079. '$mod.p = rtl.char;',
  19080. '$mod.p = rtl.double;',
  19081. '$mod.p = rtl.double;',
  19082. '$mod.p = rtl.pointer;',
  19083. '$mod.p = rtl.pointer;',
  19084. '$mod.p = rtl.shortint;',
  19085. '$mod.p = rtl.shortint;',
  19086. '$mod.p = rtl.byte;',
  19087. '$mod.p = rtl.byte;',
  19088. '$mod.p = rtl.smallint;',
  19089. '$mod.p = rtl.smallint;',
  19090. '$mod.p = rtl.word;',
  19091. '$mod.p = rtl.word;',
  19092. '$mod.p = rtl.longword;',
  19093. '$mod.p = rtl.longword;',
  19094. '$mod.p = rtl.jsvalue;',
  19095. '$mod.p = rtl.jsvalue;',
  19096. '']));
  19097. end;
  19098. procedure TTestModule.TestRTTI_TypeInfo_Type_BaseTypes;
  19099. begin
  19100. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19101. StartProgram(false);
  19102. Add([
  19103. 'type',
  19104. ' TCaption = type string;',
  19105. ' TYesNo = type boolean;',
  19106. ' TLetter = type char;',
  19107. ' TFloat = type double;',
  19108. ' TPtr = type pointer;',
  19109. ' TShortInt = type shortint;',
  19110. ' TByte = type byte;',
  19111. ' TSmallInt = type smallint;',
  19112. ' TWord = type word;',
  19113. ' TInt32 = type longint;',
  19114. ' TDWord = type longword;',
  19115. ' TValue = type jsvalue;',
  19116. ' TAliasValue = type TValue;',
  19117. 'var',
  19118. ' p: TPtr;',
  19119. ' a: TAliasValue;',
  19120. 'begin',
  19121. ' p:=typeinfo(tcaption);',
  19122. ' p:=typeinfo(tyesno);',
  19123. ' p:=typeinfo(tletter);',
  19124. ' p:=typeinfo(tfloat);',
  19125. ' p:=typeinfo(tptr);',
  19126. ' p:=typeinfo(tshortint);',
  19127. ' p:=typeinfo(tbyte);',
  19128. ' p:=typeinfo(tsmallint);',
  19129. ' p:=typeinfo(tword);',
  19130. ' p:=typeinfo(tdword);',
  19131. ' p:=typeinfo(tvalue);',
  19132. ' p:=typeinfo(taliasvalue);',
  19133. ' p:=typeinfo(a);',
  19134. '']);
  19135. ConvertProgram;
  19136. CheckSource('TestRTTI_TypeInfo_Type_BaseTypes',
  19137. LinesToStr([ // statements
  19138. '$mod.$rtti.$inherited("TCaption", rtl.string, {});',
  19139. '$mod.$rtti.$inherited("TYesNo", rtl.boolean, {});',
  19140. '$mod.$rtti.$inherited("TLetter", rtl.char, {});',
  19141. '$mod.$rtti.$inherited("TFloat", rtl.double, {});',
  19142. '$mod.$rtti.$inherited("TPtr", rtl.pointer, {});',
  19143. '$mod.$rtti.$inherited("TShortInt", rtl.shortint, {});',
  19144. '$mod.$rtti.$inherited("TByte", rtl.byte, {});',
  19145. '$mod.$rtti.$inherited("TSmallInt", rtl.smallint, {});',
  19146. '$mod.$rtti.$inherited("TWord", rtl.word, {});',
  19147. '$mod.$rtti.$inherited("TInt32", rtl.longint, {});',
  19148. '$mod.$rtti.$inherited("TDWord", rtl.longword, {});',
  19149. '$mod.$rtti.$inherited("TValue", rtl.jsvalue, {});',
  19150. '$mod.$rtti.$inherited("TAliasValue", $mod.$rtti["TValue"], {});',
  19151. 'this.p = null;',
  19152. 'this.a = undefined;',
  19153. '']),
  19154. LinesToStr([ // $mod.$main
  19155. '$mod.p = $mod.$rtti["TCaption"];',
  19156. '$mod.p = $mod.$rtti["TYesNo"];',
  19157. '$mod.p = $mod.$rtti["TLetter"];',
  19158. '$mod.p = $mod.$rtti["TFloat"];',
  19159. '$mod.p = $mod.$rtti["TPtr"];',
  19160. '$mod.p = $mod.$rtti["TShortInt"];',
  19161. '$mod.p = $mod.$rtti["TByte"];',
  19162. '$mod.p = $mod.$rtti["TSmallInt"];',
  19163. '$mod.p = $mod.$rtti["TWord"];',
  19164. '$mod.p = $mod.$rtti["TDWord"];',
  19165. '$mod.p = $mod.$rtti["TValue"];',
  19166. '$mod.p = $mod.$rtti["TAliasValue"];',
  19167. '$mod.p = $mod.$rtti["TAliasValue"];',
  19168. '']));
  19169. end;
  19170. procedure TTestModule.TestRTTI_TypeInfo_LocalFail;
  19171. begin
  19172. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19173. StartProgram(false);
  19174. Add('procedure DoIt;');
  19175. Add('type');
  19176. Add(' integer = longint;');
  19177. Add(' TPoint = record');
  19178. Add(' x,y: integer;');
  19179. Add(' end;');
  19180. Add('var p: pointer;');
  19181. Add('begin');
  19182. Add(' p:=typeinfo(tpoint);');
  19183. Add('end;');
  19184. Add('begin');
  19185. SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
  19186. ConvertProgram;
  19187. end;
  19188. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
  19189. begin
  19190. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19191. StartProgram(false);
  19192. Add('{$modeswitch externalclass}');
  19193. Add('type');
  19194. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  19195. Add(' TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;');
  19196. Add(' TFlag = (up,down);');
  19197. Add(' TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;');
  19198. Add(' TFlags = set of TFlag;');
  19199. Add(' TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;');
  19200. Add('var');
  19201. Add(' ti: TTypeInfo;');
  19202. Add(' tiInt: TTypeInfoInteger;');
  19203. Add(' tiEnum: TTypeInfoEnum;');
  19204. Add(' tiSet: TTypeInfoSet;');
  19205. Add('begin');
  19206. Add(' ti:=typeinfo(string);');
  19207. Add(' ti:=typeinfo(boolean);');
  19208. Add(' ti:=typeinfo(char);');
  19209. Add(' ti:=typeinfo(double);');
  19210. Add(' tiInt:=typeinfo(shortint);');
  19211. Add(' tiInt:=typeinfo(byte);');
  19212. Add(' tiInt:=typeinfo(smallint);');
  19213. Add(' tiInt:=typeinfo(word);');
  19214. Add(' tiInt:=typeinfo(longint);');
  19215. Add(' tiInt:=typeinfo(longword);');
  19216. Add(' ti:=typeinfo(jsvalue);');
  19217. Add(' tiEnum:=typeinfo(tflag);');
  19218. Add(' tiSet:=typeinfo(tflags);');
  19219. ConvertProgram;
  19220. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
  19221. LinesToStr([ // statements
  19222. 'this.TFlag = {',
  19223. ' "0": "up",',
  19224. ' up: 0,',
  19225. ' "1": "down",',
  19226. ' down: 1',
  19227. '};',
  19228. '$mod.$rtti.$Enum("TFlag", {',
  19229. ' minvalue: 0,',
  19230. ' maxvalue: 1,',
  19231. ' ordtype: 1,',
  19232. ' enumtype: this.TFlag',
  19233. '});',
  19234. '$mod.$rtti.$Set("TFlags", {',
  19235. ' comptype: $mod.$rtti["TFlag"]',
  19236. '});',
  19237. 'this.ti = null;',
  19238. 'this.tiInt = null;',
  19239. 'this.tiEnum = null;',
  19240. 'this.tiSet = null;',
  19241. '']),
  19242. LinesToStr([ // $mod.$main
  19243. '$mod.ti = rtl.string;',
  19244. '$mod.ti = rtl.boolean;',
  19245. '$mod.ti = rtl.char;',
  19246. '$mod.ti = rtl.double;',
  19247. '$mod.tiInt = rtl.shortint;',
  19248. '$mod.tiInt = rtl.byte;',
  19249. '$mod.tiInt = rtl.smallint;',
  19250. '$mod.tiInt = rtl.word;',
  19251. '$mod.tiInt = rtl.longint;',
  19252. '$mod.tiInt = rtl.longword;',
  19253. '$mod.ti = rtl.jsvalue;',
  19254. '$mod.tiEnum = $mod.$rtti["TFlag"];',
  19255. '$mod.tiSet = $mod.$rtti["TFlags"];',
  19256. '']));
  19257. end;
  19258. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses2;
  19259. begin
  19260. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19261. StartProgram(false);
  19262. Add('{$modeswitch externalclass}');
  19263. Add('type');
  19264. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  19265. Add(' TStaticArr = array[boolean] of string;');
  19266. Add(' TTypeInfoStaticArray = class external name ''rtl.tTypeInfoStaticArray''(TTypeInfo) end;');
  19267. Add(' TDynArr = array of string;');
  19268. Add(' TTypeInfoDynArray = class external name ''rtl.tTypeInfoDynArray''(TTypeInfo) end;');
  19269. Add(' TProc = procedure;');
  19270. Add(' TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
  19271. Add(' TMethod = procedure of object;');
  19272. Add(' TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
  19273. Add('var');
  19274. Add(' StaticArray: TStaticArr;');
  19275. Add(' tiStaticArray: TTypeInfoStaticArray;');
  19276. Add(' DynArray: TDynArr;');
  19277. Add(' tiDynArray: TTypeInfoDynArray;');
  19278. Add(' ProcVar: TProc;');
  19279. Add(' tiProcVar: TTypeInfoProcVar;');
  19280. Add(' MethodVar: TMethod;');
  19281. Add(' tiMethodVar: TTypeInfoMethodVar;');
  19282. Add('begin');
  19283. Add(' tiStaticArray:=typeinfo(StaticArray);');
  19284. Add(' tiStaticArray:=typeinfo(TStaticArr);');
  19285. Add(' tiDynArray:=typeinfo(DynArray);');
  19286. Add(' tiDynArray:=typeinfo(TDynArr);');
  19287. Add(' tiProcVar:=typeinfo(ProcVar);');
  19288. Add(' tiProcVar:=typeinfo(TProc);');
  19289. Add(' tiMethodVar:=typeinfo(MethodVar);');
  19290. Add(' tiMethodVar:=typeinfo(TMethod);');
  19291. ConvertProgram;
  19292. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
  19293. LinesToStr([ // statements
  19294. ' $mod.$rtti.$StaticArray("TStaticArr", {',
  19295. ' dims: [2],',
  19296. ' eltype: rtl.string',
  19297. '});',
  19298. '$mod.$rtti.$DynArray("TDynArr", {',
  19299. ' eltype: rtl.string',
  19300. '});',
  19301. '$mod.$rtti.$ProcVar("TProc", {',
  19302. ' procsig: rtl.newTIProcSig(null)',
  19303. '});',
  19304. '$mod.$rtti.$MethodVar("TMethod", {',
  19305. ' procsig: rtl.newTIProcSig(null),',
  19306. ' methodkind: 0',
  19307. '});',
  19308. 'this.StaticArray = rtl.arraySetLength(null,"",2);',
  19309. 'this.tiStaticArray = null;',
  19310. 'this.DynArray = [];',
  19311. 'this.tiDynArray = null;',
  19312. 'this.ProcVar = null;',
  19313. 'this.tiProcVar = null;',
  19314. 'this.MethodVar = null;',
  19315. 'this.tiMethodVar = null;',
  19316. '']),
  19317. LinesToStr([ // $mod.$main
  19318. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  19319. '$mod.tiStaticArray = $mod.$rtti["TStaticArr"];',
  19320. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  19321. '$mod.tiDynArray = $mod.$rtti["TDynArr"];',
  19322. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  19323. '$mod.tiProcVar = $mod.$rtti["TProc"];',
  19324. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  19325. '$mod.tiMethodVar = $mod.$rtti["TMethod"];',
  19326. '']));
  19327. end;
  19328. procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
  19329. begin
  19330. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19331. StartProgram(false);
  19332. Add('{$modeswitch externalclass}');
  19333. Add('type');
  19334. Add(' TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
  19335. Add(' TRec = record end;');
  19336. Add(' TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
  19337. // ToDo: ^PRec
  19338. Add(' TObject = class end;');
  19339. Add(' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
  19340. Add(' TClass = class of tobject;');
  19341. Add(' TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
  19342. Add(' TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
  19343. Add('var');
  19344. Add(' Rec: trec;');
  19345. Add(' tiRecord: ttypeinforecord;');
  19346. Add(' Obj: tobject;');
  19347. Add(' tiClass: ttypeinfoclass;');
  19348. Add(' aClass: tclass;');
  19349. Add(' tiClassRef: ttypeinfoclassref;');
  19350. // ToDo: ^PRec
  19351. Add(' tiPointer: ttypeinfopointer;');
  19352. Add('begin');
  19353. Add(' tirecord:=typeinfo(trec);');
  19354. Add(' tirecord:=typeinfo(trec);');
  19355. Add(' ticlass:=typeinfo(obj);');
  19356. Add(' ticlass:=typeinfo(tobject);');
  19357. Add(' ticlass:=typeinfo(aclass);');
  19358. Add(' ticlassref:=typeinfo(tclass);');
  19359. ConvertProgram;
  19360. CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
  19361. LinesToStr([ // statements
  19362. 'this.TRec = function (s) {',
  19363. ' this.$equal = function (b) {',
  19364. ' return true;',
  19365. ' };',
  19366. '};',
  19367. '$mod.$rtti.$Record("TRec", {});',
  19368. 'rtl.createClass($mod, "TObject", null, function () {',
  19369. ' this.$init = function () {',
  19370. ' };',
  19371. ' this.$final = function () {',
  19372. ' };',
  19373. '});',
  19374. '$mod.$rtti.$ClassRef("TClass", {',
  19375. ' instancetype: $mod.$rtti["TObject"]',
  19376. '});',
  19377. 'this.Rec = new $mod.TRec();',
  19378. 'this.tiRecord = null;',
  19379. 'this.Obj = null;',
  19380. 'this.tiClass = null;',
  19381. 'this.aClass = null;',
  19382. 'this.tiClassRef = null;',
  19383. 'this.tiPointer = null;',
  19384. '']),
  19385. LinesToStr([ // $mod.$main
  19386. '$mod.tiRecord = $mod.$rtti["TRec"];',
  19387. '$mod.tiRecord = $mod.$rtti["TRec"];',
  19388. '$mod.tiClass = $mod.Obj.$rtti;',
  19389. '$mod.tiClass = $mod.$rtti["TObject"];',
  19390. '$mod.tiClass = $mod.aClass.$rtti;',
  19391. '$mod.tiClassRef = $mod.$rtti["TClass"];',
  19392. '']));
  19393. end;
  19394. procedure TTestModule.TestRTTI_TypeInfo_FunctionClassType;
  19395. begin
  19396. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19397. StartProgram(false);
  19398. Add([
  19399. '{$modeswitch externalclass}',
  19400. 'type',
  19401. ' TClass = class of tobject;',
  19402. ' TObject = class',
  19403. ' function MyClass: TClass;',
  19404. ' class function ClassType: TClass;',
  19405. ' end;',
  19406. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  19407. ' TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;',
  19408. 'function TObject.MyClass: TClass;',
  19409. 'var t: TTypeInfoClass;',
  19410. 'begin',
  19411. ' t:=TypeInfo(Self);',
  19412. ' t:=TypeInfo(Result);',
  19413. ' t:=TypeInfo(TObject);',
  19414. 'end;',
  19415. 'class function TObject.ClassType: TClass;',
  19416. 'var t: TTypeInfoClass;',
  19417. 'begin',
  19418. ' t:=TypeInfo(Self);',
  19419. ' t:=TypeInfo(Result);',
  19420. 'end;',
  19421. 'var',
  19422. ' Obj: TObject;',
  19423. ' t: TTypeInfoClass;',
  19424. 'begin',
  19425. ' t:=TypeInfo(TObject.ClassType);',
  19426. ' t:=TypeInfo(Obj.ClassType);',
  19427. ' t:=TypeInfo(Obj.MyClass);',
  19428. '']);
  19429. ConvertProgram;
  19430. CheckSource('TestRTTI_TypeInfo_FunctionClassType',
  19431. LinesToStr([ // statements
  19432. '$mod.$rtti.$Class("TObject");',
  19433. '$mod.$rtti.$ClassRef("TClass", {',
  19434. ' instancetype: $mod.$rtti["TObject"]',
  19435. '});',
  19436. 'rtl.createClass($mod, "TObject", null, function () {',
  19437. ' this.$init = function () {',
  19438. ' };',
  19439. ' this.$final = function () {',
  19440. ' };',
  19441. ' this.MyClass = function () {',
  19442. ' var Result = null;',
  19443. ' var t = null;',
  19444. ' t = this.$rtti;',
  19445. ' t = Result.$rtti;',
  19446. ' t = $mod.$rtti["TObject"];',
  19447. ' return Result;',
  19448. ' };',
  19449. ' this.ClassType = function () {',
  19450. ' var Result = null;',
  19451. ' var t = null;',
  19452. ' t = this.$rtti;',
  19453. ' t = Result.$rtti;',
  19454. ' return Result;',
  19455. ' };',
  19456. '});',
  19457. 'this.Obj = null;',
  19458. 'this.t = null;',
  19459. '']),
  19460. LinesToStr([ // $mod.$main
  19461. '$mod.t = $mod.TObject.ClassType().$rtti;',
  19462. '$mod.t = $mod.Obj.$class.ClassType().$rtti;',
  19463. '$mod.t = $mod.Obj.MyClass().$rtti;',
  19464. '']));
  19465. end;
  19466. procedure TTestModule.TestRTTI_Interface_Corba;
  19467. begin
  19468. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19469. StartProgram(false);
  19470. Add([
  19471. '{$interfaces corba}',
  19472. '{$modeswitch externalclass}',
  19473. 'type',
  19474. ' IUnknown = interface',
  19475. ' end;',
  19476. ' IBird = interface',
  19477. ' function GetItem: longint;',
  19478. ' procedure SetItem(Value: longint);',
  19479. ' property Item: longint read GetItem write SetItem;',
  19480. ' end;',
  19481. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  19482. ' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
  19483. 'procedure DoIt(t: TTypeInfoInterface); begin end;',
  19484. 'var',
  19485. ' i: IBird;',
  19486. ' t: TTypeInfoInterface;',
  19487. 'begin',
  19488. ' t:=TypeInfo(IBird);',
  19489. ' t:=TypeInfo(i);',
  19490. ' DoIt(t);',
  19491. ' DoIt(TypeInfo(IBird));',
  19492. '']);
  19493. ConvertProgram;
  19494. CheckSource('TestRTTI_Interface_Corba',
  19495. LinesToStr([ // statements
  19496. 'rtl.createInterface(',
  19497. ' $mod,',
  19498. ' "IUnknown",',
  19499. ' "{5D22E7CA-4E00-3000-8000-000000000000}",',
  19500. ' [],',
  19501. ' null,',
  19502. ' function () {',
  19503. ' }',
  19504. ');',
  19505. 'rtl.createInterface(',
  19506. ' $mod,',
  19507. ' "IBird",',
  19508. ' "{585952B8-45B2-3E86-BAC5-B22E86800000}",',
  19509. ' ["GetItem", "SetItem"],',
  19510. ' null,',
  19511. ' function () {',
  19512. ' var $r = this.$rtti;',
  19513. ' $r.addMethod("GetItem", 1, null, rtl.longint);',
  19514. ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
  19515. ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
  19516. ' }',
  19517. ');',
  19518. 'this.DoIt = function (t) {',
  19519. '}; ',
  19520. 'this.i = null;',
  19521. 'this.t = null;',
  19522. '']),
  19523. LinesToStr([ // $mod.$main
  19524. '$mod.t = $mod.$rtti["IBird"];',
  19525. '$mod.t = $mod.i.$rtti;',
  19526. '$mod.DoIt($mod.t);',
  19527. '$mod.DoIt($mod.$rtti["IBird"]);',
  19528. '']));
  19529. end;
  19530. procedure TTestModule.TestRTTI_Interface_COM;
  19531. begin
  19532. Converter.Options:=Converter.Options-[coNoTypeInfo];
  19533. StartProgram(false);
  19534. Add([
  19535. '{$interfaces com}',
  19536. '{$modeswitch externalclass}',
  19537. 'type',
  19538. ' TGuid = record end;',
  19539. ' integer = longint;',
  19540. ' IUnknown = interface',
  19541. ' function QueryInterface(const iid: TGuid; out obj): Integer;',
  19542. ' function _AddRef: Integer;',
  19543. ' function _Release: Integer;',
  19544. ' end;',
  19545. ' IBird = interface',
  19546. ' function GetItem: longint;',
  19547. ' procedure SetItem(Value: longint);',
  19548. ' property Item: longint read GetItem write SetItem;',
  19549. ' end;',
  19550. ' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
  19551. ' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
  19552. 'var',
  19553. ' i: IBird;',
  19554. ' t: TTypeInfoInterface;',
  19555. 'begin',
  19556. ' t:=TypeInfo(IBird);',
  19557. ' t:=TypeInfo(i);',
  19558. '']);
  19559. ConvertProgram;
  19560. CheckSource('TestRTTI_Interface_COM',
  19561. LinesToStr([ // statements
  19562. 'this.TGuid = function (s) {',
  19563. ' this.$equal = function (b) {',
  19564. ' return true;',
  19565. ' };',
  19566. '};',
  19567. '$mod.$rtti.$Record("TGuid", {});',
  19568. 'rtl.createInterface(',
  19569. ' $mod,',
  19570. ' "IUnknown",',
  19571. ' "{06A53E33-DB48-3B02-9906-776A86A09333}",',
  19572. ' ["QueryInterface", "_AddRef", "_Release"],',
  19573. ' null,',
  19574. ' function () {',
  19575. ' this.$kind = "com";',
  19576. ' var $r = this.$rtti;',
  19577. ' $r.addMethod("QueryInterface", 1, [["iid", $mod.$rtti["TGuid"], 2], ["obj", null, 4]], rtl.longint);',
  19578. ' $r.addMethod("_AddRef", 1, null, rtl.longint);',
  19579. ' $r.addMethod("_Release", 1, null, rtl.longint);',
  19580. ' }',
  19581. ');',
  19582. 'rtl.createInterface(',
  19583. ' $mod,',
  19584. ' "IBird",',
  19585. ' "{FF135A0E-7B4C-35B8-8737-674A0E33EF92}",',
  19586. ' ["GetItem", "SetItem"],',
  19587. ' $mod.IUnknown,',
  19588. ' function () {',
  19589. ' var $r = this.$rtti;',
  19590. ' $r.addMethod("GetItem", 1, null, rtl.longint);',
  19591. ' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
  19592. ' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
  19593. ' }',
  19594. ');',
  19595. 'this.i = null;',
  19596. 'this.t = null;',
  19597. '']),
  19598. LinesToStr([ // $mod.$main
  19599. '$mod.t = $mod.$rtti["IBird"];',
  19600. '$mod.t = $mod.i.$rtti;',
  19601. '']));
  19602. end;
  19603. procedure TTestModule.TestResourcestringProgram;
  19604. begin
  19605. StartProgram(false);
  19606. Add([
  19607. 'const Bar = ''bar'';',
  19608. 'resourcestring',
  19609. ' Red = ''red'';',
  19610. ' Foobar = ''fOo''+bar;',
  19611. 'var s: string;',
  19612. ' c: char;',
  19613. 'begin',
  19614. ' s:=red;',
  19615. ' s:=test1.red;',
  19616. ' c:=red[1];',
  19617. ' c:=test1.red[2];',
  19618. ' if red=foobar then ;',
  19619. ' if red[3]=red[4] then ;']);
  19620. ConvertProgram;
  19621. CheckSource('TestResourcestringProgram',
  19622. LinesToStr([ // statements
  19623. 'this.Bar = "bar";',
  19624. 'this.s = "";',
  19625. 'this.c = "";',
  19626. '$mod.$resourcestrings = {',
  19627. ' Red: {',
  19628. ' org: "red"',
  19629. ' },',
  19630. ' Foobar: {',
  19631. ' org: "fOobar"',
  19632. ' }',
  19633. '};',
  19634. '']),
  19635. LinesToStr([ // $mod.$main
  19636. '$mod.s = rtl.getResStr(pas.program, "Red");',
  19637. '$mod.s = rtl.getResStr(pas.program, "Red");',
  19638. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(0);',
  19639. '$mod.c = rtl.getResStr(pas.program, "Red").charAt(1);',
  19640. 'if (rtl.getResStr(pas.program, "Red") === rtl.getResStr(pas.program, "Foobar")) ;',
  19641. 'if (rtl.getResStr(pas.program, "Red").charAt(2) === rtl.getResStr(pas.program, "Red").charAt(3)) ;',
  19642. '']));
  19643. end;
  19644. procedure TTestModule.TestResourcestringUnit;
  19645. begin
  19646. StartUnit(false);
  19647. Add([
  19648. 'interface',
  19649. 'const Red = ''rEd'';',
  19650. 'resourcestring',
  19651. ' Blue = ''blue'';',
  19652. ' NotRed = ''not''+Red;',
  19653. 'var s: string;',
  19654. 'implementation',
  19655. 'resourcestring',
  19656. ' ImplGreen = ''green'';',
  19657. 'initialization',
  19658. ' s:=blue+ImplGreen;',
  19659. ' s:=test1.blue+test1.implgreen;',
  19660. ' s:=blue[1]+implgreen[2];']);
  19661. ConvertUnit;
  19662. CheckSource('TestResourcestringUnit',
  19663. LinesToStr([ // statements
  19664. 'this.Red = "rEd";',
  19665. 'this.s = "";',
  19666. '$mod.$resourcestrings = {',
  19667. ' Blue: {',
  19668. ' org: "blue"',
  19669. ' },',
  19670. ' NotRed: {',
  19671. ' org: "notrEd"',
  19672. ' },',
  19673. ' ImplGreen: {',
  19674. ' org: "green"',
  19675. ' }',
  19676. '};',
  19677. '']),
  19678. LinesToStr([ // $mod.$main
  19679. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  19680. '$mod.s = rtl.getResStr(pas.Test1, "Blue") + rtl.getResStr(pas.Test1, "ImplGreen");',
  19681. '$mod.s = rtl.getResStr(pas.Test1, "Blue").charAt(0) + rtl.getResStr(pas.Test1, "ImplGreen").charAt(1);',
  19682. '']));
  19683. end;
  19684. procedure TTestModule.TestResourcestringImplementation;
  19685. begin
  19686. StartUnit(false);
  19687. Add([
  19688. 'interface',
  19689. 'implementation',
  19690. 'resourcestring',
  19691. ' ImplRed = ''red'';']);
  19692. ConvertUnit;
  19693. CheckSource('TestResourcestringImplementation',
  19694. LinesToStr([ // intf statements
  19695. 'var $impl = $mod.$impl;']),
  19696. LinesToStr([ // $mod.$init
  19697. '']),
  19698. LinesToStr([ // impl statements
  19699. '$mod.$resourcestrings = {',
  19700. ' ImplRed: {',
  19701. ' org: "red"',
  19702. ' }',
  19703. '};',
  19704. '']));
  19705. end;
  19706. procedure TTestModule.TestAtributes_Ignore;
  19707. begin
  19708. StartProgram(false);
  19709. Add([
  19710. '{$modeswitch ignoreattributes}',
  19711. 'type',
  19712. ' [custom1, custom2(1+3,''foo'')] [mod1.custom3]',
  19713. ' TObject = class',
  19714. ' [custom5()] FS: string;',
  19715. ' [customProp] property S: string read FS;',
  19716. ' end;',
  19717. 'var',
  19718. ' [custom6]',
  19719. ' o: TObject;',
  19720. 'begin',
  19721. '']);
  19722. ConvertProgram;
  19723. CheckSource('TestAtributes_Ignore',
  19724. LinesToStr([ // statements
  19725. 'rtl.createClass($mod, "TObject", null, function () {',
  19726. ' this.$init = function () {',
  19727. ' this.FS = "";',
  19728. ' };',
  19729. ' this.$final = function () {',
  19730. ' };',
  19731. '});',
  19732. 'this.o = null;',
  19733. '']),
  19734. LinesToStr([ // $mod.$main
  19735. '']));
  19736. end;
  19737. procedure TTestModule.TestAssert;
  19738. begin
  19739. StartProgram(false);
  19740. Add([
  19741. 'procedure DoIt;',
  19742. 'var',
  19743. ' b: boolean;',
  19744. ' s: string;',
  19745. 'begin',
  19746. ' {$Assertions on}',
  19747. ' Assert(b);',
  19748. 'end;',
  19749. 'begin',
  19750. ' DoIt;',
  19751. '']);
  19752. ConvertProgram;
  19753. CheckSource('TestAssert',
  19754. LinesToStr([ // statements
  19755. 'this.DoIt = function () {',
  19756. ' var b = false;',
  19757. ' var s = "";',
  19758. ' if (b) throw "assert failed";',
  19759. '};',
  19760. '']),
  19761. LinesToStr([ // $mod.$main
  19762. '$mod.DoIt();',
  19763. '']));
  19764. end;
  19765. procedure TTestModule.TestAssert_SysUtils;
  19766. begin
  19767. AddModuleWithIntfImplSrc('SysUtils.pas',
  19768. LinesToStr([
  19769. 'type',
  19770. ' TObject = class',
  19771. ' constructor Create;',
  19772. ' end;',
  19773. ' EAssertionFailed = class',
  19774. ' constructor Create(s: string);',
  19775. ' end;',
  19776. '']),
  19777. LinesToStr([
  19778. 'constructor TObject.Create;',
  19779. 'begin end;',
  19780. 'constructor EAssertionFailed.Create(s: string);',
  19781. 'begin end;',
  19782. '']) );
  19783. StartProgram(true);
  19784. Add([
  19785. 'uses sysutils;',
  19786. 'procedure DoIt;',
  19787. 'var',
  19788. ' b: boolean;',
  19789. ' s: string;',
  19790. 'begin',
  19791. ' {$Assertions on}',
  19792. ' Assert(b);',
  19793. ' Assert(b,''msg'');',
  19794. 'end;',
  19795. 'begin',
  19796. ' DoIt;',
  19797. '']);
  19798. ConvertProgram;
  19799. CheckSource('TestAssert_SysUtils',
  19800. LinesToStr([ // statements
  19801. 'this.DoIt = function () {',
  19802. ' var b = false;',
  19803. ' var s = "";',
  19804. ' if (b) throw pas.SysUtils.EAssertionFailed.$create("Create");',
  19805. ' if (b) throw pas.SysUtils.EAssertionFailed.$create("Create$1", ["msg"]);',
  19806. '};',
  19807. '']),
  19808. LinesToStr([ // $mod.$main
  19809. '$mod.DoIt();',
  19810. '']));
  19811. end;
  19812. procedure TTestModule.TestObjectChecks;
  19813. begin
  19814. Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsObjectChecks];
  19815. StartProgram(false);
  19816. Add([
  19817. 'type',
  19818. ' TObject = class',
  19819. ' procedure DoIt;',
  19820. ' end;',
  19821. ' TClass = class of tobject;',
  19822. ' TBird = class',
  19823. ' end;',
  19824. ' TBirdClass = class of TBird;',
  19825. 'var',
  19826. ' o : TObject;',
  19827. ' c: TClass;',
  19828. ' b: TBird;',
  19829. ' bc: TBirdClass;',
  19830. 'procedure TObject.DoIt;',
  19831. 'begin',
  19832. ' b:=TBird(o);',
  19833. 'end;',
  19834. 'begin',
  19835. ' o.DoIt;',
  19836. ' b:=TBird(o);',
  19837. ' bc:=TBirdClass(c);',
  19838. '']);
  19839. ConvertProgram;
  19840. CheckSource('TestCheckMethodCall',
  19841. LinesToStr([ // statements
  19842. 'rtl.createClass($mod, "TObject", null, function () {',
  19843. ' this.$init = function () {',
  19844. ' };',
  19845. ' this.$final = function () {',
  19846. ' };',
  19847. ' this.DoIt = function () {',
  19848. ' rtl.checkMethodCall(this,$mod.TObject);',
  19849. ' $mod.b = rtl.asExt($mod.o, $mod.TBird, 1);',
  19850. ' };',
  19851. '});',
  19852. 'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
  19853. '});',
  19854. 'this.o = null;',
  19855. 'this.c = null;',
  19856. 'this.b = null;',
  19857. 'this.bc = null;',
  19858. '']),
  19859. LinesToStr([ // $mod.$main
  19860. '$mod.o.DoIt();',
  19861. '$mod.b = rtl.asExt($mod.o,$mod.TBird, 1);',
  19862. '$mod.bc = rtl.asExt($mod.c, $mod.TBird, 2);',
  19863. '']));
  19864. end;
  19865. procedure TTestModule.TestRangeChecks_AssignInt;
  19866. begin
  19867. Scanner.Options:=Scanner.Options+[po_CAssignments];
  19868. StartProgram(false);
  19869. Add([
  19870. '{$R+}',
  19871. 'var',
  19872. ' b: byte = 2;',
  19873. ' w: word = 3;',
  19874. 'procedure DoIt(p: byte);',
  19875. 'begin',
  19876. ' b:=w;',
  19877. ' b+=w;',
  19878. ' b:=1;',
  19879. 'end;',
  19880. '{$R-}',
  19881. 'begin',
  19882. ' DoIt(w);',
  19883. ' b:=w;',
  19884. ' b:=2;',
  19885. '{$R+}',
  19886. '']);
  19887. ConvertProgram;
  19888. CheckSource('TestRangeChecks_AssignInt',
  19889. LinesToStr([ // statements
  19890. 'this.b = 2;',
  19891. 'this.w = 3;',
  19892. 'this.DoIt = function (p) {',
  19893. ' rtl.rc(p, 0, 255);',
  19894. ' $mod.b = rtl.rc($mod.w,0,255);',
  19895. ' rtl.rc($mod.b += $mod.w, 0, 255);',
  19896. ' $mod.b = 1;',
  19897. '};',
  19898. '']),
  19899. LinesToStr([ // $mod.$main
  19900. '$mod.DoIt($mod.w);',
  19901. '$mod.b = rtl.rc($mod.w,0,255);',
  19902. '$mod.b = 2;',
  19903. '']));
  19904. end;
  19905. procedure TTestModule.TestRangeChecks_AssignIntRange;
  19906. begin
  19907. Scanner.Options:=Scanner.Options+[po_CAssignments];
  19908. StartProgram(false);
  19909. Add([
  19910. '{$R+}',
  19911. 'type Ten = 1..10;',
  19912. 'var',
  19913. ' b: Ten = 2;',
  19914. ' w: Ten = 3;',
  19915. 'procedure DoIt(p: Ten);',
  19916. 'begin',
  19917. ' b:=w;',
  19918. ' b+=w;',
  19919. ' b:=1;',
  19920. 'end;',
  19921. '{$R-}',
  19922. 'begin',
  19923. ' DoIt(w);',
  19924. ' b:=w;',
  19925. ' b:=2;',
  19926. '{$R+}',
  19927. '']);
  19928. ConvertProgram;
  19929. CheckSource('TestRangeChecks_AssignIntRange',
  19930. LinesToStr([ // statements
  19931. 'this.b = 2;',
  19932. 'this.w = 3;',
  19933. 'this.DoIt = function (p) {',
  19934. ' rtl.rc(p, 1, 10);',
  19935. ' $mod.b = rtl.rc($mod.w, 1, 10);',
  19936. ' rtl.rc($mod.b += $mod.w, 1, 10);',
  19937. ' $mod.b = 1;',
  19938. '};',
  19939. '']),
  19940. LinesToStr([ // $mod.$main
  19941. '$mod.DoIt($mod.w);',
  19942. '$mod.b = rtl.rc($mod.w, 1, 10);',
  19943. '$mod.b = 2;',
  19944. '']));
  19945. end;
  19946. procedure TTestModule.TestRangeChecks_AssignEnum;
  19947. begin
  19948. StartProgram(false);
  19949. Add([
  19950. '{$R+}',
  19951. 'type TEnum = (red,green);',
  19952. 'var',
  19953. ' e: TEnum = red;',
  19954. 'procedure DoIt(p: TEnum);',
  19955. 'begin',
  19956. ' e:=p;',
  19957. ' p:=TEnum(0);',
  19958. ' p:=succ(e);',
  19959. 'end;',
  19960. '{$R-}',
  19961. 'begin',
  19962. ' DoIt(e);',
  19963. ' e:=TEnum(1);',
  19964. ' e:=pred(e);',
  19965. '{$R+}',
  19966. '']);
  19967. ConvertProgram;
  19968. CheckSource('TestRangeChecks_AssignEnum',
  19969. LinesToStr([ // statements
  19970. 'this.TEnum = {',
  19971. ' "0": "red",',
  19972. ' red: 0,',
  19973. ' "1": "green",',
  19974. ' green: 1',
  19975. '};',
  19976. 'this.e = $mod.TEnum.red;',
  19977. 'this.DoIt = function (p) {',
  19978. ' rtl.rc(p, 0, 1);',
  19979. ' $mod.e = rtl.rc(p, 0, 1);',
  19980. ' p = 0;',
  19981. ' p = rtl.rc($mod.e + 1, 0, 1);',
  19982. '};',
  19983. '']),
  19984. LinesToStr([ // $mod.$main
  19985. '$mod.DoIt($mod.e);',
  19986. '$mod.e = 1;',
  19987. '$mod.e = rtl.rc($mod.e-1, 0, 1);',
  19988. '']));
  19989. end;
  19990. procedure TTestModule.TestRangeChecks_AssignEnumRange;
  19991. begin
  19992. StartProgram(false);
  19993. Add([
  19994. '{$R+}',
  19995. 'type',
  19996. ' TEnum = (red,green);',
  19997. ' TEnumRg = red..green;',
  19998. 'var',
  19999. ' e: TEnumRg = red;',
  20000. 'procedure DoIt(p: TEnumRg);',
  20001. 'begin',
  20002. ' e:=p;',
  20003. ' p:=TEnumRg(0);',
  20004. ' p:=succ(e);',
  20005. 'end;',
  20006. '{$R-}',
  20007. 'begin',
  20008. ' DoIt(e);',
  20009. ' e:=TEnumRg(1);',
  20010. ' e:=pred(e);',
  20011. '{$R+}',
  20012. '']);
  20013. ConvertProgram;
  20014. CheckSource('TestRangeChecks_AssignEnumRange',
  20015. LinesToStr([ // statements
  20016. 'this.TEnum = {',
  20017. ' "0": "red",',
  20018. ' red: 0,',
  20019. ' "1": "green",',
  20020. ' green: 1',
  20021. '};',
  20022. 'this.e = $mod.TEnum.red;',
  20023. 'this.DoIt = function (p) {',
  20024. ' rtl.rc(p, 0, 1);',
  20025. ' $mod.e = rtl.rc(p, 0, 1);',
  20026. ' p = 0;',
  20027. ' p = rtl.rc($mod.e + 1, 0, 1);',
  20028. '};',
  20029. '']),
  20030. LinesToStr([ // $mod.$main
  20031. '$mod.DoIt($mod.e);',
  20032. '$mod.e = 1;',
  20033. '$mod.e = rtl.rc($mod.e-1, 0, 1);',
  20034. '']));
  20035. end;
  20036. procedure TTestModule.TestRangeChecks_AssignChar;
  20037. begin
  20038. StartProgram(false);
  20039. Add([
  20040. '{$R+}',
  20041. 'type TLetter = char;',
  20042. 'var',
  20043. ' b: TLetter = ''2'';',
  20044. ' w: TLetter = ''3'';',
  20045. 'procedure DoIt(p: TLetter);',
  20046. 'begin',
  20047. ' b:=w;',
  20048. ' b:=''1'';',
  20049. 'end;',
  20050. '{$R-}',
  20051. 'begin',
  20052. ' DoIt(w);',
  20053. ' b:=w;',
  20054. ' b:=''2'';',
  20055. '{$R+}',
  20056. '']);
  20057. ConvertProgram;
  20058. CheckSource('TestRangeChecks_AssignChar',
  20059. LinesToStr([ // statements
  20060. 'this.b = "2";',
  20061. 'this.w = "3";',
  20062. 'this.DoIt = function (p) {',
  20063. ' rtl.rcc(p, 0, 65535);',
  20064. ' $mod.b = rtl.rcc($mod.w, 0, 65535);',
  20065. ' $mod.b = "1";',
  20066. '};',
  20067. '']),
  20068. LinesToStr([ // $mod.$main
  20069. '$mod.DoIt($mod.w);',
  20070. '$mod.b = rtl.rcc($mod.w, 0, 65535);',
  20071. '$mod.b = "2";',
  20072. '']));
  20073. end;
  20074. procedure TTestModule.TestRangeChecks_AssignCharRange;
  20075. begin
  20076. StartProgram(false);
  20077. Add([
  20078. '{$R+}',
  20079. 'type TDigit = ''0''..''9'';',
  20080. 'var',
  20081. ' b: TDigit = ''2'';',
  20082. ' w: TDigit = ''3'';',
  20083. 'procedure DoIt(p: TDigit);',
  20084. 'begin',
  20085. ' b:=w;',
  20086. ' b:=''1'';',
  20087. 'end;',
  20088. '{$R-}',
  20089. 'begin',
  20090. ' DoIt(w);',
  20091. ' b:=w;',
  20092. ' b:=''2'';',
  20093. '{$R+}',
  20094. '']);
  20095. ConvertProgram;
  20096. CheckSource('TestRangeChecks_AssignCharRange',
  20097. LinesToStr([ // statements
  20098. 'this.b = "2";',
  20099. 'this.w = "3";',
  20100. 'this.DoIt = function (p) {',
  20101. ' rtl.rcc(p, 48, 57);',
  20102. ' $mod.b = rtl.rcc($mod.w, 48, 57);',
  20103. ' $mod.b = "1";',
  20104. '};',
  20105. '']),
  20106. LinesToStr([ // $mod.$main
  20107. '$mod.DoIt($mod.w);',
  20108. '$mod.b = rtl.rcc($mod.w, 48, 57);',
  20109. '$mod.b = "2";',
  20110. '']));
  20111. end;
  20112. procedure TTestModule.TestRangeChecks_ArrayIndex;
  20113. begin
  20114. StartProgram(false);
  20115. Add([
  20116. '{$R+}',
  20117. 'type',
  20118. ' Ten = 1..10;',
  20119. ' TArr = array of Ten;',
  20120. ' TArrArr = array of TArr;',
  20121. ' TArrByte = array[byte] of Ten;',
  20122. ' TArrChar = array[''0''..''9''] of Ten;',
  20123. ' TArrByteChar = array[byte,''0''..''9''] of Ten;',
  20124. 'procedure DoIt;',
  20125. 'var',
  20126. ' Arr: TArr;',
  20127. ' ArrArr: TArrArr;',
  20128. ' ArrByte: TArrByte;',
  20129. ' ArrChar: TArrChar;',
  20130. ' ArrByteChar: TArrByteChar;',
  20131. ' i: Ten;',
  20132. ' c: char;',
  20133. 'begin',
  20134. ' i:=Arr[1];',
  20135. ' i:=ArrByteChar[1,''2''];',
  20136. ' Arr[1]:=Arr[1];',
  20137. ' Arr[i]:=Arr[i];',
  20138. ' ArrByte[3]:=ArrByte[3];',
  20139. ' ArrByte[i]:=ArrByte[i];',
  20140. ' ArrChar[''5'']:=ArrChar[''5''];',
  20141. ' ArrChar[c]:=ArrChar[c];',
  20142. ' ArrByteChar[7,''7'']:=ArrByteChar[7,''7''];',
  20143. ' ArrByteChar[i,c]:=ArrByteChar[i,c];',
  20144. 'end;',
  20145. 'begin',
  20146. '']);
  20147. ConvertProgram;
  20148. CheckSource('TestRangeChecks_ArrayIndex',
  20149. LinesToStr([ // statements
  20150. 'this.DoIt = function () {',
  20151. ' var Arr = [];',
  20152. ' var ArrArr = [];',
  20153. ' var ArrByte = rtl.arraySetLength(null, 1, 256);',
  20154. ' var ArrChar = rtl.arraySetLength(null, 1, 10);',
  20155. ' var ArrByteChar = rtl.arraySetLength(null, 1, 256, 10);',
  20156. ' var i = 1;',
  20157. ' var c = "";',
  20158. ' i = rtl.rc(Arr[1], 1, 10);',
  20159. ' i = rtl.rc(ArrByteChar[1][2], 1, 10);',
  20160. ' Arr[1] = rtl.rc(Arr[1], 1, 10);',
  20161. ' rtl.rcArrW(Arr, i, rtl.rcArrR(Arr, i));',
  20162. ' ArrByte[3] = rtl.rc(ArrByte[3], 1, 10);',
  20163. ' rtl.rcArrW(ArrByte, i, rtl.rcArrR(ArrByte, i));',
  20164. ' ArrChar[5] = rtl.rc(ArrChar[5], 1, 10);',
  20165. ' rtl.rcArrW(ArrChar, c.charCodeAt() - 48, rtl.rcArrR(ArrChar, c.charCodeAt() - 48));',
  20166. ' ArrByteChar[7][7] = rtl.rc(ArrByteChar[7][7], 1, 10);',
  20167. ' rtl.rcArrW(ArrByteChar, i, c.charCodeAt() - 48, rtl.rcArrR(ArrByteChar, i, c.charCodeAt() - 48));',
  20168. '};',
  20169. '']),
  20170. LinesToStr([ // $mod.$main
  20171. '']));
  20172. end;
  20173. procedure TTestModule.TestRangeChecks_StringIndex;
  20174. begin
  20175. StartProgram(false);
  20176. Add([
  20177. '{$R+}',
  20178. 'procedure DoIt(var h: string);',
  20179. 'var',
  20180. ' s: string;',
  20181. ' i: longint;',
  20182. ' c: char;',
  20183. 'begin',
  20184. ' c:=s[1];',
  20185. ' s[i]:=s[i];',
  20186. ' h[i]:=h[i];',
  20187. 'end;',
  20188. 'begin',
  20189. '']);
  20190. ConvertProgram;
  20191. CheckSource('TestRangeChecks_StringIndex',
  20192. LinesToStr([ // statements
  20193. 'this.DoIt = function (h) {',
  20194. ' var s = "";',
  20195. ' var i = 0;',
  20196. ' var c = "";',
  20197. ' c = rtl.rcc(rtl.rcCharAt(s, 0), 0, 65535);',
  20198. ' s = rtl.rcSetCharAt(s, i - 1, rtl.rcCharAt(s, i - 1));',
  20199. ' h.set(rtl.rcSetCharAt(h.get(), i - 1, rtl.rcCharAt(h.get(), i - 1)));',
  20200. '};',
  20201. '']),
  20202. LinesToStr([ // $mod.$main
  20203. '']));
  20204. end;
  20205. procedure TTestModule.TestRangeChecks_TypecastInt;
  20206. begin
  20207. StartProgram(false);
  20208. Add([
  20209. '{$R+}',
  20210. 'var',
  20211. ' i: nativeint;',
  20212. ' b: byte;',
  20213. ' sh: shortint;',
  20214. ' w: word;',
  20215. ' sm: smallint;',
  20216. ' lw: longword;',
  20217. ' li: longint;',
  20218. 'begin',
  20219. ' b:=12+byte(i);',
  20220. ' sh:=12+shortint(i);',
  20221. ' w:=12+word(i);',
  20222. ' sm:=12+smallint(i);',
  20223. ' lw:=12+longword(i);',
  20224. ' li:=12+longint(i);',
  20225. '']);
  20226. ConvertProgram;
  20227. CheckSource('TestRangeChecks_TypecastInt',
  20228. LinesToStr([
  20229. 'this.i = 0;',
  20230. 'this.b = 0;',
  20231. 'this.sh = 0;',
  20232. 'this.w = 0;',
  20233. 'this.sm = 0;',
  20234. 'this.lw = 0;',
  20235. 'this.li = 0;',
  20236. '']),
  20237. LinesToStr([
  20238. '$mod.b = rtl.rc(12 + rtl.rc($mod.i, 0, 255), 0, 255);',
  20239. '$mod.sh = rtl.rc(12 + rtl.rc($mod.i, -128, 127), -128, 127);',
  20240. '$mod.w = rtl.rc(12 + rtl.rc($mod.i, 0, 65535), 0, 65535);',
  20241. '$mod.sm = rtl.rc(12 + rtl.rc($mod.i, -32768, 32767), -32768, 32767);',
  20242. '$mod.lw = rtl.rc(12 + rtl.rc($mod.i, 0, 4294967295), 0, 4294967295);',
  20243. '$mod.li = rtl.rc(12 + rtl.rc($mod.i, -2147483648, 2147483647), -2147483648, 2147483647);',
  20244. '']));
  20245. end;
  20246. Initialization
  20247. RegisterTests([TTestModule]);
  20248. end.